No OneTemporary
Actions

Size

7 MB

Subscribers

None

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.

	Index: trunk/pythia6/Makefile.am
	===================================================================
	--- trunk/pythia6/Makefile.am (revision 8888)
	+++ trunk/pythia6/Makefile.am (revision 8889)
	@@ -1,86 +0,0 @@
	-## Makefile.am -- Makefile for WHIZARD
	-# $Id: Makefile.am 1564 2010-01-21 18:19:23Z ohl $
	-##
	-## Process this file with automake to produce Makefile.in
	-##
	-########################################################################
	-#
	-# Copyright (C) 1999-2023 by
	-# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	-# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	-# Juergen Reuter <juergen.reuter@desy.de>
	-# with contributions from
	-# Fabian Bach <fabian.bach@t-online.de>
	-# Bijan Chokoufe <bijan.chokoufe@desy.de>
	-# Christian Speckner <cnspeckn@googlemail.com>
	-#
	-# WHIZARD is free software; you can redistribute it and/or modify it
	-# under the terms of the GNU General Public License as published by
	-# the Free Software Foundation; either version 2, or (at your option)
	-# any later version.
	-#
	-# WHIZARD is distributed in the hope that it will be useful, but
	-# WITHOUT ANY WARRANTY; without even the implied warranty of
	-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	-# GNU General Public License for more details.
	-#
	-# You should have received a copy of the GNU General Public License
	-# along with this program; if not, write to the Free Software
	-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	-#
	-########################################################################
	-
	-## The files in this directory end up in an auxiliary libtool library.
	-AM_FFLAGS =
	-AM_FCFLAGS =
	-
	-if PYTHIA6_AVAILABLE
	-
	-if FC_IS_NAG
	-AM_FFLAGS += -dcfuns -w
	-AM_FCFLAGS += -dcfuns -w
	-endif
	-
	-if PYTHIA6_IS_EH
	-AM_FFLAGS += -DPYTHIA6_EH
	-endif
	-
	-noinst_LTLIBRARIES = libpythia6_wo.la
	-
	-if LHAPDF5_AVAILABLE
	-libpythia6_wo_la_SOURCES = pythia.F
	-else
	-if LHAPDF6_AVAILABLE
	-libpythia6_wo_la_SOURCES = pythia.F
	-else
	-libpythia6_wo_la_SOURCES = pythia.F pythia_pdf.f
	-endif
	-endif
	-
	-else
	-
	-noinst_LTLIBRARIES = libpythia6_wo_dummy.la
	-libpythia6_wo_dummy_la_SOURCES = pythia6_dummy.f90
	-
	-endif
	-########################################################################
	-## Default Fortran compiler options
	-
	-## Profiling
	-if FC_USE_PROFILING
	-AM_FFLAGS += $(FCFLAGS_PROFILING)
	-AM_FCFLAGS += $(FCFLAGS_PROFILING)
	-endif
	-
	-## OpenMP
	-if FC_USE_OPENMP
	-AM_FFLAGS += $(FCFLAGS_OPENMP)
	-AM_FCFLAGS += $(FCFLAGS_OPENMP)
	-endif
	-
	-########################################################################
	-## Non-standard cleanup tasks
	-
	-## Remove backup files
	-maintainer-clean-local:
	- -rm -f *~
	Index: trunk/pythia6/pythia_pdf.f
	===================================================================
	--- trunk/pythia6/pythia_pdf.f (revision 8888)
	+++ trunk/pythia6/pythia_pdf.f (revision 8889)
	@@ -1,107 +0,0 @@
	-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
	Index: trunk/pythia6/pythia6_dummy.f90
	===================================================================
	--- trunk/pythia6/pythia6_dummy.f90 (revision 8888)
	+++ trunk/pythia6/pythia6_dummy.f90 (revision 8889)
	@@ -1,91 +0,0 @@
	-subroutine pylist (i)
	- integer, intent(in) :: i
	-end subroutine pylist
	-
	-subroutine pyinit (frame, beam, target, win)
	- character(), intent(in) :: frame, beam, target
	- double precision, intent(in) :: win
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pyinit
	-
	-subroutine pygive (chin)
	- character chin()
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pygive
	-
	-subroutine pyevnt()
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pyevnt
	-
	-subroutine pyexec()
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pyexec
	-
	-function pyp(I,J)
	- integer, intent(in) :: i,j
	- double precision :: pyp
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end function pyp
	-
	-subroutine pystat (mstat)
	- integer, intent(in) :: mstat
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pystat
	-
	-subroutine pystop ()
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pystop
	-
	-subroutine pyrobo (imi, ima, the, phi, bex, bey, bez)
	- integer, intent(in) :: imi, ima
	- double precision, intent(in) :: the, phi, bex, bey, bez
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pyrobo
	-
	-subroutine pyedit (medit)
	- integer, intent(in) :: medit
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pyedit
	-
	-subroutine pyhepc (mconv)
	- integer, intent(in) :: mconv
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine pyhepc
	-
	-function pyr (idummy)
	- integer, intent(in) :: idummy
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end function pyr
	Index: trunk/pythia6/pythia.F
	===================================================================
	--- trunk/pythia6/pythia.F (revision 8888)
	+++ trunk/pythia6/pythia.F (revision 8889)
	@@ -1,81251 +0,0 @@
	-C*********************************************************************
	-C*********************************************************************
	-C* **
	-C* Dec 2012 **
	-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 xf 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 44 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 44 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 CPRO12,CVER12
	- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
	- &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
	- &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
	- &/PYBINS/,/PYLH3P/,/PYLH3C/
	-
	-C...PYDAT1, containing status codes and most parameters.
	- DATA MSTU/
	- & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
	- 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
	- 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
	- 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
	- 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
	- 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- 7 30*0,
	- 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
	- & 80*0/
	- DATA (PARU(I),I=1,100)/
	- & 3.141592653589793D0, 6.283185307179586D0,
	- & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
	- 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
	- 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
	- 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
	- 6 40*0D0/
	- DATA (PARU(I),I=101,200)/
	- & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
	- & 0D0, 0D0, 0D0, 0D0, 0D0,
	- 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
	- 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
	- 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
	- 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
	- 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
	- 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
	- DATA MSTJ/
	- & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
	- 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
	- 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
	- 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
	- 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
	- 6 40*0,
	- & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
	- 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
	- 2 80*0/
	- DATA PARJ/
	- & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
	- & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
	- 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
	- 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
	- 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
	- 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
	- 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
	- 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
	- 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
	- 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
	- 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
	- 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	- 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
	- 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
	- 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
	- 4 10*0D0,
	- 5 10*0D0,
	- 6 10*0D0,
	- 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
	- 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
	- 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
	- 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
	- 9 5*0D0/
	-
	-C...PYDAT2, with particle data and flavour treatment parameters.
	- DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
	- &-3,0,-3,60,3,90,3,20,3,40,-1,410,2,-1,200,33,70,33,30,
	- &33,30,33,60,33,30,33,40,-2,-3,21,20,4,23,6,2-2,2*-3,
	- &0,21,20,23,-2,2-3,20,-3,21,20,3,0,24,23,26,3,21,20,
	- &23,20,4,23,26,23,6,2-2,2-3,0,-3,0,21,20,23,0,3,2*-2,
	- &2-3,20,2-3,0,21,20,23,20,23,-2,2-3,20,2-3,20,-3,2*0,
	- &23,40,23,20,23,20,23,40,23,20,23,30,3,2*0,3,0,3,0,3,
	- &20,3,0,3,30,-1,2,-1,2,-1,2,-3,0,-3,0,-3,40,3,20,3,0,-1,2,-1,
	- &2,-1,2,-3,0,-3,0,-3,20,3,30,3,80,-1,2,-3,60,3,26,0,3,40,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)/81,120,2,200,1,1070,-1,0,2*-1,
	- &20,-1,30,2-1,30,2-1,40,-1,50,2-1,40,2-1,50,2-1,6*0,
	- &-1,70,2-1,50,2-1,60,2-1,70,2-1,80,-1,560,61,60,2,7*0,
	- &61,90,2,30,2,0,52,21,170,6*2,
	- &830,121,90,2,30,25*0/
	- DATA (KCHG(I,3),I= 1, 500)/81,20,81,50,1,90,1,20,1,3*0,
	- &21,390,1,0,21,200,31,40,61,30,91,30,121,40,1001,20,
	- &21,20,41,20,61,20,81,30,1,0,21,0,31,0,41,30,121,30,
	- &1,20,1,0,121,0,1,30,1,80,41,50,31,0,1,30,21,70,1,
	- &810,211,30,1,250/
	- 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,
	- &2400D0,20D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
	- &50D0,91.188D0,80.45D0,115D0,60D0,500D0,900D0,500D0,3*300D0,
	- &30D0,5000D0,200D0,400D0,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,
	- &21.23D0,1.282D0,21.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
	- &25.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32500D0,
	- &3110D0,350D0,3210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
	- &4400D0,1000D0,3500D0,1200D0,750D0,2200D0,70D0,3*3.1D0,
	- &39.5D0,2250D0,
	- &81*0,
	-C...UED
	- &586.,588.,586.,588.,586.,586.,6*598.,
	- &3505.,6516.,640.,501.,536.,536.,25*0.D0/
	- DATA (PMAS(I,2),I= 1, 500)/50D0,1.39816D0,160D0,2.47813D0,
	- &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
	- &3.3752D0,4.17669D0,30D0,417.29147D0,0.39162D0,600D0,0.151D0,
	- &0.107D0,20D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,20D0,
	- &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
	- &20D0,0.023D0,20D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
	- &20D0,0.02D0,20D0,0.02D0,20D0,0.02D0,20D0,0.02D0,5*0D0,0.12D0,
	- &30D0,0.12D0,20D0,20.12D0,30D0,0.0394D0,4*0D0,0.036D0,0D0,
	- &0.0358D0,20D0,0.0099D0,0D0,0.0091D0,740D0,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,
	- &80.05D0,0D0,0.01D0,20.4D0,0.025D0,20.174D0,0.053D0,30.05D0,
	- &0.0009D0,40.05D0,30D0,191D0,0D0,71D0,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,
	- &70D0,60.01D0,0.25499D0,0.28446D0,131*0D0/
	- DATA (PMAS(I,3),I= 1, 500)/50D0,13.98156D0,160D0,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,
	- &600D0,0.4D0,0.25D0,20D0,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,
	- &20D0,0.12D0,20D0,0.05D0,0.005D0,0D0,0.01D0,20D0,0.05D0,20D0,
	- &0.05D0,20D0,0.05D0,20D0,0.05D0,50D0,0.14D0,30D0,0.14D0,2*0D0,
	- &20.14D0,30D0,0.04D0,40D0,0.035D0,0D0,0.035D0,20D0,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,60.1D0,0.05D0,0.1D0,0D0,0.02D0,20.3D0,
	- &0.05D0,20.3D0,0.02D0,20.1D0,0.03D0,0.001D0,40.1D0,30D0,
	- &1910D0,0.00001D0,710D0,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
	- &120.2D0,90.1D0,0.2,10.,0.07,0.3,25*0.D0/
	- DATA (PMAS(I,4),I= 1, 500)/120D0,658654D0,0D0,0.0872D0,680D0,
	- &0.1D0,0.387D0,160D0,0.00003D0,20D0,15500D0,7804.5D0,5*0D0,
	- &26.762D0,30D0,3709D0,50D0,0.317D0,20D0,0.1244D0,20D0,0.14D0,
	- &50D0,0.468D0,20D0,0.462D0,20D0,0.483D0,20D0,0.15D0,18*0D0,
	- &44.34D0,0D0,78.88D0,40D0,23.96D0,20D0,49.1D0,0D0,87.1D0,0D0,
	- &24.6D0,40D0,0.0618D0,0.029D0,60D0,0.106D0,60D0,0.019D0,20D0,
	- &70.1D0,40D0,0.342D0,20.387D0,60D0,20.387D0,60D0,0.387D0,
	- &0D0,0.387D0,20D0,80.387D0,0D0,90.387D0,1200D0,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)/50,31,60,1,0,1,50,31,60,1,0,
	- &41,30,21,400,31,160,31,20,91,0,321,20,1,30,1,20,21,
	- &20,31,20,41,0,51,20,41,20,51,20,61,0,71,20,51,2*0,
	- &61,20,71,20,81,0,751,0,71,0,1,0,1,0,261,70,81,
	- &81*0,
	-C...UED
	- &51,0,51,0,131,250/
	- 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,20,153,162,174,190,210,60,289,0,311,334,420,
	- &503,30,530,539,400,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,20,1045,30,1046,2*0,
	- &1049,1052,20,1053,1055,1058,20,1062,1063,1066,1069,0,1072,1077,
	- &1079,1082,1084,20,1088,1089,1090,1166,20,1170,1171,1172,1173,
	- &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
	- &1205,1209,1213,20,1217,1218,1219,1236,1245,20,1254,1255,1256,
	- &1257,1258,1267,20,1276,1277,1278,1279,1280,1289,1290,20,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)/58,15,210,2*0,4,2,5,2,54,2,5,3,
	- &20,9,12,16,20,79,60,22,0,23,86,83,27,30,9,1,400,1,4,9,16*0,2,
	- &5,29,22,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,20,1,30,3,20,3,1,20,2,
	- &3,4,20,1,33,0,5,2,3,2,4,20,21,76,4,20,41,4,2*0,1,2,1,2,4,1,
	- &0,74,20,21,17,29,20,41,29,20,41,9,1,9,20,89,0,99,4*1,
	- &5,3,2,5,2,5,7,4,72,1,92,1,22,14,22,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,38,3,26,27,26,6,37,26,9,24,3,2,20,
	- &322,15,12,27,70,61,26,30,
	- &81*0,
	-C...UED
	- &62,63,91,24,1,18,6,250/
	- DATA (MDME(I,1),I= 1,8000)/61,-1,71,-1,71,-1,71,-1,7*1,-1,
	- &71,-1,1,7-1,81,2-1,81,2-1,731,-1,21,-1,51,0,2-1,6*1,0,
	- &2-1,31,-1,61,2-1,61,2-1,31,-1,31,-1,31,5-1,31,-1,61,
	- &2-1,31,-1,51,621,61,2-1,61,8-1,31,-1,31,-1,31,5-1,
	- &31,4-1,61,2-1,31,-1,121,621,61,2-1,31,-1,91,621,
	- &31,-1,31,-1,1,181,41,2-1,21,-1,12491,2-1,3771,2-1,
	- &19211,2-1,61,2-1,1331,2-1,61,2-1,101,-1,31,-1,31,5-1,
	- &31,-1,161,2-1,61,2-1,161,2-1,61,2-1,131,-1,31,-1,31,
	- &5-1,31,-1,
	- &649*0,
	-C...UED
	- &101,20,151,30,91,51,0,51,0,51,0,5*1,0,
	- &1,241,29120/
	- DATA (MDME(I,2),I= 1,8000)/43102,40,102,0,653,3102,4*0,102,
	- &20,3102,40,102,20,6102,42,6102,242,20,841,20,36*41,
	- &8102,0,102,0,102,20,21102,832,80,1632,40,832,90,6253,
	- &832,140,1632,70,832,160,6253,832,130,6253,432,50,
	- &1853,632,40,12,242,211,942,0,2,3,150,442,50,3,120,2,
	- &30,1,0,3,160,23,150,242,23,180,23,30,1,110,2242,410,
	- &23,90,1642,450,3,100,1042,200,213,60,12,20,12,0,12,
	- &1442,160,48,313,242,90,1442,160,48,313,242,90,14*42,
	- &190,48,313,242,60,211,2842,50,32,30,432,24,0,32,45*0,
	- &1442,520,1013,242,211,40,242,211,60,242,211,0,242,
	- &211,242,211,242,211,242,211,242,211,242,211,242,2*11,
	- &20,342,80,48,313,2042,40,1842,40,942,0,16242,500,212,
	- &170,232,330,12,90,32,20,12,110,432,24,50,240453,4*32,
	- &30,632,30,432,30,5032,353,120,832,120,6651,632,9*0,
	- &932,170,651,100,832,150,1632,140,832,180,832,180,
	- &16*32,
	-C...UED
	- &6530,300,90,120,370,29120/
	- DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
	- &0.998205D0,350D0,1D0,60D0,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,20.00205D0,20.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,20D0,0.321369D0,0.016494D0,20D0,0.016502D0,
	- &0.320615D0,20D0,0.00001D0,0.000591D0,60D0,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,50D0,20.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,
	- &690D0,0.000001D0,0.000072D0,0.001333D0,40D0,0.000001D0,
	- &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
	- &660D0,0.000014D0,0.082234D0,20D0,0.000013D0,0.003746D0,0D0,
	- &0.913992D0,180D0,30.215119D0,0.214724D0,2*0D0,0.06996D0,
	- &0.069959D0,0D0,21D0,20.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,20.1939D0,20.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,20.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,20.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,20.004D0,0.07D0,0.065D0,20.005D0,20.011D0,50.001D0,
	- &0.07D0,0.065D0,20.005D0,20.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,20.003D0,20.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,20.002D0,20.004D0,2*0.002D0,0.034D0,
	- &0.027D0,20.002D0,20.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,
	- &20.005D0,20.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,
	- &40.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,40.005D0,0.25D0,
	- &0.0952D0,0.94D0,0.06D0,20.4D0,20.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,
	- &20.005D0,0.008D0,0.012D0,0.02D0,0.055D0,20.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,20.3D0,20.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,20.3D0,20.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,20.06D0,0.516D0,0.483D0,0.001D0,0.88D0,20.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,21D0,0.018D0,20.005D0,0.003D0,0.002D0,
	- &20.006D0,0.018D0,20.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,
	- &40.004D0,20.002D0,20.004D0,0.003D0,0.002D0,20.003D0,
	- &30.002D0,20.001D0,0.002D0,20.001D0,20.002D0,0.0013D0,
	- &0.0018D0,50.001D0,40.003D0,20.005D0,20.002D0,2*0.001D0,
	- &20.002D0,20.001D0,0.2432D0,0.057D0,20.035D0,0.15D0,20.075D0,
	- &0.03D0,20.015D0,20.08D0,0.76D0,0.08D0,41D0,20.08D0,0.76D0,
	- &0.08D0,1D0,20.5D0,1D0,20.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
	- DATA (BRAT(I) ,I=1189,1381)/20.08D0,0.76D0,30.08D0,0.76D0,
	- &30.08D0,0.76D0,30.08D0,0.76D0,30.08D0,0.76D0,30.08D0,0.76D0,
	- &30.08D0,0.76D0,0.08D0,21D0,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,41D0,20.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,41D0,20.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,41D0,0.52D0,0.26D0,0.11D0,20.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,20.015D0,20.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,80.5D0,0.02D0,0.98D0,1D0,40.5D0,3*0.146D0,
	- &30.05D0,0.15D0,20.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
	- &0.667D0,0.333D0,40.25D0,0.667D0,0.333D0,0.667D0,0.333D0,20.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,60D0,1D0,60D0,1D0,4*0.013853D0,0.562703D0,
	- &0.376702D0,0.00518D0,40.006254D0,0.974985D0,70D0,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,30.0633D0,0.063299D0,0.063295D0,0.056281D0,20D0,
	- &60.020495D0,20D0,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,61D0,0.095602D0,20.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,
	- &20D0,0.000011D0,0.001258D0,50D0,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,20D0,0.055332D0,20.319757D0,0.121576D0,2*0.001556D0,
	- &40D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,30D0,
	- &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,40D0,0.035282D0,0.001812D0,20D0,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.,
	- &30.D0,60.08333D0,
	- &30.D0,60.08333D0,
	- &6*0.166667D0,
	- &2912*0.D0/
	- DATA (KFDP(I,1),I= 1, 377)/21,22,23,4-24,25,21,22,23,424,25,
	- &21,22,23,4-24,25,21,22,23,424,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,424,25,237,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,
	- &21000023,31000025,41000035,21000024,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,223,25,35,4-1,4-3,4-5,4*-7,-11,-13,
	- &-15,-17,324,1,2,3,4,5,6,7,8,11,13,15,17,21,222,23,24,23,25,24,
	- &37,23,25,36,1000022,21000023,31000025,41000035,21000024,
	- &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,21000023,31000025,41000035,21000024,
	- &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,21000022,21000023,21000025,21000035,
	- &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,222,211,22,111,211,22,211,221,111,11,211,111,2211,
	- &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
	- &323,313,321,3311,-13,3211,12,14,311,2*321,311,321,313,323,313,
	- &323,311,4321,211,111,322,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,2111,2221,2331,2113,2223,
	- &2333,-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,2421,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,22,2431,421,411,423,413,82,11,13,82,
	- &443,82,612,614,216,3-411,3-413,2-411,2-413,2441,2*443,
	- &220443,22,24,2,4,511,521,511,523,513,523,513,521,511,612,
	- &614,216,3-421,3-423,2-421,2-423,2441,2443,220443,22,
	- &24,2,4,521,511,521,513,523,513,523,511,521,612,614,216,
	- &3-431,3-433,2-431,2-433,3441,3443,320443,22,2*4,2,4,531/
	- DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,24,212,2*14,
	- &216,42,44,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,22212,2112,-12,3122,3212,3112,2212,22112,-12,2*3122,3222,
	- &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
	- &3312,23122,3212,3322,3312,3122,3322,3312,-12,24122,7-11,7-13,
	- &22224,22212,22214,23122,23212,23214,53222,43224,2*3322,
	- &3324,22224,72212,52214,22112,22114,23122,23212,23214,
	- &23222,23224,42,3,22,1,22,-11,-13,22,44122,-11,-13,22,
	- &34132,34232,-11,-13,22,4332,-11,-13,22,-11,-13,2*2,-11,-13,
	- &22,-11,-13,22,-11,-13,22,-11,-13,22,-11,-13,22,25122,-12,
	- &-14,-16,54122,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,45122,-12,-14,-16,2*-2,
	- &2-4,-2,-4,-12,-14,-16,2-2,2-4,-2,-4,25132,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,
	- &2311,321,311,321,313,323,321,211,111,321,130,310,2211,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,221,213,-213,113,213,10211,10111,-10211,2221,213,2*113,
	- &-213,2321,2311,113,323,2313,323,313,-313,323,-323,423,2413,
	- &2423,413,443,82,523,2513,2523,2513,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,
	- &212,214,216,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,
	- &212,214,216,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,
	- &212,214,216,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,61000022,61000023,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,21000039,61000022,61000023,61000025,
	- &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,22,-1,2,-1,32,-1,2*4,-3,
	- &34,-3,26,51000039,161000022,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,
	- &161000022,161000023,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,21000039,151000024,
	- &61000022,61000023,61000025,61000035,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,32,-1,24,-3,34,-3,26,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,
	- &41000011,1000012,2000012,1000012,2000012,212,214,216,3*-14,
	- &3-16,3-2,3-4,3-6,1000039,-1000024,-1000037,1000022,1000023,
	- &1000025,1000035,41000013,1000014,2000014,1000014,2000014,212,
	- &214,216,3-12,3-16,3-2,3-4,3*-6,1000039,-1000024,-1000037,
	- &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
	- &1000016,2000016,212,214,216,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,911,9-11,11,-11,11,-11,913,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,3443,3553,2*24,
	- &23000211,222,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
	- &18,224,33000211,224,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,224,-24,23,222,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
	- &14,15,16,17,18,222,23,224,23,22,224,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)/31,2,4,6,8,1,32,1,3,5,7,2,3*3,2,4,
	- &6,8,3,34,1,3,5,7,4,35,2,4,6,8,5,36,1,3,5,7,6,5,61000006,3*7,
	- &2,4,6,8,7,4,6,38,1,3,5,7,8,5,7,211,12,11,12,211,213,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,
	- &215,16,15,16,15,217,18,17,218,217,-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,225,-37,-24,336,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,223,-24,225,-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,21000016,-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,1112,1114,2211,2213,
	- &211,20213,2321,2323,211,213,211,213,211,213,211,213,211,213,
	- &211,213,3211,213,211,2321,8211,2113,3*211,111,22,211,111,211,
	- &111,4211,812,814,2211,2213,2111,221,2*113,223,333,20213,
	- &211,2321,323,2311,313,-211,111,113,2211,321,2211,311,321,310,
	- &211,-211,4211,321,4211,113,2*211,-321,111,22,-211,111,-211,111,
	- &-211,211,-211,211,16,512,514,3211,3213,211,2111,2113,
	- &2-311,2-313,-2112,3321,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,
	- &4211,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,212,214,2,3,2,3,212,214,2,1,22,411,421,411,421,21,
	- &-11,-13,-15,-1,-2,-3,-4,221,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,2111,222,111,211,-321,-211,111,
	- &11,2-211,712,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,2111,2211,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,2111,2211,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,
	- &2111,2211,-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,
	- &2321,311,22,2-82,-211,111,-211,111,211,111,211,111,-321,-311,
	- &-321,-311,411,421,411,421,22,221,-211,2211,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,221,211,111,322,1,22,41,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,21,42,224,237,2,1,3,5,1,3,5,1,3,5,-3,2-5,3,24,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,23,44,224,237,4,1,3,5,1,3,5,1,3,5,-3,
	- &2-5,5,26,45,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,25,46,224,237,6,4,-15,
	- &16,1,3,5,1,3,5,1,3,5,-3,2-5,11,212,411,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,211,412,224,237,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
	- &13,214,413,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,213,414,224,237,11,13,15,11,13,15,1,3,5,1,3,
	- &5,1,3,5,15,216,415,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,215,416,224,237,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,22,2-3,24,2-5,26,2-11,212,2-13,214,2-15,216,-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,
	- &24,-3,4,-3,36,-5,24,-3,36,-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,437,2-1,22,2-3,24,2-5,26,2-11,212,2-13,
	- &214,2-15,216,-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,36,-5,24,-3,36,-5,26,1,22,41,23,25,35,36,2*-24/
	- DATA (KFDP(I,2),I=3670,4183)/2-37,21,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,21,42,23,25,35,
	- &36,224,237,2,1,3,5,1,3,5,1,3,5,-3,2-5,3,24,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,23,44,23,25,35,36,224,237,4,1,3,5,1,
	- &3,5,1,3,5,-3,2-5,5,26,45,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,
	- &25,46,23,25,35,36,224,237,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
	- &212,411,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,214,413,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,216,415,
	- &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,321,31,42,1,211,
	- &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,31,33,35,-13,13,-15,15,3-1,3-3,
	- &3-5,31,33,35,-11,11,-15,15,3-1,3-3,3-5,31,33,35,-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,23000111,23000221,-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)/810,14,60,216,20,6*111,310,130,
	- &20,3111,310,130,321,113,211,223,221,2113,2211,2223,2221,
	- &2113,221,2113,2213,-213,113,2111,310,130,310,130,2*310,130,
	- &4020,43,44,1,4,3,22,0,-11,80,-211,50,2*111,211,-211,211,
	- &-211,100,111,40,2111,-211,-11,11,-13,22,111,30,22,3*0,111,
	- &211,40,111,110,111,-211,60,-211,3111,70,111,-211,50,2*221,
	- &30,111,50,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,2211,-211,-311,211,111,3211,-211,7211,70,111,-211,
	- &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
	- &-321,-313,-323,-211,-213,220,111,113,-311,2-211,211,-211,310,
	- &-211,2111,211,2-211,-321,-211,2211,-211,111,-211,2211,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,160,-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,160,-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,190,-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,130,221,11*0,
	- &2112,60,2212,120,23122,3212,100,3322,2*0,3122,3212,3214,2112,
	- &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,520,33,1,6*0,
	- &43,40,43,60,43,0,283,20,34122,80,4,1,4,3,22,4*4,1,4,3,
	- &22,44,1,4,3,22,40,44,1,4,3,22,44,1,4,3,22,40,44,1,4,3,
	- &22,0,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,2*2,
	- &44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,4*4,1,4,
	- &3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,2*2,
	- &44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,4*4,1,4,
	- &3,22,310,211,111,450,-211,2111,-211,3111,-211,111,211,300,
	- &-211,111,130,221,-211,111,1990,25,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,50,-12,12,-14,14,-16,16,-2,2,-4,4,20,-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,
	- &24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,2*4,3,-3,
	- &26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,2*6,5,-5,
	- &22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,2*2,1,-1/
	- DATA (KFDP(I,3),I=2784,3354)/24,3,-3,26,5,-5,22,1,-1,24,3,-3,
	- &26,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,70,
	- &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
	- &-16,-1,-3,-5,-2,-4,50,-12,12,-14,14,-16,16,-2,2,-4,4,20,-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,50,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,50,
	- &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
	- &-2,2,-4,4,20,-12,12,-14,14,-16,16,-2,2,-4,4,520,-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,
	- &22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,2*2,1,-1,
	- &24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,2*4,3,-3,
	- &26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,2*6,5,-5,
	- &22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,3,-3,5,-5,
	- &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,3510,-5,950,2,4,6,2,4,
	- &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,29900014,29900016,2,4,6,2,4,
	- &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,29900012,29900016,2,4,6,2,4,
	- &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,29900012,29900014,3831*0/
	- DATA (KFDP(I,4),I= 1,8000)/940,4111,60,111,20,-211,0,-211,
	- &30,111,2-211,0,111,0,2111,113,221,2111,-213,-211,211,113,
	- &6111,310,2130,4020,1381,410,-11,100,111,-211,40,111,620,
	- &111,211,111,211,70,111,211,111,211,350,2-211,2111,211,111,
	- &-211,2211,2-211,130,-211,111,-211,111,40,-211,111,-211,111,
	- &340,111,-211,3111,3-211,2111,3-211,140,-321,-311,3*0,-321,
	- &-311,200,-3,430,61,390,62,420,63,140,84,40,4-5,40,
	- &2-5,670,-211,111,50,-211,111,520,2101,2103,22101,60,4*81,
	- &40,481,60,481,0,2881,130,62101,1881,40,1881,40,981,0,
	- &16281,310,-211,111,6516*0/
	- DATA (KFDP(I,5),I= 1,8000)/960,2111,170,111,70,2*111,0,
	- &3111,0,111,5970,-211,2111,-211,111,-211,111,650,111,-211,
	- &3111,-211,111,71930/
	-
	-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','K0','K_20','K+','K+','K_2+','eta''','phi',
	- &'f''_2','D+','D+','D_2+','D0','D0','D_20','D_s+','D*_s+',
	- &'D_2s+','eta_c','J/psi','chi_2c','B0','B0','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','Sigma0','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','Z0','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','Kbar0','K_2bar0','K-','K-','K_2-',3' ','D-','D-',
	- &'D_2-','Dbar0','Dbar0','D_2bar0','D_s-','D_s-','D*_2s-',
	- &3' ','Bbar0','Bbar0','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',
	- &'Sigmabar0','Sigmabar-','Sigmabar-','ss_1bar','Xibar+',
	- &'Xibar+','Xibar0','Xibar0','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' ','dbar','ubar',
	- &'ebar+','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','Z0','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)/160,41,40,61,50,51,0,
	- &51,50,61,40,41,160,160,41,40,61,50,51,0,51,50,
	- &61,40,41,160/
	- 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, 427, 2012, 12, 12, 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, 92, 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)/50,31,80,1,50,31,60,1,0,4*1,
	- &30,21,2540,192,0,72,0,2,0,2,0,261,70,62,2*1,
	- &810,211,41,250/
	-
	-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 -> qDi + qSbarj', 'qi + qjbar -> qDi + qDbarj',
	- &'qi + qj -> q_Di + q_Sj ', 'qi + qibar -> qDj + qDbarj',
	- &21*' '/
	- DATA (PROC(I),I=341,380)/
	- 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
	- 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
	- 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
	- 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
	- 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
	- 5'f + f -> f'' + f'' + H_L++/-- ',
	- 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
	- 5'f + fbar'' -> W_R+/- ',5*' ',
	- 6' ', 'f + fbar -> W_L+ W_L- ',
	- 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
	- 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
	- 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
	- 6'f + fbar -> W+/- pi_T-/+ ', ' ',
	- 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
	- 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
	- 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
	- 7'f + fbar'' -> W+/- pi_T0 ',
	- 7'f + fbar'' -> W+/- pi_T0'' ',
	- 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
	- 7'f + fbar -> Z0 Z0 (ETC) '/
	- DATA (PROC(I),I=381,420)/
	- 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
	- 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
	- 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
	- 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
	- 8' ', ' ',
	- 9'f + fbar -> G* ', 'g + g -> G* ',
	- 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
	- 9'g + g -> g + G* ', ' ',
	- 9 4*' ',
	- &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
	- & 18*' '/
	- DATA (PROC(I),I=421,460)/
	- 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
	- 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
	- 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
	- 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
	- 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
	- 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
	- 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
	- 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
	- 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
	- 3'q + q~ -> g + cc~[3P2(1)] ',
	- 3 21 *' '/
	- DATA (PROC(I),I=461,500)/
	- 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
	- 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
	- 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
	- 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
	- 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
	- 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
	- 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
	- 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
	- 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
	- 7'q + q~ -> g + bb~[3P2(1)] ',
	- 7 21 *' '/
	-
	-C...Cross sections and slope offsets.
	- DATA SIGT/294*0D0/
	-
	-C...Supersymmetry switches and parameters.
	- DATA IMSS/0,
	- & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
	- 1 89*0/
	- DATA RMSS/0D0,
	- & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
	- 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
	- 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
	- 3 10*0D0,
	- 4 0D0,1D0,8*0D0,
	- 5 49*0D0/
	-C...Initial values for R-violating SUSY couplings.
	-C...Should not be changed here. See PYMSIN.
	- DATA RVLAM/27*0D0/
	- DATA RVLAMP/27*0D0/
	- DATA RVLAMB/27*0D0/
	-
	-C...Technicolor switches and parameters
	- DATA ITCM/0,
	- & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- 1 89*0/
	- DATA RTCM/0D0,
	- & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
	- 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
	- 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
	- 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
	- 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
	- 4 200D0, 48*0D0/
	-
	-C...UED switches and parameters.
	-C... IUED(0) empty IUED vector element
	-C... IUED(1) UED ON(=1)/OFF(=0) switch
	-C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
	-C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
	-C... IUED(4) N the number of large extra dimensions
	-C... IUED(5) Selects whether the code takes Lambda (=0)
	-C... or Lambda*R (=1) as input.
	-C... IUED(6) With radiative corrections to the masses (=1)
	-C... or without (=0)
	-C...
	-C... RUED(0) empty RUED vector element
	-C... RUED(1) RINV (1/R) the curvature of the extra dimension
	-C... RUED(2) XMD the (4+N)-dimensional Planck scale
	-C... RUED(3) LAMUED (Lambda cutoff scale)
	-C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
	-C...
	- DATA IUED/0,0,0,5,6,0,1,93*0/
	- DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
	-
	-C...Data for histogramming routines.
	- DATA IHIST/1000,20000,55,1/
	- DATA INDX/1000*0/
	-
	-C...Data for SUSY Les Houches Accord.
	- DATA CPRO/'PYTHIA ','PYTHIA '/
	- DATA CVER/'6.4 ','6.4 '/
	- DATA MODSEL/200*0/
	- DATA PARMIN/100*0D0/
	- DATA RMSOFT/101*0D0/
	- DATA AU/9*0D0/
	- DATA AD/9*0D0/
	- DATA AE/9*0D0/
	-
	- END
	-
	-C*********************************************************************
	-
	-C...PYCKBD
	-C...Check that BLOCK DATA PYDATA has been loaded.
	-C...Should not be required, except that some compilers/linkers
	-C...are pretty buggy in this respect.
	-
	- SUBROUTINE PYCKBD
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
	-
	-C...Check a few variables to see they have been sensibly initialized.
	- IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
	- &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
	- &MSTP(1).GT.5) THEN
	-C...If not, abort the run right away.
	- WRITE(,) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
	- WRITE(,) 'The program execution is stopped now!'
	- CALL PYSTOP(8)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYTEST
	-C...A simple program (disguised as subroutine) to run at installation
	-C...as a check that the program works as intended.
	-
	- SUBROUTINE PYTEST(MTEST)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
	-C...Local arrays.
	- DIMENSION PSUM(5),PINI(6),PFIN(6)
	-
	-C...Save defaults for values that are changed.
	- MSTJ1=MSTJ(1)
	- MSTJ3=MSTJ(3)
	- MSTJ11=MSTJ(11)
	- MSTJ42=MSTJ(42)
	- MSTJ43=MSTJ(43)
	- MSTJ44=MSTJ(44)
	- PARJ17=PARJ(17)
	- PARJ22=PARJ(22)
	- PARJ43=PARJ(43)
	- PARJ54=PARJ(54)
	- MST101=MSTJ(101)
	- MST104=MSTJ(104)
	- MST105=MSTJ(105)
	- MST107=MSTJ(107)
	- MST116=MSTJ(116)
	-
	-C...First part: loop over simple events to be generated.
	- IF(MTEST.GE.1) CALL PYTABU(20)
	- NERR=0
	- DO 180 IEV=1,500
	-
	-C...Reset parameter values. Switch on some nonstandard features.
	- MSTJ(1)=1
	- MSTJ(3)=0
	- MSTJ(11)=1
	- MSTJ(42)=2
	- MSTJ(43)=4
	- MSTJ(44)=2
	- PARJ(17)=0.1D0
	- PARJ(22)=1.5D0
	- PARJ(43)=1D0
	- PARJ(54)=-0.05D0
	- MSTJ(101)=5
	- MSTJ(104)=5
	- MSTJ(105)=0
	- MSTJ(107)=1
	- IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
	-
	-C...Ten events each for some single jets configurations.
	- IF(IEV.LE.50) THEN
	- ITY=(IEV+9)/10
	- MSTJ(3)=-1
	- IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
	- IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
	- IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
	- IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
	- IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
	- IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
	-
	-C...Ten events each for some simple jet systems; string fragmentation.
	- ELSEIF(IEV.LE.130) THEN
	- ITY=(IEV-41)/10
	- IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
	- IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
	- IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
	- IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
	- IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
	- IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
	- IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
	- IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
	- & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
	-
	-C...Seventy events with independent fragmentation and momentum cons.
	- ELSEIF(IEV.LE.200) THEN
	- ITY=1+(IEV-131)/16
	- MSTJ(2)=1+MOD(IEV-131,4)
	- MSTJ(3)=1+MOD((IEV-131)/4,4)
	- IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
	- IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
	- IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
	- & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
	- IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
	- & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
	-
	-C...A hundred events with random jets (check invariant mass).
	- ELSEIF(IEV.LE.300) THEN
	- 100 DO 110 J=1,5
	- PSUM(J)=0D0
	- 110 CONTINUE
	- NJET=2D0+6D0*PYR(0)
	- DO 130 I=1,NJET
	- KFL=21
	- IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
	- IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
	- EJET=5D0+20D0*PYR(0)
	- THETA=ACOS(2D0*PYR(0)-1D0)
	- PHI=6.2832D0*PYR(0)
	- IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
	- IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
	- IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
	- IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
	- DO 120 J=1,4
	- PSUM(J)=PSUM(J)+P(I,J)
	- 120 CONTINUE
	- 130 CONTINUE
	- IF(PSUM(4)2-PSUM(1)2-PSUM(2)2-PSUM(3)2.LT.
	- & (PSUM(5)+PARJ(32))**2) GOTO 100
	-
	-C...Fifty e+e- continuum events with matrix elements.
	- ELSEIF(IEV.LE.350) THEN
	- MSTJ(101)=2
	- CALL PYEEVT(0,40D0)
	-
	-C...Fifty e+e- continuum event with varying shower options.
	- ELSEIF(IEV.LE.400) THEN
	- MSTJ(42)=1+MOD(IEV,2)
	- MSTJ(43)=1+MOD(IEV/2,4)
	- MSTJ(44)=MOD(IEV/8,3)
	- CALL PYEEVT(0,90D0)
	-
	-C...Fifty e+e- continuum events with coherent shower.
	- ELSEIF(IEV.LE.450) THEN
	- CALL PYEEVT(0,500D0)
	-
	-C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
	- ELSE
	- CALL PYONIA(5,9.46D0)
	- ENDIF
	-
	-C...Generate event. Find total momentum, energy and charge.
	- DO 140 J=1,4
	- PINI(J)=PYP(0,J)
	- 140 CONTINUE
	- PINI(6)=PYP(0,6)
	- CALL PYEXEC
	- DO 150 J=1,4
	- PFIN(J)=PYP(0,J)
	- 150 CONTINUE
	- PFIN(6)=PYP(0,6)
	-
	-C...Check conservation of energy, momentum and charge;
	-C...usually exact, but only approximate for single jets.
	- MERR=0
	- IF(IEV.LE.50) THEN
	- IF((PFIN(1)-PINI(1))2+(PFIN(2)-PINI(2))2.GE.10D0)
	- & MERR=MERR+1
	- EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
	- IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
	- IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
	- ELSE
	- DO 160 J=1,4
	- IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
	- 160 CONTINUE
	- IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
	- ENDIF
	- IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
	- & (PFIN(J),J=1,4),PFIN(6)
	-
	-C...Check that all KF codes are known ones, and that partons/particles
	-C...satisfy energy-momentum-mass relation. Store particle statistics.
	- DO 170 I=1,N
	- IF(K(I,1).GT.20) GOTO 170
	- IF(PYCOMP(K(I,2)).EQ.0) THEN
	- WRITE(MSTU(11),5100) I
	- MERR=MERR+1
	- ENDIF
	- PD=P(I,4)2-P(I,1)2-P(I,2)2-P(I,3)2-P(I,5)**2
	- IF(ABS(PD).GT.MAX(0.1D0,0.001D0P(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(PZSUM2+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-3PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4PESUM).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.002D0P(I,4)2,0.002D0P(I,5)**2)
	- & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
	- WRITE(MSTU(11),5200) I
	- MERR=MERR+1
	- ENDIF
	- 210 CONTINUE
	-
	-C...Listing of erroneous events, and first event of each type.
	- IF(MERR.GE.1) NERR=NERR+1
	- IF(NERR.GE.10) THEN
	- WRITE(MSTU(11),6300)
	- CALL PYLIST(1)
	- CALL PYSTOP(9)
	- ENDIF
	- IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
	- IF(MERR.GE.1) WRITE(MSTU(11),6400)
	- CALL PYLIST(1)
	- ENDIF
	- 220 CONTINUE
	-
	-C...List statistics for each process type.
	- IF(MTEST.GE.1) CALL PYSTAT(1)
	- 230 CONTINUE
	-
	-C...Summarize result of run.
	- IF(NERR.EQ.0) WRITE(MSTU(11),6500)
	- IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
	-
	-C...Format statements for output.
	- 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
	- &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
	- &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
	- &4(1X,F12.5),1X,F8.2)
	- 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
	- 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
	- &'kinematics')
	- 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
	- &'wrong.'/5X,'Execution will be stopped after listing of event.')
	- 6400 FORMAT(5X,'Faulty event follows:')
	- 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
	- 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
	- &5X,'This should not have happened!')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYHEPC
	-C...Converts PYTHIA event record contents to or from
	-C...the standard event record commonblock.
	-
	- SUBROUTINE PYHEPC(MCONV)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...HEPEVT commonblock.
	- PARAMETER (NMXHEP=4000)
	- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- DOUBLE PRECISION PHEP,VHEP
	- SAVE /HEPEVT/
	-
	-C...Store HEPEVT commonblock size (for interfacing issues).
	- MSTU(8)=NMXHEP
	-
	-C...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))
	- !!! JRR: uncolored undecayed parton
	- if (I2 == 0) cycle
	- 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 CHFRAM12,CHBEAM12,CHTARG12,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/200D0/,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,20.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,50.2D0/,
	- &NFIN/20*4/
	- DATA CHLH/'lepton','hadron'/
	-
	-C...Check that BLOCK DATA PYDATA has been loaded.
	- CALL PYCKBD
	-
	-C...Reset MINT and VINT arrays. Write headers.
	- MSTI(53)=0
	- DO 100 J=1,400
	- MINT(J)=0
	- VINT(J)=0D0
	- 100 CONTINUE
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
	-
	-C...Reset error counters.
	- MSTU(23)=0
	- MSTU(27)=0
	- MSTU(30)=0
	-
	-C...Reset processes that should not be on.
	- MSUB(96)=0
	- MSUB(97)=0
	-
	-C...Select global FSR/ISR/UE parameter set = 'tune'
	-C...See routine PYTUNE for details
	- IF (MSTP(5).NE.0) THEN
	- MSTP5=MSTP(5)
	- CALL PYTUNE(MSTP5)
	- ENDIF
	-
	-C...Call user process initialization routine.
	- IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
	- MSEL=0
	- CALL UPINIT
	- MSEL=0
	- ENDIF
	-
	-C...Maximum 4 generations; set maximum number of allowed flavours.
	- MSTP(1)=MIN(4,MSTP(1))
	- MSTU(114)=MIN(MSTU(114),2*MSTP(1))
	- MSTP(58)=MIN(MSTP(58),2*MSTP(1))
	-
	-C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
	- DO 120 I=-20,20
	- VINT(180+I)=0D0
	- IA=IABS(I)
	- IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
	- DO 110 J=1,MSTP(1)
	- IB=2*J-1+MOD(IA,2)
	- IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
	- IPM=(5-ISIGN(1,I))/2
	- IDC=J+MDCY(IA,2)+2
	- IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
	- & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
	- 110 CONTINUE
	- ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
	- VINT(180+I)=1D0
	- ENDIF
	- 120 CONTINUE
	-
	-C...Initialize parton distributions: PDFLIB.
	- IF(MSTP(52).EQ.2) THEN
	- PARM(1)='NPTYPE'
	- VALUE(1)=1
	- PARM(2)='NGROUP'
	- VALUE(2)=MSTP(51)/1000
	- PARM(3)='NSET'
	- VALUE(3)=MOD(MSTP(51),1000)
	- PARM(4)='TMAS'
	- VALUE(4)=PMAS(6,1)
	- CALL PDFSET(PARM,VALUE)
	- MINT(93)=1000000+MSTP(51)
	- ENDIF
	-
	-C...Choose Lambda value to use in alpha-strong.
	- MSTU(111)=MSTP(2)
	- IF(MSTP(3).GE.2) THEN
	- ALAM=0.2D0
	- NF=4
	- IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
	- ALAM=ALAMIN(MSTP(51))
	- NF=NFIN(MSTP(51))
	- ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
	- ALAM=QCDL5
	- NF=5
	- ELSEIF(MSTP(52).EQ.2) THEN
	- ALAM=QCDL4
	- NF=4
	- ENDIF
	- PARP(1)=ALAM
	- PARP(61)=ALAM
	- PARP(72)=ALAM
	- PARU(112)=ALAM
	- MSTU(112)=NF
	- IF(MSTP(3).EQ.3) PARJ(81)=ALAM
	- ENDIF
	-
	-C...Initialize the UED masses and widths
	- IF (IUED(1).EQ.1) CALL PYXDIN
	-
	-C...Initialize the SUSY generation: couplings, masses,
	-C...decay modes, branching ratios, and so on.
	- CALL PYMSIN
	-C...Initialize widths and partial widths for resonances.
	- CALL PYINRE
	-C...Set Z0 mass and width for e+e- routines.
	- PARJ(123)=PMAS(23,1)
	- PARJ(124)=PMAS(23,2)
	-
	-C...Identify beam and target particles and frame of process.
	- CHFRAM=FRAME//' '
	- CHBEAM=BEAM//' '
	- CHTARG=TARGET//' '
	- CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
	- IF(MINT(65).EQ.1) GOTO 170
	-
	-C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
	-C...For e-gamma allow 2 alternatives.
	- MINT(121)=1
	- IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
	- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
	- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	- & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
	- ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
	- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
	- ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
	- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
	- ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	- IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	- & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
	- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
	- ENDIF
	- MINT(123)=MSTP(14)
	- IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
	- &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
	- IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
	- IF(MSTP(14).EQ.11) MINT(123)=0
	- IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
	- IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
	- IF(MSTP(14).EQ.15) MINT(123)=2
	- IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
	- IF(MSTP(14).EQ.19) MINT(123)=3
	- ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
	- IF(MSTP(14).EQ.21) MINT(123)=0
	- IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
	- IF(MSTP(14).EQ.24) MINT(123)=1
	- ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
	- IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
	- IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
	- ENDIF
	-
	-C...Set up kinematics of process.
	- CALL PYINKI(0)
	-
	-C...Set up kinematics for photons inside leptons.
	- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
	-
	-C...Precalculate flavour selection weights.
	- CALL PYKFIN
	-
	-C...Loop over gamma-p or gamma-gamma alternatives.
	- CKIN3=CKIN(3)
	- MSAV48=0
	- DO 160 IGA=1,MINT(121)
	- CKIN(3)=CKIN3
	- MINT(122)=IGA
	-
	-C...Select partonic subprocesses to be included in the simulation.
	- CALL PYINPR
	- MINT(101)=1
	- MINT(102)=1
	- MINT(103)=MINT(11)
	- MINT(104)=MINT(12)
	-
	-C...Count number of subprocesses on.
	- MINT(48)=0
	- DO 130 ISUB=1,500
	- IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
	- & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
	- MSUB(ISUB)=0
	- ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
	- & MSUB(ISUB).EQ.1) THEN
	- WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
	- CALL PYSTOP(1)
	- ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
	- WRITE(MSTU(11),5300) ISUB
	- CALL PYSTOP(1)
	- ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
	- WRITE(MSTU(11),5400) ISUB
	- CALL PYSTOP(1)
	- ELSEIF(MSUB(ISUB).EQ.1) THEN
	- MINT(48)=MINT(48)+1
	- ENDIF
	- 130 CONTINUE
	-
	-C...Stop or raise warning flag if no subprocesses on.
	- IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
	- IF(MSTP(127).NE.1) THEN
	- WRITE(MSTU(11),5500)
	- CALL PYSTOP(1)
	- ELSE
	- WRITE(MSTU(11),5700)
	- MSTI(53)=1
	- ENDIF
	- ENDIF
	- MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
	- MSAV48=MSAV48+MINT(48)
	-
	-C...Reset variables for cross-section calculation.
	- DO 150 I=0,500
	- DO 140 J=1,3
	- NGEN(I,J)=0
	- XSEC(I,J)=0D0
	- 140 CONTINUE
	- 150 CONTINUE
	-
	-C...Find parametrized total cross-sections.
	- CALL PYXTOT
	- VINT(318)=VINT(317)
	-
	-C...Maxima of differential cross-sections.
	- IF(MSTP(121).LE.1) CALL PYMAXI
	-
	-C...Initialize possibility of pileup events.
	- IF(MINT(121).GT.1) MSTP(131)=0
	- IF(MSTP(131).NE.0) CALL PYPILE(1)
	-
	-C...Initialize multiple interactions with variable impact parameter.
	- IF(MINT(50).EQ.1) THEN
	- PTMN=PARP(82)(VINT(1)/PARP(89))*PARP(90)
	- IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
	- & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
	- IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
	- MINT(35)=1
	- CALL PYMULT(1)
	- MINT(35)=3
	- CALL PYMIGN(1)
	- ENDIF
	- ENDIF
	-
	-C...Save results for gamma-p and gamma-gamma alternatives.
	- IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
	- 160 CONTINUE
	-
	-C...Initialization finished.
	- IF(MSAV48.EQ.0) THEN
	- IF(MSTP(127).NE.1) THEN
	- WRITE(MSTU(11),5500)
	- CALL PYSTOP(1)
	- ELSE
	- WRITE(MSTU(11),5700)
	- MSTI(53)=1
	- ENDIF
	- ENDIF
	- 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
	-
	-C...Formats for initialization information.
	- 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
	- &'routines',1X,17('*'))
	- 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
	- &'-',A6,' interactions.'/1X,'Execution stopped!')
	- 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
	- &1X,'Execution stopped!')
	- 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
	- &1X,'Execution stopped!')
	- 5500 FORMAT(1X,'Error: no subprocess switched on.'/
	- &1X,'Execution stopped.')
	- 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
	- &22('*'))
	- 5700 FORMAT(1X,'Error: no subprocess switched on.'/
	- &1X,'Execution will stop if you try to generate events.')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYEVNT
	-C...Administers the generation of a high-pT event via calls to
	-C...a number of subroutines.
	-
	- SUBROUTINE PYEVNT
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
	- &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
	-C...Local array.
	- DIMENSION VTX(4)
	-
	-C...Optionally let PYEVNW do the whole job.
	- IF(MSTP(81).GE.20) THEN
	- CALL PYEVNW
	- RETURN
	- ENDIF
	-
	-C...Stop if no subprocesses on.
	- IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
	- WRITE(MSTU(11),5100)
	- CALL PYSTOP(1)
	- ENDIF
	-
	-C...Initial values for some counters.
	- MSTU(1)=0
	- MSTU(2)=0
	- N=0
	- MINT(5)=MINT(5)+1
	- MINT(7)=0
	- MINT(8)=0
	- MINT(30)=0
	- MINT(83)=0
	- MINT(84)=MSTP(126)
	- MSTU(24)=0
	- MSTU70=0
	- MSTJ14=MSTJ(14)
	-C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
	- NCT=0
	- MINT(33)=0
	-
	-C...Let called routines know call is from PYEVNT (not PYEVNW).
	- MINT(35)=1
	- IF (MSTP(81).GE.10) MINT(35)=2
	-
	-C...If variable energies: redo incoming kinematics and cross-section.
	- MSTI(61)=0
	- IF(MSTP(171).EQ.1) THEN
	- CALL PYINKI(1)
	- IF(MSTI(61).EQ.1) THEN
	- MINT(5)=MINT(5)-1
	- RETURN
	- ENDIF
	- IF(MINT(121).GT.1) CALL PYSAVE(3,1)
	- CALL PYXTOT
	- ENDIF
	-
	-C...Loop over number of pileup events; check space left.
	- IF(MSTP(131).LE.0) THEN
	- NPILE=1
	- ELSE
	- CALL PYPILE(2)
	- NPILE=MINT(81)
	- ENDIF
	- DO 270 IPILE=1,NPILE
	- IF(MINT(84)+100.GE.MSTU(4)) THEN
	- CALL PYERRM(11,
	- & '(PYEVNT:) no more space in PYJETS for pileup events')
	- IF(MSTU(21).GE.1) GOTO 280
	- ENDIF
	- MINT(82)=IPILE
	-
	-C...Generate variables of hard scattering.
	- MINT(51)=0
	- MSTI(52)=0
	- 100 CONTINUE
	- IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
	- MINT(31)=0
	- MINT(39)=0
	- MINT(51)=0
	- MINT(57)=0
	- CALL PYRAND
	- IF(MSTI(61).EQ.1) THEN
	- MINT(5)=MINT(5)-1
	- RETURN
	- ENDIF
	- IF(MINT(51).EQ.2) RETURN
	- ISUB=MINT(1)
	- IF(MSTP(111).EQ.-1) GOTO 260
	-
	-C...Loopback point if PYPREP fails, especially for junction topologies.
	- NPREP=0
	- MNT31S=MINT(31)
	- 110 NPREP=NPREP+1
	- MINT(31)=MNT31S
	-
	- IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
	-C...Hard scattering (including low-pT):
	-C...reconstruct kinematics and colour flow of hard scattering.
	- MINT31=MINT(31)
	- 120 MINT(31)=MINT31
	- MINT(51)=0
	- CALL PYSCAT
	- IF(MINT(51).EQ.1) GOTO 100
	- IPU1=MINT(84)+1
	- IPU2=MINT(84)+2
	- IF(ISUB.EQ.95) GOTO 140
	-
	-C...Reset statistics on activity in event.
	- DO 130 J=351,359
	- MINT(J)=0
	- VINT(J)=0D0
	- 130 CONTINUE
	-
	-C...Showering of initial state partons (optional).
	- NFIN=N
	- ALAMSV=PARJ(81)
	- PARJ(81)=PARP(72)
	- IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
	- & CALL PYSSPA(IPU1,IPU2)
	- PARJ(81)=ALAMSV
	- IF(MINT(51).EQ.1) GOTO 100
	-
	-C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
	- IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
	- PTMAX=0.5SQRT(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(-2D0LOG(MAX(1D-10,PYR(0))))*
	- & SIN(PARU(2)*PYR(0))
	- 220 CONTINUE
	- DO 240 I=MINT(83)+1,N
	- DO 230 J=1,4
	- V(I,J)=V(I,J)+VTX(J)
	- 230 CONTINUE
	- 240 CONTINUE
	- ENDIF
	-
	-C...Perform hadronization (if desired).
	- IF(MSTP(111).GE.1) THEN
	- CALL PYEXEC
	- IF(MSTU(24).NE.0) GOTO 100
	- ENDIF
	- IF(MSTP(113).GE.1) THEN
	- DO 250 I=NRECAL,N
	- IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
	- & P(I,2)2+P(I,3)2+P(I,5)**2)
	- 250 CONTINUE
	- ENDIF
	- IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
	-
	-C...Store event information and calculate Monte Carlo estimates of
	-C...subprocess cross-sections.
	- 260 IF(IPILE.EQ.1) CALL PYDOCU
	-
	-C...Set counters for current pileup event and loop to next one.
	- MSTI(41)=IPILE
	- IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
	- IF(MSTU70.LT.10) THEN
	- MSTU70=MSTU70+1
	- MSTU(70+MSTU70)=N
	- ENDIF
	- MINT(83)=N
	- MINT(84)=N+MSTP(126)
	- IF(IPILE.LT.NPILE) CALL PYFRAM(2)
	- 270 CONTINUE
	-
	-C...Generic information on pileup events. Reconstruct missing history.
	- IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
	- PARI(91)=VINT(132)
	- PARI(92)=VINT(133)
	- PARI(93)=VINT(134)
	- IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
	- ENDIF
	- CALL PYEDIT(16)
	-
	-C...Transform to the desired coordinate frame.
	- 280 CALL PYFRAM(MSTP(124))
	- MSTU(70)=MSTU70
	- PARU(21)=VINT(1)
	-
	-C...Error messages
	- 5100 FORMAT(1X,'Error: no subprocess switched on.'/
	- &1X,'Execution stopped.')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYEVNW
	-C...Administers the generation of a high-pT event via calls to
	-C...a number of subroutines for the new multiple interactions and
	-C...showering framework.
	-
	- SUBROUTINE PYEVNW
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
	- & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
	-C...Local arrays.
	- DIMENSION VTX(4)
	-
	-C...Stop if no subprocesses on.
	- IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
	- WRITE(MSTU(11),5100)
	- CALL PYSTOP(1)
	- ENDIF
	-
	-C...Initial values for some counters.
	- MSTU(1)=0
	- MSTU(2)=0
	- N=0
	- MINT(5)=MINT(5)+1
	- MINT(7)=0
	- MINT(8)=0
	- MINT(30)=0
	- MINT(83)=0
	- MINT(84)=MSTP(126)
	- MSTU(24)=0
	- MSTU70=0
	- MSTJ14=MSTJ(14)
	-C...Normally, use K(I,4:5) colour info rather than /PYCT/.
	- NCT=0
	- MINT(33)=0
	-C...Zero counters for pT-ordered showers (failsafe)
	- NPART=0
	- NPARTD=0
	-
	-C...Let called routines know call is from PYEVNW (not PYEVNT).
	- MINT(35)=3
	-
	-C...If variable energies: redo incoming kinematics and cross-section.
	- MSTI(61)=0
	- IF(MSTP(171).EQ.1) THEN
	- CALL PYINKI(1)
	- IF(MSTI(61).EQ.1) THEN
	- MINT(5)=MINT(5)-1
	- RETURN
	- ENDIF
	- IF(MINT(121).GT.1) CALL PYSAVE(3,1)
	- CALL PYXTOT
	- ENDIF
	-
	-C...Loop over number of pileup events; check space left.
	- IF(MSTP(131).LE.0) THEN
	- NPILE=1
	- ELSE
	- CALL PYPILE(2)
	- NPILE=MINT(81)
	- ENDIF
	- DO 300 IPILE=1,NPILE
	- IF(MINT(84)+100.GE.MSTU(4)) THEN
	- CALL PYERRM(11,
	- & '(PYEVNW:) no more space in PYJETS for pileup events')
	- IF(MSTU(21).GE.1) GOTO 310
	- ENDIF
	- MINT(82)=IPILE
	-
	-C...Generate variables of hard scattering.
	- MINT(51)=0
	- MSTI(52)=0
	- LOOPHS =0
	- 100 CONTINUE
	- LOOPHS = LOOPHS + 1
	- IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
	- IF(LOOPHS.GE.10) THEN
	- CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
	- & //'multiple interactions. Returning.')
	- MINT(51)=1
	- RETURN
	- ENDIF
	- MINT(31)=0
	- MINT(39)=0
	- MINT(36)=0
	- MINT(51)=0
	- MINT(57)=0
	- CALL PYRAND
	- IF(MSTI(61).EQ.1) THEN
	- MINT(5)=MINT(5)-1
	- RETURN
	- ENDIF
	- IF(MINT(51).EQ.2) RETURN
	- ISUB=MINT(1)
	- IF(MSTP(111).EQ.-1) GOTO 290
	-
	-C...Loopback point if PYPREP fails, especially for junction topologies.
	- NPREP=0
	- MNT31S=MINT(31)
	- 110 NPREP=NPREP+1
	- MINT(31)=MNT31S
	-
	- IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
	-C...Hard scattering (including low-pT):
	-C...reconstruct kinematics and colour flow of hard scattering.
	- MINT31=MINT(31)
	- 120 MINT(31)=MINT31
	- MINT(51)=0
	- CALL PYSCAT
	- IF(MINT(51).EQ.1) GOTO 100
	- NPARTD=N
	- NFIN=N
	-
	-C...Intertwined initial state showers and multiple interactions.
	-C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
	-C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
	- MSTP61=MSTP(61)
	- IF (MINT(47).LT.2) MSTP(61)=0
	- MSTP81=MSTP(81)
	- IF (MINT(50).EQ.0) MSTP(81)=0
	- IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
	- & MINT(111).NE.12) THEN
	-C...Absolute max pT2 scale for evolution: phase space limit.
	- PT2MXS=0.25D0*VINT(2)
	-C...Check if more constrained by ISR and MI max scales:
	- PT2MXS=MIN(PT2MXS,MAX(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(-2D0LOG(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 PROC28, CHTMP16
	- 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,CHAU16,CHKF16,CHD116,CHD216,CHD316,
	- &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(2I-1),CHKIN(I),CKIN(2I)
	- 160 CONTINUE
	- SPRMAX=CKIN(32)
	- IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
	- WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
	- WRITE(MSTU(11),7000)
	-
	-C...Status codes and parameter values.
	- ELSEIF(MSTAT.EQ.5) THEN
	- WRITE(MSTU(11),7100)
	- WRITE(MSTU(11),7200)
	- DO 170 I=1,100
	- WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
	- & PARP(100+I)
	- 170 CONTINUE
	-
	-C...List of all processes implemented in the program.
	- ELSEIF(MSTAT.EQ.6) THEN
	- WRITE(MSTU(11),7400)
	- WRITE(MSTU(11),7500)
	- DO 180 I=1,500
	- IF(ISET(I).LT.0) GOTO 180
	- WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
	- 180 CONTINUE
	- WRITE(MSTU(11),7700)
	-
	- ELSEIF(MSTAT.EQ.7) THEN
	- WRITE (MSTU(11),8000)
	- NMODES(0)=0
	- NMODES(10)=0
	- NMODES(9)=0
	- DO 290 ILR=1,2
	- DO 280 KFSM=1,16
	- KFSUSY=ILR*KSUSY1+KFSM
	- NRVDC=0
	-C...SDOWN DECAYS
	- IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
	- NRVDC=3
	- DO 190 I=1,NRVDC
	- PBRAT(I)=0D0
	- NMODES(I)=0
	- 190 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
	- CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
	- CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 200 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- IF (KFDP(IDC,3).EQ.0) THEN
	- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- NMODES(2)=NMODES(2)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	- PBRAT(3)=PBRAT(3)+BRAT(IDC)
	- NMODES(3)=NMODES(3)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- ENDIF
	- 200 CONTINUE
	- ENDIF
	-C...SUP DECAYS
	- IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
	- NRVDC=2
	- DO 210 I=1,NRVDC
	- NMODES(I)=0
	- PBRAT(I)=0D0
	- 210 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
	- CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 220 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- IF (KFDP(IDC,3).EQ.0) THEN
	- IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
	- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
	- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- NMODES(2)=NMODES(2)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- ENDIF
	- 220 CONTINUE
	- ENDIF
	-C...SLEPTON DECAYS
	- IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
	- NRVDC=2
	- DO 230 I=1,NRVDC
	- PBRAT(I)=0D0
	- NMODES(I)=0
	- 230 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
	- CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 240 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- IF (KFDP(IDC,3).EQ.0) THEN
	- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
	- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- NMODES(2)=NMODES(2)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- ENDIF
	- 240 CONTINUE
	- ENDIF
	-C...SNEUTRINO DECAYS
	- IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
	- & THEN
	- NRVDC=2
	- DO 250 I=1,NRVDC
	- PBRAT(I)=0D0
	- NMODES(I)=0
	- 250 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
	- CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 260 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- IF (KFDP(IDC,3).EQ.0) THEN
	- IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
	- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
	- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	- NMODES(2)=NMODES(2)+1
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- ENDIF
	- 260 CONTINUE
	- ENDIF
	- IF (NRVDC.NE.0) THEN
	- DO 270 I=1,NRVDC
	- WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
	- NMODES(0)=NMODES(0)+NMODES(I)
	- 270 CONTINUE
	- ENDIF
	- 280 CONTINUE
	- 290 CONTINUE
	- DO 370 KFSM=21,37
	- KFSUSY=KSUSY1+KFSM
	- NRVDC=0
	-C...NEUTRALINO DECAYS
	- IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
	- NRVDC=4
	- DO 300 I=1,NRVDC
	- PBRAT(I)=0D0
	- NMODES(I)=0
	- 300 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
	- CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 310 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- ID3=IABS(KFDP(IDC,3))
	- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
	- & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
	- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- NMODES(2)=NMODES(2)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
	- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(3)=PBRAT(3)+BRAT(IDC)
	- NMODES(3)=NMODES(3)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
	- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(4)=PBRAT(4)+BRAT(IDC)
	- NMODES(4)=NMODES(4)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- 310 CONTINUE
	- ENDIF
	-C...CHARGINO DECAYS
	- IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
	- NRVDC=5
	- DO 320 I=1,NRVDC
	- PBRAT(I)=0D0
	- NMODES(I)=0
	- 320 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
	- CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
	- CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 330 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- ID3=IABS(KFDP(IDC,3))
	- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	- & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
	- & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	- & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
	- & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	- & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
	- & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- NMODES(2)=NMODES(2)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
	- & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
	- PBRAT(3)=PBRAT(3)+BRAT(IDC)
	- NMODES(3)=NMODES(3)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
	- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(3)=PBRAT(3)+BRAT(IDC)
	- NMODES(3)=NMODES(3)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
	- & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
	- PBRAT(4)=PBRAT(4)+BRAT(IDC)
	- NMODES(4)=NMODES(4)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
	- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(4)=PBRAT(4)+BRAT(IDC)
	- NMODES(4)=NMODES(4)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
	- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(5)=PBRAT(5)+BRAT(IDC)
	- NMODES(5)=NMODES(5)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
	- & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(5)=PBRAT(5)+BRAT(IDC)
	- NMODES(5)=NMODES(5)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- 330 CONTINUE
	- ENDIF
	-C...GLUINO DECAYS
	- IF (KFSM.EQ.21) THEN
	- NRVDC=3
	- DO 340 I=1,NRVDC
	- PBRAT(I)=0D0
	- NMODES(I)=0
	- 340 CONTINUE
	- CALL PYNAME(KFSUSY,CHTMP)
	- CHD0=CHTMP//' '
	- CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	- KC=PYCOMP(KFSUSY)
	- DO 350 J=1,MDCY(KC,3)
	- IDC=J+MDCY(KC,2)-1
	- ID1=IABS(KFDP(IDC,1))
	- ID2=IABS(KFDP(IDC,2))
	- ID3=IABS(KFDP(IDC,3))
	- IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	- & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
	- & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(1)=PBRAT(1)+BRAT(IDC)
	- NMODES(1)=NMODES(1)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	- & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
	- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(2)=PBRAT(2)+BRAT(IDC)
	- NMODES(2)=NMODES(2)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	- & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
	- & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	- PBRAT(3)=PBRAT(3)+BRAT(IDC)
	- NMODES(3)=NMODES(3)+1
	- IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	- IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	- ENDIF
	- 350 CONTINUE
	- ENDIF
	-
	- IF (NRVDC.NE.0) THEN
	- DO 360 I=1,NRVDC
	- WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
	- NMODES(0)=NMODES(0)+NMODES(I)
	- 360 CONTINUE
	- ENDIF
	- 370 CONTINUE
	- WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
	-
	- IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
	- WRITE (MSTU(11),8500)
	- DO 400 IRV=1,3
	- DO 390 JRV=1,3
	- DO 380 KRV=1,3
	- WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
	- & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
	- 380 CONTINUE
	- 390 CONTINUE
	- 400 CONTINUE
	- WRITE (MSTU(11),8600)
	- ENDIF
	- ENDIF
	-
	-C...Formats for printouts.
	- 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
	- &'Events and Cross-sections',1X,9('*'))
	- 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
	- &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
	- &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
	- &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
	- &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
	- &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
	- &'I',12X,'I')
	- 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
	- &D10.3,1X,'I')
	- 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
	- &1X,'I',34X,'I',28X,'I',12X,'I')
	- 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
	- &1X,'********* Total number of errors, excluding junctions =',
	- &1X,I8,' *************'/
	- &1X,'********* Total number of errors, including junctions =',
	- &1X,I8,' *************'/
	- &1X,'********* Total number of warnings = ',
	- &1X,I8,' *************'/
	- &1X,'********* Fraction of events that fail fragmentation ',
	- &'cuts =',1X,F8.5,' *********'/)
	- 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
	- &'Ratios',1X,27('*'))
	- 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
	- &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
	- &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
	- &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
	- &1X,98('='))
	- 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
	- &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
	- &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
	- 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
	- &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
	- &1P,D10.3,0P,1X,'I')
	- 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
	- &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
	- &1P,D10.3,0P,1X,'I')
	- 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
	- 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
	- &'Particles at Hard Interaction',1X,7('*'))
	- 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
	- &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
	- &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
	- &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
	- &78('=')/1X,'I',38X,'I',37X,'I')
	- 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
	- 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
	- 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
	- &'Kinematical Variables',1X,12('*'))
	- 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
	- 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
	- &16X,'I')
	- 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
	- &1X,'<',1X,1P,D10.3,0P,16X,'I')
	- 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
	- 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
	- 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
	- &'Parameter Values',1X,12('*'))
	- 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
	- &'PARP(I)'/)
	- 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
	- 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
	- &1X,13('*'))
	- 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
	- &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
	- &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
	- 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
	- 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
	- 8000 FORMAT(1X/ 1X/
	- & 17X,'Sums over R-Violating branching ratios',1X/ 1X
	- & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
	- & ,'Mother --> Sum over final state flavours',4X,'I',2X
	- & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
	- & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
	- 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
	- & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
	- & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
	- & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
	- & /1X,70('='))
	- 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
	- & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
	- 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
	- 8500 FORMAT(1X/ 1X/
	- & 1X,'R-Violating couplings',1X/ 1X /
	- & 1X,55('=')/
	- & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
	- & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
	- & ,'I',15X,'I',15X,'I',15X,'I')
	- 8600 FORMAT(1X,55('='))
	- 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
	- & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYUPEV
	-C...Administers the hard-process generation required for output to the
	-C...Les Houches event record.
	-
	- SUBROUTINE PYUPEV
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
	- &/PYINT1/,/PYINT2/,/PYINT4/
	-
	-C...HEPEUP for output.
	- INTEGER MAXNUP
	- PARAMETER (MAXNUP=500)
	- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	- SAVE /HEPEUP/
	-
	-C...Stop if no subprocesses on.
	- IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
	- WRITE(MSTU(11),5100)
	- STOP
	- ENDIF
	-
	-C...Special flags for hard-process generation only.
	- MSTP71=MSTP(71)
	- MSTP(71)=0
	- MST128=MSTP(128)
	- MSTP(128)=1
	-
	-C...Initial values for some counters.
	- N=0
	- MINT(5)=MINT(5)+1
	- MINT(7)=0
	- MINT(8)=0
	- MINT(30)=0
	- MINT(83)=0
	- MINT(84)=MSTP(126)
	- MSTU(24)=0
	- MSTU70=0
	- MSTJ14=MSTJ(14)
	-C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
	- MINT(33)=0
	-
	-C...If variable energies: redo incoming kinematics and cross-section.
	- MSTI(61)=0
	- IF(MSTP(171).EQ.1) THEN
	- CALL PYINKI(1)
	- IF(MSTI(61).EQ.1) THEN
	- MINT(5)=MINT(5)-1
	- RETURN
	- ENDIF
	- IF(MINT(121).GT.1) CALL PYSAVE(3,1)
	- CALL PYXTOT
	- ENDIF
	-
	-C...Do not allow pileup events.
	- MINT(82)=1
	-
	-C...Generate variables of hard scattering.
	- MINT(51)=0
	- MSTI(52)=0
	- 100 CONTINUE
	- IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
	- MINT(31)=0
	- MINT(51)=0
	- MINT(57)=0
	- CALL PYRAND
	- IF(MSTI(61).EQ.1) THEN
	- MINT(5)=MINT(5)-1
	- RETURN
	- ENDIF
	- IF(MINT(51).EQ.2) RETURN
	- ISUB=MINT(1)
	-
	- IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
	-C...Hard scattering (including low-pT):
	-C...reconstruct kinematics and colour flow of hard scattering.
	- MINT31=MINT(31)
	- 110 MINT(31)=MINT31
	- MINT(51)=0
	- CALL PYSCAT
	- IF(MINT(51).EQ.1) GOTO 100
	- IPU1=MINT(84)+1
	- IPU2=MINT(84)+2
	-
	-C...Decay of final state resonances.
	- MINT(32)=0
	- IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
	- & CALL PYRESD(0)
	- IF(MINT(51).EQ.1) GOTO 100
	- MINT(52)=N
	-
	-C...Longitudinal boost of hard scattering.
	- BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
	- CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
	-
	- ELSEIF(ISUB.NE.99) THEN
	-C...Diffractive and elastic scattering.
	- CALL PYDIFF
	-
	- ELSE
	-C...DIS scattering (photon flux external).
	- CALL PYDISG
	- IF(MINT(51).EQ.1) GOTO 100
	- ENDIF
	-
	-C...Check that no odd resonance left undecayed.
	- MINT(54)=N
	- NFIX=N
	- DO 120 I=MINT(84)+1,NFIX
	- IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
	- & K(I,2).NE.22) THEN
	- KCA=PYCOMP(K(I,2))
	- IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
	- CALL PYRESD(I)
	- IF(MINT(51).EQ.1) GOTO 100
	- ENDIF
	- ENDIF
	- 120 CONTINUE
	-
	-C...Boost hadronic subsystem to overall rest frame.
	-C..(Only relevant when photon inside lepton beam.)
	- IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
	-
	-C...Store event information and calculate Monte Carlo estimates of
	-C...subprocess cross-sections.
	- 130 CALL PYDOCU
	-
	-C...Transform to the desired coordinate frame.
	- 140 CALL PYFRAM(MSTP(124))
	- MSTU(70)=MSTU70
	- PARU(21)=VINT(1)
	-
	-C...Restore special flags for hard-process generation only.
	- MSTP(71)=MSTP71
	- MSTP(128)=MST128
	-
	-C...Trace colour tags; convert to LHA style labels.
	- NCT=100
	- DO 150 I=MINT(84)+1,N
	- MCT(I,1)=0
	- MCT(I,2)=0
	- 150 CONTINUE
	- DO 160 I=MINT(84)+1,N
	- KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
	- IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
	- IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
	- & THEN
	- IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
	- IDA=MOD(K(I,4),MSTU(5))
	- IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
	- & MCT(IMO,2).NE.0) THEN
	- MCT(I,1)=MCT(IMO,2)
	- ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
	- & MCT(IMO,1).NE.0) THEN
	- MCT(I,1)=MCT(IMO,1)
	- ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
	- & MCT(IDA,2).NE.0) THEN
	- MCT(I,1)=MCT(IDA,2)
	- ELSE
	- NCT=NCT+1
	- MCT(I,1)=NCT
	- ENDIF
	- ENDIF
	- IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
	- & THEN
	- IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
	- IDA=MOD(K(I,5),MSTU(5))
	- IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
	- & MCT(IMO,1).NE.0) THEN
	- MCT(I,2)=MCT(IMO,1)
	- ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
	- & MCT(IMO,2).NE.0) THEN
	- MCT(I,2)=MCT(IMO,2)
	- ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
	- & MCT(IDA,1).NE.0) THEN
	- MCT(I,2)=MCT(IDA,1)
	- ELSE
	- NCT=NCT+1
	- MCT(I,2)=NCT
	- ENDIF
	- ENDIF
	- ENDIF
	- 160 CONTINUE
	-
	-C...Put event in HEPEUP commonblock.
	- NUP=N-MINT(84)
	- IDPRUP=MINT(1)
	- XWGTUP=1D0
	- SCALUP=VINT(53)
	- AQEDUP=VINT(57)
	- AQCDUP=VINT(58)
	- DO 180 I=1,NUP
	- IDUP(I)=K(I+MINT(84),2)
	- IF(I.LE.2) THEN
	- ISTUP(I)=-1
	- MOTHUP(1,I)=0
	- MOTHUP(2,I)=0
	- ELSEIF(K(I+4,3).EQ.0) THEN
	- ISTUP(I)=1
	- MOTHUP(1,I)=1
	- MOTHUP(2,I)=2
	- ELSE
	- ISTUP(I)=1
	- MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
	- MOTHUP(2,I)=0
	- ENDIF
	- IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
	- & ISTUP(K(I+MINT(84),3)-MINT(84))=2
	- ICOLUP(1,I)=MCT(I+MINT(84),1)
	- ICOLUP(2,I)=MCT(I+MINT(84),2)
	- DO 170 J=1,5
	- PUP(J,I)=P(I+MINT(84),J)
	- 170 CONTINUE
	- VTIMUP(I)=V(I,5)
	- SPINUP(I)=9D0
	- 180 CONTINUE
	-
	-C...Optionally write out event to disk. Minimal size for time/spin fields.
	- IF(MSTP(162).GT.0) THEN
	- WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
	- DO 190 I=1,NUP
	- IF(VTIMUP(I).EQ.0D0) THEN
	- WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
	- & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
	- & ' 0. 9.'
	- ELSE
	- WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
	- & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
	- & VTIMUP(I),' 9.'
	- ENDIF
	- 190 CONTINUE
	-
	-C...Optional extra line with parton-density information.
	- IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
	- & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
	- ENDIF
	-
	-C...Error messages and other print formats.
	- 5100 FORMAT(1X,'Error: no subprocess switched on.'/
	- &1X,'Execution stopped.')
	- 5200 FORMAT(1P,2I6,4E14.6)
	- 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
	- 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
	- 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYUPIN
	-C...Fills the HEPRUP commonblock with info on incoming beams and allowed
	-C...processes, and optionally stores that information on file.
	-
	- SUBROUTINE PYUPIN
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	-
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
	-
	-C...User process initialization commonblock.
	- INTEGER MAXPUP
	- PARAMETER (MAXPUP=100)
	- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	- &LPRUP(MAXPUP)
	- SAVE /HEPRUP/
	-
	-C...Store info on incoming beams.
	- IDBMUP(1)=K(1,2)
	- IDBMUP(2)=K(2,2)
	- EBMUP(1)=P(1,4)
	- EBMUP(2)=P(2,4)
	- PDFGUP(1)=0
	- PDFGUP(2)=0
	- PDFSUP(1)=MSTP(51)
	- PDFSUP(2)=MSTP(51)
	-
	-C...Event weighting strategy.
	- IDWTUP=3
	-
	-C...Info on individual processes.
	- NPRUP=0
	- DO 100 ISUB=1,500
	- IF(MSUB(ISUB).EQ.1) THEN
	- NPRUP=NPRUP+1
	- XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
	- XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
	- XMAXUP(NPRUP)=1D0
	- LPRUP(NPRUP)=ISUB
	- ENDIF
	- 100 CONTINUE
	-
	-C...Write info to file.
	- IF(MSTP(161).GT.0) THEN
	- WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
	- & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	- DO 110 IPR=1,NPRUP
	- WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
	- & LPRUP(IPR)
	- 110 CONTINUE
	- ENDIF
	-
	-C...Formats for printout.
	- 5100 FORMAT(1P,2I8,2E14.6,6I6)
	- 5200 FORMAT(1P,3E14.6,I6)
	-
	- RETURN
	- END
	-
	-
	-C*********************************************************************
	-
	-C...Combine the two old-style Pythia initialization and event files
	-C...into a single Les Houches Event File.
	-
	- SUBROUTINE PYLHEF
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	-
	-C...PYTHIA commonblock: only used to provide read/write units and version.
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- SAVE /PYPARS/
	-
	-C...User process initialization commonblock.
	- INTEGER MAXPUP
	- PARAMETER (MAXPUP=100)
	- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	- &LPRUP(MAXPUP)
	- SAVE /HEPRUP/
	-
	-C...User process event common block.
	- INTEGER MAXNUP
	- PARAMETER (MAXNUP=500)
	- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	- SAVE /HEPEUP/
	-
	-C...Lines to read in assumed never longer than 200 characters.
	- PARAMETER (MAXLEN=200)
	- CHARACTER*(MAXLEN) STRING
	-
	-C...Format for reading lines.
	- CHARACTER*6 STRFMT
	- STRFMT='(A000)'
	- WRITE(STRFMT(3:5),'(I3)') MAXLEN
	-
	-C...Rewind initialization and event files.
	- REWIND MSTP(161)
	- REWIND MSTP(162)
	-
	-C...Write header info.
	- WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
	- WRITE(MSTP(163),'(A)') '<!--'
	- WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
	- &MSTP(181),'.',MSTP(182)
	- WRITE(MSTP(163),'(A)') '-->'
	-
	-C...Read first line of initialization info and get number of processes.
	- READ(MSTP(161),'(A)',END=400,ERR=400) STRING
	- READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
	- &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	-
	-C...Copy initialization lines, omitting trailing blanks.
	-C...Embed in <init> ... </init> block.
	- WRITE(MSTP(163),'(A)') '<init>'
	- DO 140 IPR=0,NPRUP
	- IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
	- LEN=MAXLEN+1
	- 120 LEN=LEN-1
	- IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
	- WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
	- 140 CONTINUE
	- WRITE(MSTP(163),'(A)') '</init>'
	-
	-C...Begin event loop. Read first line of event info or already done.
	- READ(MSTP(162),'(A)',END=320,ERR=400) STRING
	- 200 CONTINUE
	-
	-C...Look at first line to know number of particles in event.
	- READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
	-
	-C...Begin an <event> block. Copy event lines, omitting trailing blanks.
	- WRITE(MSTP(163),'(A)') '<event>'
	- DO 240 I=0,NUP
	- IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
	- LEN=MAXLEN+1
	- 220 LEN=LEN-1
	- IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
	- WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
	- 240 CONTINUE
	-
	-C...Copy trailing comment lines - with a # in the first column - as is.
	- 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
	- IF(STRING(1:1).EQ.'#') THEN
	- LEN=MAXLEN+1
	- 280 LEN=LEN-1
	- IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
	- WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
	- GOTO 260
	- ENDIF
	-
	-C..End the <event> block. Loop back to look for next event.
	- WRITE(MSTP(163),'(A)') '</event>'
	- GOTO 200
	-
	-C...Successfully reached end of event loop: write closing tag
	-C...and remove temporary intermediate files (unless asked not to).
	- 300 WRITE(MSTP(163),'(A)') '</event>'
	- 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
	- IF(MSTP(164).EQ.1) RETURN
	- CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
	- CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
	- RETURN
	-
	-C...Error exit.
	- 400 WRITE(,) ' PYLHEF file joining failed!'
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYINRE
	-C...Calculates full and effective widths of gauge bosons, stores
	-C...masses and widths, rescales coefficients to be used for
	-C...resonance production generation.
	-
	- SUBROUTINE PYINRE
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYDAT4/CHAF(500,2)
	- CHARACTER CHAF*16
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYINT6/PROC(0:500)
	- CHARACTER PROC*28
	- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
	- &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
	-C...Local arrays and data.
	- 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-TANBE2)/(1D0+TANBE2))**2
	- SQMZ=PMAS(23,1)**2
	- SQMW=PMAS(24,1)**2
	- SQMH=PMAS(25,1)**2
	- SQMA=SQMH(SQMZ-SQMH)/(SQMZRATBE-SQMH)
	- SQMHP=0.5D0(SQMA+SQMZ+SQRT((SQMA+SQMZ)2-4D0SQMASQMZRATBE))
	- 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.5D0ATAN(2D0TANBE(SQMA+SQMZ)/((1D0-TANBE2)
	- & (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.5D0COS(2D0BESU)*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(2D0ALSU)COS(BESU+ALSU)-2D0SIN(2D0ALSU)*
	- & SIN(BESU+ALSU)
	- PARU(177)=COS(2D0BESU)COS(BESU+ALSU)
	- PARU(178)=COS(BESU-ALSU)-0.5D0COS(2D0BESU)*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))+
	- & 2D0WDTE(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))+
	- & 2D0WDTE(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))+
	- & 2D0WDTEM(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.9D0PMAS(KC,1),10D0PMAS(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(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
	-
	-C...Local arrays, character variables and data.
	- CHARACTER CHFRAM12,CHBEAM12,CHTARG12,CHCOM(3)12,CHALP(2)*26,
	- &CHIDNT(3)12,CHTEMP12,CHCDE(39)12,CHINIT76,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+2D0PM(2)SQRT(PM(1)2+WIN2)
	- IF(MSTP(122).GE.1) THEN
	- LOFFS=(29-(LEN(2)+LEN(3)))/2
	- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	- & ' fixed target'//' '
	- WRITE(MSTU(11),5200) CHINIT
	- WRITE(MSTU(11),5400) WIN
	- WRITE(MSTU(11),5500) SQRT(S)
	- ENDIF
	-
	-C...Frame defined by user three-vectors.
	- ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
	- MINT(111)=3
	- P(1,5)=PM(1)
	- P(2,5)=PM(2)
	- P(1,4)=SQRT(P(1,1)2+P(1,2)2+P(1,3)2+P(1,5)2)
	- P(2,4)=SQRT(P(2,1)2+P(2,2)2+P(2,3)2+P(2,5)2)
	- S=(P(1,4)+P(2,4))2-(P(1,1)+P(2,1))2-(P(1,2)+P(2,2))**2-
	- & (P(1,3)+P(2,3))**2
	- IF(MSTP(122).GE.1) THEN
	- LOFFS=(22-(LEN(2)+LEN(3)))/2
	- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	- & ' user configuration'//' '
	- WRITE(MSTU(11),5200) CHINIT
	- WRITE(MSTU(11),5600)
	- WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
	- WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
	- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	- ENDIF
	-
	-C...Frame defined by user four-vectors.
	- ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
	- MINT(111)=4
	- PMS1=P(1,4)2-P(1,1)2-P(1,2)2-P(1,3)2
	- P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
	- PMS2=P(2,4)2-P(2,1)2-P(2,2)2-P(2,3)2
	- P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
	- S=(P(1,4)+P(2,4))2-(P(1,1)+P(2,1))2-(P(1,2)+P(2,2))**2-
	- & (P(1,3)+P(2,3))**2
	- IF(MSTP(122).GE.1) THEN
	- LOFFS=(22-(LEN(2)+LEN(3)))/2
	- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	- & ' user configuration'//' '
	- WRITE(MSTU(11),5200) CHINIT
	- WRITE(MSTU(11),5600)
	- WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
	- WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
	- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	- ENDIF
	-
	-C...Frame defined by user five-vectors.
	- ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
	- MINT(111)=5
	- S=(P(1,4)+P(2,4))2-(P(1,1)+P(2,1))2-(P(1,2)+P(2,2))**2-
	- & (P(1,3)+P(2,3))**2
	- IF(MSTP(122).GE.1) THEN
	- LOFFS=(22-(LEN(2)+LEN(3)))/2
	- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	- & ' user configuration'//' '
	- WRITE(MSTU(11),5200) CHINIT
	- WRITE(MSTU(11),5600)
	- WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
	- WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
	- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	- ENDIF
	-
	-C...Frame defined by HEPRUP common block.
	- ELSEIF(MINT(111).GE.11) THEN
	- S=(EBMUP(1)+EBMUP(2))2-(SQRT(MAX(0D0,EBMUP(1)2-PM(1)**2))-
	- & SQRT(MAX(0D0,EBMUP(2)2-PM(2)2)))**2
	- IF(MSTP(122).GE.1) THEN
	- LOFFS=(22-(LEN(2)+LEN(3)))/2
	- CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	- & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	- & ' user configuration'//' '
	- WRITE(MSTU(11),5200) CHINIT
	- WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
	- WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	- ENDIF
	-
	-C...Unknown frame. Error for too low CM energy.
	- ELSE
	- WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
	- CALL PYSTOP(7)
	- ENDIF
	- IF(S.LT.PARP(2)**2) THEN
	- WRITE(MSTU(11),5900) SQRT(S)
	- CALL PYSTOP(7)
	- ENDIF
	-
	-C...Formats for initialization and error information.
	- 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
	- &1X,'Execution stopped!')
	- 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
	- &1X,'Execution stopped!')
	- 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
	- 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
	- &19X,'I'/1X,'I',76X,'I'/1X,78('='))
	- 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
	- 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
	- &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
	- 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
	- &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
	- 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
	- 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
	- &1X,'Execution stopped!')
	- 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
	- &'generation.'/1X,'Execution stopped!')
	- 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
	- &'GeV beam energies',13X,'I')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYINKI
	-C...Sets up kinematics, including rotations and boosts to/from CM frame.
	-
	- SUBROUTINE PYINKI(MODKI)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-
	-C...User process initialization commonblock.
	- INTEGER MAXPUP
	- PARAMETER (MAXPUP=100)
	- INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	- DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	- COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	- &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	- &LPRUP(MAXPUP)
	- SAVE /HEPRUP/
	-
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
	-
	-C...Set initial flavour state.
	- N=2
	- DO 100 I=1,2
	- K(I,1)=1
	- K(I,2)=MINT(10+I)
	- IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
	- 100 CONTINUE
	-
	-C...Reset boost. Do kinematics for various cases.
	- DO 110 J=6,10
	- VINT(J)=0D0
	- 110 CONTINUE
	-
	-C...Set up kinematics for events defined in CM frame.
	- IF(MINT(111).EQ.1) THEN
	- WIN=VINT(290)
	- IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
	- S=WIN**2
	- P(1,5)=VINT(3)
	- P(2,5)=VINT(4)
	- IF(MINT(141).NE.0) P(1,5)=VINT(303)
	- IF(MINT(142).NE.0) P(2,5)=VINT(304)
	- P(1,1)=0D0
	- P(1,2)=0D0
	- P(2,1)=0D0
	- P(2,2)=0D0
	- P(1,3)=SQRT(((S-P(1,5)2-P(2,5)2)*2-(2D0P(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+2D0P(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)=4D0PTMN*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.125D0LOG(1D0+0.10D0VINT(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/71,30,61,40,43,26,4*0/
	-C...X and Y parameters of sigmatot = X * s*epsilon + Y s**(-eta).
	- DATA XPAR/221.70D0,313.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/21,32,3,4,30,32,23,4,40/
	- DATA IHADB/71,30,2,3,4,3,24,40/
	-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/21,32,3,4,30,5,6,7,8,9,10,40/
	- DATA IFITDD/21,32,3,4,30,5,6,7,8,9,10,40/
	- 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=2D0BHA+2D0BHB+4D0*SEPS-4.2D0
	- SIGTMP(I,1)=FACELSIGTMP(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+2D0ALPLOG(S/SQML))/
	- & (BSD+2D0ALPLOG(S/SQMU)))/(2D0*ALP)
	- BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
	- SUM2=CRESLOG(1D0+((PMA+PMRC)/(PMA+PMTH))*2)/
	- & (BSD+2D0ALPLOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
	- SIGTMP(I,2)=FACSDXPAR(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+2D0ALPLOG(S/SQML))/
	- & (BSD+2D0ALPLOG(S/SQMU)))/(2D0*ALP)
	- BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
	- SUM2=CRESLOG(1D0+((PMB+PMRC)/(PMB+PMTH))*2)/
	- & (BSD+2D0ALPLOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
	- SIGTMP(I,3)=FACSDXPAR(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(SSMP/((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))/(2D0ALP)
	- 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/(ALPSQMU(PMB+PMTH)*(PMB+PMRC))))
	- SUM2=CRESLOG(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/(ALPSQMU(PMA+PMTH)*(PMA+PMRC))))
	- SUM3=CRESLOG(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*2LOG(1D0+((PMA+PMRC)/(PMA+PMTH))*2)
	- & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))*2)/MAX(0.1D0,2D0ALP*SLRR+BXX)
	- SIGTMP(I,4)=FACDDXPAR(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)=16D0PARP(15)2VINT(154)**2/
	- & ((4D0PARP(15)2+VINT(307))(4D0VINT(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)2PARP(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)=16D0PARP(15)2VINT(154)**2/
	- & ((4D0PARP(15)2+VINT(308))(4D0VINT(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)2PARP(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)=16D0PARP(15)2VINT(154)**2/
	- & ((4D0PARP(15)2+VINT(307))(4D0VINT(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)16D0PARP(15)*2VINT(154)**2/
	- & ((4D0PARP(15)2+VINT(308))(4D0VINT(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)2PARP(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)*2PARP(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/(96D0PARU(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.08D0PARP(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+GAMR12)
	- 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+GAMR22)
	- ENDIF
	- IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
	- WTMAT(IBIN,3+2MINT(72))=WTMAT(IBIN,3+2MINT(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,2D0SQM3SQM4/(VINTPT(IACC,11)VINT(2))*2)
	- RSQM=1D0+RM34
	- CTHMAX=SQRT(1D0-4D0VINT(71)2/(TAUMAXVINT(2)))
	- CTHMIN=-CTHMAX
	- IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0VINT(71)*2/
	- & (TAUMAX*VINT(2)))
	- ACTH1=CTHMAX-CTHMIN
	- ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
	- ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
	- ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
	- ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
	- CTH=VINTPT(IACC,13)
	- WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
	- WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
	- & MAX(RM34,RSQM-CTH)
	- WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
	- & MAX(RM34,RSQM+CTH)
	- WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
	- & MAX(RM34,RSQM-CTH)**2
	- WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
	- & MAX(RM34,RSQM+CTH)**2
	- ENDIF
	- 180 CONTINUE
	-
	-C...Check that equation system solvable.
	- IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
	- MSOLV=1
	- WTRELS=0D0
	- DO 190 IBIN=1,NBIN
	- IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
	- & IRED=1,NBIN),WTREL(IBIN)
	- IF(NAREL(IBIN).EQ.0) MSOLV=0
	- WTRELS=WTRELS+WTREL(IBIN)
	- 190 CONTINUE
	- IF(ABS(WTRELS).LT.1D-20) MSOLV=0
	-
	-C...Solve to find relative importance of cross-section pieces.
	- IF(MSOLV.EQ.1) THEN
	- DO 200 IBIN=1,NBIN
	- WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
	- WTRSAV(IBIN)=WTREL(IBIN)
	- 200 CONTINUE
	-C...Auxiliary vectors to record order of permutations
	- DO I=1,NBIN
	- IP(I) = I
	- IQ(I) = I
	- ENDDO
	- DO 230 IRED=1,NBIN-1
	- MROW=IRED
	- RESMAX=ABS(WTREL(MROW))
	-C...Find row with largest residual
	- DO JBIN=IRED+1,NBIN
	- IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
	- MROW=JBIN
	- RESMAX=ABS(WTREL(MROW))
	- ENDIF
	- ENDDO
	- IF(RESMAX.LT.1D-20) THEN
	- MSOLV=0
	- GOTO 260
	- ENDIF
	- MCOL = IRED
	- AMAX = ABS(WTMAT(MROW,MCOL))
	-C...Find column with largest entry
	- DO JBIN=IRED+1,NBIN
	- IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
	- MCOL = JBIN
	- AMAX = ABS(WTMAT(MROW,MCOL))
	- ENDIF
	- ENDDO
	-C...Swap rows if necessary
	- IF(MROW.NE.IRED) THEN
	- DO JBIN=1,NBIN
	- TMPE=WTMAT(IRED,JBIN)
	- WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
	- WTMAT(MROW,JBIN)=TMPE
	- ENDDO
	- TMPE=WTREL(IRED)
	- WTREL(IRED)=WTREL(MROW)
	- WTREL(MROW)=TMPE
	- MTMP=IQ(IRED)
	- IQ(IRED)=IQ(MROW)
	- IQ(MROW)=MTMP
	- ENDIF
	-C...Swap columns if necessary
	- IF(MCOL.NE.IRED) THEN
	- DO JBIN=1,NBIN
	- TMPE=WTMAT(JBIN,IRED)
	- WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
	- WTMAT(JBIN,MCOL)=TMPE
	- ENDDO
	- MTMP=IP(IRED)
	- IP(IRED)=IP(MCOL)
	- IP(MCOL)=MTMP
	- ENDIF
	-C...Begin eliminating equations
	- DO 220 IBIN=IRED+1,NBIN
	- IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
	- MSOLV=0
	- GOTO 260
	- ENDIF
	-C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
	- RQTU=WTMAT(IBIN,IRED)
	- RQTL=WTMAT(IRED,IRED)
	-C...Switch order of operations
	- WTREL(IBIN)=WTREL(IBIN)-RQTU*
	- $ (WTREL(IRED)/RQTL)
	- DO 210 ICOE=IRED,NBIN
	- WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
	- $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
	- 210 CONTINUE
	- 220 CONTINUE
	- 230 CONTINUE
	- DO 250 IRED=NBIN,1,-1
	- DO 240 ICOE=IRED+1,NBIN
	- WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
	- 240 CONTINUE
	- IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
	- MSOLV=0
	- GOTO 260
	- ENDIF
	- COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
	- TEMPC(IRED)=COEFU(IRED)
	- 250 CONTINUE
	-C...Return to original order
	- DO IBIN=1,NBIN
	- MTMP=IP(IBIN)
	- COEFU(MTMP)=TEMPC(IBIN)
	- ENDDO
	- ENDIF
	-
	-C...Share evenly if failure.
	- 260 IF(MSOLV.EQ.0) THEN
	- DO 270 IBIN=1,NBIN
	- COEFU(IBIN)=1D0
	- WTRELN(IBIN)=0.1D0
	- IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
	- & WTRSAV(IBIN)/WTRELS)
	- 270 CONTINUE
	- ENDIF
	-
	-C...Normalize coefficients, with piece shared democratically.
	- COEFSU=0D0
	- WTRELS=0D0
	- DO 280 IBIN=1,NBIN
	- COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
	- COEFSU=COEFSU+COEFU(IBIN)
	- WTRELS=WTRELS+WTRELN(IBIN)
	- 280 CONTINUE
	- IF(COEFSU.GT.0D0) THEN
	- DO 290 IBIN=1,NBIN
	- COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))0.5D0
	- & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
	- 290 CONTINUE
	- ELSE
	- DO 300 IBIN=1,NBIN
	- COEFO(IBIN)=1D0/NBIN
	- 300 CONTINUE
	- ENDIF
	- IF(IVAR.EQ.1) IOFF=0
	- IF(IVAR.EQ.2) IOFF=17
	- IF(IVAR.EQ.3) IOFF=7
	- IF(IVAR.EQ.4) IOFF=12
	- DO 310 IBIN=1,NBIN
	- ICOF=IOFF+IBIN
	- IF(IVAR.EQ.1) THEN
	- IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
	- ICOF=7
	- ENDIF
	- ENDIF
	- IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
	- IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
	- COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
	- ELSE
	- COEF(ISUB,ICOF)=COEFO(IBIN)
	- ENDIF
	- 310 CONTINUE
	-
	- IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
	- & (COEFO(IBIN),IBIN=1,NBIN)
	-
	- 320 CONTINUE
	-
	-C...Find two most promising maxima among points previously determined.
	- DO 330 J=1,4
	- IACCMX(J)=0
	- SIGSMX(J)=0D0
	- 330 CONTINUE
	- NMAX=0
	- DO 390 IACC=1,NACC
	- DO 340 J=1,30
	- VINT(10+J)=VINTPT(IACC,J)
	- 340 CONTINUE
	- IF(ISTSB.NE.5) THEN
	- CALL PYSIGH(NCHN,SIGS)
	- IF(MWTXS.EQ.1) THEN
	- CALL PYEVWT(WTXS)
	- SIGS=WTXS*SIGS
	- ENDIF
	- ELSE
	- SIGS=0D0
	- DO 350 IKIN3=1,MSTP(129)
	- CALL PYKMAP(5,0,0D0)
	- IF(MINT(51).EQ.1) GOTO 350
	- CALL PYSIGH(NCHN,SIGTMP)
	- IF(MWTXS.EQ.1) THEN
	- CALL PYEVWT(WTXS)
	- SIGTMP=WTXS*SIGTMP
	- ENDIF
	- IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
	- 350 CONTINUE
	- ENDIF
	- IEQ=0
	- DO 360 IMV=1,NMAX
	- IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
	- 360 CONTINUE
	- IF(IEQ.EQ.0) THEN
	- DO 370 IMV=NMAX,1,-1
	- IIN=IMV+1
	- IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
	- IACCMX(IMV+1)=IACCMX(IMV)
	- SIGSMX(IMV+1)=SIGSMX(IMV)
	- 370 CONTINUE
	- IIN=1
	- 380 IACCMX(IIN)=IACC
	- SIGSMX(IIN)=SIGS
	- IF(NMAX.LE.1) NMAX=NMAX+1
	- ENDIF
	- 390 CONTINUE
	-
	-C...Read out starting position for search.
	- IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
	- SIGSAM=SIGSMX(1)
	- DO 440 IMAX=1,NMAX
	- IACC=IACCMX(IMAX)
	- MTAU=MVARPT(IACC,1)
	- MTAUP=MVARPT(IACC,2)
	- MYST=MVARPT(IACC,3)
	- MCTH=MVARPT(IACC,4)
	- VTAU=0.5D0
	- VYST=0.5D0
	- VCTH=0.5D0
	- VTAUP=0.5D0
	-
	-C...Starting point and step size in parameter space.
	- DO 430 IRPT=1,2
	- DO 420 IVAR=1,4
	- IF(NPTS(IVAR).EQ.1) GOTO 420
	- IF(IVAR.EQ.1) VVAR=VTAU
	- IF(IVAR.EQ.2) VVAR=VTAUP
	- IF(IVAR.EQ.3) VVAR=VYST
	- IF(IVAR.EQ.4) VVAR=VCTH
	- IF(IVAR.EQ.1) MVAR=MTAU
	- IF(IVAR.EQ.2) MVAR=MTAUP
	- IF(IVAR.EQ.3) MVAR=MYST
	- IF(IVAR.EQ.4) MVAR=MCTH
	- IF(IRPT.EQ.1) VDEL=0.1D0
	- IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
	- & 0.98D0-VVAR))
	- IF(IRPT.EQ.1) VMAR=0.02D0
	- IF(IRPT.EQ.2) VMAR=0.002D0
	- IMOV0=1
	- IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
	- DO 410 IMOV=IMOV0,8
	-
	-C...Define new point in parameter space.
	- IF(IMOV.EQ.0) THEN
	- INEW=2
	- VNEW=VVAR
	- ELSEIF(IMOV.EQ.1) THEN
	- INEW=3
	- VNEW=VVAR+VDEL
	- ELSEIF(IMOV.EQ.2) THEN
	- INEW=1
	- VNEW=VVAR-VDEL
	- ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
	- & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
	- VVAR=VVAR+VDEL
	- SIGSSM(1)=SIGSSM(2)
	- SIGSSM(2)=SIGSSM(3)
	- INEW=3
	- VNEW=VVAR+VDEL
	- ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
	- & VVAR-2D0*VDEL.GT.VMAR) THEN
	- VVAR=VVAR-VDEL
	- SIGSSM(3)=SIGSSM(2)
	- SIGSSM(2)=SIGSSM(1)
	- INEW=1
	- VNEW=VVAR-VDEL
	- ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
	- VDEL=0.5D0*VDEL
	- VVAR=VVAR+VDEL
	- SIGSSM(1)=SIGSSM(2)
	- INEW=2
	- VNEW=VVAR
	- ELSE
	- VDEL=0.5D0*VDEL
	- VVAR=VVAR-VDEL
	- SIGSSM(3)=SIGSSM(2)
	- INEW=2
	- VNEW=VVAR
	- ENDIF
	-
	-C...Convert to relevant variables and find derived new limits.
	- ILERR=0
	- IF(IVAR.EQ.1) THEN
	- VTAU=VNEW
	- CALL PYKMAP(1,MTAU,VTAU)
	- IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
	- CALL PYKLIM(4)
	- IF(MINT(51).EQ.1) ILERR=1
	- ENDIF
	- ENDIF
	- IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
	- & ILERR.EQ.0) THEN
	- IF(IVAR.EQ.2) VTAUP=VNEW
	- CALL PYKMAP(4,MTAUP,VTAUP)
	- ENDIF
	- IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
	- CALL PYKLIM(2)
	- IF(MINT(51).EQ.1) ILERR=1
	- ENDIF
	- IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
	- IF(IVAR.EQ.3) VYST=VNEW
	- CALL PYKMAP(2,MYST,VYST)
	- CALL PYKLIM(3)
	- IF(MINT(51).EQ.1) ILERR=1
	- ENDIF
	- IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
	- & ILERR.EQ.0) THEN
	- IF(IVAR.EQ.4) VCTH=VNEW
	- CALL PYKMAP(3,MCTH,VCTH)
	- ENDIF
	- IF(ISUB.EQ.96) VINT(25)=VINT(21)(1.-VINT(23)*2)
	-
	-C...Evaluate cross-section. Save new maximum. Final maximum.
	- IF(ILERR.NE.0) THEN
	- SIGS=0.
	- ELSEIF(ISTSB.NE.5) THEN
	- CALL PYSIGH(NCHN,SIGS)
	- IF(MWTXS.EQ.1) THEN
	- CALL PYEVWT(WTXS)
	- SIGS=WTXS*SIGS
	- ENDIF
	- ELSE
	- SIGS=0D0
	- DO 400 IKIN3=1,MSTP(129)
	- CALL PYKMAP(5,0,0D0)
	- IF(MINT(51).EQ.1) GOTO 400
	- CALL PYSIGH(NCHN,SIGTMP)
	- IF(MWTXS.EQ.1) THEN
	- CALL PYEVWT(WTXS)
	- SIGTMP=WTXS*SIGTMP
	- ENDIF
	- IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
	- 400 CONTINUE
	- ENDIF
	- SIGSSM(INEW)=SIGS
	- IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
	- IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
	- & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
	- 410 CONTINUE
	- 420 CONTINUE
	- 430 CONTINUE
	- 440 CONTINUE
	- IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
	- XSEC(ISUB,1)=1.05D0*SIGSAM
	-C...Add extra headroom for UED
	- IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
	- IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
	- & WTGAGA*XSEC(ISUB,1)
	- 450 CONTINUE
	- IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
	- & PARP(174)*XSEC(ISUB,1)
	- IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
	- 460 CONTINUE
	- MINT(51)=0
	-
	-C...Print summary table.
	- IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
	- IF(MSTP(127).NE.1) THEN
	- WRITE(MSTU(11),5900)
	- CALL PYSTOP(1)
	- ELSE
	- WRITE(MSTU(11),6400)
	- MSTI(53)=1
	- ENDIF
	- ENDIF
	- IF(MSTP(122).GE.1) THEN
	- WRITE(MSTU(11),6000)
	- WRITE(MSTU(11),6100)
	- DO 470 ISUB=1,500
	- IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
	- IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
	- IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
	- & GOTO 470
	- IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
	- IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
	- & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
	- IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
	- WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
	- 470 CONTINUE
	- WRITE(MSTU(11),6300)
	- ENDIF
	-
	-C...Format statements for maximization results.
	- 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
	- &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
	- &'cth',9X,'tau''',7X,'sigma')
	- 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
	- &'phase space.'/1X,'Process switched off!')
	- 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
	- 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
	- &'cross-section.'/1X,'Process switched off!')
	- 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
	- 5500 FORMAT(1X,1P,10D11.3)
	- 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
	- 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
	- &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
	- 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
	- 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
	- &'cross-section.'/1X,'Execution stopped!')
	- 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
	- &'cross-section maximum search',1X,8('*'))
	- 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
	- &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
	- &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
	- 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
	- 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
	- 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
	- &'cross-section.'/
	- &1X,'Execution will stop if you try to generate events.')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYPILE
	-C...Initializes multiplicity distribution and selects mutliplicity
	-C...of pileup events, i.e. several events occuring at the same
	-C...beam crossing.
	-
	- SUBROUTINE PYPILE(MPILE)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
	-C...Local arrays and saved variables.
	- DIMENSION WTI(0:200)
	- SAVE IMIN,IMAX,WTI,WTS
	-
	-C...Sum of allowed cross-sections for pileup events.
	- IF(MPILE.EQ.1) THEN
	- VINT(131)=SIGT(0,0,5)
	- IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
	- IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
	- IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
	- IF(MSTP(133).LE.0) RETURN
	-
	-C...Initialize multiplicity distribution at maximum.
	- XNAVE=VINT(131)*PARP(131)
	- IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
	- INAVE=MAX(1,MIN(200,NINT(XNAVE)))
	- WTI(INAVE)=1D0
	- WTS=WTI(INAVE)
	- WTN=WTI(INAVE)*INAVE
	-
	-C...Find shape of multiplicity distribution below maximum.
	- IMIN=INAVE
	- DO 100 I=INAVE-1,1,-1
	- IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
	- IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
	- IF(WTI(I).LT.1D-6) GOTO 110
	- WTS=WTS+WTI(I)
	- WTN=WTN+WTI(I)*I
	- IMIN=I
	- 100 CONTINUE
	-
	-C...Find shape of multiplicity distribution above maximum.
	- 110 IMAX=INAVE
	- DO 120 I=INAVE+1,200
	- IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
	- IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
	- IF(WTI(I).LT.1D-6) GOTO 130
	- WTS=WTS+WTI(I)
	- WTN=WTN+WTI(I)*I
	- IMAX=I
	- 120 CONTINUE
	- 130 VINT(132)=XNAVE
	- VINT(133)=WTN/WTS
	- IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
	- & WTS/(WTS+WTI(1)/XNAVE)
	- IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
	- IF(MSTP(133).GE.2) VINT(134)=XNAVE
	-
	-C...Pick multiplicity of pileup events.
	- ELSE
	- IF(MSTP(133).LE.0) THEN
	- MINT(81)=MAX(1,MSTP(134))
	- ELSE
	- WTR=WTS*PYR(0)
	- DO 140 I=IMIN,IMAX
	- MINT(81)=I
	- WTR=WTR-WTI(I)
	- IF(WTR.LE.0D0) GOTO 150
	- 140 CONTINUE
	- 150 CONTINUE
	- ENDIF
	- ENDIF
	-
	-C...Format statement for error message.
	- 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
	- &'crossing too large, ',1P,D12.4)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYSAVE
	-C...Saves and restores parameter and cross section values for the
	-C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
	-C...Also makes random choice between alternatives.
	-
	- SUBROUTINE PYSAVE(ISAVE,IGA)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
	-C...Local arrays and saved variables.
	- DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
	- &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
	- &INTCP(15,20),RECP(15,20)
	- SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
	-
	-C...Save list of subprocesses and cross-section information.
	- IF(ISAVE.EQ.1) THEN
	- ICP=0
	- DO 120 I=1,500
	- IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
	- ICP=ICP+1
	- NSUBCP(IGA,ICP)=I
	- MSUBCP(IGA,ICP)=MSUB(I)
	- DO 100 J=1,20
	- COEFCP(IGA,ICP,J)=COEF(I,J)
	- 100 CONTINUE
	- DO 110 J=1,3
	- NGENCP(IGA,ICP,J)=NGEN(I,J)
	- XSECCP(IGA,ICP,J)=XSEC(I,J)
	- 110 CONTINUE
	- 120 CONTINUE
	- NCP(IGA)=ICP
	- DO 130 J=1,3
	- NGENCP(IGA,0,J)=NGEN(0,J)
	- XSECCP(IGA,0,J)=XSEC(0,J)
	- 130 CONTINUE
	- DO 160 I1=0,6
	- DO 150 I2=0,6
	- DO 140 J=0,5
	- SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
	- 140 CONTINUE
	- 150 CONTINUE
	- 160 CONTINUE
	-
	-C...Save various common process variables.
	- DO 170 J=1,10
	- INTCP(IGA,J)=MINT(40+J)
	- 170 CONTINUE
	- INTCP(IGA,11)=MINT(101)
	- INTCP(IGA,12)=MINT(102)
	- INTCP(IGA,13)=MINT(107)
	- INTCP(IGA,14)=MINT(108)
	- INTCP(IGA,15)=MINT(123)
	- RECP(IGA,1)=CKIN(3)
	- RECP(IGA,2)=VINT(318)
	-
	-C...Save cross-section information only.
	- ELSEIF(ISAVE.EQ.2) THEN
	- DO 190 ICP=1,NCP(IGA)
	- I=NSUBCP(IGA,ICP)
	- DO 180 J=1,3
	- NGENCP(IGA,ICP,J)=NGEN(I,J)
	- XSECCP(IGA,ICP,J)=XSEC(I,J)
	- 180 CONTINUE
	- 190 CONTINUE
	- DO 200 J=1,3
	- NGENCP(IGA,0,J)=NGEN(0,J)
	- XSECCP(IGA,0,J)=XSEC(0,J)
	- 200 CONTINUE
	-
	-C...Choose between allowed alternatives.
	- ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
	- IF(ISAVE.EQ.4) THEN
	- XSUMCP=0D0
	- DO 210 IG=1,MINT(121)
	- XSUMCP=XSUMCP+XSECCP(IG,0,1)
	- 210 CONTINUE
	- XSUMCP=XSUMCP*PYR(0)
	- DO 220 IG=1,MINT(121)
	- IGA=IG
	- XSUMCP=XSUMCP-XSECCP(IG,0,1)
	- IF(XSUMCP.LE.0D0) GOTO 230
	- 220 CONTINUE
	- 230 CONTINUE
	- ENDIF
	-
	-C...Restore cross-section information.
	- DO 240 I=1,500
	- MSUB(I)=0
	- 240 CONTINUE
	- DO 270 ICP=1,NCP(IGA)
	- I=NSUBCP(IGA,ICP)
	- MSUB(I)=MSUBCP(IGA,ICP)
	- DO 250 J=1,20
	- COEF(I,J)=COEFCP(IGA,ICP,J)
	- 250 CONTINUE
	- DO 260 J=1,3
	- NGEN(I,J)=NGENCP(IGA,ICP,J)
	- XSEC(I,J)=XSECCP(IGA,ICP,J)
	- 260 CONTINUE
	- 270 CONTINUE
	- DO 280 J=1,3
	- NGEN(0,J)=NGENCP(IGA,0,J)
	- XSEC(0,J)=XSECCP(IGA,0,J)
	- 280 CONTINUE
	- DO 310 I1=0,6
	- DO 300 I2=0,6
	- DO 290 J=0,5
	- SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
	- 290 CONTINUE
	- 300 CONTINUE
	- 310 CONTINUE
	-
	-C...Restore various common process variables.
	- DO 320 J=1,10
	- MINT(40+J)=INTCP(IGA,J)
	- 320 CONTINUE
	- MINT(101)=INTCP(IGA,11)
	- MINT(102)=INTCP(IGA,12)
	- MINT(107)=INTCP(IGA,13)
	- MINT(108)=INTCP(IGA,14)
	- MINT(123)=INTCP(IGA,15)
	- CKIN(3)=RECP(IGA,1)
	- CKIN(1)=2D0*CKIN(3)
	- VINT(318)=RECP(IGA,2)
	-
	-C...Sum up cross-section info (for PYSTAT).
	- ELSEIF(ISAVE.EQ.5) THEN
	- DO 330 I=1,500
	- MSUB(I)=0
	- NGEN(I,1)=0
	- NGEN(I,3)=0
	- XSEC(I,3)=0D0
	- 330 CONTINUE
	- NGEN(0,1)=0
	- NGEN(0,2)=0
	- NGEN(0,3)=0
	- XSEC(0,3)=0
	- DO 350 IG=1,MINT(121)
	- DO 340 ICP=1,NCP(IG)
	- I=NSUBCP(IG,ICP)
	- IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
	- NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
	- NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
	- XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
	- 340 CONTINUE
	- NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
	- NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
	- NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
	- XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
	- 350 CONTINUE
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYGAGA
	-C...For lepton beams it gives photon-hadron or photon-photon systems
	-C...to be treated with the ordinary machinery and combines this with a
	-C...description of the lepton -> lepton + photon branching.
	-
	- SUBROUTINE PYGAGA(IGAGA,WTGAGA)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
	- &/PYINT5/
	-C...Local variables and data statement.
	- DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
	- &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
	- SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
	- DATA EPS/1D-4/
	-
	-C...Initialize generation of photons inside leptons.
	- IF(IGAGA.EQ.1) THEN
	-
	-C...Save quantities on incoming lepton system.
	- VINT(301)=VINT(1)
	- VINT(302)=VINT(2)
	- PMS(1)=VINT(303)**2
	- IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
	- PMS(2)=VINT(304)**2
	- IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
	- PMC(3)=VINT(302)-PMS(1)-PMS(2)
	- W2MIN=MAX(CKIN(77),2D0CKIN(3),2D0CKIN(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+2I),1D0-2D0VINT(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),
	- & (YMINPMC(3)-CKIN(64+2I))/PMC(I))
	- XMAX(I)=MIN(XMAX(I),(YMAXPMC(3)-CKIN(63+2I))/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+2I),XMIN(I)2PMS(I)/(1D0-XMIN(I))+
	- & ((1D0-XMAX(I))(VINT(302)-2D0PMS(3-I))-
	- & 2D0PMS(I)/(1D0-XMAX(I)))SIN(THEMIN/2D0)**2,0D0)
	- Q2MAX(I)=XMAX(I)*2PMS(I)/(1D0-XMAX(I))+
	- & ((1D0-XMIN(I))(VINT(302)-2D0PMS(3-I))-
	- & 2D0PMS(I)/(1D0-XMIN(I)))SIN(THEMAX/2D0)**2
	- IF(CKIN(64+2I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2I),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,12D0MAX(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=WTGAGA2D0(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),2D0CKIN(3),2D0CKIN(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)=4D0PTMN*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)*2PMS(I)/(1D0-X(I))) GOTO 120
	- IF(Q2(I).GT.(1D0-X(I))(VINT(302)-2D0PMS(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+2I).OR.Y(I).GT.CKIN(72+2I)) GOTO 120
	- RAT=((1D0-X(I))Q2(I)-X(I)2PMS(I))/
	- & ((1D0-X(I))*2(VINT(302)-2D0PMS(3-I)-2D0PMS(I)))
	- THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
	- IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
	- IF(CKIN(68+2I).GT.0D0.AND.THETA(I).GT.CKIN(68+2I))
	- & GOTO 120
	-
	-C...Phi angle isotropic. Reconstruct pT.
	- PHI(I)=PARU(2)*PYR(0)
	- PT(I)=SQRT(((1D0-X(I))PMC(I))2/(4D0VINT(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.5D0X(1)PMC(1)X(2)PMC(2)/VINT(302)-
	- & 2D0PT(1)PT(2)COS(PHI(1)-PHI(2))+2D0
	- & SQRT((0.5D0X(1)PMC(1)/VINT(301))2+Q2(1)-PT(1)2)*
	- & SQRT((0.5D0X(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.5D0SQRT((W2-PMS1-PMS2)2-4D0PMS1*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=WTGAGA2D0(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)=4D0PTMN*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.5D0SQRT((PMC(3)2-4D0PMS(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.
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
	- & MSTP(14).LE.10) THEN
	- IF(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
	- 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/(96D0PARU(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=4D0PARP(15)*2
	- Q1S=4D0VINT(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=2D0BHAD(IHA)+2D0BHAD(IHB)+4D0SH*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=2D0ALP4D0
	- ENDIF
	-
	-C...Determine maximum possible t range and coefficient of generation.
	- SQLA12=(SH-SQM1-SQM2)*2-4D0SQM1*SQM2
	- SQLA34=(SH-SQM3-SQM4)*2-4D0SQM3*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)
	- & (SQM1SQM4-SQM2SQM3)/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+CRESSMRES1/(SMRES1+SQM3))
	- IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
	- ELSEIF(ISUB.EQ.93) THEN
	- FSD=(1D0-SQM4/SH)(1D0+CRESSMRES2/(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/
	- & (SHSMP+SQM3SQM4))(1D0+CRESSMRES1/(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=2D0ALPLOG(SH/SQM3)
	- IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
	- ELSEIF(ISUB.EQ.93) THEN
	- BADD=2D0ALPLOG(SH/SQM4)
	- IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
	- ELSEIF(ISUB.EQ.94) THEN
	- BADD=2D0ALP(LOG(EXP(4D0)+SH/(ALPSQM3SQM4))-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-4D0SQM3*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)
	- & (SQM1SQM4-SQM2SQM3)/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)=2D0SQRT(MAX(0D0,-(THC+THATH+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/I2c21/tau + I1/I3c31/(tau+tau_R) +
	-C...I1/I4c4tau/((stau-m^2)^2+(mGamma)^2) +
	-C...I1/I5c51/(tau+tau_R') +
	-C...I1/I6c6tau/((stau-m'^2)^2+(m'Gamma')^2) +
	-C...I1/I7c7tau/(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/I2c2(1 - tau/tau')^3/tau' +
	-C...I1/I3c31/(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/I1c1(y-ymin) + I0/I2c2(ymax-y*) +
	-C...I0/I3c31/cosh(y) + I0/I4c41/(1-exp(y-y*max)) +
	-C...I0/I5c51/(1-exp(-y-ymin)), I0 = ymax-ymin,
	-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/I1c11/(A - cth) + I0/I2c21/(A + cth) +
	-C...I0/I3c31/(A - cth)^2 + I0/I4c41/(A + cth)^2,
	-C...A = 1 + 2(m3m4/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)
	- !!! BCN: Relaxing the Pythia warnings that are frequent for beam events
	- IF (VINT(41).GT.1.1.OR.VINT(42).GT.1.1) 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.25D0XT2GMXVINT(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=WTMXLOG(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=WTLOG(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.25D0VINT(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.25D0VINT(4)*2
	- VINT(284)=(Q0S+PS)*(Q1S+PS)/
	- & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
	- ENDIF
	- ENDIF
	- IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
	-
	-C...Format statements for differential cross-section maximum violations.
	- 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
	- &'in event',1X,I7,'D0'/1X,'Execution stopped!')
	- 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
	- &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
	- 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
	- &'in event',1X,I7)
	- 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
	- &'in event',1X,I7,'D0'/1X,'Execution stopped!')
	- 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
	- &'in event',1X,I7)
	- 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
	- 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
	- 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
	- 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
	- 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
	- 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYSCAT
	-C...Finds outgoing flavours and event type; sets up the kinematics
	-C...and colour flow of the hard scattering
	-
	- SUBROUTINE PYSCAT
	-
	-C...Double precision and integer declarations
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-
	-C...User process event common block.
	- INTEGER MAXNUP
	- PARAMETER (MAXNUP=500)
	- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	- SAVE /HEPEUP/
	-
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
	- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
	- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	- COMMON/PYPUED/IUED(0:99),RUED(0:99)
	- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
	- &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
	- &/PYTCSM/,/PYPUED/
	-C...Local arrays and saved variables
	- DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
	- &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
	- INTEGER IOKFLA(6),IIFLAV
	-C...UED related declarations:
	-C...equivalences between ordered particles (451->475)
	-C...and UED particle code (5 000 000 + id)
	- DIMENSION IUEDEQ(475),MUED(2)
	- DATA (IUEDEQ(I),I=451,475)/
	- & 6100001,6100002,6100003,6100004,6100005,6100006,
	- & 5100001,5100002,5100003,5100004,5100005,5100006,
	- & 6100011,6100013,6100015,
	- & 5100012,5100011,5100014,5100013,5100016,5100015,
	- & 5100021,5100022,5100023,5100024/
	- SAVE VINTSV
	-
	-C...Read out process
	- ISUB=MINT(1)
	- ISUBSV=ISUB
	-
	-C...Restore information for low-pT processes
	- IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
	- DO 100 J=41,66
	- 100 VINT(J)=VINTSV(J)
	- ENDIF
	-
	-C...Convert H' or A process into equivalent H one
	- IHIGG=1
	- KFHIGG=25
	- IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
	- &ISUB.LE.190)) THEN
	- IHIGG=2
	- IF(MOD(ISUB-1,10).GE.5) IHIGG=3
	- KFHIGG=33+IHIGG
	- IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
	- IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
	- IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
	- IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
	- IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
	- IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
	- IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
	- IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
	- IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
	- IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
	- IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
	- IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
	- ENDIF
	-
	- IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
	-
	-C...Convert bottomonium process into equivalent charmonium ones.
	- IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
	-
	-C...Choice of subprocess, number of documentation lines
	- IDOC=6+ISET(ISUB)
	- IF(ISUB.EQ.95) IDOC=8
	- IF(ISET(ISUB).EQ.5) IDOC=9
	- IF(ISET(ISUB).EQ.11) IDOC=4+NUP
	- MINT(3)=IDOC-6
	- IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
	- MINT(4)=IDOC
	- IPU1=MINT(84)+1
	- IPU2=MINT(84)+2
	- IPU3=MINT(84)+3
	- IPU4=MINT(84)+4
	- IPU5=MINT(84)+5
	- IPU6=MINT(84)+6
	-
	-C...Reset K, P and V vectors. Store incoming particles
	- DO 120 JT=1,MSTP(126)+100
	- I=MINT(83)+JT
	- IF(I.GT.MSTU(4)) GOTO 120
	- DO 110 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=0D0
	- 110 CONTINUE
	- 120 CONTINUE
	- DO 140 JT=1,2
	- I=MINT(83)+JT
	- K(I,1)=21
	- K(I,2)=MINT(10+JT)
	- DO 130 J=1,5
	- P(I,J)=VINT(285+5*JT+J)
	- 130 CONTINUE
	- 140 CONTINUE
	- MINT(6)=2
	- KFRES=0
	-
	-C...Store incoming partons in their CM-frame. Save pdf value.
	- SH=VINT(44)
	- SHR=SQRT(SH)
	- SHP=VINT(26)*VINT(2)
	- SHPR=SQRT(SHP)
	- SHUSER=SHR
	- IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
	- DO 150 JT=1,2
	- I=MINT(84)+JT
	- K(I,1)=14
	- K(I,2)=MINT(14+JT)
	- K(I,3)=MINT(83)+2+JT
	- P(I,3)=0.5D0SHUSER(-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)*24D0/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/(4D0XH)*PYR(0)) GOTO 220
	- SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	- Z(3-JT)=1D0-XH/(1D0-Z(JT))
	- SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	- Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	- Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	- & 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/(4D0XH)*PYR(0)) GOTO 230
	- SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	- Z(3-JT)=1D0-XH/(1D0-Z(JT))
	- SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	- Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	- Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	- & 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/(4D0XH)*PYR(0)) GOTO 330
	- SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	- Z(3-JT)=1D0-XH/(1D0-Z(JT))
	- SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	- Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	- Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	- & 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/(4D0XH)*PYR(0)) GOTO 340
	- SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	- Z(3-JT)=1D0-XH/(1D0-Z(JT))
	- SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	- Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	- Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	- & 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/(4D0XH)*PYR(0)) GOTO 370
	- SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	- CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	- Z(3-JT)=1D0-XH/(1D0-Z(JT))
	- SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	- 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	- Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	- Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	- & 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+5JTA)-P(I,5)2+VINT(196+5JTA)**2))
	- P(I,1)=PTCOS(VINT(198+5JTA))
	- P(I,2)=PTSIN(VINT(198+5JTA))
	- 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-4D0PMS1*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.5D0SHPRZ(JT).LE.P(I,5)) THEN
	- MINT(51)=1
	- RETURN
	- ENDIF
	- PABS=SQRT(MAX(0D0,(0.5D0SHPRZ(JT))2-P(I,5)2))
	- PTABS=PABSSQRT(MAX(0D0,1D0-CTHE(JT)*2))
	- P(I,1)=PTABS*COS(PHI(JT))
	- P(I,2)=PTABS*SIN(PHI(JT))
	- P(I,3)=PABSCTHE(JT)(-1)**(JT+1)
	- P(I,4)=0.5D0SHPRZ(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.5D0SHPR-PABSCTHE(JT))(-1)*(JT+1)
	- P(IZW,4)=0.5D0SHPR(1D0-Z(JT))
	- P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)2+PTABS2-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.5D0SHPRZ(JT).LE.P(I,5)) P(I,5)=0D0
	- PABS=SQRT(MAX(0D0,(0.5D0SHPRZ(JT))2-P(I,5)2))
	- PTABS=PABSSQRT(MAX(0D0,1D0-CTHE(JT)*2))
	- P(I,1)=PTABS*COS(PHI(JT))
	- P(I,2)=PTABS*SIN(PHI(JT))
	- P(I,3)=PABSCTHE(JT)(-1)**(JT+1)
	- P(I,4)=0.5D0SHPRZ(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.5D0SHPR-PABSCTHE(JT))(-1)*(JT+1)
	- P(IZW,4)=0.5D0SHPR(1D0-Z(JT))
	- P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)2+PTABS2-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=BEXCMP(I1,1)+BEYCMP(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(PX2+PY2))
	- PHICM=PYANGL(PX,PY)
	-C...Store hard scattering subsystem. Rotate and boost it
	- SQLAM=(SH-P(IPU5,5)2-P(IPU6,5)2)*2-4D0P(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)=PABSSTHWZCOS(PHIWZ)
	- P(IPU5,2)=PABSSTHWZSIN(PHIWZ)
	- P(IPU5,3)=PABS*CTHWZ
	- P(IPU5,4)=SQRT(PABS2+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(PABS2+P(IPU6,5)2)
	- CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
	- DO 620 JT=1,2
	- I1=MINT(83)+8+JT
	- I2=MINT(84)+4+JT
	- K(I1,1)=21
	- K(I1,2)=K(I2,2)
	- DO 610 J=1,5
	- P(I1,J)=P(I2,J)
	- 610 CONTINUE
	- 620 CONTINUE
	- N=IPU6
	- MINT(7)=MINT(83)+9
	- MINT(8)=MINT(83)+10
	- ENDIF
	-
	- IF(ISET(ISUB).EQ.11) THEN
	- ELSEIF(IDOC.GE.8) THEN
	-C...Store colour connection indices
	- DO 630 J=1,2
	- JC=J
	- IF(KCS.EQ.-1) JC=3-J
	- IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
	- & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
	- IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
	- & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
	- IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
	- & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
	- IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
	- & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
	- 630 CONTINUE
	-
	-C...Copy outgoing partons to documentation lines
	- IMAX=2
	- IF(IDOC.EQ.9) IMAX=3
	- DO 650 I=1,IMAX
	- I1=MINT(83)+IDOC-IMAX+I
	- I2=MINT(84)+2+I
	- K(I1,1)=21
	- K(I1,2)=K(I2,2)
	- IF(IDOC.LE.9) K(I1,3)=0
	- IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
	- DO 640 J=1,5
	- P(I1,J)=P(I2,J)
	- 640 CONTINUE
	- 650 CONTINUE
	-
	- ELSEIF(IDOC.EQ.9) THEN
	-C...Store colour connection indices
	- DO 660 J=1,2
	- JC=J
	- IF(KCS.EQ.-1) JC=3-J
	- IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
	- & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
	- & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
	- IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
	- & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
	- & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
	- IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
	- & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
	- IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
	- & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
	- 660 CONTINUE
	-
	-C...Copy outgoing partons to documentation lines
	- DO 680 I=1,3
	- I1=MINT(83)+IDOC-3+I
	- I2=MINT(84)+2+I
	- K(I1,1)=21
	- K(I1,2)=K(I2,2)
	- K(I1,3)=0
	- DO 670 J=1,5
	- P(I1,J)=P(I2,J)
	- 670 CONTINUE
	- 680 CONTINUE
	- ENDIF
	-
	-C...Copy outgoing partons to list of allowed radiators.
	- NPART=0
	- IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
	- DO 690 I=MINT(84)+3,N
	- NPART=NPART+1
	- IPART(NPART)=I
	- PTPART(NPART)=SQRT(P(I,5)2+P(I,1)2+P(I,2)**2)
	- 690 CONTINUE
	- ENDIF
	-
	-C...Low-pT events: remove gluons used for string drawing purposes
	- IF(ISUB.EQ.95) THEN
	- IF(MINT(35).LE.1) THEN
	- K(IPU3,1)=K(IPU3,1)+10
	- K(IPU4,1)=K(IPU4,1)+10
	- ENDIF
	- DO 700 J=41,66
	- VINTSV(J)=VINT(J)
	- VINT(J)=0D0
	- 700 CONTINUE
	- DO 720 I=MINT(83)+5,MINT(83)+8
	- DO 710 J=1,5
	- P(I,J)=0D0
	- 710 CONTINUE
	- 720 CONTINUE
	- ENDIF
	-
	- RETURN
	- END
	-
	-C***********************************************************************
	-
	-C...PYEVOL
	-C...Handles intertwined pT-ordered spacelike initial-state parton
	-C...and multiple interactions.
	-
	- SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
	-C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
	-C...MODE = 0 : (Re-)initialize ISR/MI evolution.
	-C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...External
	- EXTERNAL PYALPS
	- DOUBLE PRECISION PYALPS
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
	- & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
	- COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
	-C...Max size of hard system = HEPEUP size
	- INTEGER MAXNUP
	- PARAMETER (MAXNUP=500)
	-C...Local arrays and saved variables.
	- DIMENSION VINTSV(11:80),KSAV(MAXNUP,5),PSAV(MAXNUP,5),
	- & VSAV(MAXNUP,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,NSAV-MINT(84)
	- 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,NSAV-MINT(84)
	- 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.1D0ALAM3)*2)
	- IF (MSTP(70).EQ.2) THEN
	-C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
	- VINT(18)=(PARP(82)(VINT(1)/PARP(89))PARP(90))*2
	- ELSEIF (MSTP(70).EQ.3) THEN
	-C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
	- ALPHA0 = MAX(1D-6,PARP(73))
	- Q20 = ALAM3**2/PARP(64)
	- IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
	- VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
	- ENDIF
	-C...Also store PT2MIN in VINT(17).
	- 180 VINT(17)=PT2MIN
	-
	-C...Set FS masses zero now.
	- VINT(63)=0D0
	- VINT(64)=0D0
	-
	-C...Initialize IS showers with VINT(56) as max scale.
	- PT2ISR=VINT(56)
	- PT20=PT2MIN
	- IF (MSTP(70).EQ.0) THEN
	- PT20=MAX(PT2MIN,PARP(62)**2)
	- ELSEIF (MSTP(70).EQ.1) THEN
	- PT20=MAX(PT2MIN,(PARP(81)(VINT(1)/PARP(89))PARP(90))*2)
	- ENDIF
	- CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
	- IF(MINT(51).NE.0) RETURN
	-
	- RETURN
	-
	-C----------------------------------------------------------------------
	-C...MODE= 1: Evolve event from PTMAX to PTMIN.
	- ELSEIF (MODE.EQ.1) THEN
	-
	-C...Skip if no phase space.
	- 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
	-
	-C...Starting pT2 max scale (to be udpated successively).
	- PT2CMX=PT2MAX
	-
	-C...Evolve two sides of the event to find which branches at highest pT.
	- 200 JSMX=-1
	- MIMX=0
	- PT2MX=0D0
	-
	-C...Loop over current shower initiators.
	- IF (MSTP(61).GE.1) THEN
	- DO 230 MI=1,MINT(31)
	- IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
	- ISUB=96
	- IF (MI.EQ.1) ISUB=ISUBHD
	- MINT(1)=ISUB
	- MINT(36)=MI
	-C...Set up shat, initiator x values, and x remaining in BR.
	- VINT(44)=SHAT(MI)
	- VINT(141)=XMI(1,MI)
	- VINT(142)=XMI(2,MI)
	- VINT(143)=1D0
	- VINT(144)=1D0
	- DO 210 JI=1,MINT(31)
	- IF (JI.EQ.MINT(36)) GOTO 210
	- VINT(143)=VINT(143)-XMI(1,JI)
	- VINT(144)=VINT(144)-XMI(2,JI)
	- 210 CONTINUE
	-C...Loop over sides.
	-C...Generate trial branchings for this interaction. The hardest
	-C...branching so far is automatically updated if necessary in /PYISMX/.
	- DO 220 JS=1,2
	- MINT(30)=JS
	- PT20=PT2MIN
	- IF (MSTP(70).EQ.0) THEN
	- PT20=MAX(PT2MIN,PARP(62)**2)
	- ELSEIF (MSTP(70).EQ.1) THEN
	- PT20=MAX(PT2MIN,
	- & (PARP(81)(VINT(1)/PARP(89))PARP(90))*2)
	- ENDIF
	- CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
	- IF (MINT(51).NE.0) RETURN
	- 220 CONTINUE
	- 230 CONTINUE
	- ENDIF
	-
	-C...Generate trial additional interaction.
	- MINT(36)=MINT(31)+1
	- 240 IF (MOD(MSTP(81),10).GE.1) THEN
	- MINT(1)=96
	-C...Set up X remaining in BR.
	- VINT(143)=1D0
	- VINT(144)=1D0
	- DO 250 JI=1,MINT(31)
	- VINT(143)=VINT(143)-XMI(1,JI)
	- VINT(144)=VINT(144)-XMI(2,JI)
	- 250 CONTINUE
	-C...Generate trial interaction
	- 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
	- IF (MINT(51).EQ.1) RETURN
	- ENDIF
	-
	-C...And the winner is:
	- IF (PT2MX.LT.PT2MIN) THEN
	- GOTO 330
	- ELSEIF (JSMX.EQ.0) THEN
	-C...Accept additional interaction (may still fail).
	- CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
	- IF(MINT(51).NE.0) RETURN
	- IF (IFAIL.EQ.0) THEN
	- SHAT(MINT(36))=VINT(44)
	-C...Decide on flavours (valence/sea/companion).
	- DO 270 JS=1,2
	- MINT(30)=JS
	- CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
	- IF(MINT(51).NE.0) RETURN
	- 270 CONTINUE
	- ENDIF
	- ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
	-C...Reconstruct kinematics of acceptable ISR branching.
	-C...Set up shat, initiator x values, and x remaining in BR.
	- MINT(30)=JSMX
	- MINT(36)=MIMX
	- VINT(44)=SHAT(MINT(36))
	- VINT(141)=XMI(1,MINT(36))
	- VINT(142)=XMI(2,MINT(36))
	- VINT(143)=1D0
	- VINT(144)=1D0
	- DO 280 JI=1,MINT(31)
	- IF (JI.EQ.MINT(36)) GOTO 280
	- VINT(143)=VINT(143)-XMI(1,JI)
	- VINT(144)=VINT(144)-XMI(2,JI)
	- 280 CONTINUE
	- PT2NEW=PT2MX
	- CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
	- IF (MINT(51).EQ.1) RETURN
	- ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
	-C...Bookeep joining. Cannot (yet) be constructed kinematically.
	- MINT(354)=MINT(354)+1
	- VINT(354)=VINT(354)+SQRT(PT2MX)
	- IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
	- MJOIND(JSMX-2,MJN1MX)=MJN2MX
	- MJOIND(JSMX-2,MJN2MX)=MJN1MX
	- ENDIF
	-
	-C...Update PT2 iteration scale.
	- PT2CMX=PT2MX
	-
	-C...Loop back to continue evolution.
	- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	- CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
	- ELSE
	- IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
	- ENDIF
	-
	-C----------------------------------------------------------------------
	-C...MODE= 2: (Re-)store user information on hardest interaction etc.
	- ELSEIF (MODE.EQ.2) THEN
	-
	-C...Revert to "ordinary" meanings of some parameters.
	- 290 DO 310 JS=1,2
	- MINT(12+JS)=K(IMI(JS,1,1),2)
	- VINT(140+JS)=XMI(JS,1)
	- IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
	- VINT(142+JS)=1D0
	- DO 300 MI=1,MINT(31)
	- VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
	- 300 CONTINUE
	- 310 CONTINUE
	-
	-C...Restore saved quantities for hardest interaction.
	- MINT(1)=ISUBHD
	- MINT(15)=M15SV
	- MINT(16)=M16SV
	- MINT(21)=M21SV
	- MINT(22)=M22SV
	- DO 320 J=11,80
	- VINT(J)=VINTSV(J)
	- 320 CONTINUE
	-
	- ENDIF
	-
	- 330 RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYSSPA
	-C...Generates spacelike parton showers.
	-
	- SUBROUTINE PYSSPA(IPU1,IPU2)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
	- &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
	-C...Local arrays and data.
	- DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
	- &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
	- &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
	- &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
	- &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
	- DATA IS/2*0/
	-
	-C...Read out basic information; set global Q^2 scale.
	- IPUS1=IPU1
	- IPUS2=IPU2
	- ISUB=MINT(1)
	- Q2MX=VINT(56)
	- VINT2R=VINT(2)VINT(143)VINT(144)
	- IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
	- &MIN(VINT2R,PARP(67)*VINT(56))
	- FCQ2MX=1D0
	-
	-C...Define which processes ME corrections have been implemented for.
	- MECOR=0
	- IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
	- IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
	- & ISUB.EQ.144) MECOR=1
	- IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
	- IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
	- ENDIF
	-
	-C...Initialize QCD evolution and check phase space.
	- Q2MNC=PARP(62)**2
	- Q2MNCS(1)=Q2MNC
	- Q2MNCS(2)=Q2MNC
	- IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
	- Q0S=PARP(15)**2
	- PS=VINT(3)**2
	- Q2EFF=VINT(54)((Q0S+PS)/(VINT(54)+PS))
	- & EXP(PS(VINT(54)-Q0S)/((VINT(54)+PS)(Q0S+PS)))
	- Q2INT=SQRT(Q0S*Q2EFF)
	- Q2MNCS(1)=MAX(Q2MNC,Q2INT)
	- ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
	- Q2MNCS(1)=MAX(Q2MNC,VINT(283))
	- ENDIF
	- IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
	- Q0S=PARP(15)**2
	- PS=VINT(4)**2
	- Q2EFF=VINT(54)((Q0S+PS)/(VINT(54)+PS))
	- & EXP(PS(VINT(54)-Q0S)/((VINT(54)+PS)(Q0S+PS)))
	- Q2INT=SQRT(Q0S*Q2EFF)
	- Q2MNCS(2)=MAX(Q2MNC,Q2INT)
	- ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
	- Q2MNCS(2)=MAX(Q2MNC,VINT(284))
	- ENDIF
	- MCEV=0
	- ALAMS=PARU(112)
	- PARU(112)=PARP(61)
	- FQ2C=1D0
	- TCMX=0D0
	- IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
	- MCEV=1
	- IF(MSTP(64).EQ.1) FQ2C=PARP(63)
	- IF(MSTP(64).EQ.2) FQ2C=PARP(64)
	- TCMX=LOG(FQ2CQ2MX/PARP(61)*2)
	- IF(Q2MX.LT.MAX(Q2MNC,2D0PARP(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,2D0SPME)
	- 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.9D0Q2S(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+
	- & 8D0Q2S(1)Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
	- ENDIF
	- IF(MCEV.EQ.1) TEVCB=LOG(FQ2CQ2B/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.EQ2LOG((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/(4D0PARU(102))LOG((1D0-XEE-XB)*(1D0-XEE)/
	- & (XEE*(XB+XEE)))/XB
	- ELSEIF(KFLB.EQ.-24) THEN
	- WTAPE(11)=1D0/(4D0PARU(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=TEVCBEXP(MAX(-50D0,LOG(PYR(0))B0/WTSUMC))
	- ELSE
	- TEVCB=TEVCBEXP(MAX(-50D0,LOG(PYR(0))B0/(5D0*WTSUMC)))
	- ENDIF
	- ENDIF
	- IF(MEEV.EQ.1) THEN
	- TEVEB=TEVEBEXP(MAX(-50D0,LOG(PYR(0))PARU(2)/
	- & (PARU(101)FWTEWTSUME*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)*2EXP(MAX(-50D0,TEVCB))/FQ2C
	- IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
	- IF(MEEV.EQ.2) Q2EB=ALAM(JT)*2EXP(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.1D0PMAS(KFLCB,1)*2
	- TEVCB=LOG(FQ2CQ2B/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(FQ2CQ2B/ALAM(JT)*2)
	- ELSE
	- Q2B=Q2EB
	- Q2REF=Q2B
	- IF(MCEV.EQ.1) TEVCB=LOG(FQ2CQ2B/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+Z2)(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-2D0Z(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-2D0Z(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))(RSOFTXEC/((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=(4D0Q2B)/(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=(4D0Z2Q2B)/(4D0Z2Q2B+(1D0-Z)XB2VINT2R)
	- 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(WTZXFAN/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-4D0DQ2(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-4D0DQ2(JR)*DQ2(JT))
	- DPD(4)=SQRT(DPD(2)*2-4D0DQ2(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.5D0DPD(1)DPD(2)+0.5D0DPD(3)*
	- & DPD(4)-DQ2(JR)(DQ2(JT)+DQ2(3)))/(4D0DSHDPC(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.5D0DPD(1)*DPD(2)+
	- & 0.5D0DPD(3)DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
	- & (4D0DSHDPC(3)**2)
	- IF(DPT2.LT.0D0) GOTO 100
	- DPB(1)=(0.5D0DPD(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.
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- ELSEIF(K(IT,2).LT.0) THEN
	- ID1=IS(JT)
	- ID2=IT
	- ELSEIF(K(IT,2).EQ.21) THEN
	- IF(PYR(0).GT.0.5D0) THEN
	- ID1=IS(JT)
	- ID2=IT
	- ELSE
	- ID1=IT
	- ID2=IS(JT)
	- ENDIF
	- 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(DBSVX2+DBSVZ2.GE.1D0) GOTO 100
	- CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
	- IR=N+(JT-1)*(IS(1)-N)
	- CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
	- & 0D0,0D0,0D0)
	-
	-C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
	- IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
	- NPART=NPART+1
	- IPART(NPART)=IT
	- PTPART(NPART)=SQRT(PARP(71)*DPT2)
	- ENDIF
	-
	-C...Global statistics.
	- MINT(352)=MINT(352)+1
	- VINT(352)=VINT(352)+SQRT(P(IT,1)2+P(IT,2)2)
	- IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)2+P(IT,2)2)
	-
	- ENDIF
	-
	-C...Update kinematics variables.
	- IS(JT)=N
	- DQ2(JT)=Q2B
	- IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
	- DSH=DSHZ
	-
	-C...Save quantities; loop back.
	- Q2S(JT)=Q2B
	- DPHI(JT)=PHIBR
	- MCESV(JT)=MCE
	- IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
	- &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
	- KFLS(JT+2)=KFLS(JT)
	- KFLS(JT)=KFLA
	- XS(JT)=XA
	- ZS(JT)=Z
	- DO 310 KFL=-25,25
	- XFS(JT,KFL)=XFA(KFL)
	- 310 CONTINUE
	- TEVCSV(JT)=TEVCB
	- TEVESV(JT)=TEVEB
	- ELSE
	- MORE(JT)=0
	- IF(JT.EQ.1) IPU1=N
	- IF(JT.EQ.2) IPU2=N
	- ENDIF
	- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	- CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
	- IF(MSTU(21).GE.1) N=NS
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
	-
	-C...Boost hard scattering partons to frame of shower initiators.
	- DO 320 J=1,3
	- ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
	- 320 CONTINUE
	- K(N+2,1)=1
	- DO 330 J=1,5
	- P(N+2,J)=P(NS+1,J)
	- 330 CONTINUE
	- CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
	- ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
	- ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)2+P(N+2,2)2))
	- IMIN=MINT(83)+5
	- IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
	- CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
	- CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
	-
	-C...Store user information. Reset Lambda value.
	- IF(MINT(31).LE.1) THEN
	- K(IPU1,3)=MINT(83)+3
	- K(IPU2,3)=MINT(83)+4
	- ELSE
	- K(IPU1,3)=MINT(83)+1
	- K(IPU2,3)=MINT(83)+2
	- ENDIF
	- DO 340 JT=1,2
	- MINT(12+JT)=KFLS(JT)
	- VINT(140+JT)=XS(JT)
	- IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
	- IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
	- 340 CONTINUE
	- PARU(112)=ALAMS
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYPTIS
	-C...Generates pT-ordered spacelike initial-state parton showers and
	-C...trial joinings.
	-C...MODE=-1: Initialize ISR from scratch, starting from the hardest
	-C... interaction initiators at PT2NOW.
	-C...MODE= 0: Generate a trial branching on interaction MINT(36), side
	-C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
	-C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
	-C... is below PT2CUT.
	-C... (Also generate test joinings if MSTP(96)=1.)
	-C...MODE= 1: Accept stored shower branching. Update event record etc.
	-C...PT2NOW : Starting (max) PT2 scale for evolution.
	-C...PT2CUT : Lower limit for evolution.
	-C...PT2 : Result of evolution. Generated PT2 for trial emission.
	-C...IFAIL : Status return code. IFAIL=0 when all is well.
	-
	- SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
	- & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
	- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
	- & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
	-C...Local variables
	- DIMENSION ZSAV(2,240),PT2SAV(2,240),
	- & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
	- & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
	- & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
	- SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
	- & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
	-C...For check on excessive weights.
	- CHARACTER CHWT*12
	-
	-C...Only give errors for very large weights, otherwise just warnings
	- DATA WTEMAX /1.5D0/
	-C...Only give errors for large pT, otherwise just warnings
	- DATA PTEMAX /5D0/
	-
	- IFAIL=-1
	-
	-C----------------------------------------------------------------------
	-C...MODE=-1: Initialize initial state showers from scratch, i.e.
	-C...starting from the hardest interaction initiators.
	- IF (MODE.EQ.-1) THEN
	-C...Set hard scattering SHAT.
	- SHTNOW(1)=VINT(44)
	-C...Mass thresholds and Lambda for QCD evolution.
	- AEM2PI=PARU(101)/PARU(2)
	- RMB=PMAS(5,1)
	- RMC=PMAS(4,1)
	- ALAM4=PARP(61)
	- IF(MSTU(112).LT.4) ALAM4=PARP(61)(PARP(61)/RMC)*(2D0/25D0)
	- IF(MSTU(112).GT.4) ALAM4=PARP(61)(RMB/PARP(61))*(2D0/25D0)
	- ALAM5=ALAM4(ALAM4/RMB)*(2D0/23D0)
	- ALAM3=ALAM4(RMC/ALAM4)*(2D0/27D0)
	-C...Optionally use Lambda_MC = Lambda_CMW
	- IF (MSTP(64).EQ.3) THEN
	- ALAM5 = ALAM5 * 1.569
	- ALAM4 = ALAM4 * 1.618
	- ALAM3 = ALAM3 * 1.661
	- ENDIF
	- RMB2=RMB**2
	- RMC2=RMC**2
	-C...Massive quark forced creation threshold (in M**2).
	- TMIN=1.01D0
	-C...Set upper limit for X (ensures some X left for beam remnant).
	- XMXC=1D0-2D0*PARP(111)/VINT(1)
	-
	- IF (MSTP(61).GE.1) THEN
	-C...Initial values: flavours, momenta, virtualities.
	- DO 100 JS=1,2
	- NISGEN(JS,1)=0
	-
	-C...Special kinematics check for c/b quarks (that g -> c cbar or
	-C...b bbar kinematically possible).
	- KFLB=K(IMI(JS,1,1),2)
	- KFLCB=IABS(KFLB)
	- IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
	-C...Check PT2MAX > mQ^2
	- IF (VINT(56).LT.1.05D0PMAS(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(Z2+(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(Z2+(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)=6D0LOG(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(Z2+(1D0-Z)*2)
	- ELSE
	- WTAPJ(MJ)=Z4D0/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/(AEM2PIWTAPE))-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/(TPLPYR(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
	-C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
	-C...picked up by ISR (necessary since intertwining not implemented)
	-C...Here simply kill backwards-evolution probability.
	- IF (KFLB.EQ.21.AND.(IABS(KFLA).EQ.4.OR.IABS(KFLA).EQ.5)) THEN
	- IF (KSVCA.GE.1) WTVETO = 0D0
	- ENDIF
	- WTVETO=WTVETO*XFJ(KFLA)
	-C...Monte Carlo veto to accept trial joining
	- 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)2RMQ2/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=Z2+(1D0-Z)2
	-C...Massive correction
	- IF (MQMASS.NE.0) THEN
	- WTZ=WTZ+2D0Z(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
	-C...(prevent infinite loop by limiting number of NTRY)
	- IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0.AND.NTRY.LE.200) 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 last if several)
	- DO 260 IFS=1,NPART
	- MCJ = MCT(IPART(IFS),MSIDE)
	- IF (MCJ.NE.MCTAG) GOTO 260
	-C...Pick last matching final-state partner if several
	-C...(if no matching final-state partner, defaults back to annihilation)
	- KSJ = K(IPART(IFS),1)
	- IF (KSJ.GE.1.AND.KSJ.LT.10) 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 (4D0PT2.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 (4D0PT2PYR(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))))2PT2SAV(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=WTZXFAN/XFBNWTPDFA
	- ELSEIF(MCRQQ.EQ.1) THEN
	- WTPDFA=TPM/WPDF0
	- WTTOT=WTCRQQWTZXFAN/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)=KT1MSTU(5)2+IM1MSTU(5)+ID1
	- K(I,5)=KT2MSTU(5)2+IM2MSTU(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.5D0SQRT(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(BETAX2+BETAZ2.GE.1D0) THEN
	- CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
	- MINT(51)=1
	- IFAIL=-1
	- RETURN
	- ENDIF
	- CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
	- I1=IMI(1,MI,1)
	- THETA=PYANGL(P(I1,3),P(I1,1))
	- CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
	-
	-C...Global statistics.
	- MINT(352)=MINT(352)+1
	- VINT(352)=VINT(352)+SQRT(P(IT,1)2+P(IT,2)2)
	- IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)2+P(IT,2)2)
	-
	-C...Add parton with relevant pT scale for timelike shower.
	- IF (K(IT,2).NE.22) THEN
	- NPART=NPART+1
	- IPART(NPART)=IT
	- PTPART(NPART)=SQRT(PT2AMX)
	- ENDIF
	-
	-C...Update saved variables.
	- SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
	- NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
	- XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
	- PT2SAV(JSMX,MIMX)=PT2MX
	- ZSAV(JS,MIMX)=ZMX
	-
	- KSA=IABS(K(IS,2))
	- KMA=IABS(K(IM,2))
	- IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
	-C...Gluon reconstructs to quark.
	-C...Decide whether newly created quark is valence or sea:
	- MINT(30)=JS
	- CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
	- IF(MINT(51).NE.0) RETURN
	- ENDIF
	- IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
	-C...Quark reconstructs to gluon.
	-C...Now some guy may have lost his companion. Check.
	- ICMP=IMI(JS,MI,2)
	- IF (ICMP.GT.0) THEN
	- CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
	- & //' away. Cannot handle that yet. Giving up.')
	- MINT(51)=1
	- RETURN
	- ELSEIF(ICMP.LT.0) THEN
	-C...A sea quark with companion still in BR was reconstructed to a gluon.
	-C...Companion should now be removed from the beam remnant.
	-C...(Momentum integral is automatically updated in next call to PYPDFU.)
	- ICMP=-ICMP
	- IFL=-K(IS,2)
	- DO 380 JCMP=ICMP,NVC(JS,IFL)-1
	- XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
	- DO 370 JI=1,MINT(31)
	- KMI=-IMI(JS,JI,2)
	- JFL=-K(IMI(JS,JI,1),2)
	- IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
	- & ,2)+1
	- 370 CONTINUE
	- 380 CONTINUE
	- NVC(JS,IFL)=NVC(JS,IFL)-1
	- ENDIF
	-C...Set gluon IMI(JS,MI,2) = 0.
	- IMI(JS,MI,2)=0
	- ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
	-C...Quark reconstructing to quark. If sea with companion still in BR
	-C...then update associated x value.
	-C...(Momentum integral is automatically updated in next call to PYPDFU.)
	- IF (IMI(JS,MI,2).LT.0) THEN
	- ICMP=-IMI(JS,MI,2)
	- IFL=-K(IS,2)
	- XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
	- ENDIF
	- ENDIF
	-
	- ENDIF
	-
	-C...If reached this point, normal exit.
	- 390 IFAIL=0
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYMEMX
	-C...Generates maximum ME weight in some initial-state showers.
	-C...Inparameter MECOR: kind of hard scattering process
	-C...Outparameter WTFF: maximum weight for fermion -> fermion
	-C... WTGF: maximum weight for gluon/photon -> fermion
	-C... WTFG: maximum weight for fermion -> gluon/photon
	-C... WTGG: maximum weight for gluon -> gluon
	-
	- SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
	-
	-C...Default maximum weight.
	- WTFF=1D0
	- WTGF=1D0
	- WTFG=1D0
	- WTGG=1D0
	-
	-C...Select maximum weight by process.
	- IF(MECOR.EQ.1) THEN
	- WTFF=1D0
	- WTGF=3D0
	- ELSEIF(MECOR.EQ.2) THEN
	- WTFG=1D0
	- WTGG=1D0
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYMEWT
	-C...Calculates actual ME weight in some initial-state showers.
	-C...Inparameter MECOR: kind of hard scattering process
	-C... IFLCB: flavour combination of branching,
	-C... 1 for fermion -> fermion,
	-C... 2 for gluon/photon -> fermion
	-C... 3 for fermion -> gluon/photon,
	-C... 4 for gluon -> gluon
	-C... Q2: Q2 value of shower branching
	-C... Z: Z value of branching
	-C...In+outparameter PHIBR: azimuthal angle of branching
	-C...Outparameter WTME: actual ME weight
	-
	- SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
	-
	-C...Default output.
	- WTME=1D0
	-
	-C...Define kinematics of shower branching in Mandelstam variables.
	- SQM=VINT(44)
	- SH=SQM/Z
	- TH=-Q2
	- UH=Q2-SQM*(1D0-Z)/Z
	-
	-C...Matrix-element corrections for f + fbar -> s-channel vector boson.
	- IF(MECOR.EQ.1) THEN
	- IF(IFLCB.EQ.1) THEN
	- WTME=(TH2+UH2+2D0SQMSH)/(SH2+SQM2)
	- ELSEIF(IFLCB.EQ.2) THEN
	- WTME=(SH2+TH2+2D0SQMUH)/((SH-SQM)2+SQM2)
	- ENDIF
	-
	-C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
	- ELSEIF(MECOR.EQ.2) THEN
	- IF(IFLCB.EQ.3) THEN
	- WTME=(SH2+UH2)/(SH2+(SH-SQM)2)
	- ELSEIF(IFLCB.EQ.4) THEN
	- WTME=0.5D0(SH4+UH4+TH4+SQM4)/(SH2-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=(SH2+TH2+2D0(SQM-TH)(SQM-SH))/
	- 1 (SH*2+2D0SQM*(SQM-SH))
	- ENDIF
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYPTMI
	-C...Handles the generation of additional interactions in the new
	-C...multiple interactions framework.
	-C...MODE=-1 : Initalize MI from scratch.
	-C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
	-C... Sudakov for PT2, abort if below PT2CUT.
	-C...MODE= 1 : Accept interaction at PT2NOW and store variables.
	-C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
	-C...PT2NOW : Starting (max) PT2 scale for evolution.
	-C...PT2CUT : Lower limit for evolution.
	-C...PT2 : Result of evolution. Generated PT2 for trial interaction.
	-C...IFAIL : Status return code.
	-C... = 0: All is well.
	-C... < 0: Phase space exhausted, generation to be terminated.
	-C... > 0: Additional interaction vetoed, but continue evolution.
	-
	- SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
	- & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	-C...Local arrays and saved variables.
	- DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
	-
	- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
	- & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
	- & /PYISMX/,/PYCTAG/
	- SAVE 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=XT2FACXT2/(XT2FAC-XT2LOG(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.25D0VINT(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.25D0VINT(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/(4D0TAUT)
	- 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.5D0VINT(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
	-C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
	-C...picked up by MPI (necessary since intertwining not implemented)
	-C...Here simply reclassify companions as ordinary SEA. Will give
	-C...additional spurious companions, but is simplest solution.
	- IF (IABS(IFL).EQ.4.OR.IABS(IFL).EQ.5) THEN
	- SEA = SEA + CMP
	- CMP = 0D0
	- ENDIF
	-
	- 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=3D0XCXS(XC2+XS2)/(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+XS2(-3D0+XS)+3D0XSLOG(XS))
	- ELSEIF (NPOW.EQ.2) THEN
	- PYFCMP=FAC(1D0-Y)2/(2D0((1D0-XS)(1D0+XS(4D0+XS))
	- & +3D0XS(1D0+XS)*LOG(XS)))
	- ELSEIF (NPOW.EQ.3) THEN
	- PYFCMP=FAC(1D0-Y)32D0/(4D0+27D0XS-31D0XS**3
	- & +6D0XSLOG(XS)(3D0+2D0XS*(3D0+XS)))
	- ELSEIF (NPOW.GE.4) THEN
	- PYFCMP=FAC(1D0-Y)4/(2D0(1D0+2D0XS)((1D0-XS)*(1D0+
	- & XS(10D0+XS))+6D0XSLOG(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-2D0XS(-3D0+XS))+3D0*LOG(XS))
	- PYPCMP=PYPCMP/((-1D0+XS)(2D0+XS(-1D0+2D0*XS)))
	- ELSEIF (NPOW.EQ.1) THEN
	- PYPCMP=-1D0-3D0XS+(2D0(-1D0+XS)*2(1D0+XS+XS**2))
	- & /(2D0+XS*2(XS-3D0)+3D0XSLOG(XS))
	- ELSEIF (NPOW.EQ.2) THEN
	- PYPCMP=XS((1D0-XS)(19D0+XS(43D0+4D0XS))
	- & +6D0LOG(XS)(1D0+6D0XS+4D0XS**2))
	- PYPCMP=PYPCMP/(4D0((XS-1D0)(1D0+XS*(4D0+XS))
	- & -3D0XSLOG(XS)*(1+XS)))
	- ELSEIF (NPOW.EQ.3) THEN
	- PYPCMP=3D0XS((XS-1)(7D0+XS(28D0+13D0*XS))
	- & -2D0LOG(XS)(1D0+XS(9D0+2D0XS*(6D0+XS))))
	- PYPCMP=PYPCMP/(4D0+27D0XS-31D0XS**3
	- & +6D0XSLOG(XS)(3D0+2D0XS*(3D0+XS)))
	- ELSE
	- PYPCMP=(-9D0XS(XS*2-1D0)(5D0+XS(24D0+XS))+12D0XS*LOG(XS)
	- & (1D0+2D0XS)(1D0+2D0XS(5D0+2D0XS)))
	- PYPCMP=PYPCMP/(8D0(1D0+2D0XS)((XS-1D0)(1D0+XS*(10D0+XS))
	- & -6D0XSLOG(XS)*(1D0+XS)))
	- ENDIF
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYUPRE
	-C...Rearranges contents of the HEPEUP commonblock so that
	-C...mothers precede daughters and daughters of a decay are
	-C...listed consecutively.
	-
	- SUBROUTINE PYUPRE
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	-
	-C...User process event common block.
	- INTEGER MAXNUP
	- PARAMETER (MAXNUP=500)
	- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	- SAVE /HEPEUP/
	-
	-C...Local arrays.
	- DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
	- &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
	- &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
	-
	-C...Check whether a rearrangement is required.
	- NEED=0
	- DO 100 IUP=1,NUP
	- IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
	- 100 CONTINUE
	- DO 110 IUP=2,NUP
	- IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
	- 110 CONTINUE
	-
	- IF(NEED.NE.0) THEN
	-C...Find the new order that particles should have.
	- NEWPOS(0)=0
	- NNEW=0
	- INEW=-1
	- 120 INEW=INEW+1
	- DO 130 IUP=1,NUP
	- IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
	- NNEW=NNEW+1
	- NEWPOS(NNEW)=IUP
	- ENDIF
	- 130 CONTINUE
	- IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
	- IF(NNEW.NE.NUP) THEN
	- CALL PYERRM(2,
	- & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
	- RETURN
	- ENDIF
	-
	-C...Copy old info into temporary storage.
	- DO 150 I=1,NUP
	- IDUPT(I)=IDUP(I)
	- ISTUPT(I)=ISTUP(I)
	- MOTUPT(1,I)=MOTHUP(1,I)
	- MOTUPT(2,I)=MOTHUP(2,I)
	- ICOUPT(1,I)=ICOLUP(1,I)
	- ICOUPT(2,I)=ICOLUP(2,I)
	- DO 140 J=1,5
	- PUPT(J,I)=PUP(J,I)
	- 140 CONTINUE
	- VTIUPT(I)=VTIMUP(I)
	- SPIUPT(I)=SPINUP(I)
	- 150 CONTINUE
	-
	-C...Copy info back into HEPEUP in right order.
	- DO 180 I=1,NUP
	- IOLD=NEWPOS(I)
	- IDUP(I)=IDUPT(IOLD)
	- ISTUP(I)=ISTUPT(IOLD)
	- MOTHUP(1,I)=0
	- MOTHUP(2,I)=0
	- DO 160 IMOT=1,I-1
	- IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
	- IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
	- 160 CONTINUE
	- IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
	- MOTHSW=MOTHUP(1,I)
	- MOTHUP(1,I)=MOTHUP(2,I)
	- MOTHUP(2,I)=MOTHSW
	- ENDIF
	- ICOLUP(1,I)=ICOUPT(1,IOLD)
	- ICOLUP(2,I)=ICOUPT(2,IOLD)
	- DO 170 J=1,5
	- PUP(J,I)=PUPT(J,IOLD)
	- 170 CONTINUE
	- VTIMUP(I)=VTIUPT(IOLD)
	- SPINUP(I)=SPIUPT(IOLD)
	- 180 CONTINUE
	- ENDIF
	-
	-c...If incoming particles are massive recalculate to put them massless.
	- IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
	- PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
	- PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
	- PUP(4,1)=0.5D0*PPLUS
	- PUP(3,1)=PUP(4,1)
	- PUP(5,1)=0D0
	- PUP(4,2)=0.5D0*PMINUS
	- PUP(3,2)=-PUP(4,2)
	- PUP(5,2)=0D0
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYADSH
	-C...Administers the generation of successive final-state showers
	-C...in external processes.
	-
	- SUBROUTINE PYADSH(NFIN)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
	-C...Local array.
	- DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
	-
	-C...Set primary vertex.
	- DO 100 J=1,5
	- V(MINT(83)+5,J)=0D0
	- V(MINT(83)+6,J)=0D0
	- V(MINT(84)+1,J)=0D0
	- V(MINT(84)+2,J)=0D0
	- 100 CONTINUE
	-
	-C...Isolate systems of particles with the same mother.
	- NSYS=0
	- IMS=-1
	- DO 140 I=MINT(84)+3,NFIN
	- IM=K(I,3)
	- IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
	- IF(IM.NE.IMS) THEN
	- NSYS=NSYS+1
	- IBEG(NSYS)=I
	- IMS=IM
	- ENDIF
	-
	-C...Set production vertices.
	- IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
	- & THEN
	- DO 110 J=1,4
	- V(I,J)=0D0
	- 110 CONTINUE
	- ELSE
	- DO 120 J=1,4
	- V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
	- 120 CONTINUE
	- ENDIF
	- IF(MSTP(125).GE.1) THEN
	- IDOC=I-MSTP(126)+4
	- DO 130 J=1,5
	- V(IDOC,J)=V(I,J)
	- 130 CONTINUE
	- ENDIF
	- 140 CONTINUE
	-
	-C...End loop over systems. Return if no showers to be performed.
	- IBEG(NSYS+1)=NFIN+1
	- IF(MSTP(71).LE.0) RETURN
	-
	-C...Loop through systems of particles; check that sensible size.
	- DO 270 ISYS=1,NSYS
	- NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
	- IF(MINT(35).LE.2) THEN
	- IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
	- GOTO 270
	- ELSEIF(NSIZ.LE.1) THEN
	- CALL PYERRM(2,'(PYADSH:) only one particle in system')
	- GOTO 270
	- ELSEIF(NSIZ.GT.80) THEN
	- CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
	- GOTO 270
	- ENDIF
	- ENDIF
	-
	-C...Save status codes and daughters of showering particles; reset them.
	- DO 150 J=1,4
	- PSUM(J)=0D0
	- 150 CONTINUE
	- DO 170 II=1,NSIZ
	- I=IBEG(ISYS)-1+II
	- KSAV(II,1)=K(I,1)
	- IF(K(I,1).GT.10) THEN
	- K(I,1)=1
	- IF(KSAV(II,1).EQ.14) K(I,1)=3
	- ENDIF
	- IF(KSAV(II,1).LE.10) THEN
	- ELSEIF(K(I,1).EQ.1) THEN
	- KSAV(II,4)=K(I,4)
	- KSAV(II,5)=K(I,5)
	- K(I,4)=0
	- K(I,5)=0
	- ELSE
	- KSAV(II,4)=MOD(K(I,4),MSTU(5))
	- KSAV(II,5)=MOD(K(I,5),MSTU(5))
	- K(I,4)=K(I,4)-KSAV(II,4)
	- K(I,5)=K(I,5)-KSAV(II,5)
	- ENDIF
	- DO 160 J=1,4
	- PSUM(J)=PSUM(J)+P(I,J)
	- 160 CONTINUE
	- 170 CONTINUE
	-
	-C...Perform shower.
	- QMAX=SQRT(MAX(0D0,PSUM(4)2-PSUM(1)2-PSUM(2)**2-
	- & PSUM(3)**2))
	- IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
	- NSAV=N
	- IF(MINT(35).LE.2) THEN
	- IF(NSIZ.EQ.2) THEN
	- CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
	- ELSE
	- CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
	- ENDIF
	-
	-C...For external processes, first call, also ISR partons radiate.
	-C...Can use existing PYPART list, removing partons that radiate later.
	- ELSEIF(ISYS.EQ.1) THEN
	- NPARTN=0
	- DO 175 II=1,NPART
	- IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
	- NPARTN=NPARTN+1
	- IPART(NPARTN)=IPART(II)
	- PTPART(NPARTN)=PTPART(II)
	- ENDIF
	- 175 CONTINUE
	- NPART=NPARTN
	- CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
	- ELSE
	-C...For subsequent calls use the systems excluded above.
	- NPART=NSIZ
	- NPARTD=0
	- DO 180 II=1,NSIZ
	- I=IBEG(ISYS)-1+II
	- IPART(II)=I
	- PTPART(II)=0.5D0*QMAX
	- 180 CONTINUE
	- CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
	- ENDIF
	-
	-C...Look up showered copies of original showering particles.
	- DO 260 II=1,NSIZ
	- I=IBEG(ISYS)-1+II
	- IMV=I
	-C...Particles without daughters need not be studied.
	- IF(KSAV(II,1).LE.10) GOTO 260
	- IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
	- ELSEIF(K(I,1).EQ.11) THEN
	- 190 IMV=MOD(K(IMV,4),MSTU(5))
	- IF(K(IMV,1).EQ.11) GOTO 190
	- ELSE
	- KDA1=MOD(K(I,4),MSTU(5))
	- IF(KDA1.GT.0) THEN
	- IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
	- ENDIF
	- KDA2=MOD(K(I,5),MSTU(5))
	- IF(KDA2.GT.0) THEN
	- IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
	- ENDIF
	- DO 200 I3=I+1,N
	- IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
	- & THEN
	- IMV=I3
	- KDA1=MOD(K(I3,4),MSTU(5))
	- IF(KDA1.GT.0) THEN
	- IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
	- ENDIF
	- KDA2=MOD(K(I3,5),MSTU(5))
	- IF(KDA2.GT.0) THEN
	- IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
	- ENDIF
	- ENDIF
	- 200 CONTINUE
	- ENDIF
	-
	-C...Restore daughter info of original partons to showered copies.
	- IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
	- IF(KSAV(II,1).LE.10) THEN
	- ELSEIF(K(I,1).EQ.1) THEN
	- K(IMV,4)=KSAV(II,4)
	- K(IMV,5)=KSAV(II,5)
	- ELSE
	- K(IMV,4)=K(IMV,4)+KSAV(II,4)
	- K(IMV,5)=K(IMV,5)+KSAV(II,5)
	- ENDIF
	-
	-C...Reset mother info of existing daughters to showered copies.
	- DO 210 I3=IBEG(ISYS+1),NFIN
	- IF(K(I3,3).EQ.I) K(I3,3)=IMV
	- IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
	- IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
	- IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
	- ENDIF
	- 210 CONTINUE
	-
	-C...Boost all original daughters to new frame of showered copy.
	-C...Also update their colour tags.
	- IF(IMV.NE.I) THEN
	- DO 220 J=1,3
	- BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
	- 220 CONTINUE
	- FAC=2D0/(1D0+BETA(1)2+BETA(2)2+BETA(3)**2)
	- DO 230 J=1,3
	- BETA(J)=FAC*BETA(J)
	- 230 CONTINUE
	- DO 250 I3=IBEG(ISYS+1),NFIN
	- IMO=I3
	- 240 IMO=K(IMO,3)
	- IF(MSTP(128).LE.0) THEN
	- IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
	- IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
	- & THEN
	- CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
	- IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
	- ENDIF
	- ELSE
	- IF(IMO.EQ.IMV) THEN
	- CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
	- IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
	- ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
	- GOTO 240
	- ENDIF
	- ENDIF
	- 250 CONTINUE
	- ENDIF
	- 260 CONTINUE
	-
	-C...End of loop over showering systems
	- 270 CONTINUE
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYVETO
	-C...Interface to UPVETO, which allows user to veto event generation
	-C...on the parton level, after parton showers but before multiple
	-C...interactions, beam remnants and hadronization is added.
	-
	- SUBROUTINE PYVETO(IVETO)
	-
	-C...All real arithmetic in double precision.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-C...Three Pythia functions return integers, so need declaring.
	- INTEGER PYK,PYCHGE,PYCOMP
	-
	-C...PYTHIA commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYPARS/,/PYINT1/
	-C...HEPEVT commonblock.
	- PARAMETER (NMXHEP=4000)
	- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- DOUBLE PRECISION PHEP,VHEP
	- SAVE /HEPEVT/
	-C...Local array.
	- DIMENSION IRESO(100)
	-
	-C...Define longitudinal boost from initiator rest frame to cm frame.
	- GAMMA=0.5D0(VINT(141)+VINT(142))/SQRT(VINT(141)VINT(142))
	- GABEZ=0.5D0(VINT(141)-VINT(142))/SQRT(VINT(141)VINT(142))
	-
	-C...Presentation is different if using pT-ordered shower
	- IF(MINT(35).EQ.3) THEN
	- GAMMA=1D0
	- GABEZ=0D0
	- ENDIF
	-
	-C... Reset counters.
	- NEVHEP=0
	- NHEP=0
	- NRESO=0
	-
	-C...Oth pass: identify beam and incoming partons
	- DO 140 I=MINT(83)+1,MINT(83)+6
	- ISTORE=0
	- IF(K(I,2).EQ.94) THEN
	-
	- ELSE
	- NRESO=NRESO+1
	- IRESO(NRESO)=I
	- IMOTH=K(I,3)
	- ENDIF
	- 140 CONTINUE
	-
	-C...First pass: identify final locations of resonances
	-C...and of their daughters before showering.
	- DO 150 I=MINT(84)+3,N
	- ISTORE=0
	- IMOTH=0
	-
	-C...Skip shower CM frame documentation lines.
	- IF(K(I,2).EQ.94) THEN
	-
	-C... Store a new intermediate product, when mother in documentation.
	- ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
	- & K(I,3).LE.MINT(84)) THEN
	- ISTORE=1
	- NHEP=NHEP+1
	- II=NHEP
	- NRESO=NRESO+1
	- IRESO(NRESO)=I
	- IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
	-
	-C... Store a new intermediate product, when mother in main section.
	- ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
	- & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
	- ISTORE=1
	- NHEP=NHEP+1
	- II=NHEP
	- NRESO=NRESO+1
	- IRESO(NRESO)=I
	- IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
	- ENDIF
	-
	- IF(ISTORE.EQ.1) THEN
	-C...Copy parton info, boosting momenta along z axis to cm frame.
	- ISTHEP(II)=2
	- IDHEP(II)=K(I,2)
	- PHEP(1,II)=P(I,1)
	- PHEP(2,II)=P(I,2)
	- PHEP(3,II)=GAMMAP(I,3)+GABEZP(I,4)
	- PHEP(4,II)=GAMMAP(I,4)+GABEZP(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)=GAMMAP(I,3)+GABEZP(I,4)
	- PHEP(4,II)=GAMMAP(I,4)+GABEZP(I,3)
	- PHEP(5,II)=P(I,5)
	-C...Store one mother. Rest of history and vertex info zeroed.
	- JMOHEP(1,II)=IMOTH
	- JMOHEP(2,II)=0
	- JDAHEP(1,II)=0
	- JDAHEP(2,II)=0
	- VHEP(1,II)=0D0
	- VHEP(2,II)=0D0
	- VHEP(3,II)=0D0
	- VHEP(4,II)=0D0
	- ENDIF
	- 200 CONTINUE
	-C...Call user-written routine to decide whether to keep events.
	- CALL UPVETO(IVETO)
	- RETURN
	- END
	-C*********************************************************************
	-
	-C...PYRESD
	-C...Allows resonances to decay (including parton showers for hadronic
	-C...channels).
	-
	- SUBROUTINE PYRESD(IRES)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYPUED/IUED(0:99),RUED(0:99)
	- SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
	- &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
	-C...Local arrays and complex and character variables.
	- DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
	- &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(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 CODE9,MASS9
	-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((A2-(B+C)2)(A2-(B-C)2))/(2D0A)
	-
	-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)=-4D0D34D56+DT(3D0DT+4D0DU)+DT2(DT*DU/
	- &(D34D56)-2D0(1D0/D34+1D0/D56)(DT+DU)+2D0(D34/D56+D56/D34))
	- DJGK(DT,DU)=8D0(D34+D56)2-8D0(D34+D56)(DT+DU)-6D0DT*DU-
	- &2D0DTDU(DTDU/(D34D56)-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(PA2+P(N+IL,5)2)
	- PV(IL+1,4)=SQRT(PA2+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(GABEP/(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
	-
	-CXXX 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=RMGLU2+RMQ12-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-RMRES2)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/(16D0XWXW1)
	- 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=SFISFF(VE*POLL+PARJ(132)-PARJ(131))
	- HF1W=SFWSFF2((VE*2+1D0)POLL+2D0VE
	- & (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-(2D0PMQ/P(ID,5))*2))
	- VF=SIGN(1D0,QF)-4D0QFXW
	- RFV=0.5D0VQ(3D0-VQ*2)(QF*2POLL-2D0QFVF*HF1I+
	- & VF*2HF1W)+VQ*3HF1W
	- IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ*3HF1W/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)=-2D0COUP(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)*2HGZ(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)*2HGZ(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+2JT-1,3)=0.5D0P(ID,5)
	- P(N+2JT-1,4)=0.5D0P(ID,5)
	- P(N+2JT,3)=-0.5D0P(ID,5)
	- P(N+2JT,4)=0.5D0P(ID,5)
	- CALL PYROBO(N+2JT-1,N+2JT,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=P10P21P32P43-P10P21P33P42-P10P22P31P43+P10P22*
	- & P33P41+P10P23P31P42-P10P23P32P41-P11P20P32P43+P11*
	- & P20P33P42+P11P22P30P43-P11P22P33P40-P11P23P30*P42+
	- & P11P23P32P40+P12P20P31P43-P12P20P33P41-P12P21P30
	- & P43+P12P21P33P40+P12P23P30P41-P12P23P31P40-P13P20*
	- & P31P42+P13P20P32P41+P13P21P30P42-P13P21P32P40-P13*
	- & P22P30P41+P13P22P31*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-4D0EF1XWV
	- KFLF2A=IABS(KFL1(2))
	- EF2=KCHG(KFLF2A,1)/3D0
	- AF2=SIGN(1D0,EF2+0.1D0)
	- VF2=AF2-4D0EF2XWV
	- VA12AS=4D0VF1AF1VF2AF2/((VF12+AF12)(VF22+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
	- & -2PKK(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.5D0ETA/XMV2EPSI((1D0+VA12AS)(PKK(3,5)+PKK(4,6))
	- & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
	- & +6.25D-2ETA2/XMV4(-2D0PKK(3,4)2PKK(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)
	- & +VA12ASPKK(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 +2D0ETAXMAXMB/XMV*2
	- & +2D0(ETAXMAXMB/XMV2)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=16D0PKK(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
	- & -2PKK(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.25D02D0PKK(3,5)PKK(4,6)
	- & -0.5D0ETA/XMV2EPSI2D0(PKK(3,5)+PKK(4,6))
	- & +6.25D-2ETA2/XMV4(-2D0PKK(3,4)2PKK(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 +2D0ETAXMAXMB/XMV*2
	- & +(2D0ETAXMAXMB/XMV2)*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-4D0EIXWV
	- EF=KCHG(IABS(KFL1(1)),1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	-
	- VF=AF-4D0EFXWV
	- RMF=MIN(1D0,4D0PMAS(IABS(KFL1(1)),1)*2/SH)
	- WT1=EI*2VINT(111)EF2+EIVIVINT(112)EF*VF+
	- & (VI2+AI2)VINT(114)(VF*2+(1D0-RMF)AF**2)
	- WT2=RMF(EI2VINT(111)EF2+EIVIVINT(112)EF*VF+
	- & (VI2+AI2)VINT(114)VF**2)
	- WT3=SQRT(1D0-RMF)(EIAIVINT(112)EF*AF+
	- & 4D0VIAIVINT(114)VF*AF)
	- WT=WT1(1D0+CTHE(1)2)+WT2(1D0-CTHE(1)**2)+
	- & 2D0WT3CTHE(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-4D0RM3*RM4))
	- WT=(1D0+BE34CTHE(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)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	- CLIRF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,4)*2
	- CRILF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	- CRIRF=COUP(1,1)*2HGZ(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)*2HGZ(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)))S34S56
	- & ((TI2+UI2+2D0SH(S34+S56))/(TIUI)-S34S56(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+GMMW2)
	- CAWZ=COUP(2,3)/DT-2D0XW1COUP(1,2)(SH-SQMW)FACBW
	- CBWZ=COUP(1,3)/DU+2D0XW1COUP(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=4D0D34D56(COUP(5,3)2+COUP(5,4)2)(CAWZ*2
	- & DIGK(DT,DU)+CBWZ*2DIGK(DU,DT)+CAWZCBWZDJGK(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+SQMZPMAS(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+(CCWWFGK253)**2
	- WTMAX=4D0D34D56(CAWW2DIGK(DT,DU)+CBWW*2DIGK(DU,DT)-
	- & CAWWCBWWDJGK(DT,DU)+CCWW*2(DIGK(DT,DU)+DIGK(DU,DT)-
	- & DJGK(DT,DU)))
	- ELSE
	- WT=POLLFGK1352+POLR(CCWWFGK253)*2
	- WTMAX=4D0D34D56(POLL(CAWW*2DIGK(DT,DU)+
	- & CBWW*2DIGK(DU,DT)-CAWWCBWWDJGK(DT,DU))+
	- & POLRCCWW2(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)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	- CLIRF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,4)*2
	- CRILF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	- CRIRF=COUP(1,1)*2HGZ(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)*2HGZ(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=16D0PKK(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-4D0EIXWV
	- 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-4D0EFXWV
	- 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(EIAIVINT(112)EFAF+EIAPIVINT(113)EF*APF+
	- & 4D0VIAIVINT(114)VFAF+(VIAPI+VPIAI)VINT(115)*
	- & (VFAPF+VPFAF)+4D0VPIAPIVINT(116)VPF*APF)/
	- & (EI*2VINT(111)EF2+EIVIVINT(112)EF*VF+
	- & EIVPIVINT(113)EFVPF+(VI2+AI2)VINT(114)
	- & (VF2+AF2)+(VIVPI+AIAPI)VINT(115)(VFVPF+AFAPF)+
	- & (VPI2+API2)VINT(116)(VPF2+APF2))
	- WT=1D0+ASYMCTHE(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-4D0RM1RM2)
	- & (1D0-2D0RM1-2D0RM2+RM12+RM22+10D0RM1RM2)
	- CFLAT=-CCOS2+0.5D0(RM1+RM2)(1D0-2D0RM1-2D0RM2+
	- & (RM2-RM1)**2)
	- WT=CFLAT+CCOS2CTHE(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-4D0RM1*RM2)
	- WT=1D0+FLAM2(1D0-CTHE(1)2)/(8D0RM1)
	- 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=4D0D34D56(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=16D0PKK(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=8D0VIAIVFAF/((VI2+AI2)(VF2+AF*2))
	- WT=1D0+ASYMCTHE(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-4D0RM1RM2)
	- & (1D0-2D0RM1-2D0RM2+RM12+RM22+10D0RM1RM2)
	- CFLAT=-CCOS2+0.5D0(RM1+RM2)(1D0-2D0RM1-2D0RM2+
	- & (RM2-RM1)**2)
	- WT=CFLAT+CCOS2CTHE(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-4D0RM1*RM2)
	- WT=1D0+FLAM2(1D0-CTHE(1)2)/(8D0RM1)
	- 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=4D0D34D56(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=16D0PKK(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+SIDECTHE(1)(1D0-0.5D0RM1)/(1D0+0.5D0RM1)
	- WTMAX=1D0+(1D0-0.5D0RM1)/(1D0+0.5D0RM1)
	- 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-2D0XW)/(4D0XW*(1D0-XW))
	- BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	- BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	- KFAI=IABS(MINT(15))
	- EI=KCHG(KFAI,1)/3D0
	- AI=SIGN(1D0,EI+0.1D0)
	- VI=AI-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- ALEFTI=(EI+VALIBWZR)2+(VALIBWZI)**2
	- ARIGHI=(EI+VARIBWZR)2+(VARIBWZI)**2
	- KFAF=IABS(KFL1(1))
	- EF=KCHG(KFAF,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- VALF=0.5D0*(VF+AF)
	- VARF=0.5D0*(VF-AF)
	- ALEFTF=(EF+VALFBWZR)2+(VALFBWZI)**2
	- ARIGHF=(EF+VARFBWZR)2+(VARFBWZI)**2
	- ASAME=ALEFTIALEFTF+ARIGHIARIGHF
	- AFLIP=ALEFTIARIGHF+ARIGHIALEFTF
	- 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+GMMZ2)
	- BWZI=(0.5D0/(1D0-XW))SHGMMZ/((SH-SQMZ)2+GMMZ2)
	- KFAI=IABS(MINT(15))
	- EI=KCHG(KFAI,1)/3D0
	- AI=SIGN(1D0,EI+0.1D0)
	- VI=AI-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- BLEFTI=(EI-VALIBWZR)2+(VALIBWZI)**2
	- BRIGHI=(EI-VARIBWZR)2+(VARIBWZI)**2
	- KFAF=IABS(KFL1(1))
	- EF=KCHG(KFAF,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- VALF=0.5D0*(VF+AF)
	- VARF=0.5D0*(VF-AF)
	- BLEFTF=(EF-VALFBWZR)2+(VALFBWZI)**2
	- BRIGHF=(EF-VARFBWZR)2+(VARFBWZI)**2
	- BSAME=BLEFTIBLEFTF+BRIGHIBRIGHF
	- BFLIP=BLEFTIBRIGHF+BRIGHIBLEFTF
	- 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-4D0EIXWV
	- EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- RMF=MIN(1D0,4D0PMAS(PYCOMP(KFL1(1)),1)*2/SH)
	- WT1=(VI2+AI2)(VF2+(1D0-RMF)AF**2)
	- WT2=RMF(VI2+AI2)VF**2
	- WT3=SQRT(1D0-RMF)4D0VIAIVF*AF
	- WT=WT1(1D0+CTHE(1)2)+WT2(1D0-CTHE(1)**2)+
	- & 2D0WT3CTHE(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-4D0RM3*RM4))
	- WT=(1D0+BE34CTHE(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-3D0CTHE(1)2+4D0CTHE(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+6D0CTHE(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-4D0RM3*RM4))
	- VINT(45)=-0.5D0SH(1D0-RM3-RM4-BE34*CTHE(1))
	- VINT(46)=-0.5D0SH(1D0-RM3-RM4+BE34*CTHE(1))
	- VINT(48)=0.25D0SHBE34*2MAX(0D0,1D0-CTHE(1)**2)
	- VINT(47)=SQRT(VINT(48))
	- ENDIF
	-
	-C...Possibility of colour rearrangement in W+W- events.
	- IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
	- IAKF1=IABS(KFL1(1))
	- IAKF2=IABS(KFL1(2))
	- IAKF3=IABS(KFL2(1))
	- IAKF4=IABS(KFL2(2))
	- IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
	- & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
	- & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
	- IF(MINT(51).NE.0) RETURN
	- ENDIF
	-
	-C...Loop back if needed.
	- 710 IF(IP.LT.NP) GOTO 170
	-
	-C...Boost back to standard frame.
	- 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
	- &BEZIN)
	-
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYMULT
	-C...Initializes treatment of multiple interactions, selects kinematics
	-C...of hardest interaction if low-pT physics included in run, and
	-C...generates all non-hardest interactions.
	-
	- SUBROUTINE PYMULT(MMUL)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
	- &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
	-C...Local arrays and saved variables.
	- DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
	- SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
	- &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
	- &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
	-
	-C...Initialization of multiple interaction treatment.
	- IF(MMUL.EQ.1) THEN
	- IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
	- ISUB=96
	- MINT(1)=96
	- VINT(63)=0D0
	- VINT(64)=0D0
	- VINT(143)=1D0
	- VINT(144)=1D0
	-
	-C...Loop over phase space points: xT2 choice in 20 bins.
	- 100 SIGSUM=0D0
	- DO 120 IXT2=1,20
	- NMUL(IXT2)=MSTP(83)
	- SIGM(IXT2)=0D0
	- DO 110 ITRY=1,MSTP(83)
	- RSCA=0.05D0*((21-IXT2)-PYR(0))
	- XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
	- XT2=MAX(0.01D0*VINT(149),XT2)
	- VINT(25)=XT2
	-
	-C...Choose tau and y*. Calculate cos(theta-hat).
	- IF(PYR(0).LE.COEF(ISUB,1)) THEN
	- TAUT=(2D0(1D0+SQRT(1D0-XT2))/XT2-1D0)*PYR(0)
	- TAU=XT2(1D0+TAUT)2/(4D0TAUT)
	- 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.5D0VINT(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=2D0PARP(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.5D0PARU(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=(P83AEXP(-MIN(50D0,B*2))+
	- & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	- ELSE
	- OV=EXP(-B**POWIP)/PARU(2)
	- SO=SO+PARU(2)BDELTAB*OV
	- ENDIF
	- IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)BDELTAB*OV
	- PACC=1D0-EXP(-MIN(50D0,PARU(1)XKOV))
	- SP=SP+PARU(2)BDELTAB*PACC
	- SOP=SOP+PARU(2)BDELTABOVPACC
	- BSP=BSP+BPARU(2)BDELTABPACC
	- IF(IBDIV.EQ.0.AND.PARU(1)XKOV.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)XKSO/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=PIK0.5EXP(-BDIV**2)
	- ELSEIF(MSTP(82).EQ.4) THEN
	- S4A=P83AEXP(-BDIV*2)
	- S4B=P83BEXP(-BDIV2CQ2R)
	- S4C=P83CEXP(-BDIV2CQ2I)
	- PHIGHB=PIK0.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=VNT146XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))
	- & VINT(149)*(1D0+VINT(149))
	- ELSE
	- XC2=4D0CKIN(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=(P83AEXP(-MIN(50D0,B*2))+
	- & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	- ELSE
	- OV=EXP(-B**POWIP)/PARU(2)
	- ENDIF
	- VINT(148)=OV/VNT147
	- PACC=1D0-EXP(-MIN(50D0,PIK*OV))
	- XT2=1D0
	- XT2FAC=VNT146VINT(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=(P83AEXP(-MIN(50D0,B*2))+
	- & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/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)*RPWIPEXP(-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,PIKOV)))/(PIKOV)
	- 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*2exp(-(sigma above pT2)/norm)
	-C...or (MSTP(82)>=2) dpT2/(pT2+pT02)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=XT2FACXT2/(XT2FAC-XT2LOG(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(-XT2FACXT2/(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/(4D0TAUT)
	- 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.5D0VINT(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=(4D0VINT(48)+2D0VINT(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))+
	- & P83BCQ2REXP(-MIN(50D0,B2*CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B2CQ2I)))/(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.5D0POWIP)
	- 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*RPWIPEXP(-RPWIP))
	- 170 IF(PYR(0).LT.PROB1) THEN
	- B2RPW=2D0RPWIPPYR(0)
	- ACCIP=(B2RPW/RPWIP)*RPWIPEXP(RPWIP-B2RPW)
	- ELSE
	- B2RPW=2D0*(RPWIP-LOG(PYR(0)))
	- ACCIP=(0.5D0B2RPW/RPWIP)RPWIPEXP(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-20D0RBIN)NMUL(IRBIN)
	- SIGCOR=(IRBIN-20D0RBIN)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,VNT146VINT(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=VNT146VINT(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=XT2FACXT2/(XT2FAC-XT2LOG(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/(4D0TAUT)
	- 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.5D0VINT(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.5D0VINT(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.25D0VINT(1)(VINT(41)(1D0+CTH)-VINT(42)(1D0-CTH))
	- P(N+1,4)=0.25D0VINT(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.25D0VINT(1)(VINT(41)(1D0-CTH)-VINT(42)(1D0+CTH))
	- P(N+2,4)=0.25D0VINT(1)(VINT(41)(1D0-CTH)+VINT(42)(1D0+CTH))
	- P(N+2,5)=0D0
	-
	- IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
	-C....Choose relevant string pieces to place gluons on.
	- DO 260 I=N+1,N+2
	- DMIN=1D8
	- DO 250 ISTR=1,NSTR
	- I1=KSTR(ISTR,1)
	- I2=KSTR(ISTR,2)
	- DIST=(P(I,4)P(I1,4)-P(I,1)P(I1,1)-P(I,2)*P(I1,2)-
	- & P(I,3)P(I1,3))(P(I,4)P(I2,4)-P(I,1)P(I2,1)-
	- & P(I,2)P(I2,2)-P(I,3)P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
	- & P(I1,1)P(I2,1)-P(I1,2)P(I2,2)-P(I1,3)*P(I2,3))
	- IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
	- DMIN=DIST
	- IST1=I1
	- IST2=I2
	- ISTM=ISTR
	- ENDIF
	- 250 CONTINUE
	-
	-C....Colour flow adjustments, new string pieces.
	- IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
	- & MOD(K(IST1,4),MSTU(5))
	- IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
	- & MSTU(5)*(K(IST1,5)/MSTU(5))+I
	- K(I,5)=MSTU(5)*IST1
	- K(I,4)=MSTU(5)*IST2
	- IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
	- & MOD(K(IST2,5),MSTU(5))
	- IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
	- & MSTU(5)*(K(IST2,4)/MSTU(5))+I
	- KSTR(ISTM,2)=I
	- KSTR(NSTR+1,1)=I
	- KSTR(NSTR+1,2)=IST2
	- NSTR=NSTR+1
	- 260 CONTINUE
	-
	-C...String drawing and colour flow for gluon loop.
	- ELSEIF(K(N+1,2).EQ.21) THEN
	- K(N+1,4)=MSTU(5)*(N+2)
	- K(N+1,5)=MSTU(5)*(N+2)
	- K(N+2,4)=MSTU(5)*(N+1)
	- K(N+2,5)=MSTU(5)*(N+1)
	- KSTR(NSTR+1,1)=N+1
	- KSTR(NSTR+1,2)=N+2
	- KSTR(NSTR+2,1)=N+2
	- KSTR(NSTR+2,2)=N+1
	- NSTR=NSTR+2
	-
	-C...String drawing and colour flow for qqbar pair.
	- ELSE
	- K(N+1,4)=MSTU(5)*(N+2)
	- K(N+2,5)=MSTU(5)*(N+1)
	- KSTR(NSTR+1,1)=N+1
	- KSTR(NSTR+1,2)=N+2
	- NSTR=NSTR+1
	- ENDIF
	-
	-C...Global statistics.
	- MINT(351)=MINT(351)+1
	- VINT(351)=VINT(351)+PT
	- IF (MINT(351).EQ.1) VINT(356)=PT
	-
	-C...Update remaining energy; iterate.
	- N=N+2
	- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	- CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
	- MINT(51)=1
	- RETURN
	- ENDIF
	- MINT(31)=MINT(31)+1
	- VINT(151)=VINT(151)+VINT(41)
	- VINT(152)=VINT(152)+VINT(42)
	- VINT(143)=VINT(143)-VINT(41)
	- VINT(144)=VINT(144)-VINT(42)
	-C...Allow FSR for UE (always handle with old showers)
	- IF(MSTP(152).EQ.1) THEN
	- M41SAV=MSTJ(41)
	- IF (MSTJ(41).EQ.10) MSTJ(41)=2
	- MSTJ(41)=MOD(MSTJ(41),10)
	- CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
	- MSTJ(41)=M41SAV
	- ENDIF
	- IF(MINT(31).LT.240) GOTO 220
	- 270 CONTINUE
	- MINT(1)=ISUBSV
	- DO 280 J=11,80
	- VINT(J)=VINTSV(J)
	- 280 CONTINUE
	- ENDIF
	-
	-C...Format statements for printout.
	- 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
	- &'actions for MSTP(82) =',I2,' ******')
	- 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	- &D9.2,' mb: rejected')
	- 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	- &D9.2,' mb: accepted')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYREMN
	-C...Adds on target remnants (one or two from each side) and
	-C...includes primordial kT for hadron beams.
	-
	- SUBROUTINE PYREMN(IPU1,IPU2)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
	-C...Local arrays.
	- DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
	- &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
	-
	-C...Find event type and remaining energy.
	- ISUB=MINT(1)
	- NS=N
	- IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
	- VINT(143)=1D0-VINT(141)
	- VINT(144)=1D0-VINT(142)
	- ENDIF
	-
	-C...Define initial partons.
	- NTRY=0
	- 100 NTRY=NTRY+1
	- DO 130 JT=1,2
	- I=MINT(83)+JT+2
	- IF(JT.EQ.1) IPU=IPU1
	- IF(JT.EQ.2) IPU=IPU2
	- K(I,1)=21
	- K(I,2)=K(IPU,2)
	- K(I,3)=I-2
	- PMS(JT)=0D0
	- VINT(156+JT)=0D0
	- VINT(158+JT)=0D0
	- IF(MINT(47).EQ.1) THEN
	- DO 110 J=1,5
	- P(I,J)=P(I-2,J)
	- 110 CONTINUE
	- ELSEIF(ISUB.EQ.95) THEN
	- K(I,2)=21
	- ELSE
	- P(I,5)=P(IPU,5)
	-
	-C...No primordial kT, or chosen according to truncated Gaussian or
	-C...exponential, or (for photon) predetermined or power law.
	- 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
	- IF(MSTP(91).LE.0) THEN
	- PT=0D0
	- ELSEIF(MSTP(91).EQ.1) THEN
	- PT=PARP(91)*SQRT(-LOG(PYR(0)))
	- ELSE
	- RPT1=PYR(0)
	- RPT2=PYR(0)
	- PT=-PARP(92)LOG(RPT1RPT2)
	- 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(RPT1RPT2)
	- ENDIF
	- IF(PTB.GT.PARP(100)) GOTO 120
	- PT=SQRT(PTA2+PTB2+2D0PTAPTBCOS(PARU(2)PYR(0)))
	- PT=PT0.8D0*MINT(57)
	- IF(NTRY.GT.10) PT=PT0.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(RPT1RPT2)
	- 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-4D0PMS(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/(XNOMHPK)))
	- 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
	-C...Modifications by Uta Klein for high-energy eh collisions
	-#ifndef PYTHIA6_EH
	- IF(ABS(PEMV).LT.1D-10) THEN
	- MINT(51)=1
	- MINT(57)=MINT(57)+1
	- RETURN
	- ENDIF
	-#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)
	-C...Modifications by Uta Klein for high-energy eh collisions
	-#ifndef PYTHIA6_EH
	- IF(ABS(HBE).GE.1D0) THEN
	- MINT(51)=1
	- MINT(57)=MINT(57)+1
	- RETURN
	- ENDIF
	-#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.5D0VINT(1)(VINT(151)+VINT(152))
	- PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0VINT(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.5D0VINT(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.5D0PARP(111)
	- PMIN(JT)=SQRT(PMIN(JT)2+P(MINT(83)+JT+2,1)2+
	- & P(MINT(83)+JT+2,2)**2)
	- 340 CONTINUE
	-C...Modifications by Uta Klein for high-energy eh collisions
	-#ifndef PYTHIA6_EH
	- 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
	-#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+CUT2))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=CUTCUTR*PYR(0)
	- CHI(JT)=(CHIR2-CUT2)/(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+CUT2)))**
	- & (0.5D0PARP(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+2IMB)))
	- 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-4D0DPMTR*DPMTL))
	-C IF(DSQLAM.LE.1D-6*DPMTB) THEN
	-C MINT(51)=1
	-C MINT(57)=MINT(57)+1
	-C RETURN
	-C 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=(DRKR2-1D0)/(DRKR2+1D0)
	- DBEL=-(DRKL2-1D0)/(DRKL2+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)
	-C IF(PDEV.GT.1D-4*VINT(1)) THEN
	-C MINT(51)=1
	-C MINT(57)=MINT(57)+1
	-C RETURN
	-C ENDIF
	-
	-C...Calculate rotation and boost from overall CM frame to
	-C...hadronic CM frame in leptoproduction.
	- MINT(91)=0
	- IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
	- MINT(91)=1
	- LESD=1
	- IF(MINT(42).EQ.1) LESD=2
	- LPIN=MINT(83)+3-LESD
	-
	-C...Sum upp momenta of everything not lepton or photon to define boost.
	- DO 510 J=1,4
	- PSUM(J)=0D0
	- 510 CONTINUE
	- DO 530 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
	- IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
	- IF(K(I,2).EQ.22) GOTO 530
	- DO 520 J=1,4
	- PSUM(J)=PSUM(J)+P(I,J)
	- 520 CONTINUE
	- 530 CONTINUE
	- VINT(223)=-PSUM(1)/PSUM(4)
	- VINT(224)=-PSUM(2)/PSUM(4)
	- VINT(225)=-PSUM(3)/PSUM(4)
	-
	-C...Boost incoming hadron to hadronic CM frame to determine rotations.
	- K(N+1,1)=1
	- DO 540 J=1,5
	- P(N+1,J)=P(LPIN,J)
	- V(N+1,J)=V(LPIN,J)
	- 540 CONTINUE
	- CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
	- VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
	- CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
	- IF(LESD.EQ.2) THEN
	- VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
	- ELSE
	- VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
	- ENDIF
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYMIGN
	-C...Initializes treatment of new multiple interactions scenario,
	-C...selects kinematics of hardest interaction if low-pT physics
	-C...included in run, and generates all non-hardest interactions.
	-
	- SUBROUTINE PYMIGN(MMUL)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	- EXTERNAL PYALPS
	- DOUBLE PRECISION PYALPS
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
	- &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
	-C...Local arrays and saved variables.
	- DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
	- &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
	- SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
	- &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
	- &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
	-
	-C...Initialization of multiple interaction treatment.
	- IF(MMUL.EQ.1) THEN
	- IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
	- ISUB=96
	- MINT(1)=96
	- VINT(63)=0D0
	- VINT(64)=0D0
	- VINT(143)=1D0
	- VINT(144)=1D0
	-
	-C...Loop over phase space points: xT2 choice in 20 bins.
	- 100 SIGSUM=0D0
	- DO 120 IXT2=1,20
	- NMUL(IXT2)=MSTP(83)
	- SIGM(IXT2)=0D0
	- DO 110 ITRY=1,MSTP(83)
	- RSCA=0.05D0*((21-IXT2)-PYR(0))
	- XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
	- XT2=MAX(0.01D0*VINT(149),XT2)
	- VINT(25)=XT2
	-
	-C...Choose tau and y*. Calculate cos(theta-hat).
	- IF(PYR(0).LE.COEF(ISUB,1)) THEN
	- TAUT=(2D0(1D0+SQRT(1D0-XT2))/XT2-1D0)*PYR(0)
	- TAU=XT2(1D0+TAUT)2/(4D0TAUT)
	- 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.5D0VINT(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=2D0PARP(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.5D0PARU(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=(P83AEXP(-MIN(50D0,B*2))+
	- & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	- ELSE
	- OV=EXP(-B**POWIP)/PARU(2)
	- SO=SO+PARU(2)BDELTAB*OV
	- ENDIF
	- IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)BDELTAB*OV
	- PACC=1D0-EXP(-MIN(50D0,PARU(1)XKOV))
	- SP=SP+PARU(2)BDELTAB*PACC
	- SOP=SOP+PARU(2)BDELTABOVPACC
	- BSP=BSP+BPARU(2)BDELTABPACC
	- IF(IBDIV.EQ.0.AND.PARU(1)XKOV.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)XKSO/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=PIK0.5EXP(-BDIV**2)
	- ELSEIF(MSTP(82).EQ.4) THEN
	- S4A=P83AEXP(-BDIV*2)
	- S4B=P83BEXP(-BDIV2CQ2R)
	- S4C=P83CEXP(-BDIV2CQ2I)
	- PHIGHB=PIK0.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=VNT146XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))
	- & VINT(149)*(1D0+VINT(149))
	- ELSE
	- XC2=4D0CKIN(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=(P83AEXP(-MIN(50D0,B*2))+
	- & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	- ELSE
	- OV=EXP(-B**POWIP)/PARU(2)
	- ENDIF
	- VINT(148)=OV/VNT147
	- PACC=1D0-EXP(-MIN(50D0,PIK*OV))
	- XT2=1D0
	- XT2FAC=VNT146VINT(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=(P83AEXP(-MIN(50D0,B*2))+
	- & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/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)*RPWIPEXP(-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,PIKOV)))/(PIKOV)
	- 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*2exp(-(sigma above pT2)/norm)
	-C...or (MSTP(82)>=2) dpT2/(pT2+pT02)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=XT2FACXT2/(XT2FAC-XT2LOG(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(-XT2FACXT2/(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/(4D0TAUT)
	- 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.5D0VINT(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=(4D0VINT(48)+2D0VINT(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))+
	- & P83BCQ2REXP(-MIN(50D0,B2*CQ2R))+
	- & P83CCQ2IEXP(-MIN(50D0,B2CQ2I)))/(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.5D0POWIP)
	- 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*RPWIPEXP(-RPWIP))
	- 170 IF(PYR(0).LT.PROB1) THEN
	- B2RPW=2D0RPWIPPYR(0)
	- ACCIP=(B2RPW/RPWIP)*RPWIPEXP(RPWIP-B2RPW)
	- ELSE
	- B2RPW=2D0*(RPWIP-LOG(PYR(0)))
	- ACCIP=(0.5D0B2RPW/RPWIP)RPWIPEXP(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-20D0RBIN)NMUL(IRBIN)
	- SIGCOR=(IRBIN-20D0RBIN)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,VNT146VINT(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=(4D0VINT(48)+2D0VINT(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=VNT146VINT(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=XT2FACXT2/(XT2FAC-XT2LOG(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/(4D0TAUT)
	- 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.5D0VINT(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.5D0VINT(1)SQRT(XT2)
	-
	-C...Choose flavour of reacting partons (and subprocess).
	- RSIGS=SIGS*PYR(0)
	- DO 270 ICHN=1,NCHN
	- KFL1=ISIG(ICHN,1)
	- KFL2=ISIG(ICHN,2)
	- ICONMI=ISIG(ICHN,3)
	- RSIGS=RSIGS-SIGH(ICHN)
	- IF(RSIGS.LE.0D0) GOTO 280
	- 270 CONTINUE
	-
	-C...Reassign to appropriate process codes.
	- 280 ISUBMI=ICONMI/10
	- ICONMI=MOD(ICONMI,10)
	-
	-C...Choose new quark flavour for annihilation graphs
	- IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
	- SH=TAU*VINT(2)
	- CALL PYWIDT(21,SH,WDTP,WDTE)
	- 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
	- DO 300 I=1,MDCY(21,3)
	- KFLF=KFDP(I+MDCY(21,2)-1,1)
	- RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
	- IF(RKFL.LE.0D0) GOTO 310
	- 300 CONTINUE
	- 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
	- IF(KFLF.GE.4) GOTO 290
	- ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
	- KFLF=4
	- ICONMI=ICONMI-2
	- ELSEIF(ISUBMI.EQ.53) THEN
	- KFLF=5
	- ICONMI=ICONMI-4
	- ENDIF
	- ENDIF
	-
	-C...Final state flavours and colour flow: default values
	- JS=1
	- KFL3=KFL1
	- KFL4=KFL2
	- KCC=20
	- KCS=ISIGN(1,KFL1)
	-
	- IF(ISUBMI.EQ.11) THEN
	-C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
	- KCC=ICONMI
	- IF(KFL1*KFL2.LT.0) KCC=KCC+2
	-
	- ELSEIF(ISUBMI.EQ.12) THEN
	-C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
	- KFL3=ISIGN(KFLF,KFL1)
	- KFL4=-KFL3
	- KCC=4
	-
	- ELSEIF(ISUBMI.EQ.13) THEN
	-C...f + fbar -> g + g; th arbitrary
	- KFL3=21
	- KFL4=21
	- KCC=ICONMI+4
	-
	- ELSEIF(ISUBMI.EQ.28) THEN
	-C...f + g -> f + g; th = (p(f)-p(f))**2
	- IF(KFL1.EQ.21) JS=2
	- KCC=ICONMI+6
	- IF(KFL1.EQ.21) KCC=KCC+2
	- IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
	- IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
	-
	- ELSEIF(ISUBMI.EQ.53) THEN
	-C...g + g -> f + fbar; th arbitrary
	- KCS=(-1)**INT(1.5D0+PYR(0))
	- KFL3=ISIGN(KFLF,KCS)
	- KFL4=-KFL3
	- KCC=ICONMI+10
	-
	- ELSEIF(ISUBMI.EQ.68) THEN
	-C...g + g -> g + g; th arbitrary
	- KCC=ICONMI+12
	- KCS=(-1)**INT(1.5D0+PYR(0))
	- ENDIF
	-
	-C...Store flavours of scattering.
	- MINT(13)=KFL1
	- MINT(14)=KFL2
	- MINT(15)=KFL1
	- MINT(16)=KFL2
	- MINT(21)=KFL3
	- MINT(22)=KFL4
	-
	-C...Set flavours and mothers of scattering partons.
	- K(N+1,1)=14
	- K(N+2,1)=14
	- K(N+3,1)=3
	- K(N+4,1)=3
	- K(N+1,2)=KFL1
	- K(N+2,2)=KFL2
	- K(N+3,2)=KFL3
	- K(N+4,2)=KFL4
	- K(N+1,3)=MINT(83)+1
	- K(N+2,3)=MINT(83)+2
	- K(N+3,3)=N+1
	- K(N+4,3)=N+2
	-
	-C...Store colour connection indices.
	- DO 320 J=1,2
	- JC=J
	- IF(KCS.EQ.-1) JC=3-J
	- IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
	- IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
	- IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
	- IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
	- 320 CONTINUE
	-
	-C...Store incoming and outgoing partons in their CM-frame.
	- SHR=SQRT(TAU)*VINT(1)
	- P(N+1,3)=0.5D0*SHR
	- P(N+1,4)=0.5D0*SHR
	- P(N+2,3)=-0.5D0*SHR
	- P(N+2,4)=0.5D0*SHR
	- P(N+3,5)=PYMASS(K(N+3,2))
	- P(N+4,5)=PYMASS(K(N+4,2))
	- IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
	- P(N+3,4)=0.5D0(SHR+(P(N+3,5)2-P(N+4,5)*2)/SHR)
	- P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)2-P(N+3,5)2))
	- P(N+4,4)=SHR-P(N+3,4)
	- P(N+4,3)=-P(N+3,3)
	-
	-C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
	- PHI=PARU(2)*PYR(0)
	- CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
	-
	-C...Set up default values before showers.
	- MINT(31)=MINT(31)+1
	- IPU1=N+1
	- IPU2=N+2
	- IPU3=N+3
	- IPU4=N+4
	- VINT(141)=VINT(41)
	- VINT(142)=VINT(42)
	- N=N+4
	-
	-C...Showering of initial state partons (optional).
	-C...Note: no showering of final state partons here; it comes later.
	- IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
	- MINT(51)=0
	- ALAMSV=PARJ(81)
	- PARJ(81)=PARP(72)
	- NSAV=N
	- DO 340 I=1,4
	- DO 330 J=1,5
	- KSAV(I,J)=K(N-4+I,J)
	- PSAV(I,J)=P(N-4+I,J)
	- 330 CONTINUE
	- 340 CONTINUE
	- CALL PYSSPA(IPU1,IPU2)
	- PARJ(81)=ALAMSV
	-C...If shower failed then restore to situation before shower.
	- IF(MINT(51).GE.1) THEN
	- N=NSAV
	- DO 360 I=1,4
	- DO 350 J=1,5
	- K(N-4+I,J)=KSAV(I,J)
	- P(N-4+I,J)=PSAV(I,J)
	- 350 CONTINUE
	- 360 CONTINUE
	- IPU1=N-3
	- IPU2=N-2
	- VINT(141)=VINT(41)
	- VINT(142)=VINT(42)
	- ENDIF
	- ENDIF
	-
	-C...Keep track of loose colour ends and information on scattering.
	- 370 IMI(1,MINT(31),1)=IPU1
	- IMI(2,MINT(31),1)=IPU2
	- IMI(1,MINT(31),2)=0
	- IMI(2,MINT(31),2)=0
	- XMI(1,MINT(31))=VINT(141)
	- XMI(2,MINT(31))=VINT(142)
	- PT2MI(MINT(31))=VINT(54)
	- IMISEP(MINT(31))=N
	-
	-C...Decide whether quarks in last scattering were valence, companion or
	-C...sea.
	- DO 430 JS=1,2
	- KFBEAM=MINT(10+JS)
	- KFSBM=ISIGN(1,MINT(10+JS))
	- IFL=K(IMI(JS,MINT(31),1),2)
	- IMI(JS,MINT(31),2)=0
	- IF (IABS(IFL).GT.6) GOTO 430
	-
	-C...Get PDFs at X and Q2 of the parton shower initiator for the
	-C...last scattering. At this point VINT(143:144) do not yet
	-C...include the scattered x values VINT(141:142).
	- X=VINT(140+JS)/VINT(142+JS)
	- IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
	- Q2=PARP(62)**2
	- ELSE
	- Q2=VINT(54)
	- ENDIF
	-C...Note: XPSVC = x*pdf.
	- MINT(30)=JS
	- CALL PYPDFU(KFBEAM,X,Q2,XPQ)
	- SEA=XPSVC(IFL,-1)
	- VAL=XPSVC(IFL,0)
	- CMP=0D0
	- DO 380 IVC=1,NVC(JS,IFL)
	- CMP=CMP+XPSVC(IFL,IVC)
	- 380 CONTINUE
	-
	-C...Decide (Extra factor x cancels in the dvision).
	- RVCS=PYR(0)*(SEA+VAL+CMP)
	- IVNOW=1
	- 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
	-C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
	- IVNOW=0
	- IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
	- IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
	- IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
	- IF(KFIVAL(JS,1).EQ.0) THEN
	- IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
	- IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
	- IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
	- & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
	- ELSE
	- DO 400 I1=1,NMI(JS)
	- IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
	- & IVNOW=IVNOW-1
	- 400 CONTINUE
	- ENDIF
	- IF(IVNOW.EQ.0) GOTO 390
	-C...Mark valence.
	- IMI(JS,MINT(31),2)=0
	-C...Sets valence content of gamma, pi0, K0S, K0L if not done.
	- IF(KFIVAL(JS,1).EQ.0) THEN
	- IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
	- KFIVAL(JS,1)=IFL
	- KFIVAL(JS,2)=-IFL
	- ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
	- KFIVAL(JS,1)=IFL
	- IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
	- IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
	- ENDIF
	- ENDIF
	-
	- ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
	-C...If sea, add opposite sign companion parton. Store X and I.
	- NVC(JS,-IFL)=NVC(JS,-IFL)+1
	- XASSOC(JS,-IFL,NVC(JS,-IFL))=X
	-C...Set pointer to companion
	- IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
	- ELSE
	-C...If companion, decide which one.
	- CMPSUM=VAL+SEA
	- ISEL=0
	- 410 ISEL=ISEL+1
	- CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
	- IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
	-C...Find original sea (anti-)quark:
	- IASSOC=0
	- DO 420 I1=1,NMI(JS)
	- IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
	- IF (-IMI(JS,I1,2).EQ.ISEL) THEN
	- IMI(JS,MINT(31),2)=IMI(JS,I1,1)
	- IMI(JS,I1,2)=IMI(JS,MINT(31),1)
	- ENDIF
	- 420 CONTINUE
	-C...Change X to what associated companion had, so that the correct
	-C...amount of momentum can be subtracted from the companion sum below.
	- X=XASSOC(JS,IFL,ISEL)
	-C...Mark companion read.
	- XASSOC(JS,IFL,ISEL)=0D0
	- ENDIF
	- 430 CONTINUE
	-
	-C...Global statistics.
	- MINT(351)=MINT(351)+1
	- VINT(351)=VINT(351)+PT
	- IF (MINT(351).EQ.1) VINT(356)=PT
	-
	-C...Update remaining energy and other counters.
	- IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	- CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
	- MINT(51)=1
	- RETURN
	- ENDIF
	- NMI(1)=NMI(1)+1
	- NMI(2)=NMI(2)+1
	- VINT(151)=VINT(151)+VINT(41)
	- VINT(152)=VINT(152)+VINT(42)
	- VINT(143)=VINT(143)-VINT(141)
	- VINT(144)=VINT(144)-VINT(142)
	-
	-C...Iterate, with more interactions allowed.
	- IF(MINT(31).LT.240) GOTO 240
	- 440 CONTINUE
	-
	-C...Restore saved quantities for hardest interaction.
	- MINT(1)=ISUBSV
	- MINT(13)=M13SV
	- MINT(14)=M14SV
	- MINT(15)=M15SV
	- MINT(16)=M16SV
	- MINT(21)=M21SV
	- MINT(22)=M22SV
	- DO 450 J=11,80
	- VINT(J)=VINTSV(J)
	- 450 CONTINUE
	- VINT(141)=V141SV
	- VINT(142)=V142SV
	-
	- ENDIF
	-
	-C...Format statements for printout.
	- 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
	- &'actions for MSTP(82) =',I2,' ******')
	- 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	- &D9.2,' mb: rejected')
	- 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	- &D9.2,' mb: accepted')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYMIHK
	-C...Finds left-behind remnant flavour content and hooks up
	-C...the colour flow between the hard scattering and remnants
	-
	- SUBROUTINE PYMIHK
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...The event record
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	-C...Parameters
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	-C...The common block of dangling ends
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
	-C...Local variables
	- PARAMETER (NERSIZ=4000)
	- COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
	- & ,MACCPT
	- COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
	- SAVE /PYCBLS/,/PYCTAG/
	- DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
	- & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
	- DATA NERRPR/0/
	- SAVE NERRPR
	- FOUR(I,J)=P(I,4)P(J,4)-P(I,3)P(J,3)-P(I,2)P(J,2)-P(I,1)P(J,1)
	-
	-C...Set up error checkers
	- IBOOST=0
	-
	-C...Initialize colour arrays: MCO (Original) and MCT (New)
	- DO 110 I=MINT(84)+1,NERSIZ
	- DO 100 JC=1,2
	- MCT(I,JC)=0
	- MCO(I,JC)=0
	- 100 CONTINUE
	-C...Also zero colour tracing information, if existed.
	- IF (I.LE.N) THEN
	- K(I,4)=MOD(K(I,4),MSTU(5)**2)
	- K(I,5)=MOD(K(I,5),MSTU(5)**2)
	- ENDIF
	- 110 CONTINUE
	-
	-C...Initialize colour tag collapse arrays:
	-C...JCCO (Original) and JCCN (New).
	- DO 130 MG=MINT(84)+1,NERSIZ
	- DO 120 JC=1,2
	- JCCO(MG,JC)=0
	- JCCN(MG,JC)=0
	- 120 CONTINUE
	- 130 CONTINUE
	-
	-C...Zero gluon insertion array
	- DO 150 IM=1,1000
	- DO 140 J=1,3
	- INSR(IM,J)=0
	- 140 CONTINUE
	- 150 CONTINUE
	-
	-C...Compute hard scattering system rapidities
	- IF (MSTP(89).EQ.1) THEN
	- DO 160 IM=1,240
	- IF (IM.LE.MINT(31)) THEN
	- YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
	- ELSE
	-C...Set (unsigned) rapidity = 100 for beam remnant systems.
	- YMI(IM)=100D0
	- ENDIF
	- 160 CONTINUE
	- ENDIF
	-
	-C...Treat each side separately
	- DO 290 JS=1,2
	-
	-C...Initialize side.
	- NG(JS)=0
	- JV=0
	- KFS=ISIGN(1,MINT(10+JS))
	-
	-C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
	- IF(KFIVAL(JS,1).EQ.0) THEN
	- IF(MINT(10+JS).EQ.111) THEN
	- KFIVAL(JS,1)=INT(1.5D0+PYR(0))
	- KFIVAL(JS,2)=-KFIVAL(JS,1)
	- ELSEIF(MINT(10+JS).EQ.22) THEN
	- PYRKF=PYR(0)
	- KFIVAL(JS,1)=1
	- IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
	- IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
	- IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
	- KFIVAL(JS,2)=-KFIVAL(JS,1)
	- ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
	- IF(PYR(0).GT.0.5D0) THEN
	- KFIVAL(JS,1)=1
	- KFIVAL(JS,2)=-3
	- ELSE
	- KFIVAL(JS,1)=3
	- KFIVAL(JS,2)=-1
	- ENDIF
	- ENDIF
	- ENDIF
	-
	-C...Initialize beam remnant sea and valence content flavour by flavour.
	- NVSUM(JS)=0
	- NBRTOT(JS)=0
	- DO 210 JFA=1,6
	-C...Count up original number of JFA valence quarks and antiquarks.
	- NVALQ=0
	- NVALQB=0
	- NSEA=0
	- DO 170 J=1,3
	- IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
	- IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
	- 170 CONTINUE
	- NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
	-C...Subtract kicked out valence and determine sea from flavour cons.
	- DO 180 IM=1,NMI(JS)
	- IFL = K(IMI(JS,IM,1),2)
	- IFA = IABS(IFL)
	- IFS = ISIGN(1,IFL)
	- IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
	-C...Subtract K.O. valence quark from remainder.
	- NVALQ=NVALQ-1
	- JV=NVSUM(JS)-NVALQ-NVALQB
	- IV(JS,JV)=IMI(JS,IM,1)
	- ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
	-C...Subtract K.O. valence antiquark from remainder.
	- NVALQB=NVALQB-1
	- JV=NVSUM(JS)-NVALQ-NVALQB
	- IV(JS,JV)=IMI(JS,IM,1)
	- ELSEIF (IFA.EQ.JFA) THEN
	-C...Outside sea without companion: add opposite sea flavour inside.
	- IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
	- ENDIF
	- 180 CONTINUE
	-C...Check if space left in PYJETS for additional BR flavours
	- NFLSUM=IABS(NSEA)+NVALQ+NVALQB
	- NBRTOT(JS)=NBRTOT(JS)+NFLSUM
	- IF (N+NFLSUM+1.GT.MSTU(4)) THEN
	- CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
	- MINT(51)=1
	- RETURN
	- ENDIF
	-C...Add required val+sea content to beam remnant.
	- IF (NFLSUM.GT.0) THEN
	- DO 200 IA=1,NFLSUM
	-C...Insert beam remnant quark as p.t. symbolic parton in ER.
	- N=N+1
	- DO 190 IX=1,5
	- K(N,IX)=0
	- P(N,IX)=0D0
	- V(N,IX)=0D0
	- 190 CONTINUE
	- K(N,1)=3
	- K(N,2)=ISIGN(JFA,NSEA)
	- IF (IA.LE.NVALQ) K(N,2)=JFA
	- IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
	- K(N,3)=MINT(83)+JS
	-C...Also update NMI, IMI, and IV arrays.
	- NMI(JS)=NMI(JS)+1
	- IMI(JS,NMI(JS),1)=N
	- IMI(JS,NMI(JS),2)=-1
	- IF (IA.LE.NVALQ+NVALQB) THEN
	- IMI(JS,NMI(JS),2)=0
	- JV=JV+1
	- IV(JS,JV)=IMI(JS,NMI(JS),1)
	- ENDIF
	- 200 CONTINUE
	- ENDIF
	- 210 CONTINUE
	-
	- IM=0
	- 220 IM=IM+1
	- IF (IM.LE.NMI(JS)) THEN
	- IF (K(IMI(JS,IM,1),2).EQ.21) THEN
	- NG(JS)=NG(JS)+1
	-C...Add fictitious parent gluons for companion pairs.
	- ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
	-C...Randomly assign companions to sea quarks which have none.
	- IF (IMI(JS,IM,2).LT.0) THEN
	- IMC=PYR(0)*NMI(JS)
	- 230 IMC=MOD(IMC,NMI(JS))+1
	- IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
	- IF (IMI(JS,IMC,2).GE.0) GOTO 230
	- IMI(JS, IM,2) = IMI(JS,IMC,1)
	- IMI(JS,IMC,2) = IMI(JS, IM,1)
	- ENDIF
	-C...Add fictitious parent gluon
	- N=N+1
	- DO 240 IX=1,5
	- K(N,IX)=0
	- P(N,IX)=0D0
	- V(N,IX)=0D0
	- 240 CONTINUE
	- K(N,1)=14
	- K(N,2)=21
	- K(N,3)=MINT(83)+JS
	-C...Set gluon (anti-)colour daughter pointers
	- K(N,4)=IMI(JS, IM,1)
	- K(N,5)=IMI(JS, IM,2)
	-C...Set quark (anti-)colour parent pointers
	- K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
	- K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
	-C...Add gluon to IMI
	- NMI(JS)=NMI(JS)+1
	- IMI(JS,NMI(JS),1)=N
	- IMI(JS,NMI(JS),2)=0
	- ENDIF
	- GOTO 220
	- ENDIF
	-
	-C...If incoming (anti-)baryon, insert inside (anti-)junction.
	-C...Set up initial v-v-j-v configuration. Otherwise set up
	-C...mesonic v-vbar configuration
	- IF (IABS(MINT(10+JS)).GT.1000) THEN
	-C...Determine junction type (1: B=1 2: B=-1)
	- ITJUNC(JS) = (3-KFS)/2
	-C...Insert junction.
	- N=N+1
	- DO 250 IX=1,5
	- K(N,IX)=0
	- P(N,IX)=0D0
	- V(N,IX)=0D0
	- 250 CONTINUE
	-C...Set special junction codes:
	- K(N,1)=42
	- K(N,2)=88
	-C...Set parent to side.
	- K(N,3)=MINT(83)+JS
	- K(N,4)=ITJUNC(JS)*MSTU(5)
	- K(N,5)=0
	-C...Connect valence quarks to junction.
	- MOUT(JS)=0
	- MANTI=ITJUNC(JS)-1
	-C...Set (anti)colour mother = junction.
	- DO 260 JV=1,3
	- K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
	- & +MSTU(5)*N
	-C...Keep track of partons adjacent to junction:
	- JST(JS,JV)=IV(JS,JV)
	- 260 CONTINUE
	- ELSE
	-C...Mesons: set up initial q-qbar topology
	- ITJUNC(JS)=0
	- IF (K(IV(JS,1),2).GT.0) THEN
	- IQ=IV(JS,1)
	- IQBAR=IV(JS,2)
	- ELSE
	- IQ=IV(JS,2)
	- IQBAR=IV(JS,1)
	- ENDIF
	- IV(JS,3)=0
	- JST(JS,1)=IQ
	- JST(JS,2)=IQBAR
	- JST(JS,3)=0
	- K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
	- K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
	-C...Special for mesons. Insert gluon if BR empty.
	- IF (NBRTOT(JS).EQ.0) THEN
	- N=N+1
	- DO 270 IX=1,5
	- K(N,IX)=0
	- P(N,IX)=0D0
	- V(N,IX)=0D0
	- 270 CONTINUE
	- K(N,1)=3
	- K(N,2)=21
	- K(N,3)=MINT(83)+JS
	- K(N,4)=0
	- K(N,5)=0
	- NBRTOT(JS)=1
	- NG(JS)=NG(JS)+1
	-C...Add gluon to IMI
	- NMI(JS)=NMI(JS)+1
	- IMI(JS,NMI(JS),1)=N
	- IMI(JS,NMI(JS),2)=0
	- ENDIF
	- MOUT(JS)=0
	- ENDIF
	-
	-C...Count up number of valence quarks outside BR.
	- DO 280 JV=1,3
	- IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
	- & MOUT(JS)=MOUT(JS)+1
	- 280 CONTINUE
	-
	- 290 CONTINUE
	-
	-C...Now both sides have been prepared in an initial vvjv (baryonic) or
	-C...v(g)vbar (mesonic) configuration.
	-
	-C...Create colour line tags starting from initiators.
	- NCT=0
	- DO 320 IM=1,MINT(31)
	-C...Consider each side in turn.
	- DO 310 JS=1,2
	- I1=IMI(JS,IM,1)
	- I2=IMI(3-JS,IM,1)
	- DO 300 JCS=4,5
	- IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
	- & GOTO 300
	- IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
	-
	- KCS=JCS
	- CALL PYCTTR(I1,KCS,I2)
	- IF(MINT(51).NE.0) RETURN
	-
	- 300 CONTINUE
	- 310 CONTINUE
	- 320 CONTINUE
	-
	- DO 340 JS=1,2
	-C...Create colour tags for beam remnant partons.
	- DO 330 IM=MINT(31)+1,NMI(JS)
	- IP=IMI(JS,IM,1)
	- IF (K(IP,2).NE.21) THEN
	- JC=(3-ISIGN(1,K(IP,2)))/2
	- IF (MCT(IP,JC).EQ.0) THEN
	- NCT=NCT+1
	- MCT(IP,JC)=NCT
	- ENDIF
	- ELSE
	-C...Gluons
	- ICD=K(IP,4)
	- IAD=K(IP,5)
	- IF (ICD.NE.0) THEN
	-C...Fictituous gluons just inherit from their quark daughters.
	- ICC=MCT(ICD,1)
	- IAC=MCT(IAD,2)
	- ELSE
	-C...Real beam remnant gluons get their own colours
	- ICC=NCT+1
	- IAC=NCT+2
	- NCT=NCT+2
	- ENDIF
	- MCT(IP,1)=ICC
	- MCT(IP,2)=IAC
	- ENDIF
	- 330 CONTINUE
	- 340 CONTINUE
	-
	-C...Create colour tags for colour lines which are detached from the
	-C...initial state.
	-
	- DO 360 MQGST=1,2
	- DO 350 I=MINT(84)+1,N
	-
	-C...Look for coloured string endpoint, or (later) leftover gluon.
	- IF (K(I,1).NE.3) GOTO 350
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0) GOTO 350
	- KQ=KCHG(KC,2)
	- IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
	-
	-C...Pick up loose string end with no previous tag.
	- KCS=4
	- IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
	- IF(MCT(I,KCS-3).NE.0) GOTO 350
	-
	- CALL PYCTTR(I,KCS,I)
	- IF(MINT(51).NE.0) RETURN
	-
	- 350 CONTINUE
	- 360 CONTINUE
	-
	-C...Store original colour tags
	- DO 370 I=MINT(84)+1,N
	- MCO(I,1)=MCT(I,1)
	- MCO(I,2)=MCT(I,2)
	- 370 CONTINUE
	-
	-C...Iteratively add gluons to already existing string pieces, enforcing
	-C...various possible orderings, and rejecting insertions that would give
	-C...rise to singlet gluons.
	-C...<kappa tau> normalization.
	- RM0=1.5D0
	- MRETRY=0
	- PARP80=PARP(80)
	-
	-C...Set up simplified kinematics.
	-C...Boost hard interaction systems.
	- IBOOST=IBOOST+1
	- DO 380 IM=1,MINT(31)
	- BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
	- CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
	- 380 CONTINUE
	-C...Assign preliminary beam remnant momenta.
	- DO 390 I=MINT(53)+1,N
	- JS=K(I,3)
	- P(I,1)=0D0
	- P(I,2)=0D0
	- IF (K(I,2).NE.88) THEN
	- P(I,4)=0.5D0VINT(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)+2MSTU(5)*2
	- IF (K(IP2,2).NE.88) THEN
	- K(IP2,5-MANTI)=K(IP2,5-MANTI)+2MSTU(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-2JS)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-2JS)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-2JS)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-2JS)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=1000K(IDQ(1),2)+100K(IDQ(2),2)
	- IS=3
	- IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
	- & (1D0+3D0PARJ(4))PYR(0).LT.1D0) IS=1
	- KFDQ=KFDQ+ISIGN(IS,KFDQ)
	- ENDIF
	-
	-C...Collapse diquark-j-quark system to baryon, if allowed and possible.
	-C...Note: third quark can per definition not also be valence,
	-C...therefore we can only do this if we are allowed to use sea quarks.
	- 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
	- NTRY=0
	- 780 NTRY=NTRY+1
	- CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
	- IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
	- GOTO 780
	- ELSEIF(NTRY.GT.100) THEN
	-C...If no baryon can be found, give up and form diquark.
	- IDQ(3)=0
	- GOTO 770
	- ELSE
	-C...Replace junction by baryon.
	- K(IJU,1)=1
	- K(IJU,2)=KFBAR
	- K(IJU,3)=MINT(83)+JS
	- K(IJU,4)=0
	- K(IJU,5)=0
	- P(IJU,5)=PYMASS(KFBAR)
	- DO 790 MSJ=1,3
	-C...Prepare removal of participating quarks from ER.
	- K(JST(JS,MSJ),1)=-1
	- 790 CONTINUE
	- ENDIF
	- ELSE
	-C...If collapse to baryon not possible or not allowed, replace junction
	-C...by diquark. This way, collapsed gluons that were pointing at the
	-C...junction will now point (correctly) at diquark.
	- MANTI=ITJUNC(JS)-1
	- K(IJU,1)=3
	- K(IJU,2)=KFDQ
	- K(IJU,3)=MINT(83)+JS
	- K(IJU,4)=0
	- K(IJU,5)=0
	- DO 800 MSJ=1,3
	- IP=JST(JS,MSJ)
	- IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
	- K(IJU,4+MANTI)=0
	- K(IJU,5-MANTI)=IP*MSTU(5)
	- K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
	- & MSTU(5)*IJU
	- MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
	- ELSE
	-C...Prepare removal of participating quarks from ER.
	- K(IP,1)=-1
	- ENDIF
	- 800 CONTINUE
	- ENDIF
	-
	-C...Update so ER pointers to collapsed quarks
	-C...now go to collapsed object.
	- DO 820 I=MINT(84)+1,N
	- IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
	- & .K(I,1).GT.0) THEN
	- DO 810 ISID=4,5
	- IMO=K(I,ISID)/MSTU(5)
	- IDA=MOD(K(I,ISID),MSTU(5))
	- IF (IMO.GT.0) THEN
	- IF (K(IMO,1).EQ.-1) IMO=IJU
	- ENDIF
	- IF (IDA.GT.0) THEN
	- IF (K(IDA,1).EQ.-1) IDA=IJU
	- ENDIF
	- K(I,ISID)=IDA+MSTU(5)*IMO
	- 810 CONTINUE
	- ENDIF
	- 820 CONTINUE
	- ENDIF
	- ENDIF
	-
	-C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
	-C...(this only happens for baryons, where we want to force the gluon
	-C...to sit next to the junction. Mesons handled above.)
	- IF (NBRTOT(JS).EQ.0) THEN
	- N=N+1
	- DO 830 IX=1,5
	- K(N,IX)=0
	- P(N,IX)=0D0
	- V(N,IX)=0D0
	- 830 CONTINUE
	- IGL=N
	- K(IGL,1)=3
	- K(IGL,2)=21
	- K(IGL,3)=MINT(83)+JS
	- IF (ITJUNC(JS).NE.0) THEN
	-C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
	- JLEG=PYR(0)*NVSUM(JS)+1
	- I1=JST(JS,JLEG)
	- JST(JS,JLEG)=IGL
	- JCT=MCT(I1,ITJUNC(JS))
	- MCT(IGL,3-ITJUNC(JS))=JCT
	- NCT=NCT+1
	- MCT(IGL,ITJUNC(JS))=NCT
	- MANTI=ITJUNC(JS)-1
	- ELSE
	-C...Meson. Should not happen.
	- CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
	- IF(NERRPR.LT.5) THEN
	- WRITE(MSTU(11),*) 'This should not have been possible!'
	- CALL PYLIST(4)
	- NERRPR=NERRPR+1
	- ENDIF
	- MINT(51)=1
	- RETURN
	- ENDIF
	- I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
	- K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
	- K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
	- K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
	- IF (K(I2,2).NE.88) THEN
	- K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
	- ELSE
	- IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
	- K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
	- ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
	- K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
	- ELSE
	- K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
	- ENDIF
	- ENDIF
	- ENDIF
	- 840 CONTINUE
	-
	-C...Remove collapsed quarks and junctions from ER and update IMI.
	- CALL PYEDIT(11)
	-
	-C...Also update beam remnant part of IMI.
	- NMI(1)=MINT(31)
	- NMI(2)=MINT(31)
	- DO 850 I=MINT(53)+1,N
	- IF (K(I,1).LE.0) GOTO 850
	-C...Restore BR quark/diquark/baryon pointers in IMI.
	- IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
	- JS=K(I,3)-MINT(83)
	- NMI(JS)=NMI(JS)+1
	- IMI(JS,NMI(JS),1)=I
	- IMI(JS,NMI(JS),2)=0
	- ENDIF
	- 850 CONTINUE
	-
	-C...Restore companion information from collapsed gluons.
	- DO 870 I=MINT(53)+1,N
	- IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
	- JS=K(I,3)-MINT(83)
	- JCD=MOD(K(I,4),MSTU(5))
	- JAD=MOD(K(I,5),MSTU(5))
	- DO 860 IM=1,NMI(JS)
	- IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
	- IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
	- 860 CONTINUE
	- IMI(JS,IMC,2)=IMI(JS,IMA,1)
	- IMI(JS,IMA,2)=IMI(JS,IMC,1)
	- ENDIF
	- 870 CONTINUE
	-
	-C...Renumber colour lines (since some have disappeared)
	- JCT=0
	- JCD=0
	- 880 JCT=JCT+1
	- MFOUND=0
	- I=MINT(84)
	- 890 I=I+1
	- IF (I.EQ.N+1) THEN
	- IF (MFOUND.EQ.0) JCD=JCD+1
	- ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
	- MCT(I,1)=JCT-JCD
	- MFOUND=1
	- ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
	- MCT(I,2)=JCT-JCD
	- MFOUND=1
	- ENDIF
	- IF (I.LE.N) GOTO 890
	- IF (JCT.LT.NCT) GOTO 880
	- NCT=JCT-JCD
	-
	-C...Reset hard interaction subsystems to their CM frames.
	- IF (IBOOST.EQ.1) THEN
	- DO 900 IM=1,MINT(31)
	- BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
	- CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
	- 900 CONTINUE
	-C...Zero beam remnant longitudinal momenta and energies
	- DO 910 I=MINT(53)+1,N
	- P(I,3)=0D0
	- P(I,4)=0D0
	- 910 CONTINUE
	- ELSE
	- CALL PYERRM(9
	- & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
	-C...Kill event and start another.
	- MINT(51)=1
	- RETURN
	- ENDIF
	-
	- 9999 RETURN
	- END
	-C*********************************************************************
	-
	-C...PYCTTR
	-C...Adapted from PYPREP.
	-C...Assigns LHA1 colour tags to coloured partons based on
	-C...K(I,4) and K(I,5) colour connection record.
	-C...KCS negative signifies that a previous tracing should be continued.
	-C...(in case the tag to be continued is empty, the routine exits)
	-C...Starts at I and ends at I or IEND.
	-C...Special considerations for systems with junctions.
	-C...Special: if IEND=-1, means trace this parton to its color partner,
	-C... then exit. If no partner found, exit with 0.
	-
	- SUBROUTINE PYCTTR(I,KCS,IEND)
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYINT1/MINT(400),VINT(400)
	-C...The common block of colour tags.
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
	- DATA NERRPR/0/
	- SAVE NERRPR
	-
	-C...Skip if parton not existing or does not have KCS
	- IF (K(I,1).LE.0) GOTO 120
	- KC=PYCOMP(K(I,2))
	- IF (KC.EQ.0) GOTO 120
	- KQ=KCHG(KC,2)
	- IF (KQ.EQ.0) GOTO 120
	- IF (IABS(KQ).EQ.1.AND.KQ(9-2ABS(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.2MSTU(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)+2MSTU(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)+2MSTU(5)*2
	- ELSE
	- IF(MREV.EQ.0) KCS=9-KCS
	- IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
	-C...Set KCS daughter traced tag for IA
	- K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
	- ENDIF
	-C...Assign new colour tag
	- MCT(IA,KCS-3)=NCS
	-C...Finish if IEND=-1 and found final-state color partner
	- IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
	- IEND=IA
	- GOTO 120
	- ENDIF
	- IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
	-
	- 120 RETURN
	- END
	-
	-*********************************************************************
	-
	-C...PYMIHG
	-C...Collapse JCP1 and connecting tags to JCG1.
	-C...Collapse JCP2 and connecting tags to JCG2.
	-
	- SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...The event record
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	-C...Parameters
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYINT1/
	-C...Local variables
	- COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
	- COMMON /PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYCBLS/,/PYCTAG/
	-
	-C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
	-C...in temporary tag collapse array JCCN. Only break up one connection.
	- MACCPT=1
	- MCLPS=0
	- DO 100 ICC=1,NCC
	- JCCN(ICC,1)=JCCO(ICC,1)
	- JCCN(ICC,2)=JCCO(ICC,2)
	-C...If there was a mother, it was previously connected to JCP1.
	-C...Should be changed to JCP2.
	- IF (MCLPS.EQ.0) THEN
	- IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
	- & ,JCP2)) THEN
	- JCCN(ICC,1)=MAX(JCG2,JCP2)
	- JCCN(ICC,2)=MIN(JCG2,JCP2)
	- MCLPS=1
	- ENDIF
	- ENDIF
	- 100 CONTINUE
	-C...Also collapse colours on JCP1 side of JCG1
	- IF (JCP1.NE.0) THEN
	- JCCN(NCC+1,1)=MAX(JCP1,JCG1)
	- JCCN(NCC+1,2)=MIN(JCP1,JCG1)
	- ELSE
	- JCCN(NCC+1,1)=MAX(JCP2,JCG2)
	- JCCN(NCC+1,2)=MIN(JCP2,JCG2)
	- ENDIF
	-
	-C...Initialize event record colour tag array MCT array to MCO.
	- DO 110 I=MINT(84)+1,N
	- MCT(I,1)=MCO(I,1)
	- MCT(I,2)=MCO(I,2)
	- 110 CONTINUE
	-
	-C...Collapse tags:
	-C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
	-C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
	-C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
	-C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
	- DO 160 IS=1,4
	-C...Skip if junction.
	- IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
	-C...Define starting point in tag space.
	-C...JCA = previous tag
	-C...JCO = present tag
	-C...JCN = new tag
	- IF (MOD(IS,2).EQ.1) THEN
	- JCO=JCP1
	- JCN=JCG1
	- JCALL=JCG1
	- ELSEIF (MOD(IS,2).EQ.0) THEN
	- JCO=JCP2
	- JCN=JCG2
	- JCALL=JCG2
	- ENDIF
	- ITRACE=0
	- 120 ITRACE=ITRACE+1
	- IF (ITRACE.GT.1000) THEN
	-C...NB: Proper error message should be defined here.
	- CALL PYERRM(14
	- & ,'(PYMIHG:) Inf loop when collapsing colours.')
	- MINT(57)=MINT(57)+1
	- MINT(51)=1
	- RETURN
	- ENDIF
	-C...Collapse all JCN tags to JCALL
	- DO 130 I=MINT(84)+1,N
	- IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
	- IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
	- 130 CONTINUE
	-C...IS = 1,2: first step forward. IS = 3,4: first step backward.
	- IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
	- JCA=JCN
	- JCN=JCO
	- ELSE
	- JCA=JCO
	- JCO=JCN
	- ENDIF
	-C...If possible, step from JCO to new tag JCN not equal to JCA.
	- DO 140 ICC=1,NCC+1
	- IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
	- & JCCN(ICC,2)
	- IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
	- & JCCN(ICC,1)
	- 140 CONTINUE
	-C...Iterate if new colour was arrived at, but don't go in circles.
	- IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
	-C...Change all JCN tags in MCO to JCALL in MCT.
	- DO 150 I=MINT(84)+1,N
	- IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
	- IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
	-C...If gluon and colour tag = anticolour tag (and not = 0) try again.
	- IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
	- & .NE.0) MACCPT=0
	- 150 CONTINUE
	- 160 CONTINUE
	-
	- DO 200 JCL=NCT,1,-1
	- JCA=0
	- JCN=JCL
	- 170 JCO=JCN
	- DO 180 ICC=1,NCC+1
	- IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
	- & =JCCN(ICC,2)
	- IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
	- & =JCCN(ICC,1)
	- 180 CONTINUE
	-C...Overpaint all JCN with JCL
	- IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
	- DO 190 I=MINT(84)+1,N
	- IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
	- IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
	-C...If gluon and colour tag = anticolour tag (and not = 0) try again.
	- IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
	- & .NE.0) MACCPT=0
	- 190 CONTINUE
	- JCA=JCO
	- GOTO 170
	- ENDIF
	- 200 CONTINUE
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYMIRM
	-C...Picks primordial kT and shares longitudinal momentum among
	-C...beam remnants.
	-
	- SUBROUTINE PYMIRM
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...The event record
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	-C...Parameters
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	-C...The common block of colour tags.
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	-C...The common block of dangling ends
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
	-C...Local variables
	- DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
	-C...W(I,J)\| J=0 \| 1 \| 2 \|
	-C... I=0 \| Wrem**2 \| W+ \| W- \|
	-C... 1 \| W1**2 \| W1+ \| W1- \|
	-C... 2 \| W2**2 \| W2+ \| W2- \|
	-C...4-product
	- FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	-C...Tentative parametrization of <kT> as a function of Q.
	- SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
	-C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
	-C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
	- GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
	-C...Lambda kinematic function.
	- FLAM(A,B,C)=A2+B2+C*2-2D0(AB+BC+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/40D0SIGMA6/EPS*6)
	- IF (PYR(0).LT.P12) THEN
	-C...Use flat approx with accept/reject up to EPS.
	- PT=PYR(0)*EPS
	- WT=(3D0/2D0SIGMA2/(PT2+3D0/2D0SIGMA2))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=PT6/(PT2+3D0/2D0SIGMA2)*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(PTX2+PTY2)
	- 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(PTX2+PTY2)
	- 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.5D0FACPTCX
	- P(L1,2)=P(L1,2)+0.5D0FACPTCY
	- P(L2,1)=P(L2,1)+0.5D0FACPTCX
	- P(L2,2)=P(L2,2)+0.5D0FACPTCY
	- P(L3,1)=P(L3,1)+0.5D0FACPTCX
	- P(L3,2)=P(L3,2)+0.5D0FACPTCY
	- P(IDA,1)=P(IDA,1)-0.5D0FACPTCX
	- P(IDA,2)=P(IDA,2)-0.5D0FACPTCY
	- 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(PT1PT2-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
	- & (XCOMP2+XX2)/(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))/(2D0W(1,1)W(0,2))
	- R2=(COMTRM+W(2,0)-W(1,0))/(2D0W(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=2D0FOUR(IJ1,IJ2)2D0*FOUR(IK1,IK2)
	- RLN=2D0FOUR(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(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYINT1/MINT(400),VINT(400)
	-C...The common block of colour tags.
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
	- &/PYPARS/
	-C...MCN: Temporary storage of new colour tags
	- INTEGER MCN(4000,2)
	-C...Arrays for storing color 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)*2P2AVG)
	- 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 = 2RAPMAX/(1D0NBINY)
	-C... Explicitly zero histogram bin content
	- DO 160 IBINY=1,NBINY
	- NSTRY(IBINY)=0
	- 160 CONTINUE
	- DO 180 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 170 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.5DRAP.AND.Y2.GE.YBINLO+0.5DRAP)
	- & NSTRY(IBINY) = NSTRY(IBINY) + 1
	- 170 CONTINUE
	- 180 CONTINUE
	-C... Loop over pieces to find individual reconnect probability
	- DO 200 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)*2PT2AVG)
	- ENDIF
	- PKEEP = 1.0
	- DO 190 IBINY=IBINLO,IBINHI
	-C DNSUM = DNSUM + 1D0
	- DNOVL = MAX(0,NSTRY(IBINY)-1)
	- PKEEP = PKEEP * (1D0-CRMODFPARP(78))(DRAPAVDNOVL)
	-C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
	- 190 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
	- 200 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
	- 210 NLOOP=NLOOP+1
	- MORD=1
	- DO 220 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
	- 220 CONTINUE
	-C...Max do 1000 reordering loops
	- IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 210
	-
	-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 230 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
	- 230 CONTINUE
	- ENDIF
	-
	-C...Loop over CR partons
	-C...(Ignore junctions for now.)
	- NLOOP=0
	- 240 NLOOP=NLOOP+1
	- RLMAX=0D0
	- ICRMAX=0
	-C...Loop over coloured partons
	- DO 260 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 260
	-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 260
	- 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 250 IC2=1,NCR
	- J=ICR(IC2)
	- MSJ=MSCR(IC2)
	-C...Skip if already connected
	- IF (MCN(J,MSJ).NE.0) GOTO 250
	-C...Skip if this not colour-anticolour pair
	- IF (MSI.EQ.MSJ) GOTO 250
	-C...And do not let gluons connect to themselves
	- IF (I.EQ.J) GOTO 250
	-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
	- 250 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
	- 260 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 240
	- 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 290 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 290
	- 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 280 KCT=ICTMIN,LCT
	- IC=0
	- IA=0
	- DO 270 IT=MAX(1,IP),N
	- IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 270
	- IF (MCN(IT,1).EQ.KCT) IC=IT
	- IF (MCN(IT,2).EQ.KCT) IA=IT
	- 270 CONTINUE
	-C...Skip if this color tag no longer present in event record
	- IF (IC.EQ.0.OR.IA.EQ.0) GOTO 280
	- RL=FOUR(IC,I)*FOUR(IA,I)
	- IF (RL.LT.RLMAX) THEN
	- RLMAX=RL
	- ICMAX=IC
	- IAMAX=IA
	- ENDIF
	- 280 CONTINUE
	- LCT=LCT+1
	- MCN(I,1)=MCN(ICMAX,1)
	- MCN(I,2)=LCT
	- MCN(ICMAX,1)=LCT
	- ENDIF
	- 290 CONTINUE
	-C...Here we need to loop over entire event.
	- DO 300 IZ=MAX(1,IP),N
	-C...Do not erase parton shower colour history
	- IF (K(IZ,1).NE.3) GOTO 300
	-C...Check colour charge
	- MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
	- IF (MCI.EQ.0) GOTO 300
	- IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
	- IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
	- 300 CONTINUE
	- ENDIF
	-
	- 9999 RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYDIFF
	-C...Handles diffractive and elastic scattering.
	-
	- SUBROUTINE PYDIFF
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
	-
	-C...Reset K, P and V vectors. Store incoming particles.
	- DO 110 JT=1,MSTP(126)+10
	- I=MINT(83)+JT
	- DO 100 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	- N=MINT(84)
	- MINT(3)=0
	- MINT(21)=0
	- MINT(22)=0
	- MINT(23)=0
	- MINT(24)=0
	- MINT(4)=4
	- DO 130 JT=1,2
	- I=MINT(83)+JT
	- K(I,1)=21
	- K(I,2)=MINT(10+JT)
	- DO 120 J=1,5
	- P(I,J)=VINT(285+5*JT+J)
	- 120 CONTINUE
	- 130 CONTINUE
	- MINT(6)=2
	-
	-C...Subprocess; kinematics.
	- SQLAM=(VINT(2)-VINT(63)-VINT(64))*2-4D0VINT(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,(PMMAS2-PM12-PM22)2-
	- & 4D0PM12PM2*2))/(2D0PMMAS)
	- P(N-1,3)=PZP
	- P(N,3)=-PZP
	- P(N-1,4)=SQRT(PM12+PZP2)
	- P(N,4)=SQRT(PM22+PZP2)
	- CALL PYROBO(N-1,N,ACOS(2D0PYR(0)-1D0),PARU(2)PYR(0),
	- & 0D0,0D0,0D0)
	- DBETAZ=PZ(-1)(JT+1)/SQRT(PZ2+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-
	- & 4D0P(N-1,5)2P(N,5)**2
	- P(N-1,3)=(PESQRT(SQLAM)+PZ(VINT(62+JT)+P(N-1,5)**2-
	- & P(N,5)*2))/(2D0VINT(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((CHI2/(CHI2+CUT2))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=CUTCUTR*PYR(0)
	- CHI=(CHIR2-CUT2)/(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(CHI2+CUT2)))**
	- & (0.5D0PARP(98))(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
	- ENDIF
	- IF(CHI.LT.P(N,5)2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)2/
	- & VINT(62+JT)) GOTO 160
	- SQM=P(N-2,5)2/(1D0-CHI)+P(N,5)2/CHI
	- PZI=(PE(VINT(62+JT)-SQM)+PZ(VINT(62+JT)+SQM))/
	- & (2D0*VINT(62+JT))
	- PEI=SQRT(PZI**2+SQM)
	- PQQP=(1D0-CHI)*(PEI+PZI)
	- P(N-2,3)=0.5D0(PQQP-P(N-2,5)2/PQQP)(-1)**(JT+1)
	- P(N-2,4)=SQRT(P(N-2,3)2+P(N-2,5)2)
	- P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
	- P(N-1,3)=P(N-1,4)(-1)*JT
	- P(N,3)=PZI(-1)*(JT+1)-P(N-2,3)
	- P(N,4)=SQRT(P(N,3)2+P(N,5)2)
	- ENDIF
	-
	-C...Documentation lines.
	- K(I+2,1)=21
	- IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
	- IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
	- & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
	- K(I+2,3)=I
	- P(I+2,3)=PZ(-1)*(JT+1)
	- P(I+2,4)=PE
	- P(I+2,5)=SQRT(VINT(62+JT))
	- 200 CONTINUE
	-
	-C...Rotate outgoing partons/particles using cos(theta).
	- IF(VINT(23).LT.0.9D0) THEN
	- CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
	- ELSE
	- CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYDISG
	-C...Set up a DIS process as gamma* + f -> f, with beam remnant
	-C...and showering added consecutively. Photon flux by the PYGAGA
	-C...routine (if at all).
	-
	- SUBROUTINE PYDISG
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
	-C...Local arrays.
	- DIMENSION PMS(4)
	-
	-C...Choice of subprocess, number of documentation lines
	- IDOC=7
	- MINT(3)=IDOC-6
	- MINT(4)=IDOC
	- IPU1=MINT(84)+1
	- IPU2=MINT(84)+2
	- IPU3=MINT(84)+3
	- ISIDE=1
	- IF(MINT(107).EQ.4) ISIDE=2
	-
	-C...Reset K, P and V vectors. Store incoming particles
	- DO 110 JT=1,MSTP(126)+20
	- I=MINT(83)+JT
	- DO 100 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	- DO 130 JT=1,2
	- I=MINT(83)+JT
	- K(I,1)=21
	- K(I,2)=MINT(10+JT)
	- DO 120 J=1,5
	- P(I,J)=VINT(285+5*JT+J)
	- 120 CONTINUE
	- 130 CONTINUE
	- MINT(6)=2
	-
	-C...Store incoming partons in hadronic CM-frame
	- DO 140 JT=1,2
	- I=MINT(84)+JT
	- K(I,1)=14
	- K(I,2)=MINT(14+JT)
	- K(I,3)=MINT(83)+2+JT
	- 140 CONTINUE
	- IF(MINT(15).EQ.22) THEN
	- P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
	- P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
	- P(MINT(84)+1,5)=-SQRT(VINT(307))
	- P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
	- P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
	- KFRES=MINT(16)
	- ISIDE=2
	- ELSE
	- P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
	- P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
	- P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
	- P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
	- P(MINT(84)+1,5)=-SQRT(VINT(308))
	- KFRES=MINT(15)
	- ISIDE=1
	- ENDIF
	- SIDESG=(-1D0)**(ISIDE-1)
	-
	-C...Copy incoming partons to documentation lines.
	- DO 170 JT=1,2
	- I1=MINT(83)+4+JT
	- I2=MINT(84)+JT
	- K(I1,1)=21
	- K(I1,2)=K(I2,2)
	- K(I1,3)=I1-2
	- DO 150 J=1,5
	- P(I1,J)=P(I2,J)
	- 150 CONTINUE
	-
	-C...Second copy for partons before ISR shower, since no such.
	- I1=MINT(83)+2+JT
	- K(I1,1)=21
	- K(I1,2)=K(I2,2)
	- K(I1,3)=I1-2
	- DO 160 J=1,5
	- P(I1,J)=P(I2,J)
	- 160 CONTINUE
	- 170 CONTINUE
	-
	-C...Define initial partons.
	- NTRY=0
	- 180 NTRY=NTRY+1
	- IF(NTRY.GT.100) THEN
	- MINT(51)=1
	- RETURN
	- ENDIF
	-
	-C...Scattered quark in hadronic CM frame.
	- I=MINT(83)+7
	- K(IPU3,1)=3
	- K(IPU3,2)=KFRES
	- K(IPU3,3)=I
	- P(IPU3,5)=PYMASS(KFRES)
	- P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
	- P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
	- P(IPU3,5)=0D0
	- K(I,1)=21
	- K(I,2)=KFRES
	- K(I,3)=MINT(83)+4+ISIDE
	- P(I,3)=P(IPU3,3)
	- P(I,4)=P(IPU3,4)
	- P(I,5)=P(IPU3,5)
	- N=IPU3
	- MINT(21)=KFRES
	- MINT(22)=0
	-
	-C...No primordial kT, or chosen according to truncated Gaussian or
	-C...exponential, or (for photon) predetermined or power law.
	- 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
	- IF(MSTP(91).LE.0) THEN
	- PT=0D0
	- ELSEIF(MSTP(91).EQ.1) THEN
	- PT=PARP(91)*SQRT(-LOG(PYR(0)))
	- ELSE
	- RPT1=PYR(0)
	- RPT2=PYR(0)
	- PT=-PARP(92)LOG(RPT1RPT2)
	- 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(RPT1RPT2)
	- ENDIF
	- IF(PTB.GT.PARP(100)) GOTO 190
	- PT=SQRT(PTA2+PTB2+2D0PTAPTBCOS(PARU(2)PYR(0)))
	- IF(NTRY.GT.10) PT=PT0.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(RPT1RPT2)
	- 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+PT2+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+2IMB)))
	- 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-4D0PMS(1)*PMS(2)))
	- DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
	- &(2D0VINT(1)PCP)
	- DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
	- &(2D0VINT(1)PRP)
	- DBEC=-SIDESG(DRKC2-1D0)/(DRKC*2+1D0)
	- DBER=SIDESG(DRKR2-1D0)/(DRKR*2+1D0)
	- CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
	- CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
	-
	-C...Let current quark shower; recoil but no showering by colour partner.
	- QMAX=2D0*SQRT(VINT(309-ISIDE))
	- MSTJ48=MSTJ(48)
	- MSTJ(48)=1
	- PARJ86=PARJ(86)
	- PARJ(86)=0D0
	- IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
	- MSTJ(48)=MSTJ48
	- PARJ(86)=PARJ86
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYDOCU
	-C...Handles the documentation of the process in MSTI and PARI,
	-C...and also computes cross-sections based on accumulated statistics.
	-
	- SUBROUTINE PYDOCU
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
	- &/PYINT5/
	-
	-C...Calculate Monte Carlo estimates of cross-sections.
	- ISUB=MINT(1)
	- IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
	- NGEN(0,3)=NGEN(0,3)+1
	- XSEC(0,3)=0D0
	- DO 100 I=1,500
	- IF(I.EQ.96.OR.I.EQ.97) THEN
	- XSEC(I,3)=0D0
	- ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
	- & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
	- XSEC(I,3)=XSEC(96,2)NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))
	- & DBLE(NGEN(96,2)))
	- ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
	- XSEC(I,3)=XSEC(96,2)NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))
	- & DBLE(NGEN(96,2)))
	- ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
	- XSEC(I,3)=0D0
	- ELSEIF(NGEN(I,2).EQ.0) THEN
	- XSEC(I,3)=XSEC(I,2)NGEN(0,3)/(DBLE(NGEN(I,1))
	- & DBLE(NGEN(0,2)))
	- ELSE
	- XSEC(I,3)=XSEC(I,2)NGEN(I,3)/(DBLE(NGEN(I,1))
	- & DBLE(NGEN(I,2)))
	- ENDIF
	- XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
	- 100 CONTINUE
	-
	-C...Rescale to known low-pT cross-section for standard QCD processes.
	- IF(MSUB(95).EQ.1) THEN
	- XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
	- & XSEC(68,3)+XSEC(95,3)
	- XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
	- IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
	- FAC=XSECW/XSECH
	- XSEC(11,3)=FAC*XSEC(11,3)
	- XSEC(12,3)=FAC*XSEC(12,3)
	- XSEC(13,3)=FAC*XSEC(13,3)
	- XSEC(28,3)=FAC*XSEC(28,3)
	- XSEC(53,3)=FAC*XSEC(53,3)
	- XSEC(68,3)=FAC*XSEC(68,3)
	- XSEC(95,3)=FAC*XSEC(95,3)
	- XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
	- ENDIF
	- ENDIF
	-
	-C...Save information for gamma-p and gamma-gamma.
	- IF(MINT(121).GT.1) THEN
	- IGA=MINT(122)
	- CALL PYSAVE(2,IGA)
	- CALL PYSAVE(5,0)
	- ENDIF
	-
	-C...Reset information on hard interaction.
	- DO 110 J=1,200
	- MSTI(J)=0
	- PARI(J)=0D0
	- 110 CONTINUE
	-
	-C...Copy integer valued information from MINT into MSTI.
	- DO 120 J=1,32
	- MSTI(J)=MINT(J)
	- 120 CONTINUE
	- IF(MINT(121).GT.1) MSTI(9)=MINT(122)
	-
	-C...Store cross-section variables in PARI.
	- PARI(1)=XSEC(0,3)
	- PARI(2)=XSEC(0,3)/MINT(5)
	- PARI(7)=VINT(97)
	- PARI(9)=VINT(99)
	- PARI(10)=VINT(100)
	- VINT(98)=VINT(98)+VINT(100)
	- IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
	-
	-C...Store kinematics variables in PARI.
	- PARI(11)=VINT(1)
	- PARI(12)=VINT(2)
	- IF(ISUB.NE.95) THEN
	- DO 130 J=13,26
	- PARI(J)=VINT(30+J)
	- 130 CONTINUE
	- PARI(29)=VINT(39)
	- PARI(30)=VINT(40)
	- PARI(31)=VINT(141)
	- PARI(32)=VINT(142)
	- PARI(33)=VINT(41)
	- PARI(34)=VINT(42)
	- PARI(35)=PARI(33)-PARI(34)
	- PARI(36)=VINT(21)
	- PARI(37)=VINT(22)
	- PARI(38)=VINT(26)
	- PARI(39)=VINT(157)
	- PARI(40)=VINT(158)
	- PARI(41)=VINT(23)
	- PARI(42)=2D0*VINT(47)/VINT(1)
	- ENDIF
	-
	-C...Store information on scattered partons in PARI.
	- IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
	- DO 140 IS=7,8
	- I=MINT(IS)
	- PARI(36+IS)=P(I,3)/VINT(1)
	- PARI(38+IS)=P(I,4)/VINT(1)
	- PR=MAX(1D-20,P(I,5)2+P(I,1)2+P(I,2)**2)
	- PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
	- & SQRT(PR),1D20)),P(I,3))
	- PR=MAX(1D-20,P(I,1)2+P(I,2)2)
	- PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
	- & SQRT(PR),1D20)),P(I,3))
	- PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)2+P(I,2)2+P(I,3)**2)
	- PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)2+P(I,2)2))
	- PARI(48+IS)=PYANGL(P(I,1),P(I,2))
	- 140 CONTINUE
	- ENDIF
	-
	-C...Store sum up transverse and longitudinal momenta.
	- PARI(65)=2D0*PARI(17)
	- IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
	- DO 150 I=MSTP(126)+1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
	- PT=SQRT(P(I,1)2+P(I,2)2)
	- PARI(69)=PARI(69)+PT
	- IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
	- IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
	- 150 CONTINUE
	- PARI(67)=PARI(68)
	- PARI(71)=VINT(151)
	- PARI(72)=VINT(152)
	- PARI(73)=VINT(151)
	- PARI(74)=VINT(152)
	- ELSE
	- PARI(66)=PARI(65)
	- PARI(69)=PARI(65)
	- ENDIF
	-
	-C...Store various other pieces of information into PARI.
	- PARI(61)=VINT(148)
	- PARI(75)=VINT(155)
	- PARI(76)=VINT(156)
	- PARI(77)=VINT(159)
	- PARI(78)=VINT(160)
	- PARI(81)=VINT(138)
	-
	-C...Store information on lepton -> lepton + gamma in PYGAGA.
	- MSTI(71)=MINT(141)
	- MSTI(72)=MINT(142)
	- PARI(101)=VINT(301)
	- PARI(102)=VINT(302)
	- DO 160 I=103,114
	- PARI(I)=VINT(I+202)
	- 160 CONTINUE
	-
	-C...Set information for PYTABU.
	- IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
	- MSTU(161)=MINT(21)
	- MSTU(162)=0
	- ELSEIF(ISET(ISUB).EQ.5) THEN
	- MSTU(161)=MINT(23)
	- MSTU(162)=0
	- ELSE
	- MSTU(161)=MINT(21)
	- MSTU(162)=MINT(22)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYFRAM
	-C...Performs transformations between different coordinate frames.
	-
	- SUBROUTINE PYFRAM(IFRAME)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYDAT1/,/PYPARS/,/PYINT1/
	-
	-C...Check that transformation can and should be done.
	- IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
	- &MINT(91).EQ.1)) THEN
	- IF(IFRAME.EQ.MINT(6)) RETURN
	- ELSE
	- WRITE(MSTU(11),5000) IFRAME,MINT(6)
	- RETURN
	- ENDIF
	-
	- IF(MINT(6).EQ.1) THEN
	-C...Transform from fixed target or user specified frame to
	-C...overall CM frame.
	- CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
	- CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
	- CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
	- ELSEIF(MINT(6).EQ.3) THEN
	-C...Transform from hadronic CM frame in DIS to overall CM frame.
	- CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
	- & -VINT(225))
	- ENDIF
	-
	- IF(IFRAME.EQ.1) THEN
	-C...Transform from overall CM frame to fixed target or user specified
	-C...frame.
	- CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
	- ELSEIF(IFRAME.EQ.3) THEN
	-C...Transform from overall CM frame to hadronic CM frame in DIS.
	- CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
	- CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
	- CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
	- ENDIF
	-
	-C...Set information about new frame.
	- MINT(6)=IFRAME
	- MSTI(6)=IFRAME
	-
	- 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
	- &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
	- &1X,I5)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYWIDT
	-C...Calculates full and partial widths of resonances.
	-
	- SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
	- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
	- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	- COMMON/PYPUED/IUED(0:99),RUED(0:99)
	- SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
	- &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
	-C...Local arrays and saved variables.
	- COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
	- DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
	- &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
	-C...UED: equivalences between ordered particles (451->475)
	-C...and UED particle code (5 000 000 + id)
	- PARAMETER(KKFLMI=451,KKFLMA=475)
	- DIMENSION CHIDEL(3), IUEDPR(25)
	- DIMENSION IUEDEQ(KKFLMA),MUED(2)
	- COMMON/SW1/SW21,CW21
	- DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
	- & 6100001,6100002,6100003,6100004,6100005,6100006,
	- & 5100001,5100002,5100003,5100004,5100005,5100006,
	- & 6100011,6100013,6100015,
	- & 5100012,5100011,5100014,5100013,5100016,5100015,
	- & 5100021,5100022,5100023,5100024/
	-C...Save local variables
	- SAVE MOFSV,WIDWSV,WID2SV
	-C...Initial values
	- DATA MOFSV/60/,WIDWSV/60D0/,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.-X2/Y2
	- FKAC2(X,Y)=2.+X2/Y2
	-
	-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-PM12-PM22)*2-
	- & 4D0PM12PM2**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-4D0PMANPMBCN)
	- & ((PMBCN-PMBN-PMCN)*2-4D0PMBNPMCN)))
	- & ((SHR-PMA)2-(PMB+PMC)2)*
	- & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
	- & ((1D0-PMBCN)PMBCNSH)
	- ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
	- WDTP(I)=WDTP(I)*SQRT(
	- & MAX(0D0,(SH-PM12-PM22)*2-4D0PM1*2PM2**2)/
	- & MAX(1D-4,(PMR2-PM12-PM22)2-4D0PM12PM2**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-4D0PMANPMBCN)
	- & ((PMBCN-PMBN-PMCN)*2-4D0PMBNPMCN)))
	- & ((SHR-PMA)2-(PMB+PMC)2)*
	- & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
	- & ((1D0-PMBCN)PMBCNSH)
	- PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
	- PMAN=PMA2/PMR2
	- PMBN=PMB2/PMR2
	- PMCN=PMC2/PMR2
	- PMBCN=PMBC2/PMR2
	- FACNOM=SQRT(MAX(0D0,
	- & ((1D0-PMAN-PMBCN)*2-4D0PMANPMBCN)
	- & ((PMBCN-PMBN-PMCN)*2-4D0PMBNPMCN)))
	- & ((PMR-PMA)2-(PMB+PMC)2)*
	- & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
	- & ((1D0-PMBCN)PMBCNPMR**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.
	-C...PS: bug fix 16/2 2012 to avoid problems caused by adding 0.0*NaN
	- IF (WDTP(I).GT.0D0) 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)
	- ELSE
	- WDTE(I,MDME(IDC,1))= 0D0
	- WDTE(I,0)= 0D0
	- ENDIF
	- 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)*2XW/PARU(1)
	- AS=PYALPS(SH)
	- RADC=1D0+AS/PARU(1)
	-
	- IF(KFLA.EQ.6) THEN
	-C...t quark.
	- FAC=(AEM/(16D0XW))(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)=FACVCKM(3,I-3)RADCT*
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	- & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0+RM2-RM1)(RM2RPARU(141)2+1D0/PARU(141)2)+
	- & 4D0SQRT(RM2RRM2))
	- 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=SHRDCONJG(ZMIXC(IZ,4))/(2.0D0PMAS(24,1)*SINB)
	- AR=-ETZMIXC(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))/(2D0SHR)
	- WDTP(I)=(0.5D0PYALEM(SH)/PARU(102))PCM*
	- & ((ABS(FL)2+ABS(FR)2)(SH+PMNCHI2-PMSTOP*2)+
	- & SMZ(IZ)4D0SHRDBLE(FLDCONJG(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))/(2D0SHR)
	- WDTP(I)=4D0/3D00.5D0PYALPS(SH)PCM((RL2+RR2)*
	- & (SH+PMNCHI2-PMSTOP2)+PMNCHI4D0SHRRLRR)/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*2SHR/(96D0PARU(1)XMP2XMGR2)(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/(16D0XW))(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)=FACVCKM(I-3,4)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	- & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0+RM2-RM1)(PARU(141)2+RM2/PARU(141)2)+4D0RM2)
	- 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/(16D0XW))(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)=FACVCKM(4,I-3)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	- & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0+RM2-RM1)(RM2PARU(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/(16D0XW))(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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0+RM2-RM1)(PARU(141)2+RM2/PARU(141)2)+4D0RM2)
	- 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/(16D0XW))(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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0+RM2-RM1)(RM2PARU(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+2D0RM1)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=FCOFPYHFTH(SH,SHRM1,1D0)
	- WDTP(I)=FCOFEF2(1D0+2D0RM1)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+2D0RM1)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/(16D0XWXW1)
	- FAC=(AEMXWC/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-4D0EIXWV
	- 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)=
	- & 2D0XWCSH(SH-SQMZ)/((SH-SQMZ)2+HZ*2)
	- IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
	- & XWC*2SH2/((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-4D0EFXWV
	- FCOF=3D0*RADC
	- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOFPYHFTH(SH,SHRM1,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-4D0EFXWV
	- 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)=FACFCOF(VF*2(1D0+2D0RM1)+AF2(1D0-4D0RM1))
	- & BE34
	- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	- WDTP(I)=FACFCOF((EI*2VINT(111)EF2+EIVIVINT(112)
	- & EFVF+(VI2+AI2)VINT(114)VF2)(1D0+2D0*RM1)+
	- & (VI2+AI2)VINT(114)AF*2(1D0-4D0RM1))BE34
	- ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
	- FGGF=FCOFEF2(1D0+2D0RM1)BE34
	- FGZF=FCOFEFVF(1D0+2D0RM1)*BE34
	- FZZF=FCOF(VF2(1D0+2D0RM1)+AF2(1D0-4D0RM1))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/(24D0XW))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=3D0RADCVCKM((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)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(8D0XW))(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)=FAC3D0(PYMRUN(KFDP(IDC,1),SH)*2/SHFS)
	- & SQRT(MAX(0D0,1D0-4D0RM1))RADC
	-C...A0 behaves like beta, ho and H0 like beta**3.
	- IF(IHIGG.NE.3) WDTP(I)=WDTP(I)(1D0-4D0RM1)
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
	- IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)PARU(151+10IHIGG)**2
	- IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)PARU(152+10IHIGG)**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+10IHIGG))*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)=FACRM1SQRT(MAX(0D0,1D0-4D0RM1))(SH/SHFS)
	-C...A0 behaves like beta, ho and H0 like beta**3.
	- IF(IHIGG.NE.3) WDTP(I)=WDTP(I)(1D0-4D0RM1)
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
	- & PARU(153+10IHIGG)*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=(2D0PMAS(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(RLN2-PARU(1)*2)
	- PHIIM=0.5D0PARU(1)RLN
	- ELSE
	- PHIRE=(ASIN(1D0/SQRT(EPS)))**2
	- PHIIM=0D0
	- ENDIF
	- IF(IHIGG.LE.2) THEN
	- ETAREJ=-0.5D0EPS(1D0+(1D0-EPS)*PHIRE)
	- ETAIMJ=-0.5D0EPS(1D0-EPS)*PHIIM
	- ELSE
	- ETAREJ=-0.5D0EPSPHIRE
	- ETAIMJ=-0.5D0EPSPHIIM
	- 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=ETAREJPARU(151+10IHIGG)
	- ETAIMJ=ETAIMJPARU(151+10IHIGG)
	- ELSE
	- ETAREJ=ETAREJPARU(152+10IHIGG)
	- ETAIMJ=ETAIMJPARU(152+10IHIGG)
	- ENDIF
	- ENDIF
	- ETARE=ETARE+ETAREJ
	- ETAIM=ETAIM+ETAIMJ
	- 240 CONTINUE
	- ETA2=ETARE2+ETAIM2
	- WDTP(I)=FAC(AS/PARU(1))2ETA2
	-
	- 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=(2D0PMAS(J,1))*2/SH
	- ELSEIF(J.LE.3*MSTP(1)) THEN
	- JL=2(J-2MSTP(1))-1
	- EJ=KCHG(10+JL,1)/3D0
	- EPS=(2D0PMAS(10+JL,1))*2/SH
	- ELSEIF(J.EQ.3*MSTP(1)+1) THEN
	- EPS=(2D0PMAS(24,1))*2/SH
	- ELSE
	- EPS=(2D0PMAS(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(RLN2-PARU(1)*2)
	- PHIIM=0.5D0PARU(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.5D0EPS(1D0+(1D0-EPS)*PHIRE)
	- PHIPIM=-0.5D0EPS(1D0-EPS)*PHIIM
	- ELSE
	- PHIPRE=-0.5D0EPSPHIRE
	- PHIPIM=-0.5D0EPSPHIIM
	- ENDIF
	- IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
	- EJC=3D0EJ*2
	- EJH=PARU(151+10*IHIGG)
	- ELSEIF(J.LE.2*MSTP(1)) THEN
	- EJC=3D0EJ*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=EJCEJHPHIPRE
	- ETAIMJ=EJCEJHPHIPIM
	- ELSEIF(J.EQ.3*MSTP(1)+1) THEN
	-C...W loops: loop integral and charges.
	- ETAREJ=0.5D0+0.75D0EPS(1D0+(2D0-EPS)*PHIRE)
	- ETAIMJ=0.75D0EPS(2D0-EPS)*PHIIM
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
	- ETAREJ=ETAREJPARU(155+10IHIGG)
	- ETAIMJ=ETAIMJPARU(155+10IHIGG)
	- ENDIF
	- ELSE
	-C...Charged H loops: loop integral and charges.
	- FACHHH=(PMAS(24,1)/PMAS(37,1))*2
	- & PARU(158+10IHIGG+2(IHIGG/3))
	- ETAREJ=EPS(1D0-EPSPHIRE)*FACHHH
	- ETAIMJ=-EPS*2PHIIM*FACHHH
	- ENDIF
	- ETARE=ETARE+ETAREJ
	- ETAIM=ETAIM+ETAIMJ
	- 250 CONTINUE
	- ETA2=ETARE2+ETAIM2
	- WDTP(I)=FAC(AEM/PARU(1))20.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-4D0EJXWV
	- EPS=(2D0PMAS(J,1))*2/SH
	- EPSP=(2D0PMAS(J,1)/PMAS(23,1))*2
	- ELSEIF(J.LE.3*MSTP(1)) THEN
	- JL=2(J-2MSTP(1))-1
	- EJ=KCHG(10+JL,1)/3D0
	- AJ=SIGN(1D0,EJ+0.1D0)
	- VJ=AJ-4D0EJXWV
	- EPS=(2D0PMAS(10+JL,1))*2/SH
	- EPSP=(2D0PMAS(10+JL,1)/PMAS(23,1))*2
	- ELSE
	- EPS=(2D0PMAS(24,1))*2/SH
	- EPSP=(2D0PMAS(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(RLN2-PARU(1)*2)
	- PHIIM=0.5D0PARU(1)RLN
	- PSIRE=0.5D0ROOTRLN
	- PSIIM=-0.5D0ROOTPARU(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(RLN2-PARU(1)*2)
	- PHIIMP=0.5D0PARU(1)RLN
	- PSIREP=0.5D0ROOTRLN
	- PSIIMP=-0.5D0ROOTPARU(1)
	- ELSE
	- PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
	- PHIIMP=0D0
	- PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
	- PSIIMP=0D0
	- ENDIF
	- FXYRE=EPSEPSP/(8D0(EPS-EPSP))(1D0+EPSEPSP/(EPS-EPSP)*
	- & (PHIRE-PHIREP)+2D0EPS/(EPS-EPSP)(PSIRE-PSIREP))
	- FXYIM=EPS*2EPSP/(8D0(EPS-EPSP)2)
	- & (EPSP(PHIIM-PHIIMP)+2D0(PSIIM-PSIIMP))
	- F1RE=-EPSEPSP/(2D0(EPS-EPSP))*(PHIRE-PHIREP)
	- F1IM=-EPSEPSP/(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=-3D0EJVJ
	- EJH=PARU(151+10*IHIGG)
	- ELSEIF(J.LE.2*MSTP(1)) THEN
	- EJC=-3D0EJVJ
	- 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=EJCEJH(FXYRE-0.25D0*F1RE)
	- ETAIMJ=EJCEJH(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=ETAREJPARU(155+10IHIGG)
	- ETAIMJ=ETAIMJPARU(155+10IHIGG)
	- ENDIF
	- ELSE
	-C...Charged H loops: loop integral and charges.
	- FACHHH=(PMAS(24,1)/PMAS(37,1))*2(1D0-2D0XW)
	- & PARU(158+10IHIGG+2(IHIGG/3))
	- ETAREJ=FACHHH*FXYRE
	- ETAIMJ=FACHHH*FXYIM
	- ENDIF
	- ETARE=ETARE+ETAREJ
	- ETAIM=ETAIM+ETAIMJ
	- 260 CONTINUE
	- ETA2=(ETARE2+ETAIM2)/(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+10D0PG1)**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-4D0RM1+12D0RM1*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-4D0RM1+12D0RM1*2)SQRT(MAX(0D0,
	- & 1D0-4D0*RM1))
	- WID2=1D0
	- ELSE
	- WIDW=WIDWSV(IHIGG,I-15)
	- WID2=WID2SV(IHIGG,I-15)
	- ENDIF
	- ENDIF
	- WDTP(I)=FACWIDW/(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+10IHIGG)*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)=FAC0.5D0SQRT(MAX(0D0,
	- & (1D0-RM1-RM2)*2-4D0RM1RM2))*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)=FAC0.25D0
	- & PMAS(23,1)4/SH2SQRT(MAX(0D0,1D0-4D0RM1))
	- 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)=FAC0.5D0SQRT(MAX(0D0,
	- & (1D0-RM1-RM2)*2-4D0RM1RM2))*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)=FAC0.5D0PARU(187)*2SQRT(MAX(0D0,
	- & (1D0-RM1-RM2)*2-4D0RM1RM2))*3
	- WID2=WIDS(36,2)*WIDS(23,2)
	-
	- ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
	-C...H0 -> h0 + A0.
	- WDTP(I)=FAC0.5D0PARU(180)*2
	- & PMAS(23,1)4/SH2SQRT(MAX(0D0,1D0-4D0RM1))
	- WID2=WIDS(25,2)*WIDS(36,2)
	-
	- ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
	-C...H0 -> A0 + A0
	- WDTP(I)=FAC0.25D0PARU(177)*2
	- & PMAS(23,1)4/SH2SQRT(MAX(0D0,1D0-4D0RM1))
	- WID2=WIDS(36,1)
	-
	-CMRENNA++
	- ELSE
	-C...Add in SUSY decays (two-body) by rescaling by phase space factor.
	- RM10=RM1SH/PMR*2
	- RM20=RM2SH/PMR*2
	- WFAC0=1D0+RM102+RM202-2D0(RM10+RM20+RM10RM20)
	- WFAC=1D0+RM12+RM22-2D0(RM1+RM2+RM1RM2)
	- 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/(16D0XWXW1)
	- FAC=(AEMXWC/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-4D0EIXWV
	- 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)=
	- & 2D0XWCSH(SH-SQMZ)/((SH-SQMZ)2+HZ*2)
	- IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
	- & 2D0XWCSH(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*2SH2/((SH-SQMZ)2+HZ**2)
	- IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
	- & 2D0XWC2SH*2((SH-SQMZ)(SH-SQMZP)+HZHZP)/
	- & (((SH-SQMZ)2+HZ2)((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*2SH2/((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-4D0EFXWV
	- 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-4D0EFXWV
	- 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(VF2(1D0+2D0RM1)+AF2(1D0-4D0RM1))BE34
	- WDTP(I)=FACFCOF(VPF*2(1D0+2D0*RM1)+
	- & APF*2(1D0-4D0RM1))BE34
	- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	- WDTP(I)=FACFCOF((EI*2VINT(111)EF2+EIVIVINT(112)
	- & EFVF+EIVPIVINT(113)EFVPF+(VI2+AI2)VINT(114)*
	- & VF*2+(VIVPI+AIAPI)VINT(115)VFVPF+(VPI2+API2)*
	- & VINT(116)VPF2)(1D0+2D0RM1)+((VI2+AI2)VINT(114)*
	- & AF*2+(VIVPI+AIAPI)VINT(115)AFAPF+(VPI2+API2)*
	- & VINT(116)APF2)(1D0-4D0RM1))BE34
	- ELSEIF(MINT(61).EQ.2) THEN
	- FGGF=FCOFEF2(1D0+2D0RM1)BE34
	- FGZF=FCOFEFVF(1D0+2D0RM1)*BE34
	- FGZPF=FCOFEFVPF(1D0+2D0RM1)*BE34
	- FZZF=FCOF(VF2(1D0+2D0RM1)+AF2(1D0-4D0RM1))BE34
	- FZZPF=FCOF(VFVPF(1D0+2D0RM1)+AFAPF(1D0-4D0RM1))
	- & BE34
	- FZPZPF=FCOF(VPF2(1D0+2D0RM1)+APF2(1D0-4D0RM1))
	- & BE34
	- ENDIF
	- ELSEIF(I.EQ.17) THEN
	-C...Z'0 -> W+ + W-
	- WDTPZP=PARU(129)*2XW1*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))3
	- & (1D0+10D0RM1+10D0RM2+RM12+RM22+10D0RM1RM2)
	- IF(ICASE.EQ.1) THEN
	- WDTPZ=0D0
	- WDTP(I)=FAC*WDTPZP
	- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	- WDTP(I)=FAC(VPI2+API2)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-2D0XW)
	- BE34C=(1D0-4D0RM1)SQRT(MAX(0D0,1D0-4D0*RM1))
	- IF(ICASE.EQ.1) THEN
	- WDTPZ=0.25D0PARU(142)2CZC*2BE34C
	- WDTP(I)=FAC0.25D0PARU(143)*2CZC*2BE34C
	- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	- WDTP(I)=FAC0.25D0(EI*2VINT(111)+PARU(142)EIVI*
	- & VINT(112)CZC+PARU(143)EIVPIVINT(113)CZC+PARU(142)2
	- & (VI2+AI2)VINT(114)CZC*2+PARU(142)PARU(143)*
	- & (VIVPI+AIAPI)VINT(115)CZC2+PARU(143)2*
	- & (VPI2+API2)VINT(116)CZC*2)BE34C
	- ELSEIF(MINT(61).EQ.2) THEN
	- FGGF=0.25D0*BE34C
	- FGZF=0.25D0PARU(142)CZC*BE34C
	- FGZPF=0.25D0PARU(143)CZC*BE34C
	- FZZF=0.25D0PARU(142)2CZC*2BE34C
	- FZZPF=0.25D0PARU(142)PARU(143)CZC2BE34C
	- FZPZPF=0.25D0PARU(143)2CZC*2BE34C
	- 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-4D0RM1*RM2))
	- WDTPZP=PARU(145)*24D0ABS(1D0-2D0XW)*
	- & (3D0RM1+0.25D0FLAM*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(VPI2+API2)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-4D0RM1RM2))*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*2BE34C
	- WDTP(I)=FACCZPAH2BE34C
	- ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	- WDTP(I)=FAC(CZAH2(VI2+AI2)VINT(114)+CZAHCZPAH*
	- & (VIVPI+AIAPI)VINT(115)+CZPAH2(VPI2+API2)*
	- & VINT(116))*BE34C
	- ELSEIF(MINT(61).EQ.2) THEN
	- FGGF=0D0
	- FGZF=0D0
	- FGZPF=0D0
	- FZZF=CZAH*2BE34C
	- FZZPF=CZAHCZPAHBE34C
	- FZPZPF=CZPAH*2BE34C
	- 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/(24D0XW))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=3D0CKMFACRADC(PARU(131)2+PARU(132)*2)
	- FCOF2=3D0CKMFACRADC(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)=FAC0.5FCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	- IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
	-C...PS 28/06/2010
	-C...Inserted (gV2-gA2)sqrt(m1m2) term (FCOF2), following M. Chizhov
	- WDTP(I)=WDTP(I) + FAC0.56D0FCOF2SQRT(RM1*RM2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	- ENDIF
	- ELSEIF(I.EQ.21) THEN
	-C...W'+/- -> W+/- + Z0
	- WDTP(I)=FACPARU(135)20.5D0XW1(RM1/RM2)*
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))3
	- & (1D0+10D0RM1+10D0RM2+RM12+RM22+10D0RM1RM2)
	- 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-4D0RM1*RM2))
	- WDTP(I)=FACPARU(146)22D0(3D0RM1+0.25D0FLAM2)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/(8D0XW))(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)=FAC3D0RADCMAX(0D0,(RM1RPARU(141)**2+
	- & RM2R/PARU(141)*2)(1D0-RM1R-RM2R)-4D0RM1RRM2R)*
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))(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((RM1PARU(141)2+RM2/PARU(141)2)*
	- & (1D0-RM1-RM2)-4D0RM1RM2)*SQRT(MAX(0D0,
	- & (1D0-RM1-RM2)*2-4D0RM1RM2))(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)=FACPARU(195)20.5D0*SQRT(MAX(0D0,
	- & (1D0-RM1-RM2)*2-4D0RM1RM2))*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=RM1SH/PMR*2
	- RM20=RM2SH/PMR*2
	- WFAC0=1D0+RM102+RM202-2D0(RM10+RM20+RM10RM20)
	- WFAC=1D0+RM12+RM22-2D0(RM1+RM2+RM1RM2)
	- 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/(12D0XW))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)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))*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.25ALPHEMRMFLAS0.5CW21/CW2KCHG(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)=FACFKAC2(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.25ALPHEMRMFLAS/(4.*SW2)
	- GAMMAW=FACFKAC2(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)=FACFKAC2(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)=FACFKAC1(RMQST,RMFLAS)2FKAC2(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./SW2RMZKK
	- RMLST=PMAS(KKPART,1)
	- WDTP(I)=FACFKAC1(RMLST,RMZKK)2FKAC2(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./SW2RMWKK
	- RMLST=PMAS(KKPART,1)
	- WDTP(I)=FACFKAC1(RMLST,RMWKK)2FKAC2(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/(32D0PARU(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/(4D0PARU(1))ITCM(1)/RTCM(1))**2
	- & /(8D0PARU(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=FCOFRTCM(1+IKA)*2
	- HM1=PYMRUN(KFDP(IDC,1),SH)
	- HM2=PYMRUN(KFDP(IDC,2),SH)
	- ELSEIF(IKA.EQ.15) THEN
	- FCOF=FCOFRTCM(8)*2
	- ENDIF
	- WDTP(I)=FACFCOF(HM1+HM2)*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(32D0PARU(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/(4D0PARU(1))FCOFXMT2RTCM(7)**2
	- KFC3=PYCOMP(KFDP(IDC,3))
	- CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
	- CHECK = SQRT(RM1)
	- T0 = (1D0-CHECK*2)
	- & (XMT2(6D0XMT2*2+3D0XMT2RM1-4D0RM1**2)-
	- & (5D0XMT22+2D0XMT2RM1-8D0RM1*2))/(4D0XMT2**2)
	- T1 = (1D0-XMT2)(RM1-XMT2)((XMT2*2+XMT2RM1+4D0RM1*2)
	- & -3D0XMT22(XMT2+RM1))/(2D0XMT2*3)
	- T3 = RM12/XMT23(3D0XMT2-4D0RM1+4D0XMT2*RM1)
	- WDTP(I)=FACP(T0 + T1LOG((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=FCOFRTCM(5)*2
	- ELSEIF(I.LE.4) THEN
	- FCOF=FCOFRTCM(6)*2
	- ELSEIF(I.EQ.5) THEN
	- FCOF=FCOFRTCM(7)*2
	- ENDIF
	- HM1=PYMRUN(KFDP(IDC,1),SH)
	- HM2=PYMRUN(KFDP(IDC,2),SH)
	- ELSEIF(I.EQ.8) THEN
	- FCOF=FCOFRTCM(8)*2
	- ENDIF
	- WDTP(I)=FACFCOF(HM1+HM2)*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)=FACRM1SQRT(MAX(0D0,1D0-4D0RM1))/(4D0PARU(1))
	- IF(I.EQ.2) WID2=WIDS(6,1)
	- ELSE
	- WDTP(I)=FAC5D0AS*2/(96D0PARU(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)(AEM2/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-2D0XW)/(4D0XW*(1D0-XW))
	- BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	- BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	- 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)=FACRTCM(3)4
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	- & 2D0AEMSQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	- & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0SQMW/SH)*
	- & RTCM(3)2/4D0/XW/24D0/RTCM(13)2SHR*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)=FACRTCM(3)2(1D0-RTCM(3)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	- & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0RM1)*
	- & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(13)2SHR*3
	- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
	- ELSEIF(I.EQ.3) THEN
	-C...rho_tc0 -> pi_tc+ + W-.
	- WDTP(I)=FACRTCM(3)2(1D0-RTCM(3)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	- & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0RM2)*
	- & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(13)2SHR*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-4D0RM1RM2))*3
	- WID2=WIDS(PYCOMP(KTECHN+211),1)
	- ELSEIF(I.EQ.5) THEN
	-C...rho_tc0 -> gamma + pi_tc0
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (1D0-RTCM(4)2)/24D0/RTCM(12)2SHR*3
	- WID2=WIDS(PYCOMP(KTECHN+221),2)
	- ELSEIF(I.EQ.7) THEN
	-C...rho_tc0 -> Z0 + pi_tc0
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(2)-1D0)2(1D0-RTCM(3)2)/24D0/RTCM(12)2*
	- & XW/XW1SHR*3
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
	- ELSEIF(I.EQ.8) THEN
	-C...rho_tc0 -> Z0 + pi_tc0'
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (1D0-RTCM(4)2)/24D0/RTCM(12)2(1D0-2D0XW)**2/4D0/
	- & XW/XW1SHR*3
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
	- ELSEIF(I.EQ.9) THEN
	-C...rho_tc0 -> gamma + Z0
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(2)-1D0)2RTCM(3)2/24D0/RTCM(12)2SHR*3
	- WID2=WIDS(23,2)
	- ELSEIF(I.EQ.10) THEN
	-C...rho_tc0 -> Z0 + Z0
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(2)-1D0)2RTCM(3)*2XW/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-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- WDTP(I)=FACFFCOFSQRT(MAX(0D0,1D0-4D0RM1))((1D0-RM1)*
	- & ((EI+VALIBWZR)2+(VALIBWZI)**2+
	- & (EI+VARIBWZR)2+(VARIBWZI)*2)+6D0RM1*(
	- & (EI+VALIBWZR)(EI+VARIBWZR)+VALIVARIBWZI*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)(AEM2/ALPRHT)SHR*
	- & (0.125D0/XW*2)SH2/((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=.5D0SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	-c WDTP(I)=AEMPCM(AA2(PCM2+1.5D0RM1)+PCM*2VA2)
	-c & /3D0SHR*3
	- IF(I.EQ.1) THEN
	-C...rho_tc+ -> W+ + Z0.
	-C......Goldstone
	- WDTP(I)=FACRTCM(3)4
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3
	- VA2=RTCM(3)*2(2D0RTCM(2)-1D0)2XW/XW1/RTCM(12)**2
	- AA2=RTCM(3)2/RTCM(13)2/4D0/XW/XW1
	-C......W_L Z_T
	- WDTP(I)=WDTP(I)+AEMPCM(AA2(PCM2+1.5D0RM2)+PCM*2VA2)
	- & /3D0SHR*3
	- VA2=0D0
	- AA2=RTCM(3)2/RTCM(13)2/4D0/XW
	-C......W_T Z_L
	- WDTP(I)=WDTP(I)+AEMPCM(AA2(PCM2+1.5D0RM1)+PCM*2VA2)
	- & /3D0SHR*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)=FACRTCM(3)2(1D0-RTCM(3)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	- & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0SQMW/SH)*
	- & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(13)2SHR*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)=FACRTCM(3)2(1D0-RTCM(3)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	- & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	- & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0SQMZ/SH)*
	- & (1D0-RTCM(3)2)/4D0/XW/XW1/24D0/RTCM(13)2SHR*3+
	- & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(2)-1D0)2(1D0-RTCM(3)2)/24D0/RTCM(12)2*
	- & SHR*3XW/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-4D0RM1RM2))*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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (1D0-RTCM(4)2)/4D0/XW/24D0/RTCM(12)2SHR*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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(2)-1D0)2RTCM(3)2/24D0/RTCM(12)2SHR*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=3D0RADCVCKM((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)=FACFFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)(AEM2/ALPRHT)SHR(2D0RTCM(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+GMMZ2)
	- BWZI=-(0.5D0/(1D0-XW))SHGMMZ/((SH-SQMZ)2+GMMZ2)
	- 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-4D0RM1RM2))3SHR**3
	- WID2=WIDS(PYCOMP(KTECHN+111),2)
	- ELSEIF(I.EQ.2) THEN
	-C...omega_tc0 -> Z0 + pi_tc0
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (1D0-RTCM(3)2)/24D0/RTCM(12)2(1D0-2D0XW)**2/4D0/
	- & XW/XW1SHR*3
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
	- ELSEIF(I.EQ.3) THEN
	-C...omega_tc0 -> gamma + pi_tc0'
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (2D0RTCM(2)-1D0)2(1D0-RTCM(4)2)/24D0/RTCM(12)2*
	- & XW/XW1SHR*3
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
	- ELSEIF(I.EQ.5) THEN
	-C...omega_tc0 -> W+ + pi_tc-
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(12)2SHR*3+
	- & FACRTCM(3)2(1D0-RTCM(3)*2)RTCM(11)*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3
	- WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
	- ELSEIF(I.EQ.6) THEN
	-C...omega_tc0 -> pi_tc+ + W-
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(12)2SHR*3+
	- & FACRTCM(3)2(1D0-RTCM(3)*2)RTCM(11)*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*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)=FACRTCM(3)4RTCM(11)*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	- & 2D0AEMSQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))3
	- & RTCM(3)2/4D0/XW/24D0/RTCM(12)2SHR*3
	- WID2=WIDS(24,1)
	- ELSEIF(I.EQ.8) THEN
	-C...omega_tc0 -> pi_tc+ + pi_tc-.
	- WDTP(I)=FAC(1D0-RTCM(3)2)2RTCM(11)*2
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3
	- WID2=WIDS(PYCOMP(KTECHN+211),1)
	-C...omega_tc0 -> gamma + Z0
	- ELSEIF(I.EQ.9) THEN
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & RTCM(3)2/24D0/RTCM(12)2SHR*3
	- WID2=WIDS(23,2)
	-C...omega_tc0 -> Z0 + Z0
	- ELSEIF(I.EQ.10) THEN
	- WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	- & RTCM(3)*2(XW1-XW)**2/XW/XW1/4D0
	- & /24D0/RTCM(12)*2SHR**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-4D0EIXWV
	- VALI=-0.5D0*(VI+AI)
	- VARI=-0.5D0*(VI-AI)
	- WDTP(I)=FACFFCOFSQRT(MAX(0D0,1D0-4D0RM1))((1D0-RM1)*
	- & ((EI+VALIBWZR)2+(VALIBWZI)**2+
	- & (EI+VARIBWZR)2+(VARIBWZI)*2)+6D0RM1*(
	- & (EI+VALIBWZR)(EI+VARIBWZR)+VALIVARIBWZI*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+2D0RM1)SQRT(1D0-4D0RM1)*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/(4D0PARU(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/(8D0PARU(1))ITCM(1)/RTCM(1))**2
	- & /(2D0PARU(1))SHSHRCLEBG
	- 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)=FACFCOFHM1*2CLEBF*
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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=2D0TANT3/(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-RMV82)/((SH-RMV82)2+GMV8*2)
	- FV8IM=SHGMV8/((SH-RMV82)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+FMIXXIJFV8RE)*2+(FMIXXIJFV8IM)*2
	- WDTP(I)=FAC(1D0+2D0RM1)SQRT(1D0-4D0RM1)AS/ALPRHTXFAC
	- ELSEIF(I.EQ.7) THEN
	- WDTP(I)=SHRAS2/(4D0ALPRHT)
	- ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
	- PSH=SHR*(1D0-RM1)/2D0
	- WDTP(I)=AS/9D0PSH*3/RM82
	- IF(I.EQ.8) THEN
	- WDTP(I)=2D0WDTP(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)=FACASRTCM(45)**2/3D0
	- WID2=1D0
	- ELSEIF(I.EQ.2) THEN
	-C...d* -> gamma + d.
	- QF=-RTCM(43)/2D0+RTCM(44)/6D0
	- WDTP(I)=FACAEMQF**2/4D0
	- WID2=1D0
	- ELSEIF(I.EQ.3) THEN
	-C...d* -> Z0 + d.
	- QF=-RTCM(43)XW1/2D0-RTCM(44)XW/6D0
	- WDTP(I)=FACAEMQF*2/(8D0XWXW1)
	- & (1D0-RM1)*2(2D0+RM1)
	- WID2=WIDS(23,2)
	- ELSEIF(I.EQ.4) THEN
	-C...d* -> W- + u.
	- WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	- & (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)=FACASRTCM(45)**2/3D0
	- WID2=1D0
	- ELSEIF(I.EQ.2) THEN
	-C...u* -> gamma + u.
	- QF=RTCM(43)/2D0+RTCM(44)/6D0
	- WDTP(I)=FACAEMQF**2/4D0
	- WID2=1D0
	- ELSEIF(I.EQ.3) THEN
	-C...u* -> Z0 + u.
	- QF=RTCM(43)XW1/2D0-RTCM(44)XW/6D0
	- WDTP(I)=FACAEMQF*2/(8D0XWXW1)
	- & (1D0-RM1)*2(2D0+RM1)
	- WID2=WIDS(23,2)
	- ELSEIF(I.EQ.4) THEN
	-C...u* -> W+ + d.
	- WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	- & (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)=FACAEMQF**2/4D0
	- WID2=1D0
	- ELSEIF(I.EQ.2) THEN
	-C...e* -> Z0 + e.
	- QF=-RTCM(43)XW1/2D0+RTCM(44)XW/2D0
	- WDTP(I)=FACAEMQF*2/(8D0XWXW1)
	- & (1D0-RM1)*2(2D0+RM1)
	- WID2=WIDS(23,2)
	- ELSEIF(I.EQ.3) THEN
	-C...e* -> W- + nu.
	- WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	- & (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)=FACAEMQF*2/(8D0XWXW1)
	- & (1D0-RM1)*2(2D0+RM1)
	- WID2=WIDS(23,2)
	- ELSEIF(I.EQ.2) THEN
	-C...nu*_e -> W+ + e.
	- WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	- & (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)=FACFCOFSQRT(MAX(0D0,1D0-4D0RM1))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)=FACSQRT(MAX(0D0,1D0-4D0RM1))*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)=FACSQRT(MAX(0D0,1D0-4D0RM1))*(13D0/12D0+
	- & 14D0RM1/3D0+4D0RM1**2)/160D0
	- WID2=WIDS(23,1)
	- ELSEIF(I.EQ.20) THEN
	-C...G* -> W+ + W-.
	- WDTP(I)=FACSQRT(MAX(0D0,1D0-4D0RM1))*(13D0/12D0+
	- & 14D0RM1/3D0+4D0RM1**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/(768D0PARU(1)XW2))SHR5/PMWR4
	- 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=3D0RADCVCKM((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=3D0RADCVCKM((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-8D0X2+8D0X6-X8-24D0X4LOG(X)
	- Y=(SHR/PMWR)**2
	- FY=(12D0(1D0-Y)LOG(1D0-Y)+12D0Y-6D0Y*2-2D0Y3)/Y4
	- WDTP(I)=FACFCOFFX*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/(48D0XWXW1(1D0-2D0XW)))*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-2D0XW)
	- VF=SIGN(1D0,EF+0.1D0)-4D0EFXW
	- 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)=FACFCOF(VF*2(1D0+2D0RM1)+AF2(1D0-4D0RM1))
	- & SQRT(MAX(0D0,1D0-4D0RM1))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/(24D0XW))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=3D0RADCVCKM((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)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(8D0PARU(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.5D0PARP(190)4PARP(192)2/PMAS(24,1)2*
	- & (3D0*RM1+0.25D0/RM1-1D0)
	- WID2=WIDS(24,4+(1-KFLS)/2)
	- ENDIF
	- WDTP(I)=FACFCOF
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(8D0PARU(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)=FACFCOF
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)(AEM2/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/(4D0XW(1D0-XW))
	- BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	- BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	- 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=.5D0SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	- IF(I.LE.4) THEN
	- FACPV=PCM**2
	- FACPA=PCM*2+1.5D0RM1
	- VA2=0D0
	- AA2=0D0
	-C...a2_tc0 -> W+ + W-
	- IF(I.EQ.1) THEN
	- AA2=2D0RTCM(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)=AEMSHR3PCM/3D0(VA2FACPV+AA2*FACPA)
	- ELSEIF(I.GE.5.AND.I.LE.10) THEN
	- FACPV=PCM*2(1D0+RM1+RM2)+3D0RM1RM2
	- FACPA=PCM*2(1D0+RM1+RM2)
	- VA2=0D0
	- AA2=0D0
	- IF(I.EQ.5) THEN
	-C...a_T^0 -> gamma rho_T^0
	- VA2=(2D0RTCM(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=(2D0RTCM(2)-1D0)2XW/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-2D0XW)2/XW/XW1/RTCM(50)4
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
	- ENDIF
	- WDTP(I)=AEMSHR5PCM/12D0(VA2FACPV+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-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- WDTP(I)=FACFFCOFSQRT(MAX(0D0,1D0-4D0RM1))((1D0-RM1)*
	- & ((VALIBWZR)2+(VALIBWZI)**2+
	- & (VARIBWZR)2+(VARIBWZI)*2)+6D0RM1*(
	- & (VALIBWZR)(VARIBWZR)+VALIVARIBWZI*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)(AEM2/ALPRHT)SHR*
	- & (0.125D0/XW*2)SH2/((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=.5D0SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*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-2D0XW)*2/
	- & RTCM(49)**2
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
	- ENDIF
	- WDTP(I)=AEMPCM(AA2(PCM2+1.5D0RM1)+PCM*2VA2)
	- & /3D0SHR*3
	- ELSEIF(I.LE.10) THEN
	- FACPV=PCM*2(1D0+RM1+RM2)+3D0RM1RM2
	- FACPA=PCM*2(1D0+RM1+RM2)
	- VA2=0D0
	- AA2=0D0
	-C...a2_tc+ -> gamma + rho_tc+
	- IF(I.EQ.7) THEN
	- VA2=(2D0RTCM(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/(4D0XW)/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=(2D0RTCM(2)-1D0)2XW/XW1/RTCM(50)**4
	- AA2=1D0/(4D0XWXW1)/RTCM(51)**4
	- WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
	- ENDIF
	- WDTP(I)=AEMSHR5PCM/12D0(VA2FACPV+AA2*FACPA)
	- ELSE
	-C...a2_tc+ -> f + fbar'.
	- IA=I-10
	- WID2=1D0
	- IF(IA.LE.16) THEN
	- FCOF=3D0RADCVCKM((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)=FACFFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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
	-C IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
	- IF((KFMO.EQ.25.OR.KFMO.EQ.35).AND.MEQL.EQ.1.AND.
	- &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
	- IF(KFMO.EQ.36.AND.MEQL.EQ.1.AND.
	- &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=4
	- 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+2ILM).GT.CKIN(NOFF+2ILM-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((PML12-PMD(1)2)/(PMD(1)*PGD(1)))
	- ATU1=ATAN((PMU12-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-4D0RM1*RM2))
	- IF(MMED.EQ.1) FUNC1=FUNC1((1D0-RM1-RM2)2+8D0RM1*RM2)
	- IF(MMED.EQ.4) FUNC1=FUNC1*3RM1*RM2
	- IF(MMED.EQ.2) FUNC1=FUNC1*3(1D0+10D0RM1+10D0RM2+RM1**2+
	- & RM2*2+10D0RM1*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-4D0RMG(1)*RMG(2)))
	- IF(MMED.EQ.1) THEN
	- WTBE=FLAM((1D0-RMG(1)-RMG(2))2+8D0RMG(1)*RMG(2))
	- ELSEIF(MMED.EQ.4) THEN
	- WTBE=FLAM*3RMG(1)*RMG(2)
	- ELSEIF(MMED.EQ.2) THEN
	- WTBE=FLAM*3(1D0+10D0RMG(1)+10D0RMG(2)+RMG(1)**2+
	- & RMG(2)*2+10D0RMG(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(IDIVPML(1)+(10-IDIV)*PMU(1)))
	- PMG(2)=MIN(PMD(2),0.1D0(IDIVPML(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))*2MAX((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)(PMV2-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)*2PMV2/(PML(I)2+PYR(0)*
	- & (PMV2-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=PMV2-PML(I)2
	- FI2=2D0*LOG(PMV/PML(I))
	- FI3=1D0/PML(I)2-1D0/PMV2
	- IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
	- & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
	- VINT(80)=VINT(80)20D0/(8D0+(FI0/F0)(F1/FI1+6D0*F2/FI2+
	- & 5D0*F3/FI3))
	- ELSE
	- VINT(80)=VINT(80)10D0/(8D0+(FI0/F0)(F1/FI1+F2/FI2))
	- ENDIF
	- VINT(80)=VINT(80)*FI0
	- 280 CONTINUE
	- IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C***********************************************************************
	-
	-C...PYRECO
	-C...Handles the possibility of colour reconnection in W+W- events,
	-C...Based on the main scenarios of the Sjostrand and Khoze study:
	-C...I, II, II', intermediate and instantaneous; plus one model
	-C...along the lines of the Gustafson and Hakkinen: GH.
	-C...Note: also handles Z0 Z0 and W-W+ events, but notation below
	-C...is as if first resonance is W+ and second W-.
	-
	- SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter value; number of points in MC integration.
	- PARAMETER (NPT=100)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
	-C...Local arrays.
	- DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
	- &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
	- &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
	- &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
	- &TMC(20),IJOIN(100)
	-
	-C...Functions to give four-product and to do determinants.
	- FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	- DETER(I,J,L)=Q(I,1)Q(J,2)Q(L,3)-Q(I,1)Q(L,2)Q(J,3)+
	- &Q(J,1)Q(L,2)Q(I,3)-Q(J,1)Q(I,2)Q(L,3)+
	- &Q(L,1)Q(I,2)Q(J,3)-Q(L,1)Q(J,2)Q(I,3)
	-
	-C...Only allow fraction of recoupling for GH, intermediate and
	-C...instantaneous.
	- IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
	- IF(PYR(0).GT.PARP(120)) RETURN
	- ENDIF
	- ISUB=MINT(1)
	-
	-C...Common part for scenarios I, II, II', and GH.
	- IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
	- &MSTP(115).EQ.5) THEN
	-
	-C...Read out frequently-used parameters.
	- PI=PARU(1)
	- HBAR=PARU(3)
	- PMW=PMAS(24,1)
	- IF(ISUB.EQ.22) PMW=PMAS(23,1)
	- PGW=PMAS(24,2)
	- IF(ISUB.EQ.22) PGW=PMAS(23,2)
	- TFRAG=PARP(115)
	- RHAD=PARP(116)
	- FACT=PARP(117)
	- BLOWR=PARP(118)
	- BLOWT=PARP(119)
	-
	-C...Find range of decay products of the W's.
	-C...Background: the W's are stored in IW1 and IW2.
	-C...Their direct decay products in NSD1+1 through NSD1+4.
	-C...Products after shower (if any) in NSD1+5 through NAFT1
	-C...for first W and in NAFT1+1 through N for the second.
	- IF(NAFT1.GT.NSD1+4) THEN
	- NBEG(1)=NSD1+5
	- NEND(1)=NAFT1
	- ELSE
	- NBEG(1)=NSD1+1
	- NEND(1)=NSD1+2
	- ENDIF
	- IF(N.GT.NAFT1) THEN
	- NBEG(2)=NAFT1+1
	- NEND(2)=N
	- ELSE
	- NBEG(2)=NSD1+3
	- NEND(2)=NSD1+4
	- ENDIF
	-
	-C...Rearrange parton shower products along strings.
	- NOLD=N
	- CALL PYPREP(NSD1+1)
	- IF(MINT(51).NE.0) RETURN
	-
	-C...Find partons pointing back to W+ and W-; store them with quark
	-C...end of string first.
	- NNP=0
	- NNM=0
	- ISGP=0
	- ISGM=0
	- DO 120 I=NOLD+1,N
	- IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
	- IF(IABS(K(I,2)).GE.22) GOTO 120
	- IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
	- IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
	- NNP=NNP+1
	- IF(ISGP.EQ.1) THEN
	- INP(NNP)=I
	- ELSE
	- DO 100 I1=NNP,2,-1
	- INP(I1)=INP(I1-1)
	- 100 CONTINUE
	- INP(1)=I
	- ENDIF
	- IF(K(I,1).EQ.1) ISGP=0
	- ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
	- IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
	- NNM=NNM+1
	- IF(ISGM.EQ.1) THEN
	- INM(NNM)=I
	- ELSE
	- DO 110 I1=NNM,2,-1
	- INM(I1)=INM(I1-1)
	- 110 CONTINUE
	- INM(1)=I
	- ENDIF
	- IF(K(I,1).EQ.1) ISGM=0
	- ENDIF
	- 120 CONTINUE
	-
	-C...Boost to W+W- rest frame (not strictly needed).
	- DO 130 J=1,3
	- BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
	- 130 CONTINUE
	- CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
	- CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
	- CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
	-
	-C...Select decay vertices of W+ and W-.
	- TP=HBAR(-LOG(PYR(0)))P(IW1,4)/
	- & SQRT((P(IW1,5)2-PMW2)2+(P(IW1,5)2PGW/PMW)*2)
	- TM=HBAR(-LOG(PYR(0)))P(IW2,4)/
	- & SQRT((P(IW2,5)2-PMW2)2+(P(IW2,5)2PGW/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=2D0PIPYR(0)
	- X=BLOWRRHADR*COS(PHI)
	- Y=BLOWRRHADR*SIN(PHI)
	- R=SQRT(-LOG(PYR(0)))
	- PHI=2D0PIPYR(0)
	- Z=BLOWRRHADR*COS(PHI)
	- T=GTMAX+BLOWTSQRT(0.5D0)TFRAGRABS(SIN(PHI))
	-
	-C...Reject impossible points. Weight for sample distribution.
	- IF(T2-X2-Y2-Z2.LT.0D0) GOTO 250
	- WTSMP=EXP(-(X2+Y2+Z*2)/(BLOWRRHAD)*2)
	- & EXP(-2D0(T-GTMAX)2/(BLOWTTFRAG)**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)/(2D0RHAD2))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)/(2D0RHAD2))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*3BLOWT*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)-TPV1P(J)+TMV1M(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=S11S22-S12S21
	- ALP=(S12S23-S22S13)/DEN
	- BET=(S21S13-S11S23)/DEN
	-
	-C...Check if solution acceptable.
	- IANSW=1
	- IF(T.LT.GTMAX) IANSW=0
	- IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
	- IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
	-
	-C...Find point of crossing and check that not inconsistent.
	- DO 300 J=1,3
	- XPP(J)=XP(J)+(V1P(J)+ALP(V2P(J)-V1P(J)))(T-TP)
	- XMM(J)=XM(J)+(V1M(J)+BET(V2M(J)-V1M(J)))(T-TM)
	- 300 CONTINUE
	- D2PM=(XPP(1)-XMM(1))2+(XPP(2)-XMM(2))2+
	- & (XPP(3)-XMM(3))**2
	- D2P=XPP(1)2+XPP(2)2+XPP(3)**2
	- D2M=XMM(1)2+XMM(2)2+XMM(3)**2
	- IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
	-
	-C...Find string eigentimes at crossing.
	- IF(IANSW.EQ.1) THEN
	- TAUP=SQRT(MAX(0D0,(T-TP)2-(XPP(1)-XP(1))2-
	- & (XPP(2)-XP(2))2-(XPP(3)-XP(3))2))
	- TAUM=SQRT(MAX(0D0,(T-TM)2-(XMM(1)-XM(1))2-
	- & (XMM(2)-XM(2))2-(XMM(3)-XM(3))2))
	- ELSE
	- TAUP=0D0
	- TAUM=0D0
	- ENDIF
	-
	-C...Order crossings by time. End loop over crossings.
	- IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
	- NCROSS=NCROSS+1
	- DO 310 I1=NCROSS,1,-1
	- IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
	- IPC(I1)=IIP
	- IMC(I1)=IIM
	- TC(I1)=T
	- TPC(I1)=TAUP
	- TMC(I1)=TAUM
	- GOTO 320
	- ELSE
	- IPC(I1)=IPC(I1-1)
	- IMC(I1)=IMC(I1-1)
	- TC(I1)=TC(I1-1)
	- TPC(I1)=TPC(I1-1)
	- TMC(I1)=TMC(I1-1)
	- ENDIF
	- 310 CONTINUE
	- 320 CONTINUE
	- ENDIF
	- 330 CONTINUE
	- 340 CONTINUE
	-
	-C...Loop over crossings; find first (if any) acceptable one.
	- IACC=0
	- IF(NCROSS.GE.1) THEN
	- DO 350 IC=1,NCROSS
	- PNFRAG=EXP(-(TPC(IC)2+TMC(IC)2)/TFRAG**2)
	- IF(PNFRAG.GT.PYR(0)) THEN
	-C...Scenario II: only compare with fragmentation time.
	- IF(MSTP(115).EQ.2) THEN
	- IACC=IC
	- IIP=IPC(IACC)
	- IIM=IMC(IACC)
	- GOTO 360
	-C...Scenario II': also require that string length decreases.
	- ELSE
	- IIP=IPC(IC)
	- IIM=IMC(IC)
	- I1P=INP(IIP)
	- I2P=INP(IIP+1)
	- I1M=INM(IIM)
	- I2M=INM(IIM+1)
	- ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
	- ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
	- IF(ELNEW.LT.ELOLD) THEN
	- IACC=IC
	- IIP=IPC(IACC)
	- IIM=IMC(IACC)
	- GOTO 360
	- ENDIF
	- ENDIF
	- ENDIF
	- 350 CONTINUE
	- 360 CONTINUE
	- ENDIF
	-
	-C...Begin scenario GH specifics.
	- ELSEIF(MSTP(115).EQ.5) THEN
	-
	-C...Loop through all string pieces, one from W+ and one from W-.
	- IACC=0
	- ELMIN=1D0
	- DO 380 IIP=1,NNP-1
	- IF(K(INP(IIP),2).LT.0) GOTO 380
	- I1P=INP(IIP)
	- I2P=INP(IIP+1)
	- DO 370 IIM=1,NNM-1
	- IF(K(INM(IIM),2).LT.0) GOTO 370
	- I1M=INM(IIM)
	- I2M=INM(IIM+1)
	-
	-C...Look for largest decrease of (exponent of) Lambda measure.
	- ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
	- ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
	- ELDIF=ELNEW/MAX(1D-10,ELOLD)
	- IF(ELDIF.LT.ELMIN) THEN
	- IACC=IIP+IIM
	- ELMIN=ELDIF
	- IPC(1)=IIP
	- IMC(1)=IIM
	- ENDIF
	- 370 CONTINUE
	- 380 CONTINUE
	- IIP=IPC(1)
	- IIM=IMC(1)
	- ENDIF
	-
	-C...Common for scenarios I, II, II' and GH: reconnect strings.
	- IF(IACC.NE.0) THEN
	- MINT(32)=1
	- NJOIN=0
	- DO 390 IS=1,NNP+NNM
	- NJOIN=NJOIN+1
	- IF(IS.LE.IIP) THEN
	- I=INP(IS)
	- ELSEIF(IS.LE.IIP+NNM-IIM) THEN
	- I=INM(IS-IIP+IIM)
	- ELSEIF(IS.LE.IIP+NNM) THEN
	- I=INM(IS-IIP-NNM+IIM)
	- ELSE
	- I=INP(IS-NNM)
	- ENDIF
	- IJOIN(NJOIN)=I
	- IF(K(I,2).LT.0) THEN
	- CALL PYJOIN(NJOIN,IJOIN)
	- NJOIN=0
	- ENDIF
	- 390 CONTINUE
	-
	-C...Restore original event record if no reconnection.
	- ELSE
	- DO 400 I=NSD1+1,NOLD
	- IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
	- K(I,4)=MOD(K(I,4),MSTU(5)**2)
	- K(I,5)=MOD(K(I,5),MSTU(5)**2)
	- ENDIF
	- 400 CONTINUE
	- DO 410 I=NOLD+1,N
	- K(K(I,3),1)=3
	- 410 CONTINUE
	- N=NOLD
	- ENDIF
	-
	-C...Boost back system.
	- CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
	- CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
	- IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
	- & BEWW(1),BEWW(2),BEWW(3))
	-
	-C...Common part for intermediate and instantaneous scenarios.
	- ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
	- MINT(32)=1
	-
	-C...Remove old shower products and reset showering ones.
	- N=NSD1+4
	- DO 420 I=NSD1+1,NSD1+4
	- K(I,1)=3
	- K(I,4)=MOD(K(I,4),MSTU(5)**2)
	- K(I,5)=MOD(K(I,5),MSTU(5)**2)
	- 420 CONTINUE
	-
	-C...Identify quark-antiquark pairs.
	- IQ1=NSD1+1
	- IQ2=NSD1+2
	- IQ3=NSD1+3
	- IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
	- IQ4=2*NSD1+7-IQ3
	-
	-C...Reconnect strings.
	- IJOIN(1)=IQ1
	- IJOIN(2)=IQ4
	- CALL PYJOIN(2,IJOIN)
	- IJOIN(1)=IQ3
	- IJOIN(2)=IQ2
	- CALL PYJOIN(2,IJOIN)
	-
	-C...Do new parton showers in intermediate scenario.
	- IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
	- MSTJ50=MSTJ(50)
	- MSTJ(50)=0
	- CALL PYSHOW(IQ1,IQ2,P(IW1,5))
	- CALL PYSHOW(IQ3,IQ4,P(IW2,5))
	- MSTJ(50)=MSTJ50
	-
	-C...Do new parton showers in instantaneous scenario.
	- ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
	- PPM2=(P(IQ1,4)+P(IQ4,4))2-(P(IQ1,1)+P(IQ4,1))2-
	- & (P(IQ1,2)+P(IQ4,2))2-(P(IQ1,3)+P(IQ4,3))2
	- PPM=SQRT(MAX(0D0,PPM2))
	- CALL PYSHOW(IQ1,IQ4,PPM)
	- PPM2=(P(IQ3,4)+P(IQ2,4))2-(P(IQ3,1)+P(IQ2,1))2-
	- & (P(IQ3,2)+P(IQ2,2))2-(P(IQ3,3)+P(IQ2,3))2
	- PPM=SQRT(MAX(0D0,PPM2))
	- CALL PYSHOW(IQ3,IQ2,PPM)
	- ENDIF
	- ENDIF
	-
	- RETURN
	- END
	-
	-C***********************************************************************
	-
	-C...PYKLIM
	-C...Checks generated variables against pre-set kinematical limits;
	-C...also calculates limits on variables used in generation.
	-
	- SUBROUTINE PYKLIM(ILIM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
	- &/PYINT1/,/PYINT2/
	-
	-C...Common kinematical expressions.
	- MINT(51)=0
	- ISUB=MINT(1)
	- ISTSB=ISET(ISUB)
	- IF(ISUB.EQ.96) GOTO 100
	- SQM3=VINT(63)
	- SQM4=VINT(64)
	- IF(ILIM.NE.0) THEN
	- IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
	- CKIN09=MAX(CKIN(9),CKIN(13))
	- CKIN10=MIN(CKIN(10),CKIN(14))
	- CKIN11=MAX(CKIN(11),CKIN(15))
	- CKIN12=MIN(CKIN(12),CKIN(16))
	- ELSE
	- CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
	- CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
	- CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
	- CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
	- ENDIF
	- ENDIF
	- IF(ILIM.NE.1) THEN
	- TAU=VINT(21)
	- RM3=SQM3/(TAU*VINT(2))
	- RM4=SQM4/(TAU*VINT(2))
	- BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)*2-4D0RM3*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(TAUVINT(2).LT.CKIN(1)*2) MINT(51)=1
	- IF(CKIN(2).GE.0D0.AND.TAUVINT(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.5D0BE34SQRT(TAUVINT(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)+BE34SINH(YST)*
	- & CTH)*2-4D0RM3))
	- EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)COSH(YST)-BE34SINH(YST)*
	- & CTH)*2-4D0RM4))
	- IF(STH.GE.1D-10) THEN
	- EXPET3=((1D0+RM3-RM4)SINH(YST)+BE34COSH(YST)*CTH+EXSQ3)/
	- & (BE34*STH)
	- EXPET4=((1D0-RM3+RM4)SINH(YST)-BE34COSH(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)+BE34COSH(YST)*CTH)/EXSQ3
	- CTS4=((1D0-RM3+RM4)SINH(YST)-BE34COSH(YST)*CTH)/EXSQ4
	- CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
	- CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
	- SH=TAU*VINT(2)
	- RPTS=4D0VINT(71)*2/SH
	- BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)*2-4D0RM3*RM4-RPTS))
	- RM34=MAX(1D-20,2D0RM3RM4)
	- IF(2D0VINT(71)2/(VINT(21)VINT(2)).LT.0.0001D0)
	- & RM34=MAX(RM34,2D0VINT(71)2/(VINT(21)VINT(2)))
	- RTHM=(4D0RM3RM4+RPTS)/(1D0-RM3-RM4+BE34L)
	- THA=0.5D0SHMAX(RTHM,1D0-RM3-RM4-BE34*CTH)
	- UHA=0.5D0SHMAX(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(TAUPVINT(2).LT.CKIN(31)*2) MINT(51)=1
	- IF(CKIN(32).GE.0D0.AND.TAUPVINT(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+2D0TM3TM4YDCOSH+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+PTHMIN2/(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-4D0PTHMIN2/(BE342TAUE*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-4D0PTHMIN2/(BE342TAU*VINT(2))))
	- CTPMX2=-CTNMN2
	- CTNMX2=0D0
	- CTPMN2=0D0
	- IF(CKIN(4).GE.0D0) THEN
	- CTNMX2=-SQRT(MAX(0D0,1D0-4D0CKIN(4)*2/
	- & (BE34*2TAU*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=TAUMAXTAUMIN/(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=TAURETAUMIN/((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+GAMRETAN(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,2D0VINT(63)VINT(64)/(VINT(21)VINT(2))*2)
	- RSQM=1D0+RM34
	- IF(2D0VINT(71)2/(VINT(21)VINT(2)).LT.0.0001D0)
	- & RM34=MAX(RM34,2D0VINT(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-PM12-(PM2+PM3)2)*2-(2D0PM1(PM2+PM3))*2)/
	- & (4D0*SHP)
	- IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
	- PTSMN1=CKIN(51)**2
	- PTSMX2=((SHP-PM22-(PM1+PM3)2)*2-(2D0PM2(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,HMNHMX/(HMN+PYR(0)HDE)-PMRS1)
	- ENDIF
	- WTPTS1=HDE/(HWT1+HWT2HDE/(LOG(HMX/HMN)(PMRS1+PTS1))+
	- & HWT3HMNHMX/(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,HMNHMX/(HMN+PYR(0)HDE)-PMRS2)
	- ENDIF
	- WTPTS2=HDE/(HWT1+HWT2HDE/(LOG(HMX/HMN)(PMRS2+PTS2))+
	- & HWT3HMNHMX/(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+2D0SQRT(PTS1PTS2)*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-
	- & 4D0PMS3PM12)))/(2D0SHPRPMT3))
	- IF(Y3MAX.LT.1D-6) THEN
	- MINT(51)=1
	- RETURN
	- ENDIF
	- Y3=(2D0PYR(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=PE122-PZ122
	- SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)*2-4D0PMS1*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.5D0TFAC(PE12-PZ12)(PMM2+EPSSQL12)
	- VINT(218)=-0.5D0TFAC(PE12+PZ12)(PMM1+EPSSQL12)
	- 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/pisH_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/pid(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)^32E_i))
	-C...(2pi)^4 delta^4(P - sum p_i)
	-C...COMFAC contains the factor pi/s (or equivalent) and
	-C...the conversion factor from GeV^-2 to mb
	-
	- SUBROUTINE PYSIGH(NCHN,SIGS)
	-
	-C...Double precision and integer declarations
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	- COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
	- &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
	- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	- COMMON/PYPUED/IUED(0:99),RUED(0:99)
	- COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
	- &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
	- &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
	- &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
	- COMMON/PYTCCO/COEFX(194:380,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
	- &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
	- &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
	-C...Local arrays and complex variables
	- DIMENSION XPQ(-25:25)
	-
	-C...Map of processes onto which routine to call
	-C...in order to evaluate cross section:
	-C...0 = not implemented;
	-C...1 = standard QCD (including photons);
	-C...2 = heavy flavours;
	-C...3 = W/Z;
	-C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
	-C...5 = SUSY;
	-C...6 = Technicolor;
	-C...7 = exotics (Z'/W'/LQ/R/f/H++/Z_R/W_R/G).
	-C...8 = Universal Extra Dimensions
	- DIMENSION MAPPR(500)
	- DATA (MAPPR(I),I=1,180)/
	- & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
	- 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
	- 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
	- 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
	- 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
	- 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
	- 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
	- 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
	- 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
	- & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
	- 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
	- 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
	- 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	- 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
	- 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
	- 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
	- 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
	- DATA (MAPPR(I),I=181,500)/
	- 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
	- 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
	- & 100*5,
	- & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	- & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
	- 1 20*0,
	- 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
	- 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
	- 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
	- 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
	- 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
	- 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
	- & 4, 4, 18*0,
	- 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	- 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
	- 4 20*0,
	- 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	- 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
	- 8 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-4D0RM3*RM4))
	- RPTS=4D0VINT(71)*2/SH
	- BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)*2-4D0RM3*RM4-RPTS))
	- RM34=MAX(1D-20,2D0RM3RM4)
	- RSQM=1D0+RM34
	- IF(2D0VINT(71)2/MAX(1D0,VINT(21)VINT(2)).LT.0.0001D0)
	- &RM34=MAX(RM34,2D0VINT(71)2/MAX(1D0,VINT(21)VINT(2)))
	- RTHM=(4D0RM3RM4+RPTS)/(1D0-RM3-RM4+BE34L)
	- IF(ISTSB.EQ.0) THEN
	- TH=VINT(45)
	- UH=-0.5D0SHMAX(RTHM,1D0-RM3-RM4+BE34*CTH)
	- SQPTH=MAX(VINT(71)*2,0.25D0SHBE342VINT(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-4D0RM1*RM2))
	- TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
	- TH=-0.5D0SHMAX(RTHM,TUCOM-2D0RM1RM4-2D0RM2RM3-
	- & BE12BE34CTH)
	- UH=-0.5D0SHMAX(RTHM,TUCOM-2D0RM1RM3-2D0RM2RM4+
	- & BE12BE34CTH)
	- SQPTH=MAX(VINT(71)*2,0.25D0SHBE342(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=2D0SHTHUH/(SH2+TH2+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+XSF1Q2IN1/SH+XSF2Q2IN2/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+2SQRT(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=(4D0VINT(48)+2D0VINT(63)+2D0*VINT(64))/VINT(2)
	- IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
	- ENDIF
	- VINT(62)=0.25D0XT2GMXVINT(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.1PMAS(4,1)*2) THEN
	- XPQ(4)=0D0
	- XPQ(-4)=0D0
	- ENDIF
	- IF(Q2SF.LT.1.1PMAS(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/(16D0XWXW1)
	- AEM=PYALEM(Q2)
	- IF(MSTP(8).GE.1) AEM=SQRT(2D0)PARU(105)PMAS(24,1)*2XW/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+GAMR12)
	- 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+GAMR22)
	- 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+GAMR32)
	- 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=COMFACATAU1/(TAUH1)
	- 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=COMFAC0.5D0ACTH0
	- ELSE
	- COMFAC=COMFAC0.125D0(3D0ACTH0+CTNMAX3-CTNMIN*3+
	- & CTPMAX3-CTPMIN3)
	- 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=COMFACACTH00.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)3TAU/TAUP
	- ENDIF
	- COMFAC=COMFAC*FZW
	- ENDIF
	-
	-C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
	- IF(ISTSB.EQ.5) THEN
	- COMFAC=COMFACVINT(205)VINT(210)VINT(212)VINT(214)/
	- & (128D0PARU(1)4VINT(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)FACK0.5D0VINT(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=COMFACXT22(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=COMFACXT22/(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=4D0Q2Q2GA/(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=4D0Q2GA/(PMVIRT*2+Q2GA)
	- ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
	- PMVIRT=PMAS(PYCOMP(113),1)
	- REDUCE=4D0PMVIRT2Q2GA/(PMVIRT2+Q2GA)2
	- ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
	- PMVIRT=PMAS(PYCOMP(113),1)
	- REDUCE=4D0PMVIRT2Q2GA/(PMVIRT2+Q2GA)2
	- ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
	- PMVSMN=4D0PARP(15)*2
	- PMVSMX=4D0VINT(154)*2
	- REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
	- REDLON=(3D0PMVSMN+Q2GA)/(PMVSMN+Q2GA)*3-
	- & (3D0PMVSMX+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=4D0Q2GA/(PMVIRT*2+Q2GA)
	- ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
	- PMVIRT=PMAS(PYCOMP(113),1)
	- REDUCE=4D0Q2GA/(PMVIRT*2+Q2GA)
	- ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
	- PMVSMN=4D0PARP(15)*2
	- PMVSMX=4D0VINT(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-2D0BEAMAS*2/Q2GA))
	- VINT(314+ISDE)=1D0+PARP(165)REDUCEFRACLT
	- 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=COMFACAEM22D0*(SH2+UH2)/TH2
	- FACGZF=COMFACAEM2XWC4D0SH2/(TH*(TH-SQMZ))
	- FACZZF=COMFAC(AEMXWC)*22D0SH2/(TH-SQMZ)*2
	- FACWWF=COMFAC(0.5D0AEM/XW)*2SH2/(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-4D0EIXWV
	- EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
	- AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
	- VJ=AJ-4D0EJXWV
	- 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=FACGGFEI2EJ*2+FACGZFEIEJ
	- & (VIVJ(1D0+UH2/SH2)+AIAJEPSIJ*(1D0-UH2/SH2))+
	- & FACZZF((VI2+AI2)(VJ2+AJ2)*(1D0+UH2/SH2)+
	- & 4D0VIVJAIAJEPSIJ(1D0-UH2/SH2))
	- ELSEIF(MSTP(21).EQ.2) THEN
	- FACNCF=FACGGFEI2EJ**2
	- ELSE
	- FACNCF=FACZZF((VI2+AI2)(VJ2+AJ2)*
	- & (1D0+UH2/SH2)+4D0VIVJAIAJEPSIJ(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=FACWWFVINT(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=COMFACAS24D0/9D0*(SH2+UH2)/TH2
	- FACQQB=COMFACAS24D0/9D0((SH2+UH2)/TH2FACA-
	- & MSTP(34)2D0/3D0UH2/(SH*TH))
	- FACQQ2=COMFACAS24D0/9D0*((SH2+TH2)/UH2-
	- & MSTP(34)2D0/3D0SH2/(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=COMFACAS24D0/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=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2)
	- FACGG2=COMFACAS232D0/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=COMFACASAEM8D0/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)=FACGGEI*2
	- 160 CONTINUE
	-
	- ELSEIF(ISUB.EQ.18) THEN
	-C...f + fbar -> gamma + gamma
	- FACGG=COMFACAEM22D0(TH2+UH2)/(THUH)
	- 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.5D0FACGGFCOIEI*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=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*UH2/TH2-
	- & UH/SH)*FACA
	- FACQG2=COMFACAS24D0/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=COMFACFACAASAEM1D0/3D0(SH2+UH2)/(-SHUH)
	- DO 210 I=MMINA,MMAXA
	- IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
	- EI=KCHG(IABS(I),1)/3D0
	- FACGQ=FGQEI*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=COMFACASAEM8D0/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=FGQEI*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=COMFACAEM22D0(SH2+UH2)/(-SHUH)
	- DO 250 I=MMINA,MMAXA
	- IF(I.EQ.0) GOTO 250
	- EI=KCHG(IABS(I),1)/3D0
	- FACGQ=FGQEI*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-4D0PMAS(1,1)*2/SH))
	- IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
	- & SQRT(MAX(0D0,1D0-4D0PMAS(2,1)*2/SH))
	- IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
	- & SQRT(MAX(0D0,1D0-4D0PMAS(3,1)*2/SH))
	- FACQQ1=COMFACAS21D0/6D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2)FLAVWTFACA
	- FACQQ2=COMFACAS21D0/6D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	- & TH2/SH2)FLAVWTFACA
	- 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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- THUHQ=THQUHQ-SQMAVGSH
	- IF(MSTP(34).EQ.0) THEN
	- FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	- FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	- ELSE
	- FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	- FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	- ENDIF
	- FACQQ1=COMFACFACAAS*2(1D0/6D0)FACQQ1BE34
	- FACQQ2=COMFACFACAAS*2(1D0/6D0)FACQQ2BE34
	- 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=COMFACAEMASWDTESU(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=COMFACAEM2WDTESU2D0(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=COMFACAS29D0/4D0(SH2/TH2+2D0SH/TH+3D0+2D0*TH/SH+
	- & TH2/SH2)*FACA
	- FACGG2=COMFACAS29D0/4D0(UH2/SH2+2D0UH/SH+3D0+2D0*SH/UH+
	- & SH2/UH2)*FACA
	- FACGG3=COMFACAS29D0/4D0(TH2/UH2+2D0TH/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(2D0AEM/9D0)(-SH/TH)(1D0/SH2+1D0/TH2)
	- ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
	- Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
	- DELSH=UHSQRT(ASSHQ2FPSH)
	- ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
	- Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
	- DELUH=SHSQRT(ASUHQ2FPUH)
	- 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(EIDELSH+EJDELUH)*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=COMFACAS24D0/9D0*(SH2+UH2)/TH2
	- FACQQB=COMFACAS24D0/9D0((SH2+UH2)/TH2FACA-
	- & MSTP(34)2D0/3D0UH2/(SH*TH))
	- FACQQ2=COMFACAS24D0/9D0*(SH2+TH2)/UH2
	- FACQQI=-COMFACAS24D0/9D0MSTP(34)2D0/3D0SH2/(THUH)
	- 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.5D0FACQQ1RATQQI
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=112
	- SIGH(NCHN)=0.5D0FACQQ2RATQQI
	- ENDIF
	- 330 CONTINUE
	- 340 CONTINUE
	-
	-C...q + qbar -> q' + qbar' or g + g
	- FACQQB=COMFACAS24D0/9D0(TH2+UH2)/SH2
	- & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
	- FACGG1=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2)
	- FACGG2=COMFACAS232D0/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=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*UH2/TH2-
	- & UH/SH)*FACA
	- FACQG2=COMFACAS24D0/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-4D0PMAS(1,1)*2/SH))
	- IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
	- & SQRT(MAX(0D0,1D0-4D0PMAS(2,1)*2/SH))
	- IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
	- & SQRT(MAX(0D0,1D0-4D0PMAS(3,1)*2/SH))
	- FACQQ1=COMFACAS21D0/6D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2)FLAVWTFACA
	- FACQQ2=COMFACAS21D0/6D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	- & TH2/SH2)FLAVWTFACA
	- 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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- THUHQ=THQUHQ-SQMAVGSH
	- IF(MSTP(34).EQ.0) THEN
	- FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	- FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	- ELSE
	- FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	- FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	- ENDIF
	- FACQQ1=COMFACFACAAS*2(1D0/6D0)FACQQ1BE34
	- FACQQ2=COMFACFACAAS*2(1D0/6D0)FACQQ2BE34
	- 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=COMFACAS29D0/4D0(SH2/TH2+2D0SH/TH+3D0+
	- & 2D0TH/SH+TH2/SH2)FACA
	- FACGG2=COMFACAS29D0/4D0(UH2/SH2+2D0UH/SH+3D0+
	- & 2D0SH/UH+SH2/UH2)FACA
	- FACGG3=COMFACAS29D0/4D0(TH2/UH2+2D0TH/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)4D0PARU(1)*2PARU(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=COMFACQ2GA/(Q2GA+PM2RHO)*2
	- ELSE
	- COMFAC=COMFACQ2GA/(Q2GA+PM2RHO)*2
	- W2GA=VINT(2)
	- IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
	- RDRDS=4.1D-3W2GA2.167D0/((Q2GA+0.15D0W2GA)*2
	- & Q2GA*0.75D0)(1D0+0.11D0Q2GAP2GA/(1D0+0.02D0P2GA*2))
	- XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
	- ELSE
	- RDRDS=1.5D-4W2GA2.167D0/((Q2GA+0.041D0W2GA)*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)=COMFACEI*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)/SHALTU+0.5D0(TH2+UH2)/SH2(ALTU*2+
	- & PARU(1)**2)
	- B0STUI=0D0
	- B0TSUR=1D0+(SH-UH)/THALSU+0.5D0(SH2+UH2)/TH2ALSU*2
	- B0TSUI=-PARU(1)((SH-UH)/TH+(SH2+UH2)/TH2ALSU)
	- B0UTSR=1D0+(SH-TH)/UHALST+0.5D0(SH2+TH2)/UH2ALST*2
	- B0UTSI=-PARU(1)((SH-TH)/UH+(SH2+TH2)/UH2ALST)
	- 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+2D0TH/SH)W1TR+(1D0+2D0UH/SH)W1UR+
	- & 0.5D0((TH2+UH2)/SH2-EPSS)(W2TR+W2UR)-
	- & 0.25D0EPST(1D0-0.5D0EPSS)(Y3SUTR+Y3TUSR)-
	- & 0.25D0EPSU(1D0-0.5D0EPSS)(Y3STUR+Y3UTSR)+
	- & 0.25D0(-2D0(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
	- & 0.5D0EPSTEPSU)*(Y3TSUR+Y3USTR)
	- B0STUI=(1D0+2D0TH/SH)W1TI+(1D0+2D0UH/SH)W1UI+
	- & 0.5D0((TH2+UH2)/SH2-EPSS)(W2TI+W2UI)-
	- & 0.25D0EPST(1D0-0.5D0EPSS)(Y3SUTI+Y3TUSI)-
	- & 0.25D0EPSU(1D0-0.5D0EPSS)(Y3STUI+Y3UTSI)+
	- & 0.25D0(-2D0(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
	- & 0.5D0EPSTEPSU)*(Y3TSUI+Y3USTI)
	- B0TSUR=1D0+(1D0+2D0SH/TH)W1SR+(1D0+2D0UH/TH)W1UR+
	- & 0.5D0((SH2+UH2)/TH2-EPST)(W2SR+W2UR)-
	- & 0.25D0EPSS(1D0-0.5D0EPST)(Y3TUSR+Y3SUTR)-
	- & 0.25D0EPSU(1D0-0.5D0EPST)(Y3TSUR+Y3USTR)+
	- & 0.25D0(-2D0(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
	- & 0.5D0EPSSEPSU)*(Y3STUR+Y3UTSR)
	- B0TSUI=(1D0+2D0SH/TH)W1SI+(1D0+2D0UH/TH)W1UI+
	- & 0.5D0((SH2+UH2)/TH2-EPST)(W2SI+W2UI)-
	- & 0.25D0EPSS(1D0-0.5D0EPST)(Y3TUSI+Y3SUTI)-
	- & 0.25D0EPSU(1D0-0.5D0EPST)(Y3TSUI+Y3USTI)+
	- & 0.25D0(-2D0(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
	- & 0.5D0EPSSEPSU)*(Y3STUI+Y3UTSI)
	- B0UTSR=1D0+(1D0+2D0TH/UH)W1TR+(1D0+2D0SH/UH)W1SR+
	- & 0.5D0((TH2+SH2)/UH2-EPSU)(W2TR+W2SR)-
	- & 0.25D0EPST(1D0-0.5D0EPSU)(Y3USTR+Y3TSUR)-
	- & 0.25D0EPSS(1D0-0.5D0EPSU)(Y3UTSR+Y3STUR)+
	- & 0.25D0(-2D0(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
	- & 0.5D0EPSTEPSS)*(Y3TUSR+Y3SUTR)
	- B0UTSI=(1D0+2D0TH/UH)W1TI+(1D0+2D0SH/UH)W1SI+
	- & 0.5D0((TH2+SH2)/UH2-EPSU)(W2TI+W2SI)-
	- & 0.25D0EPST(1D0-0.5D0EPSU)(Y3USTI+Y3TSUI)-
	- & 0.25D0EPSS(1D0-0.5D0EPSU)(Y3UTSI+Y3STUI)+
	- & 0.25D0(-2D0(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
	- & 0.5D0EPSTEPSS)*(Y3TUSI+Y3SUTI)
	- B1STUR=-1D0-0.25D0(EPSS+EPST+EPSU)(W2SR+W2TR+W2UR)+
	- & 0.25D0(EPSU+0.5D0EPSSEPST)(Y3SUTR+Y3TUSR)+
	- & 0.25D0(EPST+0.5D0EPSSEPSU)(Y3STUR+Y3UTSR)+
	- & 0.25D0(EPSS+0.5D0EPSTEPSU)(Y3TSUR+Y3USTR)
	- B1STUI=-0.25D0(EPSS+EPST+EPSU)(W2SI+W2TI+W2UI)+
	- & 0.25D0(EPSU+0.5D0EPSSEPST)(Y3SUTI+Y3TUSI)+
	- & 0.25D0(EPST+0.5D0EPSSEPSU)(Y3STUI+Y3UTSI)+
	- & 0.25D0(EPSS+0.5D0EPSTEPSU)(Y3TSUI+Y3USTI)
	- B2STUR=-1D0+0.125D0EPSSEPST*(Y3SUTR+Y3TUSR)+
	- & 0.125D0EPSSEPSU*(Y3STUR+Y3UTSR)+
	- & 0.125D0EPSTEPSU*(Y3TSUR+Y3USTR)
	- B2STUI=0.125D0EPSSEPST*(Y3SUTI+Y3TUSI)+
	- & 0.125D0EPSSEPSU*(Y3STUI+Y3UTSI)+
	- & 0.125D0EPSTEPSU*(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=A0STUR2+A0STUI2+A0TSUR2+A0TSUI2+A0UTSR**2+
	- & A0UTSI*2+4D0A1STUR*2+4D0A1STUI2+A2STUR2+A2STUI**2
	- FACGG=COMFACFACA/(16D0PARU(1)*2)AS*2AEM*2ASQSUM
	- FACGP=COMFACFACA5D0/(192D0PARU(1)2)AS*3AEM*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=COMFACASAEM8D0/3D0SH2/(SH+PH)2*
	- & ((SH2+UH2-2D0PHTH)/(-SHUH)-2D0PHTH/(SH+PH)*2)
	- ELSE
	- FGQ=COMFACASAEM8D0/3D0SH2/(SH+PH)4(-4D0PH*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=FGQEI*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=COMFACAEM22D0SH2/(SH+PH)2
	- & ((SH2+UH2-2D0PHTH)/(-SHUH)-2D0PHTH/(SH+PH)*2)
	- ELSE
	- FGQ=COMFACAEM22D0SH2/(SH+PH)4(-4D0PHTH)
	- ENDIF
	- DO 450 I=MMINA,MMAXA
	- IF(I.EQ.0) GOTO 450
	- EI=KCHG(IABS(I),1)/3D0
	- FACGQ=FGQEI*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=COMFACAEMASWDTESUSH2/(SH+PH)2*
	- & ((TH2+UH2-2D0PHSH)/(THUH)+4D0PHSH/(SH+PH)*2)
	- ELSE
	- FACQQ=COMFACAEMASWDTESUSH2/(SH+PH)48D0PH*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-4D0PH1*PH2
	- IF(ISUB.EQ.137) THEN
	- FPARAM=-SH*(TH+UH)/DLAMB2
	- FACFF=COMFACAEM2WDTESU2D0SH2/(DLAMB2TH2UH2)*
	- & (THUH-PH1PH2)((TH2+UH2)(1D0-2D0FPARAM(1D0-FPARAM))-
	- & 2D0PH1PH2FPARAM*2)
	- ELSEIF(ISUB.EQ.138) THEN
	- FACFF=COMFACAEM2WDTESU4D0SH2SH/(DLAMB22TH2UH2)
	- & PH2(4D0(THUH-PH1PH2)(THUH+PH1SH(TH-UH)**2/DLAMB2)+
	- & 2D0PH12(TH-UH)**2)
	- ELSEIF(ISUB.EQ.139) THEN
	- FACFF=COMFACAEM2WDTESU4D0SH2SH/(DLAMB22TH2UH2)
	- & PH1(4D0(THUH-PH1PH2)(THUH+PH2SH(TH-UH)**2/DLAMB2)+
	- & 2D0PH22(TH-UH)**2)
	- ELSE
	- FACFF=COMFACAEM2WDTESU32D0SH22/(DLAMB23TH2UH2)*
	- & PH1PH2(THUH-PH1PH2)(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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- FACQQB=COMFACAS24D0/9D0((THQ2+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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- THUHQ=THQUHQ-SQMAVGSH
	- IF(MSTP(34).EQ.0) THEN
	- FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	- FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	- ELSE
	- FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	- FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	- ENDIF
	- FACQQ1=COMFACFACAAS*2(1D0/6D0)*FACQQ1
	- FACQQ2=COMFACFACAAS*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.5D0AEM/XW)*2SH(SH-SQM3)/(SQMW-TH)*2
	- FACQQU=COMFAC(0.5D0AEM/XW)*2UH(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(IJ.GT.0) SIGH(NCHN)=FACQQSFACCKM*WID2
	- IF(IJ.LT.0) SIGH(NCHN)=FACQQUFACCKM*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(IJ.GT.0) SIGH(NCHN)=FACQQSFACCKM*WID2
	- IF(IJ.LT.0) SIGH(NCHN)=FACQQUFACCKM*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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- FACQQ=COMFACASAEM(KCHG(IABS(MINT(55)),1)/3D0)2
	- & (THQ2+UHQ2+4D0SQMAVGSH(1D0-SQMAVGSH/(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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- FACFF=COMFACAEM2(KCHG(IABS(MINT(56)),1)/3D0)*42D0*
	- & ((1D0-PARJ(131)PARJ(132))(THQUHQ-SQMAVGSH)*
	- & (UHQ2+THQ2+2D0SQMAVGSH)+(1D0+PARJ(131)PARJ(132))
	- & SQMAVGSH2(SH-2D0SQMAVG))/(THQUHQ)**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=COMFACAS3(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=(SHTH+THUH+UH*SH)/SH2
	- QGTW=(SHTHUH)/SH**3
	- RGTW=SQM3/SH
	- FACQQG=COMFACAS34D0(PARP(39)/SQRT(SQM3))(1D0/SH)*
	- & (9D0RGTW2PGTW*4(RGTW*4-2D0RGTW*2PGTW+PGTW**2)-
	- & 6D0RGTWPGTW*3QGTW(2D0RGTW*4-5D0RGTW*2PGTW+PGTW**2)-
	- & PGTW*2QGTW*2(RGTW*4+2D0RGTW*2PGTW-PGTW**2)+
	- & 2D0RGTWPGTWQGTW3(RGTW*2-PGTW)+6D0RGTW*2QGTW**4)/
	- & (QGTW(QGTW-RGTWPGTW)**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=(SHTH+THUH+UH*SH)/SH2
	- QGTW=(SHTHUH)/SH**3
	- RGTW=SQM3/SH
	- FACQQG=COMFACAS312D0(PARP(39)/SQRT(SQM3))(1D0/SH)*
	- & PGTW*2(RGTWPGTW2(RGTW*2-4D0PGTW)+2D0QGTW(-RGTW**4+
	- & 5D0RGTW2PGTW+PGTW*2)-15D0RGTWQGTW*2)/
	- & (QGTW-RGTWPGTW)*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=(SHTH+THUH+UH*SH)/SH2
	- QGTW=(SHTHUH)/SH**3
	- RGTW=SQM3/SH
	- FACQQG=COMFACAS34D0(PARP(39)/SQRT(SQM3))(1D0/SH)*
	- & (12D0RGTW2PGTW*4(RGTW*4-2D0RGTW*2PGTW+PGTW**2)-
	- & 3D0RGTWPGTW*3QGTW(8D0RGTW4-RGTW2PGTW+4D0PGTW**2)+
	- & 2D0PGTW2QGTW*2(-7D0RGTW4+43D0RGTW*2PGTW+PGTW**2)+
	- & RGTWPGTWQGTW*3(16D0RGTW2-61D0PGTW)+12D0RGTW2
	- & QGTW*4)/(QGTW(QGTW-RGTWPGTW)*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=COMFAC12D0AS*2PARP(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=COMFAC16D0AS*2PARP(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=COMFACAEMEQ*2AS*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=COMFACAEMEQ*2AS*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=COMFACAEM3EQ*6384D0PARP(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/(2D0X(1)) + SHTH/(2D0X(2))
	- BQ=UHSH/(2D0X(1)) - SHTH/(2D0X(2))
	- ATILK1=X(1)VINT(2)/2D0-UHSH/(2D0SQMQQ)*AQ
	- ATILK2=X(2)VINT(2)/2D0-SHTH/(2D0SQMQQ)*AQ
	- BTILK1=-X(1)VINT(2)/2D0-UHSH/(2D0SQMQQ)*BQ
	- BTILK2=X(2)VINT(2)/2D0-SHTH/(2D0SQMQQ)*BQ
	- ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
	- & ISUB.GE.437) THEN
	- AQ=SHTH/(2D0X(1)) + UHSH/(2D0X(2))
	- BQ=SHTH/(2D0X(1)) - UHSH/(2D0X(2))
	- ATILK1=X(1)VINT(2)/2D0-SHTH/(2D0SQMQQ)*AQ
	- ATILK2=X(2)VINT(2)/2D0-UHSH/(2D0SQMQQ)*AQ
	- BTILK1=-X(1)VINT(2)/2D0-SHTH/(2D0SQMQQ)*BQ
	- BTILK2=X(2)VINT(2)/2D0-UHSH/(2D0SQMQQ)*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=AQBQ/(POLH1POLH2)
	- BX=-POLH1/POLH2
	- ELSEIF(MSTP(146).EQ.2) THEN
	-C...Gottfried Jackson frame
	- POLH1=AQ+BQ
	- POLH2=POLH1SQRT(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=POLH1SQRT(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=-SQMQQRAQ/SQRT(POLH1(POLH1-SMQQ2))
	- BX=SQMQQRBQ/SQRT(POLH1(POLH1-SMQQ2))
	- ENDIF
	-C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
	- EL1K10=AZATILK1+BZBTILK1
	- EL1K20=AZATILK2+BZBTILK2
	- EL2K10=EL1K10
	- EL2K20=EL1K20
	- EL1K11=1D0/SQRT(2D0)(AXATILK1+BX*BTILK1)
	- EL1K21=1D0/SQRT(2D0)(AXATILK2+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=COMFACPARU(1)AS*3(10D0/81D0)SQMQQR
	-* & (SH2THUH2+TH2UHSH2+UH2SHTH2)/(SHTH2THUH2*UHSH2)
	- FACQQG=COMFACPARU(1)AS*3(10D0/81D0)SQMQQR
	- & (SH2THUH2+TH2UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
	-* FACQQG=COMFACPARU(1)AS*3(10D0/81D0)SQMQQR
	-* & (SH2/(SHTH2UHSH2)+TH2/(SHTH2THUH2)+UH2/(THUH2*UHSH2))
	- ELSE
	- FF=-PARU(1)AS3(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
	- AA=(SHTH2UH2+UHSH2TH2+THUH2*SH2)/2D0
	- BB=2D0*(SH2+TH2)
	- CC=2D0*(SH2+UH2)
	- DD=2D0*SH2
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=-COMFACPARU(1)AS*3(1D0/72D0)*
	- & (16D0SQMQQ2-27D0(SHTH2+THUH2+UHSH2))/
	- & (SQMQQSQMQQR)
	- & ((SH2THUH2+TH2UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
	- ELSE
	- FF=PARU(1)AS3(16D0SQMQQ2-27D0(SHTH2+THUH2+UHSH2))/
	- & (72D0SQMQQSQMQQRSHTH2THUH2*UHSH2)
	- AA=(SHTH2UH2+UHSH2TH2+THUH2*SH2)/2D0
	- BB=2D0*(SH2+TH2)
	- CC=2D0*(SH2+UH2)
	- DD=2D0*SH2
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- ENDIF
	-C...Split total contribution into different colour flows just like
	-C...in g g -> g g (recalculate kinematics for massless partons).
	- THP=-0.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(1D0+CTH)
	- FACGG1=(SH/THP)*2+2D0SH/THP+3D0+2D0THP/SH+(THP/SH)*2
	- FACGG2=(UHP/SH)*2+2D0UHP/SH+3D0+2D0SH/UHP+(SH/UHP)*2
	- FACGG3=(THP/UHP)*2+2D0THP/UHP+3D0+2D0UHP/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)=FACQQGPARP(IONIUM+2)FACGG1/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=21
	- ISIG(NCHN,2)=21
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(IONIUM+2)FACGG2/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=21
	- ISIG(NCHN,2)=21
	- ISIG(NCHN,3)=3
	- SIGH(NCHN)=FACQQGPARP(IONIUM+2)FACGG3/FACGGS
	- ENDIF
	-
	- ELSEIF(ISUB.EQ.423) THEN
	-C...g + g -> QQ~[1S08] + g
	- IF(MSTP(145).EQ.0) THEN
	-* FACQQG=COMFACPARU(1)AS*3(5D0/16D0)*
	-* & (SHTH2UH2+THUH2SH2+UHSH2TH2)/(SQMQQRSHTHUH)*
	-* & (12D0SQMQQSHTHUH+SHTH22+THUH22+UHSH2**2)/
	-* & (SHTH2THUH2UHSH2)
	- FACQQG=COMFACPARU(1)AS*3(5D0/16D0)SQMQQR
	- & (UH2/(THUH2UHSH2)+SH2/(SHTH2UHSH2)+
	- & TH2/(SHTH2THUH2))
	- & (12D0+(SHTH22+THUH22+UHSH2*2)/(SQMQQSHTHUH))
	- ELSE
	- FA=PARU(1)AS3(5D0/48D0)SQMQQR
	- & (UH2/(THUH2UHSH2)+SH2/(SHTH2UHSH2)+
	- & TH2/(SHTH2THUH2))
	- & (12D0+(SHTH22+THUH22+UHSH2*2)/(SQMQQSHTHUH))
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=COMFAC*FA
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=COMFAC2D0FA
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(1D0+CTH)
	- FACGG1=(SH/THP)*2+2D0SH/THP+3D0+2D0THP/SH+(THP/SH)*2
	- FACGG2=(UHP/SH)*2+2D0UHP/SH+3D0+2D0SH/UHP+(SH/UHP)*2
	- FACGG3=(THP/UHP)*2+2D0THP/UHP+3D0+2D0UHP/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)=FACQQGPARP(IONIUM+3)FACGG1/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=21
	- ISIG(NCHN,2)=21
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(IONIUM+3)FACGG2/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=21
	- ISIG(NCHN,2)=21
	- ISIG(NCHN,3)=3
	- SIGH(NCHN)=FACQQGPARP(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=COMFAC5D0PARU(1)AS3(3D0SHTHSHTHPOLY**4
	- & -SQMQQPOLY2(7D0SH6+36D0SH*5TH+45D0SH4TH2
	- & +28D0SH3TH*3+45D0SH2TH4+36D0SHTH*5
	- & +7D0TH*6)
	- & +SQMQQ*2SHTH(35D0SH*8+169D0SH*7TH
	- & +299D0SH6TH2+401D0SH5TH*3+418D0SH*4TH**4
	- & +401D0SH3TH*5+299D0SH2TH6+169D0SHTH*7
	- & +35D0TH*8)
	- & -SQMQQ*3(84D0SH8+432D0SH*7TH+905D0SH6TH2
	- & +1287D0SH5TH*3+1436D0SH*4TH**4
	- & +1287D0SH3TH*5+905D0SH2TH6+432D0SHTH*7
	- & +84D0TH*8)
	- & +SQMQQ*4SHTH(126D0SH*6+451D0SH*5TH
	- & +677D0SH4TH2+836D0SH3TH*3+677D0SH2TH*4
	- & +451D0SHTH*5+126D0TH**6)
	- & -3D0SQMQQ5(42D0SH6+171D0SH*5TH
	- & +304D0SH4TH2+362D0SH3TH*3+304D0SH2TH*4
	- & +171D0SHTH*5+42D0TH**6)
	- & +2D0SQMQQ6SHTH(42D0SH*4+106D0SH*3TH
	- & +119D0SH2TH2+106D0SHTH*3+42D0TH**4)
	- & -SQMQQ*7(35D0SH4+99D0SH*3TH+120D0SH2TH2
	- & +99D0SHTH*3+35D0TH**4)
	- & +7D0SQMQQ8SHTH*POLY)/
	- & (SHTHUHSQMQQRSQMQQ*
	- & SHTHSHTH2THUHTHUH2UHSH*UHSH2)
	- ELSE
	- FF=-5D0PARU(1)AS*3/(SH2TH2*UH2
	- & SQMQQRSQMQQSHTHSHTH2THUHTHUH2UHSHUHSH2)
	- AA=SHTHUH(SHTHSHTHPOLY**4
	- & -SQMQQSHTH2POLY*2
	- & (SH*4+6D0SH*3TH-6D0SH2TH2+6D0SHTH3+TH4)
	- & +SQMQQ*2SHTH(5D0SH*8+35D0SH*7TH+49D0SH6TH2
	- & +57D0SH5TH*3+46D0SH*4TH*4+57D0SH*3TH**5
	- & +49D0SH2TH*6+35D0SHTH7+5D0TH**8)
	- & -SQMQQ*3(16D0SH8+104D0SH*7TH+215D0SH6TH2
	- & +291D0SH5TH*3+316D0SH*4TH*4+291D0SH*3TH**5
	- & +215D0SH2TH*6+104D0SHTH7+16D0TH**8)
	- & +SQMQQ*4SHTH(34D0SH*6+145D0SH*5TH
	- & +211D0SH4TH2+262D0SH3TH*3+211D0SH2TH*4
	- & +145D0SHTH*5+34D0TH**6)
	- & -SQMQQ*5(44D0SH6+193D0SH*5TH+346D0SH4TH2
	- & +410D0SH3TH*3+346D0SH2TH4+193D0SHTH*5
	- & +44D0TH*6)
	- & +2D0SQMQQ6SHTH(17D0SH*4+45D0SH*3TH
	- & +49D0SH2TH2+45D0SHTH*3+17D0TH**4)
	- & -SQMQQ*7(3D0SH2+2D0SHTH+3D0TH2)
	- & (5D0SH2+11D0SHTH+5D0*TH2)
	- & +3D0SQMQQ8SHTH*POLY)
	- BB=4D0SHTH2POLY**3
	- & (SH4+SH3TH-SH2TH2+SHTH3+TH4)
	- & -SQMQQSHTH(20D0SH10+84D0SH*9TH+166D0SH8TH2
	- & +231D0SH7TH*3+250D0SH*6TH*4+250D0SH*5TH**5
	- & +250D0SH4TH*6+231D0SH*3TH*7+166D0SH2TH*8
	- & +84D0SHTH*9+20D0TH**10)
	- & +SQMQQ*2SHTH2(40D0SH*8+86D0SH*7TH
	- & +66D0SH6TH2+67D0SH5TH*3+6D0SH*4TH**4
	- & +67D0SH3TH*5+66D0SH2TH6+86D0SHTH*7
	- & +40D0TH*8)
	- & -SQMQQ*3SHTH(40D0SH*8+57D0SH*7TH
	- & -110D0SH6TH2-263D0SH5TH*3-384D0SH*4TH**4
	- & -263D0SH3TH*5-110D0SH2TH6+57D0SHTH*7
	- & +40D0TH*8)
	- & +SQMQQ*4(20D0SH8-33D0SH*7TH-368D0SH6TH2
	- & -751D0SH5TH*3-920D0SH*4TH*4-751D0SH*3TH**5
	- & -368D0SH2TH*6-33D0SHTH7+20D0TH**8)
	- & -SQMQQ*5SHTH(4D0SH*6-81D0SH*5TH-242D0SH4TH2
	- & -250D0SH3TH*3-242D0SH2TH4-81D0SHTH*5
	- & +4D0TH*6)
	- & -SQMQQ*6SHTH(41D0SH4+120D0SH*3TH
	- & +142D0SH2TH2+120D0SHTH*3+41D0TH**4)
	- & +8D0SQMQQ7SHTHSHTH*POLY
	- CC=4D0TH2POLY**3
	- & (-SH4-2D0SH*3TH+2D0SH2TH2+3D0SHTH3+TH4)
	- & -SQMQQTH2(-20D0SH9-56D0SH*8TH-24D0SH7TH2
	- & +147D0SH6TH*3+409D0SH*5TH*4+599D0SH*4TH**5
	- & +571D0SH3TH*6+370D0SH2TH7+148D0SHTH*8
	- & +28D0TH*9)
	- & +SQMQQ*2(4D0SH10+20D0SH*9TH-16D0SH8TH2
	- & -48D0SH7TH*3+150D0SH*6TH*4+611D0SH*5TH**5
	- & +1060D0SH4TH*6+1155D0SH*3TH*7+854D0SH2TH*8
	- & +394D0SHTH*9+84D0TH**10)
	- & -SQMQQ*3SHTH(20D0SH*8+68D0SH*7TH-20D0SH6TH2
	- & +32D0SH5TH*3+286D0SH*4TH*4+577D0SH*3TH**5
	- & +618D0SH2TH*6+443D0SHTH7+140D0TH**8)
	- & +SQMQQ*4(40D0SH8+152D0SH*7TH+94D0SH6TH2
	- & +38D0SH5TH*3+290D0SH*4TH*4+631D0SH*3TH**5
	- & +738D0SH2TH*6+513D0SHTH7+140D0TH**8)
	- & -SQMQQ*5(40D0SH7+129D0SH*6TH+53D0SH5TH2
	- & +7D0SH4TH*3+129D0SH*3TH*4+264D0SH2TH*5
	- & +266D0SHTH*6+84D0TH**7)
	- & +SQMQQ*6(20D0SH6+55D0SH*5TH+2D0SH4TH2
	- & -15D0SH3TH*3+30D0SH2TH4+76D0SHTH*5
	- & +28D0TH*6)
	- & -SQMQQ*7SHTH(4D0SH*4+7D0SH*3TH-14D0SH2TH2
	- & +7D0SHTH*3+4TH**4)
	- & +SQMQQ*8SH(SH-TH)2TH
	- DD=2D0TH2SHTH2POLY*3
	- & (-SH2+2SHTH+2TH2)
	- & +SQMQQ(4D0SH*11+22D0SH*10TH+70D0SH9TH2
	- & +115D0SH8TH*3+71D0SH*7TH*4-119D0SH*6TH**5
	- & -381D0SH5TH*6-552D0SH*4TH*7-512D0SH*3TH**8
	- & -320D0SH2TH*9-126D0SHTH10-24D0TH**11)
	- & -SQMQQ*2SHTH(20D0SH*9+84D0SH*8TH
	- & +212D0SH7TH2+247D0SH6TH*3+105D0SH*5TH**4
	- & -178D0SH4TH*5-380D0SH*3TH*6-364D0SH2TH*7
	- & -210D0SHTH*8-60D0TH**9)
	- & +SQMQQ*3SHTH(40D0SH*8+159D0SH*7TH
	- & +374D0SH6TH2+404D0SH5TH*3+192D0SH*4TH**4
	- & -141D0SH3TH*5-264D0SH2TH6-216D0SHTH*7
	- & -80D0TH*8)
	- & -SQMQQ*4(40D0SH8+197D0SH*7TH+506D0SH6TH2
	- & +672D0SH5TH*3+460D0SH*4TH*4+79D0SH*3TH**5
	- & -138D0SH2TH*6-164D0SHTH7-60D0TH**8)
	- & +SQMQQ*5(20D0SH7+107D0SH*6TH+267D0SH5TH2
	- & +307D0SH4TH*3+185D0SH*3TH*4+56D0SH2TH*5
	- & -30D0SHTH*6-24D0TH**7)
	- & -SQMQQ*6(4D0SH6+31D0SH*5TH+74D0SH4TH2
	- & +71D0SH3TH*3+46D0SH2TH4+10D0SHTH*5
	- & -4D0TH*6)
	- & +4D0SQMQQ7SHTHSHTH*POLY
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- ENDIF
	-C...Split total contribution into different colour flows just like
	-C...in g g -> g g (recalculate kinematics for massless partons).
	- THP=-0.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(1D0+CTH)
	- FACGG1=(SH/THP)*2+2D0SH/THP+3D0+2D0THP/SH+(THP/SH)*2
	- FACGG2=(UHP/SH)*2+2D0UHP/SH+3D0+2D0SH/UHP+(SH/UHP)*2
	- FACGG3=(THP/UHP)*2+2D0THP/UHP+3D0+2D0UHP/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)=FACQQGPARP(IONIUM+4)FACGG1/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=21
	- ISIG(NCHN,2)=21
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(IONIUM+4)FACGG2/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=21
	- ISIG(NCHN,2)=21
	- ISIG(NCHN,3)=3
	- SIGH(NCHN)=FACQQGPARP(IONIUM+4)FACGG3/FACGGS
	- ENDIF
	-
	- ELSEIF(ISUB.EQ.425) THEN
	-C...q + g -> q + QQ~[3S18]
	- IF(MSTP(145).EQ.0) THEN
	- FACQQG=-COMFACPARU(1)AS*3(1D0/27D0)*
	- & (4D0(SH2+UH2)-SHUH)*(SHTH2+THUH2)/
	- & (SQMQQSQMQQRSHUHUHSH2)
	- ELSE
	- FF=PARU(1)AS3(4D0(SH2+UH2)-SHUH)/
	- & (54D0SQMQQSQMQQRSHUH*UHSH2)
	- AA=SHTH2+THUH2
	- BB=4D0
	- CC=8D0
	- DD=4D0
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+2)FACQG1/FACQGS
	- NCHN=NCHN+1
	- ISIG(NCHN,ISDE)=I
	- ISIG(NCHN,3-ISDE)=21
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(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=-COMFACPARU(1)AS*3(5D0/18D0)*
	- & (SH2+UH2)/(SQMQQRTHUHSH2)
	- ELSE
	- FA=-PARU(1)AS3(5D0/54D0)(SH2+UH2)/(SQMQQRTH*UHSH2)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=COMFAC*FA
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=COMFAC2D0FA
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+3)FACQG1/FACQGS
	- NCHN=NCHN+1
	- ISIG(NCHN,ISDE)=I
	- ISIG(NCHN,3-ISDE)=21
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(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=-COMFACPARU(1)AS*3(10D0/9D0)*
	- & ((7D0UHSH+8D0TH)*(SH2+UH2)
	- & +4D0TH(2D0SQMQQ*2-SHTH2-THUH2))/
	- & (SQMQQSQMQQRTHUHSH2UHSH)
	- ELSE
	- FF=10D0PARU(1)AS**3/
	- & (9D0SQMQQSQMQQRTH2UHSH2*UHSH)
	- AA=THUHSH(2D0SQMQQ*2+SHTH2+THUH2)
	- BB=8D0(SHTH2+THUH)
	- CC=8D0UHSH(SHTH+THUH)
	- DD=4D0(2D0SQMQQSH+THUHSH)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+4)FACQG1/FACQGS
	- NCHN=NCHN+1
	- ISIG(NCHN,ISDE)=I
	- ISIG(NCHN,3-ISDE)=21
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(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=COMFACPARU(1)AS*3(8D0/81D0)*
	- & (4D0(TH2+UH2)-THUH)*(SHTH2+UHSH2)/
	- & (SQMQQSQMQQRTHUHTHUH2)
	- ELSE
	- FF=-4D0PARU(1)AS*3(4D0(TH2+UH2)-THUH)/
	- & (81D0SQMQQSQMQQRTHUH*THUH2)
	- AA=SHTH2+UHSH2
	- BB=4D0
	- CC=4D0
	- DD=0D0
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+2)FACGG1/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(IONIUM+2)FACGG2/FACGGS
	- 2447 CONTINUE
	-
	- ELSEIF(ISUB.EQ.429) THEN
	-C...q + q~ -> g + QQ~[1S08]
	- IF(MSTP(145).EQ.0) THEN
	- FACQQG=COMFACPARU(1)AS*3(20D0/27D0)*
	- & (TH2+UH2)/(SQMQQRSHTHUH2)
	- ELSE
	- FA=PARU(1)AS3(20D0/81D0)(TH2+UH2)/(SQMQQRSH*THUH2)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=COMFAC*FA
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=COMFAC2D0FA
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+3)FACGG1/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(IONIUM+3)FACGG2/FACGGS
	- 2448 CONTINUE
	-
	- ELSEIF(ISUB.EQ.430) THEN
	-C...q + q~ -> g + QQ~[3PJ8]
	- IF(MSTP(145).EQ.0) THEN
	- FACQQG=COMFACPARU(1)AS*3(80D0/27D0)*
	- & ((7D0THUH+8D0SH)*(TH2+UH2)
	- & +4D0SH(2D0SQMQQ*2-SHTH2-UHSH2))/
	- & (SQMQQSQMQQRSHTHUH2THUH)
	- ELSE
	- FF=-80D0PARU(1)AS*3/(27D0SQMQQSQMQQRSH2THUH2THUH)
	- AA=SHTHUH(2D0SQMQQ*2+SHTH2+UHSH2)
	- BB=8D0(UHSH2+SHTH)
	- CC=8D0(SHTH2+SHUH)
	- DD=4D0(SHTH2+UHSH2+SHSQMQQ-SQMQQ**2)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	- & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	- & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	- & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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.5D0SH(1D0-CTH)
	- UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+4)FACGG1/FACGGS
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACQQGPARP(IONIUM+4)FACGG2/FACGGS
	- 2449 CONTINUE
	-
	- ELSEIF(ISUB.EQ.431) THEN
	-C...g + g -> QQ~[3P01] + g
	- PGTW=(SHTH+THUH+UH*SH)/SH2
	- QGTW=(SHTHUH)/SH**3
	- RGTW=SQMQQ/SH
	- IF(MSTP(145).EQ.0) THEN
	- FACQQG=COMFACPARU(1)AS*38D0/(9D0SQMQQRSH)*
	- & (9D0RGTW2PGTW*4
	- & (RGTW*4-2D0RGTW*2PGTW+PGTW**2)
	- & -6D0RGTWPGTW*3QGTW*
	- & (2D0RGTW4-5D0RGTW*2PGTW+PGTW**2)
	- & -PGTW*2QGTW*2(RGTW*4+2D0RGTW*2PGTW-PGTW**2)
	- & +2D0RGTWPGTWQGTW3(RGTW**2-PGTW)
	- & +6D0RGTW2QGTW*4)/(QGTW(QGTW-RGTWPGTW)*4)
	- ELSE
	- FC1=PARU(1)AS38D0/(27D0SQMQQRSH)*
	- & (9D0RGTW2PGTW*4
	- & (RGTW*4-2D0RGTW*2PGTW+PGTW**2)
	- & -6D0RGTWPGTW*3QGTW*
	- & (2D0RGTW4-5D0RGTW*2PGTW+PGTW**2)
	- & -PGTW*2QGTW*2(RGTW*4+2D0RGTW*2PGTW-PGTW**2)
	- & +2D0RGTWPGTWQGTW3(RGTW**2-PGTW)
	- & +6D0RGTW2QGTW*4)/(QGTW(QGTW-RGTWPGTW)*4)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=COMFAC*FC1
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=COMFAC2D0FC1
	- 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=(SHTH+THUH+UH*SH)/SH2
	- QGTW=(SHTHUH)/SH**3
	- RGTW=SQMQQ/SH
	- IF(MSTP(145).EQ.0) THEN
	- FACQQG=COMFACPARU(1)AS*38D0/(3D0SQMQQRSH)*
	- & PGTW*2(RGTWPGTW2(RGTW*2-4D0PGTW)
	- & +2D0QGTW(-RGTW*4+5D0RGTW*2PGTW+PGTW**2)
	- & -15D0RGTWQGTW*2)/(QGTW-RGTWPGTW)**4
	- ELSE
	- FF=4D0/3D0PARU(1)AS*3SQMQQR/SHTH22/THUH22/UHSH2**2
	- C1=(4D0PGTW5+23D0PGTW*2QGTW**2
	- & +(-14D0PGTW3QGTW+3D0QGTW3)RGTW
	- & -(PGTW*4+2D0PGTWQGTW2)RGTW**2
	- & +3D0PGTW2QGTWRGTW3)SH2**5
	- C2=2D0SHTH2(SH2THUH(SHTHUH(SH-TH)*(SH-UH)
	- & -THUH(TH-UH)2)+SH22(TH-UH)(TH2+UH2-SH*THUH)
	- & (PGTW2-QGTW(SH+2D0*UH)/SH))
	- C3=2D0UHSH2(SH2THUH(SHTHUH(SH-TH)*(SH-UH)
	- & -THUH(TH-UH)2)-SH22(TH-UH)(TH2+UH2-SH*THUH)
	- & (PGTW2-QGTW(SH+2D0*TH)/SH))
	- C4=-4D0THUH(TH-UH)*2
	- & (TH*3UH3+SH22(2D0TH+UH)(TH+2D0UH)
	- & -SH2THUH*(TH2+UH2))
	- & +4D0THUH2(SH*3(SH22+TH22+UH2**2)
	- & -SHTHUH(SH22+THUH(TH2-3D0TH*UH+UH2)
	- & +SH2(5D0THUH2-17D0THUH)))
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	- & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-C1+C2EL1K11EL2K11+C3EL1K21*EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0)
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	- & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-C1+C2EL1K11EL2K11+C3EL1K21EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=C2EL1K11EL2K10+C3EL1K21EL2K20
	- & +C4(EL1K11EL2K20+EL1K21*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=C2EL1K11EL2K11+C3EL1K21EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=(SHTH+THUH+UH*SH)/SH2
	- QGTW=(SHTHUH)/SH**3
	- RGTW=SQMQQ/SH
	- IF(MSTP(145).EQ.0) THEN
	- FACQQG=COMFACPARU(1)AS*38D0/(9D0SQMQQRSH)*
	- & (12D0RGTW2PGTW*4
	- & (RGTW*4-2D0RGTW*2PGTW+PGTW**2)
	- & -3D0RGTWPGTW*3QGTW*
	- & (8D0RGTW4-RGTW2PGTW+4D0PGTW*2)
	- & +2D0PGTW2QGTW*2
	- & (-7D0RGTW4+43D0RGTW*2PGTW+PGTW**2)
	- & +RGTWPGTWQGTW*3(16D0RGTW2-61D0PGTW)
	- & +12D0RGTW2QGTW*4)/(QGTW(QGTW-RGTWPGTW)*4)
	- ELSE
	- FF=(16D0PARU(1)AS*3SQMQQ*SQMQQR)/
	- & (3D0SH2TH2UH2SHTH2*2THUH2*2UHSH2**2)
	- C1=PGTW*2QGTW(PGTWRGTW-QGTW)*2(RGTW*2-2D0PGTW)
	- & SHSH2**7
	- C2=2D0SHTH2(-SH2*3TH23-SH5TH5UH*SHTH
	- & +SH2*2TH2*2UH2(8D0SHTH2-5D0SHTH)
	- & +SH*3TH*3UH*3SHTH(17D0SHTH2-2D0SHTH)
	- & +SH2TH2UH2*2(105D0SH2TH2+64D0SHTH*(SH2+TH2)
	- & +10D0(SH22+TH2*2))
	- & +SH2TH2UH*5SHTH(32D0SHTH2+7D0SHTH)
	- & -UH2*3(SH2*3-87D0SH*3TH3+TH23
	- & -45D0SH2TH2(SH2+TH2)-5D0SHTH(SH22+TH22))
	- & +SHTHUH*7SHTH(7D0SHTH2+12D0SHTH)
	- & +4D0SHTHUH24SHTH2)
	- C3=2D0UHSH2(-SH2*3UH23-SH5UH5TH*UHSH
	- & +SH2*2UH2*2TH2(8D0UHSH2-5D0SHUH)
	- & +SH*3UH*3TH*3UHSH(17D0UHSH2-2D0SHUH)
	- & +SH2UH2TH2*2(105D0SH2UH2+64D0SHUH*(SH2+UH2)
	- & +10D0(SH22+UH2*2))
	- & +SH2UH2TH*5UHSH(32D0UHSH2+7D0SHUH)
	- & -TH2*3(SH2*3-87D0SH*3UH3+UH23
	- & -45D0SH2UH2(SH2+UH2)-5D0SHUH(SH22+UH22))
	- & +SHUHTH*7UHSH(7D0UHSH2+12D0SHUH)
	- & +4D0SHUHTH24UHSH2)
	- C4=-2D0SHTHUHSH(-2D0TH2*3UH2**3
	- & -SH*5TH2UH2THUH(5D0TH+3D0UH)(3D0TH+5D0UH)
	- & +SH2*3(2D0TH+UH)(TH+2D0UH)(TH2-UH2)**2
	- & -SHTH22UH2*2THUH(5D0THUH2-4D0THUH)
	- & -SH2TH3UH*3THUH2(13D0THUH2-16D0THUH)
	- & -SH*3TH2UH2(92D0TH2UH2*THUH
	- & +53D0THUH(TH3+UH3)+11D0(TH5+UH5))
	- & -SH2*2THUH(114D0TH3UH**3
	- & +83D0TH2UH2(TH2+UH2)+28D0THUH(TH22+UH22)
	- & +3D0(TH23+UH2*3)))
	- C5=4D0SHTHUH2SHTH2(2D0SHTH+SHUH+THUH)*2
	- & (2D0UHSQMQQ2+SHTH(SH*TH-UH2))
	- C6=4D0SHUHTH2UHSH2(2D0SHUH+SHTH+THUH)*2
	- & (2D0THSQMQQ2+UHSH(SH*UH-TH2))
	- C7=4D0SHTHUH2SHTH(SH22TH*3(11D0SH+16D0TH)
	- & +SH*3TH2UH(31D0SH2+83D0SHTH+61D0TH2)
	- & +SH2THUH2(19D0SH*3+110D0SH2TH+156D0SH*TH2+
	- & 82D0TH*3)
	- & +SHTHUH*3(43D0SH3+132D0SH2TH+124D0SH*TH2
	- & +45D0TH*3)
	- & +THUH22(37D0SH3+68D0SH2TH+43D0SH*TH2+
	- & 8D0TH*3)
	- & +THUH5(11D0SH2+13D0SHTH+5D0TH2)
	- & +SH*3UH*3(3D0UHSH2-2D0SH*UH)
	- & +TH*5UHSH(5D0UHSH2+2D0SHUH))
	- C8=4D0SHUHTH2UHSH(SH22UH*3(11D0SH+16D0UH)
	- & +SH*3UH2TH(31D0SH2+83D0SHUH+61D0UH2)
	- & +SH2UHTH2(19D0SH*3+110D0SH2UH+156D0SH*UH2+
	- & 82D0UH*3)
	- & +SHUHTH*3(43D0SH3+132D0SH2UH+124D0SH*UH2
	- & +45D0UH*3)
	- & +UHTH22(37D0SH3+68D0SH2UH+43D0SH*UH2+
	- & 8D0UH*3)
	- & +UHTH5(11D0SH2+13D0SHUH+5D0UH2)
	- & +SH*3TH*3(3D0SHTH2-2D0SH*TH)
	- & +UH*5SHTH(5D0SHTH2+2D0SHTH))
	- C9=4D0SHTHUHSH(2D0TH*5UH*5THUH
	- & +4D0SHTH2*2UH2*2THUH2
	- & -SH2TH3UH*3THUH*(TH2+UH2)
	- & -2D0SH3TH2UH2(THUH2*2+2D0THUHTHUH2-TH2*UH2)
	- & +SH2*2THUHTHUH(-THUHTHUH2+3D0(TH22+UH22))
	- & +SH*5(4D0TH2UH2(THUH2-THUH)
	- & +5D0THUH(TH22+UH22)+2D0(TH23+UH23)))
	- C0=-4D0(2D0TH2*3UH2*3SQMQQ
	- & -SH2TH22UH2*2THUH(19D0THUH2-4D0THUH)
	- & -SH*3TH*3UH*3THUH2(32D0THUH2+29D0THUH)
	- & -SH2*2TH2UH2THUH(264D0TH2*UH2
	- & +136D0THUH(TH2+UH2)+15D0(TH22+UH22))
	- & +SH*5THUH(-428D0TH3UH**3
	- & -256D0TH2UH2(TH2+UH2)-43D0THUH(TH22+UH22)
	- & +2D0(TH23+UH2*3))
	- & +SH*7(-46D0TH3UH*3-21D0TH2UH2(TH2+UH2)
	- & +2D0THUH(TH22+UH22)+2D0(TH23+UH23))
	- & +SH2*3THUH(-134TH*3UH*3-53D0TH2UH2(TH2+UH2)
	- & +4D0THUH(TH22+UH22)+2D0(TH23+UH23)))
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=1D0/3D0(C13D0
	- & -C2(2D0EL1K10EL2K10+EL1K11EL2K11)
	- & -C3(2D0EL1K20EL2K20+EL1K21EL2K21)
	- & -C4(2D0EL1K10EL2K20+EL1K11EL2K21)
	- & +C52D0(EL1K10EL2K10-EL1K11EL2K11)**2
	- & +C62D0(EL1K20EL2K20-EL1K21EL2K21)**2
	- & +C72D0(EL1K10EL2K10-EL1K11EL2K11)
	- & (EL1K10EL2K20-EL1K11*EL2K21)
	- & +C82D0(EL1K20EL2K20-EL1K21EL2K21)
	- & (EL1K10EL2K20-EL1K11*EL2K21)
	- & +C92D0(EL1K10EL2K10-EL1K11EL2K11)
	- & (EL1K20EL2K20-EL1K21*EL2K21)
	- & +C02D0(EL1K10EL2K20-EL1K11EL2K21)**2)
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=C1*2D0
	- & -C2(EL1K10EL2K10+EL1K11*EL2K11)
	- & -C3(EL1K20EL2K20+EL1K21*EL2K21)
	- & -C4(EL1K10EL2K20+EL1K11*EL2K21)
	- & +C54D0EL1K10EL2K10EL1K11*EL2K11
	- & +C64D0EL1K20EL2K20EL1K21*EL2K21
	- & +C72D0(EL1K10EL2K10EL1K11*EL2K21
	- & +EL1K10EL2K20EL1K11*EL2K11)
	- & +C82D0(EL1K20EL2K20EL1K11*EL2K21
	- & +EL1K10EL2K20EL1K21*EL2K21)
	- & +C94D0EL1K10EL2K20EL1K11*EL2K21
	- & +C0(EL1K10EL2K10EL1K21EL2K21
	- & +2D0EL1K10EL2K20EL1K11EL2K21
	- & +EL1K20EL2K20EL1K11*EL2K11)
	- ELSEIF(MSTP(147).EQ.2) THEN
	- FACQQG=2D0*(C1
	- & -C2EL1K11EL2K11
	- & -C3EL1K21EL2K21
	- & -C4EL1K11EL2K21
	- & +C5(EL1K11EL2K11)**2
	- & +C6(EL1K21EL2K21)**2
	- & +C7EL1K11EL2K11EL1K11EL2K21
	- & +C8EL1K21EL2K21EL1K11EL2K21
	- & +(C9+C0)(EL1K11EL2K21)**2)
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=-COMFACPARU(1)AS*3(16D0/81D0)*
	- & (TH-3D0SQMQQ)2(SH2+UH2)/(SQMQQRTHUHSH2**2)
	- ELSE
	- FA=-PARU(1)AS3(16D0/243D0)*
	- & (TH-3D0SQMQQ)2(SH2+UH2)/(SQMQQRTHUHSH2**2)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=COMFAC*FA
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=COMFAC2D0FA
	- 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=-COMFACPARU(1)AS*3(32D0/27D0)*
	- & (4D0SQMQQSHUH+TH(SH2+UH2))/(SQMQQRUHSH2*2)
	- ELSE
	- FF=(64D0PARU(1)AS*3SQMQQR)/(27D0UHSH2*2)
	- C1=SH*UH
	- C2=2D0*SH
	- C3=0D0
	- C4=2D0*(SH-UH)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	- & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-C1+C2EL1K11EL2K11+C3EL1K21*EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0)
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	- & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-C1+C2EL1K11EL2K11+C3EL1K21EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=C2EL1K11EL2K10+C3EL1K21EL2K20
	- & +C4(EL1K11EL2K20+EL1K21*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=C2EL1K11EL2K11+C3EL1K21EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=-COMFACPARU(1)AS*3(32D0/81D0)*
	- & ((6D0SQMQQ2+TH2)UHSH2
	- & -2D0SHUH(TH2+6D0SQMQQ*UHSH))/
	- & (SQMQQRTHUHSH2**2)
	- ELSE
	- FF=-(32D0PARU(1)AS*3SQMQQSQMQQR)/(27D0TH2UHSH2*2)
	- C1=TH*UHSH2
	- C2=4D0(SH2+TH2+2D0TH*UHSH)
	- C3=4D0*UHSH2
	- C4=8D0SHUHSH
	- 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(C13D0
	- & -C2(2D0EL1K10EL2K10+EL1K11EL2K11)
	- & -C3(2D0EL1K20EL2K20+EL1K21EL2K21)
	- & -C4(2D0EL1K10EL2K20+EL1K11EL2K21)
	- & +C52D0(EL1K10EL2K10-EL1K11EL2K11)**2
	- & +C62D0(EL1K20EL2K20-EL1K21EL2K21)**2
	- & +C72D0(EL1K10EL2K10-EL1K11EL2K11)
	- & (EL1K10EL2K20-EL1K11*EL2K21)
	- & +C82D0(EL1K20EL2K20-EL1K21EL2K21)
	- & (EL1K10EL2K20-EL1K11*EL2K21)
	- & +C92D0(EL1K10EL2K10-EL1K11EL2K11)
	- & (EL1K20EL2K20-EL1K21*EL2K21)
	- & +C02D0(EL1K10EL2K20-EL1K11EL2K21)**2)
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=C1*2D0
	- & -C2(EL1K10EL2K10+EL1K11*EL2K11)
	- & -C3(EL1K20EL2K20+EL1K21*EL2K21)
	- & -C4(EL1K10EL2K20+EL1K11*EL2K21)
	- & +C54D0EL1K10EL2K10EL1K11*EL2K11
	- & +C64D0EL1K20EL2K20EL1K21*EL2K21
	- & +C72D0(EL1K10EL2K10EL1K11*EL2K21
	- & +EL1K10EL2K20EL1K11*EL2K11)
	- & +C82D0(EL1K20EL2K20EL1K11*EL2K21
	- & +EL1K10EL2K20EL1K21*EL2K21)
	- & +C94D0EL1K10EL2K20EL1K11*EL2K21
	- & +C0(EL1K10EL2K10EL1K21EL2K21
	- & +2D0EL1K10EL2K20EL1K11EL2K21
	- & +EL1K20EL2K20EL1K11*EL2K11)
	- ELSEIF(MSTP(147).EQ.2) THEN
	- FACQQG=2D0*(C1
	- & -C2EL1K11EL2K11
	- & -C3EL1K21EL2K21
	- & -C4EL1K11EL2K21
	- & +C5(EL1K11EL2K11)**2
	- & +C6(EL1K21EL2K21)**2
	- & +C7EL1K11EL2K11EL1K11EL2K21
	- & +C8EL1K21EL2K21EL1K11EL2K21
	- & +(C9+C0)(EL1K11EL2K21)**2)
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=COMFACPARU(1)AS*3(128D0/243D0)*
	- & (SH-3D0SQMQQ)2(TH2+UH2)/(SQMQQRSHTHUH2**2)
	- ELSE
	- FA=PARU(1)AS3(128D0/729D0)*
	- & (SH-3D0SQMQQ)2(TH2+UH2)/(SQMQQRSHTHUH2**2)
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=COMFAC*FA
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=COMFAC2D0FA
	- 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=COMFACPARU(1)AS*3256D0/81D0*
	- & (4D0SQMQQTHUH+SH(TH2+UH2))/(SQMQQRTHUH2*2)
	- ELSE
	- FF=-(512D0PARU(1)AS*3SQMQQR)/(81D0THUH2*2)
	- C1=TH*UH
	- C2=2D0*UH
	- C3=2D0*TH
	- C4=2D0*THUH
	- IF(MSTP(147).EQ.0) THEN
	- FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	- & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=2D0(-C1+C2EL1K11EL2K11+C3EL1K21*EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0)
	- ELSEIF(MSTP(147).EQ.3) THEN
	- FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	- & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.4) THEN
	- FACQQG=-C1+C2EL1K11EL2K11+C3EL1K21EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	- ELSEIF(MSTP(147).EQ.5) THEN
	- FACQQG=C2EL1K11EL2K10+C3EL1K21EL2K20
	- & +C4(EL1K11EL2K20+EL1K21*EL2K10)/2D0
	- ELSEIF(MSTP(147).EQ.6) THEN
	- FACQQG=C2EL1K11EL2K11+C3EL1K21EL2K21
	- & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=COMFACPARU(1)AS*3(256D0/243D0)*
	- & ((6D0SQMQQ2+SH2)THUH2
	- & -2D0THUH(SH2+6D0SQMQQ*THUH))/
	- & (SQMQQRSHTHUH2**2)
	- ELSE
	- FF=(256D0PARU(1)AS*3SQMQQSQMQQR)/(81D0SH2THUH2*2)
	- C1=SH*THUH2
	- C2=4D0(SH2+UH2+2D0SH*THUH)
	- C3=4D0(SH2+TH2+2D0SH*THUH)
	- C4=8D0(SH2-THUH+2D0SHTHUH)
	- 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(C13D0
	- & -C2(2D0EL1K10EL2K10+EL1K11EL2K11)
	- & -C3(2D0EL1K20EL2K20+EL1K21EL2K21)
	- & -C4(2D0EL1K10EL2K20+EL1K11EL2K21)
	- & +C52D0(EL1K10EL2K10-EL1K11EL2K11)**2
	- & +C62D0(EL1K20EL2K20-EL1K21EL2K21)**2
	- & +C72D0(EL1K10EL2K10-EL1K11EL2K11)
	- & (EL1K10EL2K20-EL1K11*EL2K21)
	- & +C82D0(EL1K20EL2K20-EL1K21EL2K21)
	- & (EL1K10EL2K20-EL1K11*EL2K21)
	- & +C92D0(EL1K10EL2K10-EL1K11EL2K11)
	- & (EL1K20EL2K20-EL1K21*EL2K21)
	- & +C02D0(EL1K10EL2K20-EL1K11EL2K21)**2)
	- ELSEIF(MSTP(147).EQ.1) THEN
	- FACQQG=C1*2D0
	- & -C2(EL1K10EL2K10+EL1K11*EL2K11)
	- & -C3(EL1K20EL2K20+EL1K21*EL2K21)
	- & -C4(EL1K10EL2K20+EL1K11*EL2K21)
	- & +C54D0EL1K10EL2K10EL1K11*EL2K11
	- & +C64D0EL1K20EL2K20EL1K21*EL2K21
	- & +C72D0(EL1K10EL2K10EL1K11*EL2K21
	- & +EL1K10EL2K20EL1K11*EL2K11)
	- & +C82D0(EL1K20EL2K20EL1K11*EL2K21
	- & +EL1K10EL2K20EL1K21*EL2K21)
	- & +C94D0EL1K10EL2K20EL1K11*EL2K21
	- & +C0(EL1K10EL2K10EL1K21EL2K21
	- & +2D0EL1K10EL2K20EL1K11EL2K21
	- & +EL1K20EL2K20EL1K11*EL2K11)
	- ELSEIF(MSTP(147).EQ.2) THEN
	- FACQQG=2D0*(C1
	- & -C2EL1K11EL2K11
	- & -C3EL1K21EL2K21
	- & -C4EL1K11EL2K21
	- & +C5(EL1K11EL2K11)**2
	- & +C6(EL1K21EL2K21)**2
	- & +C7EL1K11EL2K11EL1K11EL2K21
	- & +C8EL1K21EL2K21EL1K11EL2K21
	- & +(C9+C0)(EL1K11EL2K21)**2)
	- ENDIF
	- FACQQG=COMFACFFFACQQG
	- 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=4D0COMFAC3D0
	- HP0=AEM/3D0*SH
	- HP1=AEM/3D0XWCSH
	- 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-4D0EIXWV
	- 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(EI2/SH2HI0HP0VINT(111)+
	- & EIVI(1D0-SQMZ/SH)/((SH-SQMZ)2+HS2)*
	- & (HI0HP1+HI1HP0)VINT(112)+(VI2+AI*2)/
	- & ((SH-SQMZ)2+HS2)HI1HP1*VINT(114))
	- 100 CONTINUE
	-
	- ELSEIF(ISUB.EQ.2) THEN
	-C...f + fbar' -> W+/-
	- CALL PYWIDT(24,SH,WDTP,WDTE)
	- HS=SHR*WDTP(0)
	- FACBW=4D0COMFAC/((SH-SQMW)2+HS2)3D0
	- HP=AEM/(24D0XW)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=HIVCKM((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)=HIFACBWHF
	- 110 CONTINUE
	- 120 CONTINUE
	-
	- ELSEIF(ISUB.EQ.15) THEN
	-C...f + fbar -> g + (gamma/Z0) (q + qbar -> g + (gamma/Z0) only)
	- FACZG=COMFACASAEM(8D0/9D0)(TH2+UH2+2D0SQM4SH)/(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-4D0EFXWV
	- ELSEIF(I.LE.16) THEN
	- EF=KCHG(I+2,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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+FCOFEF2(1D0+2D0RM1)BE34
	- HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	- HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	- & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	- HFGZ=HFGZHFAEMVINT(112)/SQM4
	- HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACZG(EI2HFGG+EIVIHFGZ+
	- & (VI2+AI2)*HFZZ)/HBW4
	- 140 CONTINUE
	-
	- ELSEIF(ISUB.EQ.16) THEN
	-C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
	- FACWG=COMFACASAEM/XW2D0/9D0(TH2+UH2+2D0SQM4SH)/(TH*UH)
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	- CALL PYWIDT(24,SQM4,WDTP,WDTE)
	- GMMWC=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	- 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)=FACWGFCKMWIDSC
	- 150 CONTINUE
	- 160 CONTINUE
	-
	- ELSEIF(ISUB.EQ.19) THEN
	-C...f + fbar -> gamma + (gamma*/Z0)
	- FACGZ=COMFAC2D0AEM*2(TH2+UH2+2D0SQM4SH)/(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-4D0EFXWV
	- ELSEIF(I.LE.16) THEN
	- EF=KCHG(I+2,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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+FCOFEF2(1D0+2D0RM1)BE34
	- HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	- HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	- & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	- HFGZ=HFGZHFAEMVINT(112)/SQM4
	- HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	- 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)=FACGZFCOIEI*2(EI*2HFGG+EIVIHFGZ+
	- & (VI2+AI2)*HFZZ)/HBW4
	- 180 CONTINUE
	-
	- ELSEIF(ISUB.EQ.20) THEN
	-C...f + fbar' -> gamma + W+/-
	- FACGW=COMFAC0.5D0AEM**2/XW
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	- CALL PYWIDT(24,SQM4,WDTP,WDTE)
	- GMMWC=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	- FACGW=FACGW*HBW4C/HBW4
	-C...Anomalous couplings
	- TERM1=(TH2+UH2+2D0SQM4SH)/(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.5D0RTCM(46)2(THUH+(TH2+UH2)SH/
	- & (4D0SQMW))/(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=TERM1FACWR2+TERM2FACWR+TERM3
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACGWFACWKFCOIFCKMWIDSC
	- 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=COMFACAEM2((TH2+UH2+2D0(SQM3+SQM4)SH)/(TH*UH)-
	- & SQM3SQM4(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-4D0EFXWV
	- ELSEIF(I.LE.16) THEN
	- EF=KCHG(I+2,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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)+FCOFEF2(1D0+2D0RM1)BE34
	- HGZ(2,IMDM)=HGZ(2,IMDM)+FCOFEFVF(1D0+2D0RM1)*BE34
	- HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF(VF2(1D0+2D0*RM1)+
	- & AF*2(1D0-4D0RM1))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)+FCOFEF2(1D0+2D0RM1)BE34
	- HGZ(5,IMDM)=HGZ(5,IMDM)+FCOFEFVF(1D0+2D0RM1)*BE34
	- HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF(VF2(1D0+2D0*RM1)+
	- & AF*2(1D0-4D0RM1))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)HFAEMVINT(111)/SQM3
	- HGZ(2,J)=HGZ(2,J)HFAEMVINT(112)/SQM3
	- HGZ(3,J)=HGZ(3,J)HFAEMVINT(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)HFAEMVINT(111)/SQM4
	- HGZ(5,J)=HGZ(5,J)HFAEMVINT(112)/SQM4
	- HGZ(6,J)=HGZ(6,J)HFAEMVINT(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-4D0EIXWV
	- VALI=VI-AI
	- VARI=VI+AI
	- FCOI=1D0
	- IF(IABS(I).LE.10) FCOI=FACA/3D0
	- DO 260 J=1,3
	- HL3(J)=EI*2HGZ(1,J)+EIVALIHGZ(2,J)+VALI*2HGZ(3,J)
	- HR3(J)=EI*2HGZ(1,J)+EIVARIHGZ(2,J)+VARI*2HGZ(3,J)
	- HL4(J)=EI*2HGZ(4,J)+EIVALIHGZ(5,J)+VALI*2HGZ(6,J)
	- HR4(J)=EI*2HGZ(4,J)+EIVARIHGZ(5,J)+VARI*2HGZ(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.5D0FACZZFCOIFACLR/(HBW3HBW4)
	- 270 CONTINUE
	-
	- ELSEIF(ISUB.EQ.23) THEN
	-C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
	- FACZW=COMFAC0.5D0(AEM/XW)**2
	- FACZW=FACZW*WIDS(23,2)
	- THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	- FACBW=1D0/((SH-SQMW)2+GMMW2)
	- 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-4D0EIXWV
	- EJ=KCHG(JA,1)/3D0
	- AJ=SIGN(1D0,EJ+0.1D0)
	- VJ=AJ-4D0EJXWV
	- 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)=FACZWFCOIFCKM(FACBW((9D0-8D0XW)/4D0THUH+
	- & (8D0XW-6D0)/4D0SH(SQM3+SQM4))+(THUH-SH(SQM3+SQM4))*
	- & (SH-SQMW)FACBW0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
	- & THUH/(16D0XW1)((VJ+AJ)2/TH2+(VI+AI)2/UH2)+
	- & SH(SQM3+SQM4)/(8D0XW1)(VI+AI)(VJ+AJ)/(THUH))
	- & 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=SH2/((SH-SQMZ)2+GMMZC**2)
	- HBW3=GMMW/((SQM3-SQMW)2+GMMW2)
	- CALL PYWIDT(24,SQM3,WDTP,WDTE)
	- GMMW3=SQRT(SQM3)*WDTP(0)
	- HBW3C=GMMW3/((SQM3-SQMW)2+GMMW32)
	- HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	- CALL PYWIDT(24,SQM4,WDTP,WDTE)
	- GMMW4=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMW4/((SQM4-SQMW)2+GMMW42)
	-C...Kinematical functions
	- THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	- THUH34=(2D0SH(SQM3+SQM4)+THUH)/(SQM3*SQM4)
	- GS=(((SH-SQM3-SQM4)*2-4D0SQM3SQM4)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/(4D0XW)HBWZC(1D0-SQMZ/SH)
	- CZZ=AEM*2/(32D0XW*2)HBWZC
	- CNG=AEM*2/(4D0XW)
	- CNZ=AEM*2/(16D0XW*2)HBWZC*(1D0-SQMZ/SH)
	- CNN=AEM*2/(16D0XW**2)
	-C...Coulomb factor for W+W- pair
	- IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
	- COULE=(SH-4D0SQMW)/(4D0PMAS(24,1))
	- COULP=MAX(1D-10,0.5D0BE34SQRT(SH))
	- IF(COULE.LT.100D0*PMAS(24,2)) THEN
	- COULP1=SQRT(0.5D0PMAS(24,1)(SQRT(COULE**2+
	- & PMAS(24,2)**2)-COULE))
	- ELSE
	- COULP1=SQRT(0.5D0PMAS(24,1)(0.5D0PMAS(24,2)*2/COULE))
	- ENDIF
	- IF(COULE.GT.-100D0*PMAS(24,2)) THEN
	- COULP2=SQRT(0.5D0PMAS(24,1)(SQRT(COULE**2+
	- & PMAS(24,2)**2)+COULE))
	- ELSE
	- COULP2=SQRT(0.5D0PMAS(24,1)(0.5D0PMAS(24,2)*2/
	- & ABS(COULE)))
	- ENDIF
	- IF(MSTP(40).EQ.1) THEN
	- COULDC=PARU(1)-2D0ATAN((COULP12+COULP22-COULP*2)/
	- & MAX(1D-10,2D0COULPCOULP1))
	- FACCOU=1D0+0.5D0PARU(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))/
	- & (4D0COULCP)LOG(COULCD)
	- COULCS=DCMPLX(0D0,0D0)
	- NSTP=100
	- DO 300 ISTP=1,NSTP
	- COULXX=(ISTP-0.5)/NSTP
	- COULCS=COULCS+(1D0/COULXX)LOG((1D0+COULXXCOULCD)/
	- & (1D0+COULXX/COULCD))
	- 300 CONTINUE
	- COULCR=COULCR+DBLE(PARU(101)*2SH)/(16D0COULCPCOULCK)*
	- & (COULCS/NSTP)
	- FACCOU=ABS(COULCR)**2
	- ELSEIF(MSTP(40).EQ.3) THEN
	- COULDC=PARU(1)-2D0(1D0-BE34)2ATAN((COULP1**2+
	- & COULP22-COULP2)/MAX(1D-10,2D0COULPCOULP1))
	- FACCOU=1D0+0.5D0PARU(101)COULDC/MAX(1D-5,BE34)
	- ENDIF
	- ELSEIF(MSTP(40).EQ.4) THEN
	- FACCOU=1D0+0.5D0PARU(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-4D0EIXWV
	- 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=(CGGEI2+CGZVIEI+CZZ(VI2+AI2))*GS+
	- & (CNGEI+CNZ(VI+AI))GST+CNNGT
	- ELSE
	- DSIGWW=(CGGEI2+CGZVIEI+CZZ(VI2+AI2))*GS-
	- & (CNGEI+CNZ(VI+AI))GSU+CNNGU
	- 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+(4D0BET2GAT2+3D0/GAT2)*STHE2)
	- AMPNU=BET(2D0+BET2GAT*2STHE2/2D0+
	- & 2D0BET2(1D0-BET*2)STHE2/(1D0-2D0BETCTH+BET2)2)
	- AMPNG=BET((1D0+BET2)(4D0+BET*2GAT*2STHE2)+
	- & 2D0(1D0-BET2)(BET*2STHE2-2D0(1D0-BET*2))/
	- & (1D0-2D0BETCTH+BET**2))
	- PROPI1=(0.25D0SQMZ/XMW02)HBWZC*(1D0-SQMZ/SH)
	- PROPI2=(0.25D0SQMZ/XMW02)2HBWZC
	- A0=(2D0(XMW02/SQMZ)-(1D0-BET2)XW)*POLL
	- A1=(2D0(XMW02/SQMZ)2-2XMW02/SQMZ(1D0-BET2)XW)*POLL
	- A2=(1D0-BET2)2XW2(POLR+POLL)/2D0
	- ATOT=AMPNUPOLL+(A1+A2)PROPI2AMPZG-A0PROPI1*AMPNG
	- ATOT=ATOTCNN/SQMWSH/BET*2D0
	- DSIGWW=ATOT
	- ENDIF
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACWWFCOIDSIGWW
	- 310 CONTINUE
	-
	- ELSEIF(ISUB.EQ.30) THEN
	-C...f + g -> f + (gamma/Z0) (q + g -> q + (gamma/Z0) only)
	- FZQ=COMFACFACAASAEM(1D0/3D0)(SH2+UH2+2D0SQM4*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-4D0EFXWV
	- ELSEIF(I.LE.16) THEN
	- EF=KCHG(I+2,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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+FCOFEF2(1D0+2D0RM1)BE34
	- HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	- HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	- & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	- HFGZ=HFGZHFAEMVINT(112)/SQM4
	- HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	- FACZQ=FZQ(EI2HFGG+EIVIHFGZ+
	- & (VI2+AI2)*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=COMFACFACAASAEM/XW1D0/12D0*
	- & (SH2+UH2+2D0SQM4TH)/(-SH*UH)
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	- CALL PYWIDT(24,SQM4,WDTP,WDTE)
	- GMMWC=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	- 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)=FACWQVINT(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)*2SQM4-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)*2SQM4-SH(UH-VINT(3)*2)
	- ELSE
	- FZQN=SH2+UH2+2D0SQM4TH
	- FZQDTM=-SH*UH
	- ENDIF
	- FZQN=COMFAC2D0AEM*2MAX(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-4D0EFXWV
	- ELSEIF(I.LE.16) THEN
	- EF=KCHG(I+2,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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+FCOFEF2(1D0+2D0RM1)BE34
	- HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	- HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	- & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	- HFGZ=HFGZHFAEMVINT(112)/SQM4
	- HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	- FACZQ=EI*2(EI*2HFGG+EIVIHFGZ+
	- & (VI2+AI2)*HFZZ)/HBW4
	- FZQD=MAX(PMAS(IABS(I),1)*2SQM4,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=COMFACAEM2/(2D0XW)*
	- & (SH2+UH2+2D0SQM4TH)/(SQPTHSQM4-SHUH)
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	- CALL PYWIDT(24,SQM4,WDTP,WDTE)
	- GMMWC=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	- 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)=FACWQVINT(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.5D0SQMW,SQRT(SQM3SQM4))
	- FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
	- FACWW=COMFAC6D0AEM*2(1D0-FPROP(4D0/3D0+2D0SQMWE/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.5D0SQMW,SQRT(SQM3SQM4))
	- FPROP=(TH-SQMWE)*2/(-SH(SQMWE-UH))
	- FACZW=COMFAC6D0AEM*2(XW1/XW)*
	- & (1D0-FPROP(4D0/3D0+2D0SQMWE/(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,24KCHW).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/(288D0PARU(1)2)+(PARP(47)/PARP(45))2)
	- HDTLQ=LOG(PARP(45)/PARP(44))
	- HDTMR=-(4D0PARU(1))20.5D0*HDTNM+HDTLQ/12D0
	- HDTNR=(4D0PARU(1))2HDTNM+HDTLQ/6D0
	- ENDIF
	-
	-C...Calculate lowest and next-to-lowest order partial wave amplitudes
	- HDTV=1D0/(16D0PARU(1)PARP(47)**2)
	- A00L=DBLE(HDTV*SH)
	- A20L=-0.5D0*A00L
	- A11L=A00L/6D0
	- HDTLS=LOG(SH/PARP(44)**2)
	- A004=DBLE((HDTVSH)2/(4D0PARU(1)))*
	- & CMPLX(DBLE((176D0HDTMR+112D0HDTNR)/3D0+11D0/27D0-
	- & (50D0/9D0)HDTLS),DBLE(4D0PARU(1)))
	- A204=DBLE((HDTVSH)2/(4D0PARU(1)))*
	- & CMPLX(DBLE(32D0(HDTMR+2D0HDTNR)/3D0+25D0/54D0-
	- & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
	- A114=DBLE((HDTVSH)2/(6D0PARU(1)))*
	- & CMPLX(DBLE(4D0(-2D0HDTMR+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=4D0COMFAC/((SH-SQMH)2+HS*2)
	- IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
	- & FACBW=0D0
	- HP=AEM/(8D0XW)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=HPRMQFACA/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=HIPARU(150+10IHIGG+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+10IHIGG))*2
	- ENDIF
	- ENDIF
	- ENDIF
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=HIFACBWHF
	- 100 CONTINUE
	-
	- ELSEIF(ISUB.EQ.5) THEN
	-C...Z0 + Z0 -> h0
	- CALL PYWIDT(25,SH,WDTP,WDTE)
	- HS=SHR*WDTP(0)
	- FACBW=4D0COMFAC/((SH-SQMH)2+HS*2)
	- IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
	- HP=AEM/(8D0XW)SH/SQMW*SH
	- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
	- HI=HP/4D0
	- FACI=8D0/(PARU(1)*2XW1)(AEMXWC)**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-4D0EIXWV
	- EJ=KCHG(IABS(J),1)/3D0
	- AJ=SIGN(1D0,EJ)
	- VJ=AJ-4D0EJXWV
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACI(VI2+AI2)(VJ2+AJ2)HIFACBW*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=4D0COMFAC/((SH-SQMH)2+HS*2)
	- IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
	- HP=AEM/(8D0XW)SH/SQMW*SH
	- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
	- HI=HP/2D0
	- FACI=1D0/(4D0PARU(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)=FACIVINT(180+I)VINT(180+J)HIFACBW*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+GMMZ2)
	- CALL PYWIDT(23,SQM3,WDTP,WDTE)
	- GMMZ3=SQRT(SQM3)*WDTP(0)
	- HBW3C=GMMZ3/((SQM3-SQMZ)2+GMMZ32)
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
	- GMMH4=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	- THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	- FACHZ=COMFAC(HBW3C/HBW3)(HBW4C/HBW4)8D0(AEMXWC)2
	- & (THUH+2D0SHSQM3)/((SH-SQMZ)2+GMMZ2)
	- FACHZ=FACHZWIDS(23,2)WIDS(KFHIGG,2)
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
	- & PARU(154+10IHIGG)*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-4D0EIXWV
	- 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)=FACHZFCOI(VI2+AI2)
	- 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+GMMW2)
	- CALL PYWIDT(24,SQM3,WDTP,WDTE)
	- GMMW3=SQRT(SQM3)*WDTP(0)
	- HBW3C=GMMW3/((SQM3-SQMW)2+GMMW32)
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
	- GMMH4=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	- THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	- FACHW=COMFAC0.125D0(AEM/XW)*2(THUH+2D0SHSQM3)/
	- & ((SH-SQMW)2+GMMW2)(HBW3C/HBW3)(HBW4C/HBW4)
	- FACHW=FACHW*WIDS(KFHIGG,2)
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
	- & PARU(155+10IHIGG)*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)=FACHWFCOIFCKM*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=COMFACFACAASAEM/XW1D0/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+GMMHC2)
	- CALL PYWIDT(25,SQM4,WDTP,WDTE)
	- GMMHCC=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMHCC/((SQM4-SQMHC)2+GMMHCC2)
	- 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=FHCQSQML/SQMW
	- & (SH/(SQMQ-UH)+2D0SQMQ(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
	- & 2D0SQMQ/(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.5D0SHBE2*(1D0-CTH)
	- UH=-0.5D0SHBE2*(1D0+CTH)
	- IF(MAX(TH,UH).GT.-1D0) GOTO 220
	- SHANG=1D0/XW1SQMW/SQMZ(1D0+BE2)**2
	- ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	- ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	- THANG=1D0/XW1SQMW/SQMZ(BE2-CTH)**2
	- ATHRE=(TH-SQMH)/((TH-SQMH)2+GMMH2)*THANG
	- ATHIM=-GMMH/((TH-SQMH)2+GMMH2)*THANG
	- UHANG=1D0/XW1SQMW/SQMZ(BE2+CTH)**2
	- AUHRE=(UH-SQMH)/((UH-SQMH)2+GMMH2)*UHANG
	- AUHIM=-GMMH/((UH-SQMH)2+GMMH2)*UHANG
	- FACZZ=COMFAC1D0/(4096D0PARU(1)*216D0XW12)
	- & (AEM/XW)*4(SH/SQMW)*2(SQMZ/SQMW)*SH2
	- IF(MSTP(46).LE.0) FACZZ=FACZZ(ASHRE2+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/(16D0PARU(1)XWXW1))*2(64D0/9D0)*
	- & ABS(A00U+2D0A20U)*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-4D0EIXWV
	- AVI=AI2+VI2
	- 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-4D0EJXWV
	- AVJ=AJ2+VJ2
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=0.5D0FACZZAVI*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-4D0SQMW/SH)(1D0-4D0*SQMZ/SH))
	- CTH2=CTH**2
	- TH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH-BE2CTH)
	- UH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH+BE2CTH)
	- IF(MAX(TH,UH).GT.-1D0) GOTO 250
	- SHANG=4D0SQRT(SQMW/(SQMZXW1))(1D0-2D0SQMW/SH)*
	- & (1D0-2D0*SQMZ/SH)
	- ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	- ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	- ATWRE=XW1/SQMZSH/(TH-SQMW)((CTH-BE2)*2(3D0/2D0+BE2/2D0*
	- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	- & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	- & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2+
	- & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	- ATWIM=0D0
	- AUWRE=XW1/SQMZSH/(UH-SQMW)((CTH+BE2)*2(3D0/2D0-BE2/2D0*
	- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	- & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	- & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2-
	- & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	- AUWIM=0D0
	- A4RE=2D0XW1/SQMZ(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
	- A4IM=0D0
	- FACWW=COMFAC1D0/(4096D0PARU(1)*216D0XW12)
	- & (AEM/XW)*4(SH/SQMW)*2(SQMZ/SQMW)*SH2
	- IF(MSTP(46).LE.0) FACWW=FACWW(ASHRE2+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/(16D0PARU(1)XWXW1))*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-4D0EIXWV
	- AVI=AI2+VI2
	- 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-4D0EJXWV
	- AVJ=AJ2+VJ2
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACWWAVIAVJ
	- 230 CONTINUE
	- 240 CONTINUE
	- 250 CONTINUE
	-
	- ELSEIF(ISUB.EQ.73) THEN
	-C...Z0 + W+/- -> Z0 + W+/-
	- IF(SH.LE.2D0SQMZ+2D0SQMW) 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.5D0SHBE2*(1D0-CTH)
	- UH=(SQMZ-SQMW)*2/SH-0.5D0SHBE2(1D0+CTH)
	- IF(MAX(TH,UH).GT.-1D0) GOTO 280
	- THANG=(BE2-EP1CTH)(BE2-EP2*CTH)
	- ATHRE=(TH-SQMH)/((TH-SQMH)2+GMMH2)*THANG
	- ATHIM=-GMMH/((TH-SQMH)2+GMMH2)*THANG
	- ASWRE=-XW1/SQMZSH/(SH-SQMW)(-BE2(EP1+EP2)4CTH+
	- & 1D0/4D0(BE2+EP1EP2)*2((EP1-EP2)*2-4D0BE2*CTH)+
	- & 2D0BE2(BE2+EP1EP2)(EP1+EP2)*2CTH-
	- & 1D0/16D0SH/SQMW(EP12-EP22)*2(BE2+EP1EP2)*2)
	- ASWIM=0D0
	- AUWRE=XW1/SQMZSH/(UH-SQMW)(-BE2(EP2+EP1CTH)*
	- & (EP1+EP2CTH)(BE2+EP1EP2)+BE2(EP2+EP1CTH)
	- & (BE2+EP1EP2CTH)(2D0EP2-EP2*CTH+EP1)-
	- & BE2(EP2+EP1CTH)*2(BE2-EP2*2CTH)-1D0/8D0*
	- & (BE2+EP1EP2CTH)*2((EP1+EP2)*2+2D0BE2*(1D0-CTH))+
	- & 1D0/32D0SH/SQMW(BE2+EP1EP2CTH)*2
	- & (EP12-EP22)*2-BE2(EP1+EP2CTH)(EP2+EP1CTH)
	- & (BE2+EP1EP2)+BE2(EP1+EP2CTH)(BE2+EP1EP2CTH)*
	- & (2D0EP1-EP1CTH+EP2)-BE2(EP1+EP2CTH)*2
	- & (BE2-EP1*2CTH)-1D0/8D0(BE2+EP1EP2CTH)2
	- & ((EP1+EP2)*2+2D0BE2(1D0-CTH))+1D0/32D0SH/SQMW*
	- & (BE2+EP1EP2CTH)*2(EP12-EP22)**2)
	- AUWIM=0D0
	- A4RE=XW1/SQMZ(EP12EP2*2(CTH**2-1D0)-
	- & 2D0BE2(EP12+EP22+EP1EP2)CTH-2D0BE2EP1*EP2)
	- A4IM=0D0
	- FACZW=COMFAC1D0/(4096D0PARU(1)*24D0XW1)(AEM/XW)*4
	- & (SH/SQMW)*2SQRT(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=COMFACAEM2/(64D0PARU(1)*2XW*2XW1)16D0
	- & ABS(A20U+3D0A11UDBLE(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-4D0EIXWV
	- AVI=AI2+VI2
	- 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-4D0EJXWV
	- AVJ=AJ2+VJ2
	- 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)=FACZWAVIVINT(180+J)*WIDS(24,(5-KCHWJ)/2)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=FACZWVINT(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-4D0SQMW/SH)(1D0-4D0*SQMZ/SH))
	- CTH2=CTH**2
	- TH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH-BE2CTH)
	- UH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH+BE2CTH)
	- IF(MAX(TH,UH).GT.-1D0) GOTO 310
	- SHANG=4D0SQRT(SQMW/(SQMZXW1))(1D0-2D0SQMW/SH)*
	- & (1D0-2D0*SQMZ/SH)
	- ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	- ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	- ATWRE=XW1/SQMZSH/(TH-SQMW)((CTH-BE2)*2(3D0/2D0+BE2/2D0*
	- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	- & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	- & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2+
	- & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	- ATWIM=0D0
	- AUWRE=XW1/SQMZSH/(UH-SQMW)((CTH+BE2)*2(3D0/2D0-BE2/2D0*
	- & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	- & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	- & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2-
	- & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	- AUWIM=0D0
	- A4RE=2D0XW1/SQMZ(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
	- A4IM=0D0
	- FACZZ=COMFAC1D0/(4096D0PARU(1)*2)(AEM/XW)*4
	- & (SH/SQMW)*2SH2
	- IF(MSTP(46).LE.0) FACZZ=FACZZ(ASHRE2+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/(4D0PARU(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.5D0FACZZVINT(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.5D0SHBE2*(1D0-CTH)
	- UH=-0.5D0SHBE2*(1D0+CTH)
	- IF(MAX(TH,UH).GT.-1D0) GOTO 340
	- SHANG=(1D0+BE2)**2
	- ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	- ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	- THANG=(BE2-CTH)**2
	- ATHRE=(TH-SQMH)/((TH-SQMH)2+GMMH2)*THANG
	- ATHIM=-GMMH/((TH-SQMH)2+GMMH2)*THANG
	- UHANG=(BE2+CTH)**2
	- AUHRE=(UH-SQMH)/((UH-SQMH)2+GMMH2)*UHANG
	- AUHIM=-GMMH/((UH-SQMH)2+GMMH2)*UHANG
	- SGZANG=1D0/SQMWBE2(3D0-BE2)*2CTH
	- ASGRE=XW*SGZANG
	- ASGIM=0D0
	- ASZRE=XW1SH/(SH-SQMZ)SGZANG
	- ASZIM=0D0
	- TGZANG=1D0/SQMW(BE2(4D0-2D0BE2+BE4)+BE2(4D0-10D0*BE2+
	- & BE4)CTH+(2D0-11D0BE2+10D0BE4)CTH2+BE2*CTH3)
	- ATGRE=0.5D0XWSH/TH*TGZANG
	- ATGIM=0D0
	- ATZRE=0.5D0XW1SH/(TH-SQMZ)*TGZANG
	- ATZIM=0D0
	- UGZANG=1D0/SQMW(BE2(4D0-2D0BE2+BE4)-BE2(4D0-10D0*BE2+
	- & BE4)CTH+(2D0-11D0BE2+10D0BE4)CTH2-BE2*CTH3)
	- AUGRE=0.5D0XWSH/UH*UGZANG
	- AUGIM=0D0
	- AUZRE=0.5D0XW1SH/(UH-SQMZ)*UGZANG
	- AUZIM=0D0
	- A4ARE=1D0/SQMW(1D0+2D0BE2-6D0BE2CTH-CTH2)
	- A4AIM=0D0
	- A4SRE=2D0/SQMW(1D0+2D0BE2-CTH2)
	- A4SIM=0D0
	- FWW=COMFAC1D0/(4096D0PARU(1)*2)(AEM/XW)*4
	- & (SH/SQMW)*2SH2
	- 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=AWWARE2+AWWAIM2
	- AWWS2=AWWSRE2+AWWSIM2
	-
	- ELSE
	-C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
	- FWWA=COMFAC(AEM/(4D0PARU(1)XW))2(64D0/9D0)*
	- & ABS(A00U+0.5D0A20U+4.5D0A11UDBLE(CTH))*2
	- FWWS=COMFAC(AEM/(4D0PARU(1)XW))264D0ABS(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=FWWAWWA2WIDS(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)=FACWWVINT(180+I)VINT(180+J)
	- IF(EIEJ.GT.0D0) SIGH(NCHN)=0.5D0SIGH(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=4D0COMFAC/((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)=HIFACBWHF
	- 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=4D0COMFAC/((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=SHRWDTP142D0
	- ELSE
	- HI=SHRWDTP(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)=HIFACBWHF
	- 360 CONTINUE
	-
	- ELSEIF(ISUB.EQ.110) THEN
	-C...f + fbar -> gamma + h0
	- THUH=MAX(THUH,SHCKIN(3)**2)
	- FACHG=COMFAC(3D0AEM*4)/(2D0PARU(1)*2XWSQMW)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-4D0EJXWV
	- BALP=SQM4/(2D0PMAS(J,1))*2
	- BBET=SH/(2D0PMAS(J,1))*2
	- ELSEIF(J.LE.3*MSTP(1)) THEN
	- FNC=3D0
	- JL=2(J-2MSTP(1))-1
	- EJ=KCHG(10+JL,1)/3D0
	- AJ=SIGN(1D0,EJ+0.1D0)
	- VJ=AJ-4D0EJXWV
	- BALP=SQM4/(2D0PMAS(10+JL,1))*2
	- BBET=SH/(2D0PMAS(10+JL,1))*2
	- ELSE
	- BALP=SQM4/(2D0PMAS(24,1))*2
	- BBET=SH/(2D0PMAS(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.5D0BABI)+DBLE(BABI2)(DBLE(0.5D0*(1D0-BALP+
	- & BBET))(F1BET-F1ALP)+DBLE(BBET)(F2BET-F2ALP))
	- CIGTOT=CIGTOT+DBLE(FNCEJ2)FIF
	- CIZTOT=CIZTOT+DBLE(FNCEJVJ)*FIF
	- ELSE
	- TXW=XW/XW1
	- CIGTOT=CIGTOT-0.5(DBLE(BABI(1.5D0+BALP))+DBLE(BABI*2)
	- & (DBLE(1.5D0-3D0BALP+4D0BBET)*(F1BET-F1ALP)+
	- & DBLE(BBET(2D0BALP+3D0))*(F2BET-F2ALP)))
	- CIZTOT=CIZTOT-DBLE(0.5D0BABIXW1)(DBLE(5D0-TXW+2D0BALP*
	- & (1D0-TXW))(1D0+DBLE(2D0BABIBBET)(F2BET-F2ALP))+
	- & DBLE(BABI(4D0BBET(3D0-TXW)-(2D0BALP-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-4D0EIXWV
	- 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)=FACHGFCOI(ABS(DBLE(EI)CIGTOT+DBLE(VI)
	- & CIZTOT)2+AI2ABS(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=COMFACFACA(2D0/9D0)AS(WDTP13/SQRT(SQM4))*
	- & (TH2+UH2)/(SH*SQM4)
	- ELSE
	- FACGH=COMFACFACA(2D0/9D0)AS(WDTP(13)/SQRT(SQM4))*
	- & (TH2+UH2)/(SH*SQM4)
	- ENDIF
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- GMMHC=SQRT(SQM4)*WDTP(0)
	- HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
	- & ((SQM4-SQMH)2+GMMHC2)
	- 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=COMFACFACA/(144D0PARU(1)*2)AEM/XWAS3SQMH/SQMW*
	- & SQMH/SH(UH2+TH2)/(UH+TH)2(A5STUR2+A5STUI2)
	- 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=COMFACFACA(1D0/12D0)AS(WDTP13/SQRT(SQM4))*
	- & (SH2+UH2)/(-TH*SQM4)
	- ELSE
	- FACQH=COMFACFACA(1D0/12D0)AS(WDTP(13)/SQRT(SQM4))*
	- & (SH2+UH2)/(-TH*SQM4)
	- ENDIF
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- GMMHC=SQRT(SQM4)*WDTP(0)
	- HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
	- & ((SQM4-SQMH)2+GMMHC2)
	- 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=COMFACFACA/(384D0PARU(1)*2)AEM/XWAS3SQMH/SQMW*
	- & SQMH/(-TH)(UH2+SH2)/(UH+SH)2(A5TSUR2+A5TSUI2)
	- 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=COMFACFACA(3D0/16D0)AS(WDTP13/SQRT(SQM4))*
	- & (SH4+TH4+UH4+SQM44)/(SHTHUH*SQM4)
	- ELSE
	- FACGH=COMFACFACA(3D0/16D0)AS(WDTP(13)/SQRT(SQM4))*
	- & (SH4+TH4+UH4+SQM44)/(SHTHUH*SQM4)
	- ENDIF
	-C...Propagators: as simulated in PYOFSH and as desired
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- GMMHC=SQRT(SQM4)*WDTP(0)
	- HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
	- & ((SQM4-SQMH)2+GMMHC2)
	- 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)+2D0THUH
	- & (UH+2D0SH)/(SH+UH)2(W1TR-W1HR)+(SQMQ-SH/4D0)*
	- & (0.5D0W2SR+0.5D0W2HR-W2TR+W3STUR)+SH2(2D0SQMQ/
	- & (SH+UH)*2-0.5D0/(SH+UH))(W2TR-W2HR)+0.5D0THUH/SH*
	- & (W2HR-2D0W2TR)+0.125D0(SH-12D0SQMQ-4D0THUH/SH)W3TSUR)
	- B2STUI=SQMQ/SQMH*2(2D0THUH(UH+2D0SH)/(SH+UH)*2
	- & (W1TI-W1HI)+(SQMQ-SH/4D0)(0.5D0W2SI+0.5D0*W2HI-W2TI+
	- & W3STUI)+SH2(2D0SQMQ/(SH+UH)*2-0.5D0/(SH+UH))
	- & (W2TI-W2HI)+0.5D0THUH/SH(W2HI-2D0W2TI)+0.125D0*
	- & (SH-12D0SQMQ-4D0THUH/SH)W3TSUI)
	- B2SUTR=SQMQ/SQMH*2(SH(TH-SH)/(SH+TH)+2D0UHTH
	- & (TH+2D0SH)/(SH+TH)2(W1UR-W1HR)+(SQMQ-SH/4D0)*
	- & (0.5D0W2SR+0.5D0W2HR-W2UR+W3SUTR)+SH2(2D0SQMQ/
	- & (SH+TH)*2-0.5D0/(SH+TH))(W2UR-W2HR)+0.5D0UHTH/SH*
	- & (W2HR-2D0W2UR)+0.125D0(SH-12D0SQMQ-4D0UHTH/SH)W3USTR)
	- B2SUTI=SQMQ/SQMH*2(2D0UHTH(TH+2D0SH)/(SH+TH)*2
	- & (W1UI-W1HI)+(SQMQ-SH/4D0)(0.5D0W2SI+0.5D0*W2HI-W2UI+
	- & W3SUTI)+SH2(2D0SQMQ/(SH+TH)*2-0.5D0/(SH+TH))
	- & (W2UI-W2HI)+0.5D0UHTH/SH(W2HI-2D0W2UI)+0.125D0*
	- & (SH-12D0SQMQ-4D0UHTH/SH)W3USTI)
	- B2TSUR=SQMQ/SQMH*2(TH(UH-TH)/(TH+UH)+2D0SHUH
	- & (UH+2D0TH)/(TH+UH)2(W1SR-W1HR)+(SQMQ-TH/4D0)*
	- & (0.5D0W2TR+0.5D0W2HR-W2SR+W3TSUR)+TH2(2D0SQMQ/
	- & (TH+UH)*2-0.5D0/(TH+UH))(W2SR-W2HR)+0.5D0SHUH/TH*
	- & (W2HR-2D0W2SR)+0.125D0(TH-12D0SQMQ-4D0SHUH/TH)W3STUR)
	- B2TSUI=SQMQ/SQMH*2(2D0SHUH(UH+2D0TH)/(TH+UH)*2
	- & (W1SI-W1HI)+(SQMQ-TH/4D0)(0.5D0W2TI+0.5D0*W2HI-W2SI+
	- & W3TSUI)+TH2(2D0SQMQ/(TH+UH)*2-0.5D0/(TH+UH))
	- & (W2SI-W2HI)+0.5D0SHUH/TH(W2HI-2D0W2SI)+0.125D0*
	- & (TH-12D0SQMQ-4D0SHUH/TH)W3STUI)
	- B2TUSR=SQMQ/SQMH*2(TH(SH-TH)/(TH+SH)+2D0UHSH
	- & (SH+2D0TH)/(TH+SH)2(W1UR-W1HR)+(SQMQ-TH/4D0)*
	- & (0.5D0W2TR+0.5D0W2HR-W2UR+W3TUSR)+TH2(2D0SQMQ/
	- & (TH+SH)*2-0.5D0/(TH+SH))(W2UR-W2HR)+0.5D0UHSH/TH*
	- & (W2HR-2D0W2UR)+0.125D0(TH-12D0SQMQ-4D0UHSH/TH)W3UTSR)
	- B2TUSI=SQMQ/SQMH*2(2D0UHSH(SH+2D0TH)/(TH+SH)*2
	- & (W1UI-W1HI)+(SQMQ-TH/4D0)(0.5D0W2TI+0.5D0*W2HI-W2UI+
	- & W3TUSI)+TH2(2D0SQMQ/(TH+SH)*2-0.5D0/(TH+SH))
	- & (W2UI-W2HI)+0.5D0UHSH/TH(W2HI-2D0W2UI)+0.125D0*
	- & (TH-12D0SQMQ-4D0UHSH/TH)W3UTSI)
	- B2USTR=SQMQ/SQMH*2(UH(TH-UH)/(UH+TH)+2D0SHTH
	- & (TH+2D0UH)/(UH+TH)2(W1SR-W1HR)+(SQMQ-UH/4D0)*
	- & (0.5D0W2UR+0.5D0W2HR-W2SR+W3USTR)+UH2(2D0SQMQ/
	- & (UH+TH)*2-0.5D0/(UH+TH))(W2SR-W2HR)+0.5D0SHTH/UH*
	- & (W2HR-2D0W2SR)+0.125D0(UH-12D0SQMQ-4D0SHTH/UH)W3SUTR)
	- B2USTI=SQMQ/SQMH*2(2D0SHTH(TH+2D0UH)/(UH+TH)*2
	- & (W1SI-W1HI)+(SQMQ-UH/4D0)(0.5D0W2UI+0.5D0*W2HI-W2SI+
	- & W3USTI)+UH2(2D0SQMQ/(UH+TH)*2-0.5D0/(UH+TH))
	- & (W2SI-W2HI)+0.5D0SHTH/UH(W2HI-2D0W2SI)+0.125D0*
	- & (UH-12D0SQMQ-4D0SHTH/UH)W3SUTI)
	- B2UTSR=SQMQ/SQMH*2(UH(SH-UH)/(UH+SH)+2D0THSH
	- & (SH+2D0UH)/(UH+SH)2(W1TR-W1HR)+(SQMQ-UH/4D0)*
	- & (0.5D0W2UR+0.5D0W2HR-W2TR+W3UTSR)+UH2(2D0SQMQ/
	- & (UH+SH)*2-0.5D0/(UH+SH))(W2TR-W2HR)+0.5D0THSH/UH*
	- & (W2HR-2D0W2TR)+0.125D0(UH-12D0SQMQ-4D0THSH/UH)W3TUSR)
	- B2UTSI=SQMQ/SQMH*2(2D0THSH(SH+2D0UH)/(UH+SH)*2
	- & (W1TI-W1HI)+(SQMQ-UH/4D0)(0.5D0W2UI+0.5D0*W2HI-W2TI+
	- & W3UTSI)+UH2(2D0SQMQ/(UH+SH)*2-0.5D0/(UH+SH))
	- & (W2TI-W2HI)+0.5D0THSH/UH(W2HI-2D0W2TI)+0.125D0*
	- & (UH-12D0SQMQ-4D0THSH/UH)W3TUSI)
	- B4STUR=0.25D0EPSH(-2D0/3D0+0.25D0(EPSH-1D0)
	- & (W2SR-W2HR+W3STUR))
	- B4STUI=0.25D0EPSH0.25D0(EPSH-1D0)(W2SI-W2HI+W3STUI)
	- B4TUSR=0.25D0EPSH(-2D0/3D0+0.25D0(EPSH-1D0)
	- & (W2TR-W2HR+W3TUSR))
	- B4TUSI=0.25D0EPSH0.25D0(EPSH-1D0)(W2TI-W2HI+W3TUSI)
	- B4USTR=0.25D0EPSH(-2D0/3D0+0.25D0(EPSH-1D0)
	- & (W2UR-W2HR+W3USTR))
	- B4USTI=0.25D0EPSH0.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=COMFACFACA3D0/(128D0PARU(1)2)AEM/XWAS3
	- & SQMH/SQMWSQMH3/(SHTHUH)(A2STUR2+A2STUI2+A2USTR**2+
	- & A2USTI2+A2TUSR2+A2TUSI2+A4STUR2+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(4D0PARU(1)AEM/XW)(4D0PARU(1)AS)*2
	- & (0.5D0PMF/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=FACQQHPARU(150+10IHIGG+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+10IHIGG))*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+HS2)
	- 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)=FACQQHWTQQBHFACBW
	- 460 CONTINUE
	-
	- ELSEIF(ISUB.EQ.122) THEN
	-C...q + qbar -> Q + Qbar + h0
	- IA=KFPR(ISUBSV,2)
	- PMF=PYMRUN(IA,SH)
	- FACQQH=COMFAC(4D0PARU(1)AEM/XW)(4D0PARU(1)AS)*2
	- & (0.5D0PMF/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=FACQQHPARU(150+10IHIGG+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+10IHIGG))*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+HS2)
	- 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)=FACQQHWTQQBHFACBW
	- 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(4D0PARU(1)AEM/(XWXW1))*3SQMZ/32D0
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
	- & PARU(154+10IHIGG)*2
	- FACPRP=1D0/((VINT(215)-VINT(204)*2)
	- & (VINT(216)-VINT(209)2))2
	- FACZZ1=FACNORFACPRP(0.5D0TAUPVINT(2))*VINT(219)
	- FACZZ2=FACNORFACPRPVINT(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+HS2)
	- 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-4D0EIXWV
	- EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
	- AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
	- VJ=AJ-4D0EJXWV
	- FACLR1=(VI2+AI2)(VJ2+AJ2)+4D0VIAIVJ*AJ
	- FACLR2=(VI2+AI2)(VJ2+AJ2)-4D0VIAIVJ*AJ
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=(FACLR1FACZZ1+FACLR2FACZZ2)*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(4D0PARU(1)AEM/XW)3SQMW
	- IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
	- & PARU(155+10IHIGG)*2
	- FACPRP=1D0/((VINT(215)-VINT(204)*2)
	- & (VINT(216)-VINT(209)2))2
	- FACWW=FACNORFACPRP(0.5D0TAUPVINT(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+HS2)
	- 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)=FACLRFACWWFACBW
	- 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=4D0COMFAC/((SH-SQMHC)2+HS*2)
	- HP=AEM/(8D0XW)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(RMLPARU(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)=HIFACBWHF
	- 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=COMFACFACAASAEM/XW1D0/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+GMMHC2)
	- CALL PYWIDT(37,SQM4,WDTP,WDTE)
	- GMMHCC=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMHCC/((SQM4-SQMHC)2+GMMHCC2)
	- 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(SQMLPARU(141)2+SQMQ/PARU(141)2)/SQMW*
	- & (SH/(SQMQ-UH)+2D0SQMQ(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
	- & 2D0SQMQ/(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+HS2)
	- 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)=2d0COMFACWTTBH*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+HS2)
	- 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)=2d0COMFACWTTBH*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-2D0XW)/(2D0XW/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=.5D0PARU(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+GMMS2)
	- CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
	- GMMI=SQRT(SQMI)*WDTP(0)
	- HBWI=GMMI/((SQMI-SQMS)2+GMMI2)
	- 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-EJXW)A1
	- XRQ=(-EJXW)A2
	- XLF=(TT3I-EI*XW)
	- XRF=(-EI*XW)
	- TAA=(EIEJ)2(POLL+POLR)
	- TZZ=(XLF*2POLL+XRF*2POLR)(XLQ+XRQ)2/XW2/XW1*2
	- TZZ=TZZ/((1D0-SQMZ/SH)*2+SQMZZWID/SH**2)
	- TAZ=2D0EIEJ(XLQ+XRQ)(XLFPOLL+XRFPOLR)/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(TT3IZMIX(II,2)-TANW(TT3I-EI)
	- & ZMIX(II,1))
	- FREK=FAC2TANWEI*ZMIX(II,1)
	- TNN1=TNN1+FLEK*2DK
	- TNN2=TNN2+FREK*2DK
	- DO 110 JJ=1,4
	- DL=1D0/(TH-SMZ(JJ)**2)
	- FLEL=-FAC2(TT3JZMIX(JJ,2)-TANW(TT3J-EJ)
	- & ZMIX(JJ,1))
	- FREL=FAC2TANWEJ*ZMIX(JJ,1)
	- TNN3=TNN3+FLEKFREKFLELFRELDKDLSMZ(II)*SMZ(JJ)
	- 110 CONTINUE
	- 120 CONTINUE
	- TNN=(UHTH-SQM3SQM4)(A12TNN1*2POLL+
	- & A2*2TNN2*2POLR)
	- TNN=(TNN+SHA1A2TNN3((1D0-PARJ(131))*(1D0-PARJ(132))+
	- & (1D0+PARJ(131))(1D0+PARJ(132))))/4D0/XW*2
	- TZN=(UHTH-SQM3SQM4)(XLQ+XRQ)
	- & (TNN1XLFA1POLL+TNN2XRFA2POLR)
	- TZN=TZN/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)
	- & (1D0-SQMZ/SH)/SH
	- TZN=TZN/XW**2/XW1
	- TAN=EIEJ(UHTH-SQM3SQM4)/SH(A1TNN1*POLL+
	- & A2TNN2POLR)/XW
	- ENDIF
	- FACQQ1=COMFACAEM2(TAA+TZZ+TAZ)*FCOL/3D0
	- FACQQ1=FACQQ1( UHTH-SQM3SQM4 )/SH*2
	- FACQQ2=COMFACAEM2(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*2POLL+XRF*2POLR)(XLQ-XRQ)*2
	- & /XW2/XW12A1A2
	- 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(TT3IZMIX(II,2)-TANW(TT3I-EI)
	- & ZMIX(II,1))
	- FREK=FAC2TANWEI*ZMIX(II,1)
	- TNN1=TNN1+FLEK*2DK
	- TNN2=TNN2+FREK*2DK
	- DO 140 JJ=1,4
	- DL=1D0/(TH-SMZ(JJ)**2)
	- FLEL=-FAC2(TT3JZMIX(JJ,2)-TANW(TT3J-EJ)
	- & ZMIX(JJ,1))
	- FREL=FAC2TANWEJ*ZMIX(JJ,1)
	- TNN3=TNN3+FLEKFREKFLELFRELDKDLSMZ(II)*SMZ(JJ)
	- 140 CONTINUE
	- 150 CONTINUE
	- TNN=(UHTH-SQM3SQM4)A1A2(TNN22POLR+TNN1*2POLL)
	- TNNA=(TNN+SH(A12POLLL+A2*2POLRR)*TNN3)/4D0
	- TNNB=(TNN+SH(A12POLRR+A2*2POLLL)*TNN3)/4D0
	- TZN=(UHTH-SQM3SQM4)A1A2
	- TZN=TZN(XLQ-XRQ)(XLFTNN1POLL-XRFTNN2POLR)/XW1
	- TZN=TZN/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)
	- & (1D0-SQMZ/SH)/SH
	- ENDIF
	- FACQQ0=COMFACAEM2TZZFCOL/3D0(UHTH-SQM3SQM4)/SH2
	- FACQQ2=COMFACAEM2/XW2(TNNA+TZN)*FCOL/3D0
	- FACQQ1=COMFACAEM2/XW2(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=RKFCOMFACAEM2/XW2/12D0
	- FAC1=(THUH-SQM3SQM4)/((SH-SQMW)2+WWID2*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)=FAC0FAC1FCKM*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+ZWID2*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)-2D0EIXW)/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)/PROPZ2XLQ*XLL
	- ENDIF
	- FACQQ1=(XLQ2+XRQ2)(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(UHTH-SQM3SQM4)*COMFAC
	- & AEM2FCOL/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=COMFACWIDS(PYCOMP(KFPR(ISUBSV,1)),2)
	- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
	- ENDIF
	- FACXX=COMFACAEM2/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 + SQMZZWID**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=(T3IZMIXC(IZID1,2)-TANW(T3I-EI)ZMIXC(IZID1,1))
	- & DCONJG(T3IZMIXC(IZID2,2)-TANW(T3I-EI)*ZMIXC(IZID2,1))
	- GRIJ=ZMIXC(IZID1,1)DCONJG(ZMIXC(IZID2,1))(EITANW)*2
	- QLL=DCMPLX((T3I-EIXW)/XW1)OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
	- QLR=-DCMPLX((T3I-EIXW)/XW1)ORPP*PROPZ+DCONJG(GLIJ)
	- & /DCMPLX(TH-XML2)
	- QRL=-DCMPLX((EIXW)/XW1)OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
	- QRR=DCMPLX((EIXW)/XW1)ORPP*PROPZ
	- & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
	- FCOL=1D0
	- IF(IABS(I).GE.11) FCOL=3D0
	- FACGG1=(ABS(QLL)*2POLL+ABS(QRR)*2POLR)*WU2+
	- & (ABS(QRL)*2POLR+ABS(QLR)*2POLL)*WT2+
	- & 2D0DBLE(QLRDCONJG(QLL)*POLL+
	- & QRLDCONJG(QRR)POLR)*WS2
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACXXFACGG1FCOL
	- 210 CONTINUE
	- ENDIF
	-
	- ELSEIF(ISUB.LE.230) THEN
	- IF(ISUB.EQ.226) THEN
	-C...f + fbar -> ~chi+_1 + ~chi-_1
	- FACXX=COMFACAEM*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 + SQMZZWID**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(XWDIFF)
	- ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
	- & UMIXC(IZID1,2)DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XWDIFF)
	- 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/SHDIFF)-DCMPLX(EI/XW1)PROPZ*ORP
	- QLL=DCMPLX(-EI/SHDIFF)+DCMPLX((T3I-XWEI)/XW/XW1)PROPZORP
	- QRR=DCMPLX(-EI/SHDIFF)-DCMPLX(EI/XW1)PROPZ*OLP
	- IF(MOD(I,2).EQ.0) THEN
	- XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
	- QLR=DCMPLX(-EI/SHDIFF)+DCMPLX((T3I-XWEI)/XW/XW1)*
	- & PROPZOLP-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/SHDIFF)+DCMPLX((T3I-XWEI)/XW/XW1)*
	- & PROPZOLP-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)*2POLL+ABS(QRR)*2POLR)*WU2+
	- & (ABS(QRL)*2POLR+ABS(QLR)*2POLL)*WT2+
	- & 2D0DBLE(QLRDCONJG(QLL)*POLL+
	- & QRLDCONJG(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)=FACSUMWIDS(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)=FACSUMWIDS(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=COMFACAEM2/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+WWID2*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)2WU2+ABS(QLR)*2WT2+
	- & 2D0ZINTRWS2)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACGG1FCKMWIDS(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=COMFACWIDS(PYCOMP(KFPR(ISUBSV,1)),2)
	- & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
	- ASYUK=RMSS(42)*AS
	- FAC0=COMFACASYUKAEM*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 = -TANWEIZMIX(IZID,1)
	- XRQC =(SIGN(1D0,EI)ZMIX(IZID,2)-TANW
	- & (SIGN(1D0,EI)-2D0EI)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-2D0ATUKIN)
	- 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-2D0ATUKIN)
	- 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=COMFACASAEM/XW*2D0/9D0
	- GM2=SQM3
	- ZM2=SQM4
	- FAC01=2D0UMIX(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)=FACWGFCKM(FAC0ATKIN+FAC1AUKIN-
	- & FAC01ATUKIN)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=COMFACAS28D0/3D0( (XMT2+XMU*2+
	- & 2D0SQM3SH)/SH2 + RMSS(42)*2(4D0/9D0(XMT2/XST*2+
	- & XMU2/XSU2) + SQM3SH/XST/XSU/9D0) - RMSS(42)(
	- & (XMT*2+SHSQM3)/SH/XST + (XMU*2+SHSQM3)/SH/XSU ))
	- XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
	- XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
	- FACGG2=COMFACAS28D0/3D0( (XMT2+XMU*2+
	- & 2D0SQM3SH)/SH2 + RMSS(42)*2(4D0/9D0(XMT2/XST*2+
	- & XMU2/XSU2) + SQM3SH/XST/XSU/9D0) - RMSS(42)(
	- & (XMT*2+SHSQM3)/SH/XST + (XMU*2+SHSQM3)/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=COMFACAS29D0/4D0*(
	- & (XMTXMU-2D0SQM3(TH+SQM3))/XMT*2 -
	- & (XMTXMU+SQM3(UH-TH))/SH/XMT )
	- FACQQ2=COMFACAS29D0/4D0*(
	- & (XMUXMT-2D0SQM3(UH+SQM3))/XMU*2 -
	- & (XMUXMT+SQM3(TH-UH))/SH/XMU )
	- FACQQ3=COMFACAS29D0/4D0(2D0XMT*XMU/SH2 +
	- & SQM3(SH-4D0SQM3)/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=COMFACASAEM/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 = -TANWEIZMIX(IZID,1)
	- XLQZ =(SIGN(1D0,EI)ZMIX(IZID,2)-TANW
	- & (SIGN(1D0,EI)-2D0EI)ZMIX(IZID,1))/2D0
	- IF(ILR.EQ.0) THEN
	- BS=XLQZ*2SFMIX(IA,1)2+XRQZ2SFMIX(IA,2)*2
	- ELSE
	- BS=XLQZ*2SFMIX(IA,3)2+XRQZ2SFMIX(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)=FACZQRKFWIDS(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=COMFACASAEM/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=FACZQSFMIX(KFNSQ1,1+2ILR)**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)=FACZQRKFWIDS(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.5D04D0/9D0XMT/SH + (XMTSH+2D0XG2XST)/XMT*2 -
	- & ( (SH-XQ2+XG2)(-XST)-SHXG2 )/SH/(-XMT) +
	- & 0.5D01D0/2D0( XST(TH+2D0UH+XG2)-XMT(SH-2D0XST) +
	- & (-XMU)(TH+XG2+2D0XQ2) )/2D0/XMT/XSU
	- FACQG2= 4D0/9D0(-XMU)(UH+XQ2)/XSU*2 + 1D0/18D0
	- & (SH*(UH+XG2)
	- & +2D0(XQ2-XG2)XMU)/SH/(-XSU) + 0.5D04D0/9D0XMT/SH +
	- & 0.5D01D0/2D0(XST(TH+2D0UH+XG2)-XMT(SH-2D0XST)+
	- & (-XMU)(TH+XG2+2D0XQ2))/2D0/XMT/XSU
	- ASYUK=RMSS(42)*AS
	- FACQG1=COMFACASASYUK*FACQG1/2D0
	- FACQG2=COMFACASASYUK*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=RKFWIDS(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( (UHTH-SQM3SQM4)/ SH2 )
	- & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
	- KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
	- FAC0=AS*24D0/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-EJXW)SFMIX(KFNSQ,2ILR+1)**2
	- XRQ=2D0(-EJXW)SFMIX(KFNSQ,2ILR+2)**2
	- XLF=2D0(T3I-EIXW)
	- XRF=2D0(-EIXW)
	- TAA=0.5D0(EIEJ)**2
	- TZZ=(XLF2+XRF2)(XLQ+XRQ)2/64D0/XW2/XW1*2
	- TZZ=TZZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)**2)
	- TAZ=EIEJ(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
	- TAZ=TAZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)(1D0-SQMZ/SH)
	- FAC0=AEM*212D0*(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-EJXW)
	- XRQ=2D0(-EJXW)
	- XLF=2D0(TT3I-EIXW)
	- XRF=2D0(-EIXW)
	- TZZ=(XLF2+XRF2)(XLQ-XRQ)2/64D0/XW2/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=COMFACAEM2TZZFCOL4D0
	- FACQQ1=FACQQ1( UHTH-SQM3*SQM4 )/SH2
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACQQ1WIDS(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)=FACQQ1WIDS(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=COMFACAS2(7D0/48D0+3D0(UH-TH)2/16D0/SH2 )0.5D0*
	- & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
	- FACQQ1=FAC0(0.5D0+2D0SQM3TH/XST2 + 2D0SQM3**2/XSU/XST)
	- FACQQ2=FAC0(0.5D0+2D0SQM3UH/XSU2 + 2D0SQM3**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=COMFACASYUK24D0/9D0( -(XST1XST2+SHTH)/XMT*2 )
	- FACQQ2=COMFACASYUK24D0/9D0( -(XSU1XSU2+SHUH)/XMU*2 )
	- FACQQB=0.0D0
	- ELSE
	- FACQQ1=0.5D0COMFACASYUK*24D0/9D0( SHXMG2/XMT**2 )
	- FACQQ2=0.5D0COMFACASYUK*24D0/9D0( SHXMG2/XMU**2 )
	- FACQQB=0.5D0COMFACASYUK*24D0/9D0( -2D0SH*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)=FACQQ1RKFWIDS(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.5D0FACQQB)RKF
	- & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
	- ELSE
	- SIGH(NCHN)=0.5D0FACQQ1RKF*
	- & 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.5D0FACQQB)RKF
	- & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
	- ELSE
	- SIGH(NCHN)=0.5D0FACQQ2RKF*
	- & 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=COMFACAS22D0/9D0*(
	- & (UHTH-SQM3SQM4)/XMT*2 )RMSS(42)**2
	- FACQQB=COMFACAS24D0/9D0*(
	- & (UHTH-SQM3SQM4)/SH2 )
	-C...Mrenna..Switched sign to agree with Eichten, Dawson, etc.
	- FACQQI=COMFACAS24D0/27D0*(
	- & (UHTH-SQM3SQM4)/SH/XMT )*RMSS(42)
	- FACQQB=FACQQB+FACQQ1+FACQQI
	- ELSE
	- FACQQ1=COMFACAS24D0/9D0( XMG2SH/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)=FACQQ1RKFWIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
	- & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
	- IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQBRKF
	- & 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( (UHTH-SQM3SQM4)/ 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-EJXW)*SFMIX(KFNSQ,1)
	- XRQ=2D0(-EJXW)*SFMIX(KFNSQ,2)
	- ELSE
	- XLQ=2D0(T3J-EJXW)*SFMIX(KFNSQ,3)
	- XRQ=2D0(-EJXW)*SFMIX(KFNSQ,4)
	- ENDIF
	- XLF=2D0(T3I-EIXW)
	- XRF=2D0(-EIXW)
	- IF(ILR.EQ.0) THEN
	- XRQ=0D0
	- ELSE
	- XLQ=0D0
	- ENDIF
	- TAA=0.5D0(EIEJ)**2
	- TZZ=(XLF2+XRF2)(XLQ+XRQ)2/64D0/XW2/XW1*2
	- TZZ=TZZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)**2)
	- TAZ=EIEJ(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
	- TAZ=TAZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)(1D0-SQMZ/SH)
	- FAC0=AEM*212D0*(TAA+TZZ+TAZ)
	- ELSEIF(IA.LE.6) THEN
	- FAC0=AS*28D0/9D0/2D0
	- ENDIF
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACQQ1FAC0RKF*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=RKFCOMFACAS*2( 7D0/48D0+3D0(UH-TH)*2/16D0/SH2 )
	- FACQQ1=FAC0(0.5D0+2D0SQM3TH/XST2 + 2D0SQM3**2/XSU/XST)
	- FACQQ2=FAC0(0.5D0+2D0SQM3UH/XSU2 + 2D0SQM3**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-2D0XW)/(2D0XW/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=2D0SQRT(XWXW1)
	- 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=2D0QUPDCSXI
	- VZGP=QUPDCSXI(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=2D0Q2UDCSXIP
	- VZGP=CSXIP/SN2W(1D0-4D0XW*Q2UD)
	-C... Z pi_tc
	- ELSEIF(ISUB.EQ.366) THEN
	- KFA=23
	- KFB=KTECHN+111
	- ISUB=361
	- VOGP=CSXI*CT2W/RTCM(12)
	- VRGP=-QUPDCSXITANW/RTCM(12)
	- VAGP=QUPDCSXI(1D0-4D0*XW)/SN2W
	- VZGP=-QUPDCSXICS2W/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=-QUPDCSXIPTANW/RTCM(12)
	- VAGP=CSXIP(1D0-4D0Q2UD*XW)/SN2W
	- VZGP=2D0CSXIP(CS2W+4D0Q2UDXW2)/SN2W2
	-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=QUPDCSXI/(2D0SQRT(XW))
	- VZGP=-QUPDCSXI/(2D0SQRT(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=QUPDCSXI/(2D0SQRT(XW))
	- AXGP=-CSXI/RTCM(49)
	-C... Z_T pi_tc+
	- ELSEIF(ISUB.EQ.375) THEN
	- KFA=KTECHN+211
	- KFB=23
	- ISUB=370
	- VRGP=-QUPDCSXITANW/RTCM(12)
	- ARGP=CSXI/(2D0SQRT(XWXW1))/RTCM(13)
	- VWGP=-QUPDCSXI/(2D0SQRT(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=-QUPDRTCM(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=2D0TANT3/(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=X12RTCM(28)2SIN2T
	- SM1121=-X21RTCM(28)2SIN2T
	- SM2212=-SM1112
	- SM2221=-SM1121
	- SM1221=-.5D0((1D0-RTCM(29)2)SIN(2D0*RTCM(30))+
	- & (1D0-RTCM(31)*2)SIN(2D0RTCM(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,-SHRWDTP(0))
	- CALL PYWIDT(3100113,SH,WDTP,WDTE)
	- ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)*2,-SHRWDTP(0))
	- CALL PYWIDT(3400113,SH,WDTP,WDTE)
	- ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)*2,-SHRWDTP(0))
	- CALL PYWIDT(3200113,SH,WDTP,WDTE)
	- ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)*2,-SHRWDTP(0))
	- CALL PYWIDT(3300113,SH,WDTP,WDTE)
	- ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)*2,-SHRWDTP(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(SHXIGX11,0D0)
	- ZTC(2,4)=DCMPLX(SHXIGX22,0D0)
	- ZTC(2,5)=DCMPLX(SHXIGX12,0D0)
	- ZTC(2,6)=DCMPLX(SHXIGX21,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(THXIGX11,0D0)
	- ZTC(2,4)=DCMPLX(THXIGX22,0D0)
	- ZTC(2,5)=DCMPLX(THXIGX12,0D0)
	- ZTC(2,6)=DCMPLX(THXIGX21,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(UHXIGX11,0D0)
	- ZTC(2,4)=DCMPLX(UHXIGX22,0D0)
	- ZTC(2,5)=DCMPLX(UHXIGX12,0D0)
	- ZTC(2,6)=DCMPLX(UHXIGX21,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+DVVSDCMPLX(TANT32)-DGVSDCMPLX(2D0*TANT3)
	- DQQT=DGGT+DVVTDCMPLX(TANT32)-DGVTDCMPLX(2D0*TANT3)
	- DQQU=DGGU+DVVUDCMPLX(TANT32)-DGVUDCMPLX(2D0*TANT3)
	- DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
	- DQGS=DGGS-DGVS*DCMPLX(TANT3)
	- DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
	- ELSE
	- DQQS=DGGS+DVVSDCMPLX(1D0/TANT32)+DGVSDCMPLX(2D0/TANT3)
	- DQQT=DGGT+DVVTDCMPLX(1D0/TANT32)+DGVTDCMPLX(2D0/TANT3)
	- DQQU=DGGU+DVVUDCMPLX(1D0/TANT32)+DGVUDCMPLX(2D0/TANT3)
	- DQTS=DGGS+DVVSDCMPLX(1D0/TANT32)+DGVSDCMPLX(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=COMFAC0.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)=HIFACBWHF
	- 250 CONTINUE
	-
	- ELSEIF(ISUB.EQ.165) THEN
	-C...q + qbar -> l+ + l- (including contact term for compositeness)
	- ZRATR=XWCSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	- ZRATI=XWCSHGMMZ/((SH-SQMZ)2+GMMZ2)
	- KFF=IABS(KFPR(ISUB,1))
	- EF=KCHG(KFF,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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-4D0EIXWV
	- 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=(EIEF+VALIVALFZRATR+RTCM(42)SH/
	- & (AEMRTCM(41)2))2+(VALIVALFZRATI)*2+
	- & (EIEF+VARIVARFZRATR)2+(VARIVARFZRATI)*2
	- ELSE
	- FGZA=(EIEF+VALIVALFZRATR)2+(VALIVALFZRATI)*2+
	- & (EIEF+VARIVARFZRATR)2+(VARIVARFZRATI)*2
	- ENDIF
	- FGZB=(EIEF+VALIVARFZRATR)2+(VALIVARFZRATI)*2+
	- & (EIEF+VARIVALFZRATR)2+(VARIVALFZRATI)*2
	- FGZAB=AEM*2(FGZAUH2/SH2+FGZBTH2/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/(2D0RTCM(41)*4)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=COMFACFCOIFCOFFGZABWID2
	- 260 CONTINUE
	-
	- ELSEIF(ISUB.EQ.166) THEN
	-C...q + q'bar -> l + nu_l (including contact term for compositeness)
	- WFAC=(1D0/4D0)(AEM/XW)2UH2/((SH-SQMW)2+GMMW2)
	- WCIFAC=WFAC+SH2/(4D0RTCM(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)=COMFACFCOIFCOFWFACWID2
	- IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
	- & SIGH(NCHN)=COMFACFCOIFCOFWCIFACWID2
	- 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=12D0COMFAC/((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)(AEM2/ALPRHT)(SQMRHT**2/SH)
	- XWRHT=(1D0-2D0XW)/(4D0XW*(1D0-XW))
	- BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	- BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	- 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-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- HI=HP((EI+VALIBWZR)*2+(VALIBWZI)**2+
	- & (EI+VARIBWZR)2+(VARIBWZI)**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)=HIFACBWHF
	- 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=12D0COMFAC/((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)(AEM2/ALPRHT)(SQMRHT*2/SH)
	- & (0.25D0/XW*2)SH2/((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=HIVCKM((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)=HIFACBWHF
	- 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=12D0COMFAC/((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)(AEM2/ALPRHT)(SQMOMT*2/SH)
	- & (2D0RTCM(2)-1D0)*2
	- BWZR=(0.5D0/(1D0-XW))SH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	- BWZI=(0.5D0/(1D0-XW))SHGMMZ/((SH-SQMZ)2+GMMZ2)
	- 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-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- HI=HP((EI-VALIBWZR)*2+(VALIBWZI)**2+
	- & (EI-VARIBWZR)2+(VARIBWZI)**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)=HIFACBWHF
	- 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*2COMFAC
	-
	- SN2W=2D0SQRT(XWXW1)
	-C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
	-C CT2W=(1D0-2D0PARU(102))/(2D0PARU(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=(FARFZO-FAOFZR)*2+SSMZSSMRSSMO-SFZRSSMO-
	- $ SFZOSSMR-SFARSSMOSSMZ-SFAOSSMR*SSMZ
	-C...Add in techni-a contribution
	- DETD=SSMXDETD-SFZX(SSMRSSMO-SFAOSSMR-SFAR*SSMO)
	- DAA=(-SSMX(SFZOSSMR+SFZRSSMO-SSMOSSMR*SSMZ)-
	- $ SFZXSSMRSSMO)/DETD/SH
	- DZZ=-(SFAOSSMR+SFARSSMO-SSMOSSMR)/DETD/SHSSMX
	- DAZ=(FARFZRSSMO+FAOFZOSSMR)/DETD/SH*SSMX
	-
	- XWRHT=1D0/(4D0XW(1D0-XW))
	- KFF=IABS(KFPR(ISUB,1))
	- EF=KCHG(KFF,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFXWV
	- 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-4D0EIXWV
	- VALI=0.5D0*(VI+AI)
	- VARI=0.5D0*(VI-AI)
	- FCOI=FCOF
	- IF(IABS(I).LE.10) FCOI=FCOI/3D0
	- DIFLL=ABS(EIEFDAA+VALIVALFDZZ+DAZ(EIVALF+EFVALI))*2
	- DIFRR=ABS(EIEFDAA+VARIVARFDZZ+DAZ(EIVARF+EFVARI))*2
	- DIFLR=ABS(EIEFDAA+VALIVARFDZZ+DAZ(EIVARF+EFVALI))*2
	- DIFRL=ABS(EIEFDAA+VARIVALFDZZ+DAZ(EIVALF+EFVARI))*2
	- FACSIG=(DIFLL+DIFRR)((UH-SQM4)2+SHSQM4)+
	- & (DIFLR+DIFRL)((TH-SQM3)2+SHSQM3)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=HPFCOIFACSIG*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(AEM2/12D0/XW2)(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(SSMZSSMR-DCMPLX(FWR**2,0D0))-
	- & DCMPLX(FWX*2,0D0)SSMR
	- DWW=SSMR*SSMX/DETD/SH
	- FCOF=1D0
	- IF(KFA.LE.8) FCOF=3D0
	- HP=FACTCABS(DWW)2FCOF
	-
	- 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)=HIWIDS(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=(FARFZO-FAOFZR)*2+SSMZSSMRSSMO-SFZRSSMO-
	- $ SFZOSSMR-SFARSSMOSSMZ-SFAOSSMR*SSMZ
	-C...Add in techni-a contribution
	- DETD=SSMXDETD-SFZX(SSMRSSMO-SFAOSSMR-SFAR*SSMO)
	- DARHO=-(SSMX(-FARSFZO+FAOFZOFZR+FARSSMOSSMZ)-
	- $ SFZXFARSSMO)/DETD/SH
	- DZRHO=-(-FZRSFAO+FAOFZOFAR+FZRSSMO)/DETD/SH*SSMX
	- DAOME=-(SSMX(-FAOSFZR+FARFZOFZR+FAOSSMRSSMZ)-
	- $ SFZXFAOSSMR)/DETD/SH
	- DZOME=-(-FZOSFAR+FARFAOFZR+FZOSSMR)/DETD/SH*SSMX
	- DAAST=-FZX(FAOFZOSSMR+FARFZR*SSMO)/DETD/SH
	- DZAST=-FZX(SSMRSSMO-SFAOSSMR-SFARSSMO)/DETD/SH
	- DAA=(-SSMX(SFZOSSMR+SFZRSSMO-SSMOSSMR*SSMZ)-
	- $ SFZXSSMRSSMO)/DETD/SH
	- DZZ=-(SFAOSSMR+SFARSSMO-SSMOSSMR)/DETD/SHSSMX
	- DAZ=(FARFZRSSMO+FAOFZOSSMR)/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*2BE342-(TH-UH)2)
	- VFAC=(TH2+UH2-2D0SQM3SQM4)
	- AFAC=(TH2+UH2-2D0SQM3SQM4+4D0SHSQM3)
	- FANOM=SQRT(PARU(1)AEM)ITCM(1)/PARU(2)**2/RTCM(1)
	- HP=(1D0/24D0)AEM2COMFAC3D0SH
	- 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-4D0EIXWV
	- 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=(EIDARHO+VALIDZRHO/SQRT(XWXW1))VRGP
	- F2L=F2L+(EIDAOME+VALIDZOME/SQRT(XWXW1))VOGP
	- F2L=F2L+(EIDAAST+VALIDZAST/SQRT(XWXW1))VXGP
	- F2L=F2L+FANOM(VAGP(EIDAA+VALIDAZ/SQRT(XW*XW1))+
	- $ VZGP(EIDAZ+VALIDZZ/SQRT(XWXW1)))
	- F2R=(EIDARHO+VARIDZRHO/SQRT(XWXW1))VRGP
	- F2R=F2R+(EIDAOME+VARIDZOME/SQRT(XWXW1))VOGP
	- F2R=F2R+(EIDAAST+VARIDZAST/SQRT(XWXW1))VXGP
	- F2R=F2R+FANOM(VAGP(EIDAA+VARIDAZ/SQRT(XW*XW1))+
	- $ VZGP(EIDAZ+VARIDZZ/SQRT(XWXW1)))
	- HI=(ABS(F2L)2+ABS(F2R)2)*VFAC
	-C...........Eqs. (5) and (7) in LSTC-rates.pdf
	- F2L=(EIDARHO+VALIDZRHO/SQRT(XWXW1))ARGP
	- F2L=F2L+(EIDAOME+VALIDZOME/SQRT(XWXW1))AOGP
	- F2L=F2L+(EIDAAST+VALIDZAST/SQRT(XWXW1))AXGP
	- F2R=(EIDARHO+VARIDZRHO/SQRT(XWXW1))ARGP
	- F2R=F2R+(EIDAOME+VARIDZOME/SQRT(XWXW1))AOGP
	- F2R=F2R+(EIDAAST+VARIDZAST/SQRT(XWXW1))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+CT2WDAZ))+
	-c$$$ $ VALI(CT2WDZRHO/FZR+(CT2WDZZ+DAZ))/SQRT(XWXW1)
	-c$$$ F2R=EI(DARHO/FAR+(DAA+CT2WDAZ))+
	-c$$$ $ VARI(CT2WDZRHO/FZR+(CT2WDZZ+DAZ))/SQRT(XWXW1)
	- F2L=EIDARHO/FAR + VALICT2WDZRHO/FZR/SQRT(XWXW1)
	- F2R=EIDARHO/FAR + VARICT2WDZRHO/FZR/SQRT(XWXW1)
	- HK=(ABS(F2L)2+ABS(F2R)2)2D0FACA*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)=HIHPWIDS(PYCOMP(KFA),1)
	- ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
	- SIGH(NCHN)=HIHPWIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=2
	- SIGH(NCHN)=HIHPWIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
	- ELSE
	- SIGH(NCHN)=HIHPWIDS(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*2BE342-(TH-UH)2)
	- FANOM=SQRT(PARU(1)AEM)ITCM(1)/PARU(2)**2/RTCM(1)
	- VFAC=(TH2+UH2-2D0SQM3SQM4)
	- AFAC=(TH2+UH2-2D0SQM3SQM4+4D0SHSQM3)
	- ALPRHT=2.16D0*(3D0/ITCM(1))
	- FACHP=(1D0/48D0)AEM2/XWCOMFAC3D0SH
	- 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(SSMZSSMR-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(AFACABS(DWRHOARGP+DWASTAXGP)**2+
	- $ VFACABS(FANOMDWWVWGP+DWRHOVRGP+DWASTVXGP)*2)
	-C
	-C...........Eq. (25) in PRD67-115011 with DWW term dropped.
	-C
	-c$$$ HP=HP+.5D0FACHPCAB2FACA/XW/SHABS(DWW + DWRHO/FWR)**2
	- HP=HP+.5D0FACHPCAB2FACA/XW/SHABS(DWRHO/FWR)**2
	-C...Add in W_L Z_T axial and vector contributions.
	- IF(ISUBSV.EQ.370) HP=HP+FACHPRTCM(3)2(
	- $ (TH2+UH2-2D0SQM3SQM4+4D0SHSQM4)* !AFAC w/ switched masses.
	- $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)CS2W)2/SN2W*2+
	- $ VFACQUPD2XW/XW1ABS(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)=HIWIDS(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=COMFACAS24D0/9D0(SH2+UH2)SQDQQT
	- FACQQB=COMFACAS24D0/9D0((SH2+UH2)SQDQQT*FACA-
	- & MSTP(34)2D0/3D0UH2*REDQST)
	- FACQQ2=COMFACAS24D0/9D0(SH2+TH2)SQDQQU
	- FACQQI=-COMFACAS24D0/9D0MSTP(34)2D0/3D0SH2/(THUH)
	- 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)(ASRTCM(42)/RTCM(41)2)
	- & (UH2/TH+UH2/SH)+COMFAC(5D0/3D0)(UH2/RTCM(41)**4)
	- FACCI2=FACQQ2+COMFAC(8D0/9D0)(ASRTCM(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.5D0FACQQ1RATQQI
	- SIGH(NCHN)=0.5D0FACQQ2RATQQI
	- ELSE
	- SIGH(NCHN-1)=0.5D0FACCI1RATCII
	- SIGH(NCHN)=0.5D0FACCI2RATCII
	- 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=COMFACAS24D0/9D0*(TH2+UH2)
	- FACQQB=FACQQFSQDQQS(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=FACQQFSQDQQS(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
	- & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
	- FACCIB=FACQQFSQDQTS(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=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2+9D0/4D0THUH/SH2*SQDLGS)
	- FACGG2=COMFACAS232D0/27D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	- & TH2/SH2+9D0/4D0THUH/SH2*SQDLGS)
	- IF(ITCM(5).EQ.5) THEN
	- FACGG3=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2+9D0/4D0THUH/SH2*SQDHGS)
	- FACGG4=COMFACAS232D0/27D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	- & TH2/SH2+9D0/4D0THUH/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=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*UH2/TH2-
	- & UH/SH-9D0/4D0SHUH/TH2SQDLGT)FACA
	- FACQG2=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*SH2/TH2-
	- & SH/UH-9D0/4D0SHUH/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-4D0PMAS(1,1)*2/SH))
	- IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
	- & SQRT(MAX(0D0,1D0-4D0PMAS(2,1)*2/SH))
	- IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
	- & SQRT(MAX(0D0,1D0-4D0PMAS(3,1)*2/SH))
	- FACQQ1=COMFACAS21D0/6D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	- & UH2/SH2+9D0/4D0THUH/SH2SQDLGS)FLAVWT*FACA
	- FACQQ2=COMFACAS21D0/6D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	- & TH2/SH2+9D0/4D0THUH/SH2SQDLGS)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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- THUHQ=THQUHQ-SQMAVGSH
	- IF(MSTP(34).EQ.0) THEN
	- FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	- FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	- ELSE
	- FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	- FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	- ENDIF
	- IF(ITCM(5).GE.5) THEN
	- IF(IFL.EQ.4) THEN
	- FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDLGS+
	- & 2.25D0THQUHQ/SH2*SQDLGS
	- FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDLGS+
	- & 2.25D0THQUHQ/SH2*SQDLGS
	- ELSE
	- FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDHGS+
	- & 2.25D0THQUHQ/SH2*SQDHGS
	- FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDHGS+
	- & 2.25D0THQUHQ/SH2*SQDHGS
	- ENDIF
	- ENDIF
	- FACQQ1=COMFACFACAAS*2(1D0/6D0)FACQQ1BE34
	- FACQQ2=COMFACFACAAS*2(1D0/6D0)FACQQ2BE34
	- 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=COMFACAS29D0/4D0(SH2/TH2+2D0SH/TH+3D0+
	- & 2D0TH/SH+TH2/SH2)FACA
	- FACGG2=COMFACAS29D0/4D0(UH2/SH2+2D0UH/SH+3D0+
	- & 2D0SH/UH+SH2/UH2)FACA
	- FACGG3=COMFACAS29D0/4D0(TH2/UH2+2D0TH/UH+3D0+
	- & 2D0*UH/TH+UH2/TH2)
	- ELSE
	- GST= (12D0 + 40D0TH/SH + 56D0TH2/SH2 + 32D0TH3/SH*3 +
	- & 16D0TH4/SH4 + SQDGGS(4D0SH2 + 16D0SHTH + 16D0TH2)+
	- & 4D0REDGST(SH + 2D0TH)
	- & (2D0SH3 - 3D0SH2TH - 2D0SHTH2 + 2D0TH**3)/SH2 +
	- & 2D0REDGGS(2D0SH - 12D0TH2/SH - 8D0TH*3/SH2) +
	- & 2D0REDGGT(4D0SH - 22D0TH - 68D0TH2/SH - 60D0TH**3/SH2-
	- & 32D0TH4/SH3 - 16D0TH5/SH4) +
	- & SQDGGT(16D0SH2 + 16D0SHTH + 68D0TH2 + 144D0TH**3/SH +
	- & 96D0TH4/SH2 + 32D0TH5/SH3 + 16D0TH6/SH*4))/16D0
	- GSU= (12D0 + 40D0UH/SH + 56D0UH2/SH2 + 32D0UH3/SH*3 +
	- & 16D0UH4/SH4 + SQDGGS(4D0SH2 + 16D0SHUH + 16D0UH2)+
	- & 4D0REDGSU(SH + 2D0UH)
	- & (2D0SH3 - 3D0SH2UH - 2D0SHUH2 + 2D0UH**3)/SH2 +
	- & 2D0REDGGS(2D0SH - 12D0UH2/SH - 8D0UH*3/SH2) +
	- & 2D0REDGGU(4D0SH - 22D0UH - 68D0UH2/SH - 60D0UH**3/SH2-
	- & 32D0UH4/SH3 - 16D0UH5/SH4) +
	- & SQDGGU(16D0SH2 + 16D0SHUH + 68D0UH2 + 144D0UH**3/SH +
	- & 96D0UH4/SH2 + 32D0UH5/SH3 + 16D0UH6/SH*4))/16D0
	- GUT= (12D0 - 16D0TH(TH - UH)*2UH/SH**4 +
	- & 4D0REDGGU(2D0TH5 - 15D0TH*4UH - 48D0TH3UH2 -
	- & 58D0TH2UH*3 - 10D0THUH4 + UH5)/SH*4 +
	- & 4D0REDGGT(TH*5 - 10D0TH*4UH - 58D0TH3UH2 -
	- & 48D0TH2UH*3 - 15D0THUH4 + 2D0UH5)/SH4 +
	- & 4D0SQDGGU(4D0TH6 + 20D0TH*5UH + 57D0TH4UH2 +
	- & 72D0TH3UH*3+ 38D0TH2UH4+4D0THUH5 +UH6)/SH*4+
	- & 4D0SQDGGT(4D0UH6 + 4D0TH*5UH + 38D0TH4UH2 +
	- & 72D0TH3UH*3 +57D0TH2UH4+20D0THUH5+TH6)/SH*4+
	- & 2D0REDGTU((TH - UH)*2 (TH*4 + 20D0TH*3UH +
	- & 30D0TH2UH2 + 20D0THUH3 + UH4) +
	- & SH2(7D0TH*4 + 52D0TH*3UH + 274D0TH2UH2 +
	- & 52D0THUH*3 + 7D0UH*4))/(2D0SH**4))/16D0
	- FACGG1=COMFACAS29D0/4D0GSTFACA
	- FACGG2=COMFACAS29D0/4D0GSUFACA
	- FACGG3=COMFACAS29D0/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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- FACQQB=COMFACAS24D0/9D0((THQ2+UHQ*2)/SH2+
	- & 2D0*SQMAVG/SH)
	- IF(ITCM(5).GE.5) THEN
	- IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
	- FACQQB=FACQQBSH2SQDQTS
	- ELSE
	- FACQQB=FACQQBSH2SQDQQS
	- 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.5D0SH(1D0-BE34*CTH)
	- UHQ=-0.5D0SH(1D0+BE34*CTH)
	- THUHQ=THQUHQ-SQMAVGSH
	- IF(MSTP(34).EQ.0) THEN
	- FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	- FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	- ELSE
	- FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	- FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	- & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	- ENDIF
	- IF(ITCM(5).GE.5) THEN
	- IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
	- FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDHGS+
	- & 2.25D0THQUHQ/SH2*SQDHGS
	- FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDHGS+
	- & 2.25D0THQUHQ/SH2*SQDHGS
	- ELSE
	- FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDLGS+
	- & 2.25D0THQUHQ/SH2*SQDLGS
	- FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDLGS+
	- & 2.25D0THQUHQ/SH2*SQDLGS
	- ENDIF
	- ENDIF
	- FACQQ1=COMFACFACAAS*2(1D0/6D0)*FACQQ1
	- FACQQ2=COMFACFACAAS*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/3D0XWCSH
	- HP2=HP1
	- HS=SHR*VINT(117)
	- HSP=SHR*WDTP(0)
	- FACZP=4D0COMFAC3D0
	- 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-4D0EIXWV
	- 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=SHRWDTP(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)=HIFACZPHF/((SH-SQMZP)2+HSP2)
	- ELSE
	-C...Normal cross section.
	- SIGH(NCHN)=FACZP(EI2/SH2HI0HP0VINT(111)+EIVI
	- & (1D0-SQMZ/SH)/((SH-SQMZ)2+HS2)(HI0HP1+HI1HP0)
	- & VINT(112)+EIVPI(1D0-SQMZP/SH)/((SH-SQMZP)2+HSP2)*
	- & (HI0HP2+HI2HP0)VINT(113)+(VI2+AI*2)/
	- & ((SH-SQMZ)2+HS2)HI1HP1VINT(114)+(VIVPI+AIAPI)
	- & ((SH-SQMZ)(SH-SQMZP)+HSHSP)/(((SH-SQMZ)2+HS2)*
	- & ((SH-SQMZP)2+HSP2))(HI1HP2+HI2HP1)VINT(115)+
	- & (VPI2+API2)/((SH-SQMZP)2+HSP2)HI2HP2*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=4D0COMFAC/((SH-SQMWP)2+HS2)3D0
	- HP=AEM/(24D0XW)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)=HIFACBWHF
	- 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=4D0COMFAC/((SH-SQMR)2+HS2)3D0
	- HP=AEM/(12D0XW)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)=HIFACBWHF
	- 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=4D0COMFAC/((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(IJ.NE.KFLQQKFLQL) 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)=HIFACBWHF
	- 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=FACBWAEMQF*2SH/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)=HIFACBWHF
	- 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=FACBWASRTCM(45)*2SH/(3D0RTCM(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)=HIFACBWHF
	- 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=COMFACFACAPARU(151)(ASAEM/6D0)(-TH/SH)
	- & (UH2+SQMLQ2)/(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=COMFACFACAWIDS(42,1)(AS2/2D0)
	- & (7D0/48D0+3D0(UH-TH)2/(16D0SH2))(1D0+2D0SQMLQ*TH/
	- & (TH-SQMLQ)*2+2D0SQMLQUH/(UH-SQMLQ)2+4D0SQMLQ**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=COMFACWIDS(42,1)(AS*2/9D0)
	- & (SH(SH-4D0SQMLQ)-(UH-TH)**2)/SH2
	- FACLQS=COMFACWIDS(42,1)((PARU(151)*2AEM*2/8D0)
	- & (-SHTH-(SQMLQ-TH)2)/TH2+(PARU(151)AEMAS/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=COMFAC0.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)FACQSABRPOS
	- IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)FACQSABRNEG
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=2
	- IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)FACQSABRPOS
	- IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)FACQSABRNEG
	- 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)FACQSBBRPOS
	- IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)FACQSBBRNEG
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=J
	- ISIG(NCHN,3)=2
	- IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)FACQSBBRPOS
	- IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)FACQSBBRNEG
	- 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=8D0COMFAC/((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=SHPARP(181+3((IA-11)/2)+(JA-11)/2)*2/(8D0PARU(1))
	- HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
	- SIGH(NCHN)=HIFACBWHF
	- 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=COMFACAEMHBW3C/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((2D0SQM3-3D0SQML)SQM4+(SQML-2D0SQM4)TH-
	- & (TH-SQM4)SH)/(TH-SQM4)*2
	- SMM3=2D0((2D0SQM3-3D0SQM4+TH)SQML-(2D0SQML-SQM4+TH)
	- & SH)/(SH-SQML)**2
	- SMM12=4D0((2D0SQML-SQM4-2D0SQM3+TH)SH+(TH-3D0*SQM3-
	- & 3D0SQM4)TH+(2D0SQM3-2D0SQML+3D0SQM4)SQM3)/
	- & ((UH-SQM3)*(TH-SQM4))
	- SMM13=-4D0((TH+SQML-2D0SQM4)TH-(SQM3+3D0SQML-2D0SQM4)
	- & SQM3+(SQM3+3D0SQML+TH)SH-(TH-SQM3+SH)**2)/
	- & ((UH-SQM3)*(SH-SQML))
	- SMM23=-4D0((SQML-SQM4+SQM3)TH-SQM3*2+SQM3(SQML+SQM4)-
	- & 3D0SQMLSQM4-(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/(4D0PARU(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)=FHCCSMMWIDSC
	- 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+GMMH2)
	- CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
	- GMMH3=SQRT(SQM3)*WDTP(0)
	- HBW3C=GMMH3/((SQM3-SQMH)2+GMMH32)
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
	- GMMH4=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	-C...Kinematical and coupling functions
	- FACHH=COMFAC(HBW3C/HBW3)(HBW4C/HBW4)(THUH-SQM3*SQM4)
	- XWHH=(1D0-2D0XWV)/(8D0XWV*(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-4D0EIXWV
	- FCOI=1D0
	- IF(IABS(I).LE.10) FCOI=FACA/3D0
	- IF(ISUB.EQ.349) THEN
	- HBWZ=1D0/((SH-SQMZ)2+GMMZ2)
	- IF(IABS(I).LT.10) THEN
	- DSIGHH=8D0AEM2(EI**2/SH2+
	- & 2D0EIVIXWHH(SH-SQMZ)*HBWZ/SH+
	- & (VI2+AI2)XWHH2HBWZ)
	- ELSE
	- IAOFF=181+3*((IABS(I)-11)/2)
	- HSUM=(PARP(IAOFF)2+PARP(IAOFF+1)2+PARP(IAOFF+2)**2)/
	- & (4D0*PARU(1))
	- DSIGHH=8D0AEM2(EI**2/SH2+
	- & 2D0EIVIXWHH(SH-SQMZ)*HBWZ/SH+
	- & (VI2+AI2)XWHH2HBWZ)+
	- & 8D0AEM(EIHSUM/(SHTH)+
	- & (VI+AI)XWHHHSUM(SH-SQMZ)HBWZ/TH)+
	- & 4D0HSUM*2/TH2
	- ENDIF
	- ELSE
	- IF(IABS(I).LT.10) THEN
	- DSIGHH=8D0AEM2EI**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=8D0AEM2EI*2/SH2+8D0AEMEIHSUM/(SH*TH)+
	- & 4D0HSUM*2/TH2
	- ENDIF
	- ENDIF
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=FACHHFCOIDSIGHH
	- 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)*8PARP(192)**2
	- IF(ISUB.EQ.352) FACNOR=PARP(191)*62D0*
	- & PMAS(PYCOMP(9900024),1)**2
	- FACWW=COMFACFACNORTAUPVINT(2)VINT(219)
	- FACPRT=1D0/((VINT(204)*2-VINT(215))
	- & (VINT(209)**2-VINT(216)))
	- FACPRU=1D0/((VINT(204)*2+2D0VINT(217))*
	- & (VINT(209)*2+2D0VINT(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-2MOD(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-2MOD(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)=FACLRFACWWFACPRPFACBWHF
	- 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=4D0COMFAC/((SH-SQMZR)2+HS2)3D0
	- HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
	- HP=(AEM/(3D0(1D0-2D0XW)))XWCSH
	- 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-2D0XW)
	- VI=SIGN(1D0,EI+0.1D0)-4D0EIXW
	- ELSE
	- AI=-(1D0-2D0*XW)
	- VI=-1D0+4D0*XW
	- ENDIF
	- HI=HP(VI2+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)=HIFACBWHF
	- 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=4D0COMFAC/((SH-SQMWR)2+HS2)3D0
	- HP=AEM/(24D0XW)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=HIVCKM((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)=HIFACBWHF
	- 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=COMFACPARP(50)2/(16D0PARU(1))SHHF/
	- & ((SH-PMAS(KCGSTR,1)2)2+HS**2)
	-C...Modify cross section in wings of peak.
	- FACG = FACG * SH2 / 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=COMFACPARP(50)2/(32D0PARU(1))SHHF/
	- & ((SH-PMAS(KCGSTR,1)2)2+HS**2)
	-C...Modify cross section in wings of peak.
	- FACG = FACG * SH2 / 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=COMFACPARP(50)2ASSH/(72D0PARU(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)+
	- & 2D0SH2/(THUH))
	-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=-COMFACPARP(50)2ASSH/(192D0PARU(1)SQM4)
	- & (4D0(SH2+UH2)/(THSH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
	- & 3D0TH(4D0+SH/UH+UH/SH)/SH+4D0TH2(1D0/UH+1D0/SH)/SH+
	- & 2D0TH2TH/(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=COMFAC3D0PARP(50)*2ASSH/(32D0PARU(1)SQM4)
	- & ((TH2+THUH+UH2)2/(SH2THUH)+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+HS2)
	- 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+GMMH2)
	- CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
	- GMMH3=SQRT(SQM3)*WDTP(0)
	- HBW3C=GMMH3/((SQM3-SQMH)2+GMMH32)
	- SQMH=PMAS(KCF2,1)**2
	- GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
	- HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	- CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
	- GMMH4=SQRT(SQM4)*WDTP(0)
	- HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	- 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(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
	- &XPDIR(-6:6)
	- COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
	- COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	- & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	- & XMI(2,240),PT2MI(240),IMISEP(0:240)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
	- &/PYINT9/,/PYINTM/
	-C...Local arrays.
	- DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
	- &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
	- SAVE PPAR
	-
	-C...Interface to PDFLIB.
	- COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
	- SAVE /W50513/
	- DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
	- &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
	- CHARACTER*20 PARM(20)
	- DATA VALUE/200D0/,PARM/20' '/
	-
	-C...Data related to Schuler-Sjostrand photon distributions.
	- DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
	-
	-C...Valence PDF momentum integral parametrizations PER PARTON!
	- DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
	- DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
	- PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
	- &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
	-
	-C...Reset parton distributions.
	- MINT(92)=0
	- DO 100 KFL=-25,25
	- XPQ(KFL)=0D0
	- 100 CONTINUE
	- DO 110 KFL=-6,6
	- XPVAL(KFL)=0D0
	- 110 CONTINUE
	-
	-C...Check x and particle species.
	- IF(X.LE.0D0.OR.X.GE.1D0) THEN
	- WRITE(MSTU(11),5000) X
	- GOTO 9999
	- ENDIF
	- KFA=IABS(KF)
	- IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
	- &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
	- &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
	- &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
	- &KFA.NE.310.AND.KFA.NE.130) THEN
	- WRITE(MSTU(11),5100) KF
	- GOTO 9999
	- ENDIF
	-
	-C...Electron (or muon or tau) parton distribution call.
	- IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
	- CALL PYPDEL(KFA,X,Q2,XPEL)
	- DO 120 KFL=-25,25
	- XPQ(KFL)=XPEL(KFL)
	- 120 CONTINUE
	-
	-C...Photon parton distribution call (VDM+anomalous).
	- ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
	- IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
	- CALL PYPDGA(X,Q2,XPGA)
	- DO 130 KFL=-6,6
	- XPQ(KFL)=XPGA(KFL)
	- 130 CONTINUE
	- XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
	- XPVAL(1)=XPVU/4D0
	- XPVAL(2)=XPVU
	- XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
	- XPVAL(4)=MIN(XPQ(4),XPVU)
	- XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
	- XPVAL(-1)=XPVAL(1)
	- XPVAL(-2)=XPVAL(2)
	- XPVAL(-3)=XPVAL(3)
	- XPVAL(-4)=XPVAL(4)
	- XPVAL(-5)=XPVAL(5)
	- ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
	- Q2MX=Q2
	- P2MX=0.36D0
	- IF(MSTP(55).GE.7) P2MX=4.0D0
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- P2=0D0
	- IF(VINT(120).LT.0D0) P2=VINT(120)**2
	- CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
	- DO 140 KFL=-6,6
	- XPQ(KFL)=XPGA(KFL)
	- XPVAL(KFL)=VXPDGM(KFL)
	- 140 CONTINUE
	- VINT(231)=P2MX
	- ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
	- Q2MX=Q2
	- P2MX=0.36D0
	- IF(MSTP(55).GE.11) P2MX=4.0D0
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- P2=0D0
	- IF(VINT(120).LT.0D0) P2=VINT(120)**2
	- CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
	- DO 150 KFL=-6,6
	- XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
	- XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
	- 150 CONTINUE
	- VINT(231)=P2MX
	- ELSEIF(MSTP(56).EQ.2) THEN
	-C...Call PDFLIB parton distributions.
	- PARM(1)='NPTYPE'
	- VALUE(1)=3
	- PARM(2)='NGROUP'
	- VALUE(2)=MSTP(55)/1000
	- PARM(3)='NSET'
	- VALUE(3)=MOD(MSTP(55),1000)
	- IF(MINT(93).NE.3000000+MSTP(55)) THEN
	- CALL PDFSET(PARM,VALUE)
	- MINT(93)=3000000+MSTP(55)
	- ENDIF
	- XX=X
	- QQ2=MAX(0D0,Q2MIN,Q2)
	- IF(MSTP(57).EQ.0) QQ2=Q2MIN
	- P2=0D0
	- IF(VINT(120).LT.0D0) P2=VINT(120)**2
	- IP2=MSTP(60)
	- IF(MSTP(55).EQ.5004) THEN
	- IF(5D0*P2.LT.QQ2.AND.
	- & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
	- & P2.GE.0D0.AND.P2.LT.10D0.AND.
	- & XX.GT.1D-4.AND.XX.LT.1D0) THEN
	- CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
	- & BOT,TOP,GLU)
	- ELSE
	- UPV=0D0
	- DNV=0D0
	- USEA=0D0
	- DSEA=0D0
	- STR=0D0
	- CHM=0D0
	- BOT=0D0
	- TOP=0D0
	- GLU=0D0
	- ENDIF
	- ELSE
	- IF(P2.LT.QQ2) THEN
	- CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
	- & BOT,TOP,GLU)
	- ELSE
	- UPV=0D0
	- DNV=0D0
	- USEA=0D0
	- DSEA=0D0
	- STR=0D0
	- CHM=0D0
	- BOT=0D0
	- TOP=0D0
	- GLU=0D0
	- ENDIF
	- ENDIF
	- VINT(231)=Q2MIN
	- XPQ(0)=GLU
	- XPQ(1)=DNV
	- XPQ(-1)=DNV
	- XPQ(2)=UPV
	- XPQ(-2)=UPV
	- XPQ(3)=STR
	- XPQ(-3)=STR
	- XPQ(4)=CHM
	- XPQ(-4)=CHM
	- XPQ(5)=BOT
	- XPQ(-5)=BOT
	- XPQ(6)=TOP
	- XPQ(-6)=TOP
	- XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
	- XPVAL(1)=XPVU/4D0
	- XPVAL(2)=XPVU
	- XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
	- XPVAL(4)=MIN(XPQ(4),XPVU)
	- XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
	- XPVAL(-1)=XPVAL(1)
	- XPVAL(-2)=XPVAL(2)
	- XPVAL(-3)=XPVAL(3)
	- XPVAL(-4)=XPVAL(4)
	- XPVAL(-5)=XPVAL(5)
	- ELSE
	- WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
	- ENDIF
	-
	-C...Pion/gammaVDM parton distribution call.
	- ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
	- &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
	- IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
	- & MSTP(55).LE.12) THEN
	- ISET=1+MOD(MSTP(55)-1,4)
	- Q2MX=Q2
	- P2MX=0.36D0
	- IF(ISET.GE.3) P2MX=4.0D0
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- P2=0D0
	- IF(VINT(120).LT.0D0) P2=VINT(120)**2
	- CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
	- DO 160 KFL=-6,6
	- XPQ(KFL)=XPVMD(KFL)
	- XPVAL(KFL)=VXPVMD(KFL)
	- 160 CONTINUE
	- VINT(231)=P2MX
	- ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
	- CALL PYPDPI(X,Q2,XPPI)
	- DO 170 KFL=-6,6
	- XPQ(KFL)=XPPI(KFL)
	- 170 CONTINUE
	- XPVAL(2)=XPQ(2)-XPQ(-2)
	- XPVAL(-1)=XPQ(-1)-XPQ(1)
	- ELSEIF(MSTP(54).EQ.2) THEN
	-C...Call PDFLIB parton distributions.
	- PARM(1)='NPTYPE'
	- VALUE(1)=2
	- PARM(2)='NGROUP'
	- VALUE(2)=MSTP(53)/1000
	- PARM(3)='NSET'
	- VALUE(3)=MOD(MSTP(53),1000)
	- IF(MINT(93).NE.2000000+MSTP(53)) THEN
	- CALL PDFSET(PARM,VALUE)
	- MINT(93)=2000000+MSTP(53)
	- ENDIF
	- XX=X
	- QQ=SQRT(MAX(0D0,Q2MIN,Q2))
	- IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
	- CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
	- VINT(231)=Q2MIN
	- XPQ(0)=GLU
	- XPQ(1)=DSEA
	- XPQ(-1)=UPV+DSEA
	- XPQ(2)=UPV+USEA
	- XPQ(-2)=USEA
	- XPQ(3)=STR
	- XPQ(-3)=STR
	- XPQ(4)=CHM
	- XPQ(-4)=CHM
	- XPQ(5)=BOT
	- XPQ(-5)=BOT
	- XPQ(6)=TOP
	- XPQ(-6)=TOP
	- XPVAL(2)=UPV
	- XPVAL(-1)=UPV
	- ELSE
	- WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
	- ENDIF
	-
	-C...Anomalous photon parton distribution call.
	- ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
	- Q2MX=Q2
	- P2MX=PARP(15)**2
	- IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
	- IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
	- IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- P2=0D0
	- IF(VINT(120).LT.0D0) P2=VINT(120)**2
	- CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
	- DO 180 KFL=-6,6
	- XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
	- XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
	- 180 CONTINUE
	- VINT(231)=P2MX
	- ELSEIF(MSTP(56).EQ.1) THEN
	- IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
	- IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- P2=0D0
	- IF(VINT(120).LT.0D0) P2=VINT(120)**2
	- CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
	- DO 190 KFL=-6,6
	- XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
	- XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
	- 190 CONTINUE
	- VINT(231)=P2MX
	- ELSEIF(MSTP(56).EQ.2) THEN
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
	- DO 200 KFL=-6,6
	- XPQ(KFL)=XPGA(KFL)
	- XPVAL(KFL)=VXPGA(KFL)
	- 200 CONTINUE
	- VINT(231)=P2MX
	- ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
	- DO 210 KFL=-6,6
	- XPQ(KFL)=XPGA(KFL)
	- XPVAL(KFL)=VXPGA(KFL)
	- 210 CONTINUE
	- VINT(231)=P2MX
	- ELSE
	- 220 RKF=11D0*PYR(0)
	- KFR=1
	- IF(RKF.GT.1D0) KFR=2
	- IF(RKF.GT.5D0) KFR=3
	- IF(RKF.GT.6D0) KFR=4
	- IF(RKF.GT.10D0) KFR=5
	- IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
	- IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
	- IF(MSTP(57).EQ.0) Q2MX=P2MX
	- CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
	- DO 230 KFL=-6,6
	- XPQ(KFL)=XPGA(KFL)
	- XPVAL(KFL)=VXPGA(KFL)
	- 230 CONTINUE
	- VINT(231)=P2MX
	- ENDIF
	-
	-C...Proton parton distribution call.
	- ELSE
	- IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
	- CALL PYPDPR(X,Q2,XPPR)
	- DO 240 KFL=-6,6
	- XPQ(KFL)=XPPR(KFL)
	- 240 CONTINUE
	-C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
	- XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
	- XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
	- ELSEIF(MSTP(52).EQ.2) THEN
	-C...Call PDFLIB parton distributions.
	- PARM(1)='NPTYPE'
	- VALUE(1)=1
	- PARM(2)='NGROUP'
	- VALUE(2)=MSTP(51)/1000
	- PARM(3)='NSET'
	- VALUE(3)=MOD(MSTP(51),1000)
	- IF(MINT(93).NE.1000000+MSTP(51)) THEN
	- CALL PDFSET(PARM,VALUE)
	- MINT(93)=1000000+MSTP(51)
	- ENDIF
	- XX=X
	- QQ=SQRT(MAX(0D0,Q2MIN,Q2))
	- IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
	- CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
	- VINT(231)=Q2MIN
	- XPQ(0)=GLU
	- XPQ(1)=DNV+DSEA
	- XPQ(-1)=DSEA
	- XPQ(2)=UPV+USEA
	- XPQ(-2)=USEA
	- XPQ(3)=STR
	- XPQ(-3)=STR
	- XPQ(4)=CHM
	- XPQ(-4)=CHM
	- XPQ(5)=BOT
	- XPQ(-5)=BOT
	- XPQ(6)=TOP
	- XPQ(-6)=TOP
	- XPVAL(1)=DNV
	- XPVAL(2)=UPV
	- ELSE
	- WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
	- ENDIF
	- ENDIF
	-
	-C...Isospin average for pi0/gammaVDM.
	- IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
	- IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
	- XPV=XPQ(2)-XPQ(1)
	- XPQ(2)=XPQ(1)
	- XPQ(-2)=XPQ(-1)
	- ELSE
	- XPS=0.5D0*(XPQ(1)+XPQ(-2))
	- XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
	- XPQ(2)=XPS
	- XPQ(-1)=XPS
	- ENDIF
	- XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
	- & XPVAL(3)+XPVAL(4)+XPVAL(5)
	- DO 250 KFL=-6,6
	- XPVAL(KFL)=0D0
	- 250 CONTINUE
	- IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
	- XPQ(1)=XPQ(1)+0.2D0*XPV
	- XPQ(2)=XPQ(2)+0.8D0*XPV
	- XPVAL(1)=0.2D0*XPVL
	- XPVAL(2)=0.8D0*XPVL
	- ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
	- XPQ(3)=XPQ(3)+XPV
	- XPVAL(3)=XPVL
	- ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
	- XPQ(4)=XPQ(4)+XPV
	- XPVAL(4)=XPVL
	- IF(MSTP(55).GE.9) THEN
	- DO 260 KFL=-6,6
	- XPQ(KFL)=0D0
	- 260 CONTINUE
	- ENDIF
	- ELSE
	- XPQ(1)=XPQ(1)+0.5D0*XPV
	- XPQ(2)=XPQ(2)+0.5D0*XPV
	- XPVAL(1)=0.5D0*XPVL
	- XPVAL(2)=0.5D0*XPVL
	- ENDIF
	- DO 270 KFL=1,6
	- XPQ(-KFL)=XPQ(KFL)
	- XPVAL(-KFL)=XPVAL(KFL)
	- 270 CONTINUE
	-
	-C...Rescale for gammaVDM by effective gamma -> rho coupling.
	-C+++Do not rescale?
	- IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
	- & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
	- DO 280 KFL=-6,6
	- XPQ(KFL)=VINT(281)*XPQ(KFL)
	- XPVAL(KFL)=VINT(281)*XPVAL(KFL)
	- 280 CONTINUE
	- VINT(232)=VINT(281)*XPV
	- ENDIF
	-
	-C...Simple recipes for kaons.
	- ELSEIF(KFA.EQ.321) THEN
	- XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
	- XPQ(-1)=XPQ(1)
	- XPVAL(-3)=XPVAL(-1)
	- XPVAL(-1)=0D0
	- ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
	- XPS=0.5D0*(XPQ(1)+XPQ(-2))
	- XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
	- XPQ(2)=XPS
	- XPQ(-1)=XPS
	- XPQ(1)=XPQ(1)+0.5D0*XPV
	- XPQ(-1)=XPQ(-1)+0.5D0*XPV
	- XPQ(3)=XPQ(3)+0.5D0*XPV
	- XPQ(-3)=XPQ(-3)+0.5D0*XPV
	- XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
	- XPVAL(2)=0D0
	- XPVAL(-1)=0D0
	- XPVAL(1)=0.5D0*XPV
	- XPVAL(-1)=0.5D0*XPV
	- XPVAL(3)=0.5D0*XPV
	- XPVAL(-3)=0.5D0*XPV
	-
	-C...Isospin conjugation for neutron.
	- ELSEIF(KFA.EQ.2112) THEN
	- XPSV=XPQ(1)
	- XPQ(1)=XPQ(2)
	- XPQ(2)=XPSV
	- XPSV=XPQ(-1)
	- XPQ(-1)=XPQ(-2)
	- XPQ(-2)=XPSV
	- XPSV=XPVAL(1)
	- XPVAL(1)=XPVAL(2)
	- XPVAL(2)=XPSV
	-
	-C...Simple recipes for hyperon (average valence parton distribution).
	- ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
	- & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
	- XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
	- XPS=0.5D0*(XPQ(-1)+XPQ(-2))
	- XPQ(1)=XPS
	- XPQ(2)=XPS
	- XPQ(-1)=XPS
	- XPQ(-2)=XPS
	- XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
	- XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
	- XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
	- XPV=(XPVAL(1)+XPVAL(2))/3D0
	- XPVAL(1)=0D0
	- XPVAL(2)=0D0
	- XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
	- XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
	- XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
	- ENDIF
	-
	-C...Charge conjugation for antiparticle.
	- IF(KF.LT.0) THEN
	- DO 290 KFL=1,25
	- IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
	- XPSV=XPQ(KFL)
	- XPQ(KFL)=XPQ(-KFL)
	- XPQ(-KFL)=XPSV
	- 290 CONTINUE
	- DO 300 KFL=1,6
	- XPSV=XPVAL(KFL)
	- XPVAL(KFL)=XPVAL(-KFL)
	- XPVAL(-KFL)=XPSV
	- 300 CONTINUE
	- ENDIF
	-
	-C...MULTIPLE INTERACTIONS - PDF RESHAPING.
	-C...Set side.
	- JS=MINT(30)
	-C...Only reshape PDFs for the non-first interactions;
	-C...But need valence/sea separation already from first interaction.
	- IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
	- KFVSEL=KFIVAL(JS,1)
	-C...If valence quark kicked out of pi0 or gamma then that decides
	-C...whether we should consider state as d dbar, u ubar, s sbar, etc.
	- IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
	- XPVL=0D0
	- DO 310 KFL=1,6
	- XPVL=XPVL+XPVAL(KFL)
	- XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
	- XPVAL(KFL)=0D0
	- 310 CONTINUE
	- XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
	- XPVAL(IABS(KFVSEL))=XPVL
	- DO 320 KFL=1,6
	- XPQ(-KFL)=XPQ(KFL)
	- XPVAL(-KFL)=XPVAL(KFL)
	- 320 CONTINUE
	-
	-C...If valence quark kicked out of K0S or K0S then that decides whether
	-C...we should consider state as d sbar or s dbar.
	- ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
	- KFS=1
	- IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
	- XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
	- XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
	- XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
	- XPVAL(-KFS)=0D0
	- KFS=-3*KFS
	- XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
	- XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
	- XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
	- XPVAL(-KFS)=0D0
	- ENDIF
	-
	-C...XPQ distributions are nominal for a (signed) beam particle
	-C...of KF type, with 1-Sum(x_prev) rescaled to 1.
	- CMPFAC=1D0
	- NRESC=0
	- 345 NRESC=NRESC+1
	- PVCTOT(JS,-1)=0D0
	- PVCTOT(JS, 0)=0D0
	- PVCTOT(JS, 1)=0D0
	- DO 350 IFL=-6,6
	- IF(IFL.EQ.0) GOTO 350
	-
	-C...Count up number of original IFL valence quarks.
	- IVORG=0
	- IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
	- IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
	- IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
	-C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
	-C...bookkeep as if d dbar (for total momentum sum in valence sector).
	- IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
	-C...Count down number of remaining IFL valence quarks. Skip current
	-C...interaction initiator.
	- IVREM=IVORG
	- DO 330 I1=1,NMI(JS)
	- IF (I1.EQ.MINT(36)) GOTO 330
	- IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
	- & IVREM=IVREM-1
	- 330 CONTINUE
	-
	-C...Separate out original VALENCE and SEA content.
	- VAL=XPVAL(IFL)
	- SEA=MAX(0D0,XPQ(IFL)-VAL)
	- XPSVC(IFL,0)=VAL
	- XPSVC(IFL,-1)=SEA
	-
	-C...Rescale valence content if changed.
	- IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
	- & (VAL*IVREM)/IVORG
	-
	-C...Momentum integrals of original and removed valence quarks.
	- IF(IVORG.NE.0) THEN
	-C...For p/n/pbar/nbar beams can split into d_val and u_val.
	-C...Isospin conjugation for neutrons
	- IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
	- IAFLP=IABS(IFL)
	- IF (KFA.EQ.2112) IAFLP=3-IAFLP
	- VPAVG=PAVG(IAFLP,Q2)
	-C...For other baryons average d_val and u_val, like for PDFs.
	- ELSEIF(KFA.GT.1000) THEN
	- VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
	-C...For mesons and photon average d_val and u_val and scale by 3/2.
	-C...Very crude, especially for photon.
	- ELSE
	- VPAVG=0.5D0(PAVG(1,Q2)+2D0PAVG(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*2EXP(3.56D0SQRT(MAX(0D0,-LOG(3D0X))))
	- XMN=EXP(-(LOG((Q2MN-2D0)/0.052D02)/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)+FVWTV1VINT(232)
	- XPQ(-KFV1)=XPQ(-KFV1)+FVWTV1VINT(232)
	- XPQ(KFV2)=XPQ(KFV2)+FVWTV2VINT(232)
	- XPQ(-KFV2)=XPQ(-KFV2)+FVWTV2VINT(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.45D0FLA
	- 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)=FSAXPA(KFL)+FBXPB(KFL)
	- 130 CONTINUE
	- IF(KFA.NE.22) THEN
	- XPQ(KFV1)=XPQ(KFV1)+(FVAXFVA1+FBXFVB1)
	- XPQ(KFV2)=XPQ(KFV2)+(FVAXFVA2+FBXFVB2)
	- ELSE
	- XPQ(KFV1)=XPQ(KFV1)+WTV1(FVAVI232A+FB*VI232B)
	- XPQ(-KFV1)=XPQ(-KFV1)+WTV1(FVAVI232A+FB*VI232B)
	- XPQ(KFV2)=XPQ(KFV2)+WTV2(FVAVI232A+FB*VI232B)
	- XPQ(-KFV2)=XPQ(-KFV2)+WTV2(FVAVI232A+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)/(XMNQ2MN)
	- FA=1D0-FB
	- FVC=(X/XMN)*0.45D0(Q2/(Q2+RMR))**0.55D0
	- FVA=FVCFA((Q2MN+RMR)/Q2MN)**0.55D0
	- FVB=FVCFB1.10D0XMN0.45D00.11D0
	- FSC=(X/XMN)*(-0.08D0)(Q2/(Q2+RMP))**1.08D0
	- FSA=FSCFA((Q2MN+RMP)/Q2MN)**1.08D0
	- FSB=FSCFB0.21D0XMN(-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)+(FVAXFV1+FVBNV1)
	- XPQ(KFV2)=XPQ(KFV2)+(FVAXFV2+FVBNV2)
	- ELSE
	- DO 160 KFL=-3,3
	- XPQ(KFL)=XPQ(KFL)+VINT(281)FSBWTSB(KFL)
	- 160 CONTINUE
	- XPQ(KFV1)=XPQ(KFV1)+WTV1(FVAVINT(232)+FVB*VINT(281))
	- XPQ(-KFV1)=XPQ(-KFV1)+WTV1(FVAVINT(232)+FVB*VINT(281))
	- XPQ(KFV2)=XPQ(KFV2)+WTV2(FVAVINT(232)+FVB*VINT(281))
	- XPQ(-KFV2)=XPQ(-KFV2)+WTV2(FVAVINT(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/200D0/,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.5D0HLE+1.289868D0)+(AEM/PARU(1))*2
	- & (-2.164868D0HLE2+9.840808D0HLE-10.130464D0)
	- HEE=HBE2(1D0-X)(HBE2-1D0)SQRT(MAX(0D0,HDE))-
	- & 0.5D0HBE2(1D0+X)+HBE2*2/8D0((1D0+X)(-4D0X1L+3D0*XL)-
	- & 4D0*XL/(1D0-X)-5D0-X)
	- ELSE
	- HEE=HBE2(1D0-X)(HBE2-1D0)EXP(0.172784D0*HBE2)/
	- & PYGAMM(1D0+HBE2)-0.5D0HBE2(1D0+X)+HBE2*2/8D0((1D0+X)*
	- & (-4D0X1L+3D0XL)-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=HEE1000D0HBE2/(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)=AEMPHLG(1D0+(1D0-X)**2)
	- HLW=LOG(1D0+Q2/PMAS(24,1)*2)/(4D0PARU(102))
	- XPEL(-24)=AEMPHLW(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-4D0X**3/3D0+
	- & 2D0X(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=XPGPLOG(MAX(1D0,(PARP(13)/PME2)(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)+WTSTPXPGPXPGA(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)+WTSTPXPGPGLU
	- SXP(1)=SXP(1)+WTSTPXPGPDNV
	- SXP(2)=SXP(2)+WTSTPXPGPUPV
	- SXP(3)=SXP(3)+WTSTPXPGPSTR
	- SXP(4)=SXP(4)+WTSTPXPGPCHM
	- SXP(5)=SXP(5)+WTSTPXPGPBOT
	- SXP(6)=SXP(6)+WTSTPXPGPTOP
	- ENDIF
	- 150 CONTINUE
	- SUMXPP=SXP(0)+2D0SXP(1)+2D0SXP(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)TDGAG(2,NFE)+DGAG(3,NFE)T**(-DGAG(4,NFE))
	- DGB=DGBG(1,NFE)TDGBG(2,NFE)+DGBG(3,NFE)T**(-DGBG(4,NFE))
	- DGC=DGCG(1,NFE)TDGCG(2,NFE)+DGCG(3,NFE)T**(-DGCG(4,NFE))
	- XPGL=DGAXDGBX1**DGC
	-
	-C...Evaluate up- and down-type quark content.
	- DGA=DGAN(1,NFE)TDGAN(2,NFE)+DGAN(3,NFE)T**(-DGAN(4,NFE))
	- DGB=DGBN(1,NFE)TDGBN(2,NFE)+DGBN(3,NFE)T**(-DGBN(4,NFE))
	- DGC=DGCN(1,NFE)TDGCN(2,NFE)+DGCN(3,NFE)T**(-DGCN(4,NFE))
	- DGD=DGDN(1,NFE)TDGDN(2,NFE)+DGDN(3,NFE)T**(-DGDN(4,NFE))
	- DGE=DGEN(1,NFE)TDGEN(2,NFE)+DGEN(3,NFE)T**(-DGEN(4,NFE))
	- XPQN=X(X2+X12)/(DGA-DGBLOG(X1))+DGCXDGDX1**DGE
	- DGA=DGAS(1,NFE)TDGAS(2,NFE)+DGAS(3,NFE)T**(-DGAS(4,NFE))
	- DGB=DGBS(1,NFE)TDGBS(2,NFE)+DGBS(3,NFE)T**(-DGBS(4,NFE))
	- DGC=DGCS(1,NFE)TDGCS(2,NFE)+DGCS(3,NFE)T**(-DGCS(4,NFE))
	- DGD=DGDS(1,NFE)TDGDS(2,NFE)+DGDS(3,NFE)T**(-DGDS(4,NFE))
	- DGE=DGES(1,NFE)TDGES(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=DGFX(X2+X12)/(DGA-DGBLOG(X1))+DGCX*DGDX1**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/(4pi).
	- 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=Q023/(Q02+P2)/(Q022-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)(PMRHO2/(PMRHO2+P2))**2
	- FACS=AEM(1D0/FPHI)(PMPHI2/(PMPHI2+P2))**2
	- DO 110 KFL=-5,5
	- XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
	- 110 CONTINUE
	- XPVMD(1)=XPVMD(1)+(1D0-FRACU)FACUDXFVAL
	- XPVMD(2)=XPVMD(2)+FRACUFACUDXFVAL
	- XPVMD(3)=XPVMD(3)+FACS*XFVAL
	- XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)FACUDXFVAL
	- XPVMD(-2)=XPVMD(-2)+FRACUFACUDXFVAL
	- XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
	- VXPVMD(1)=(1D0-FRACU)FACUDXFVAL
	- VXPVMD(2)=FRACUFACUDXFVAL
	- VXPVMD(3)=FACS*XFVAL
	- VXPVMD(-1)=(1D0-FRACU)FACUDXFVAL
	- VXPVMD(-2)=FRACUFACUDXFVAL
	- 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))2FACNOR
	- 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.2D0ALAM3*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/ALAM32)/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/ALAM2)/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/ALAM52)/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 * (X2+X12)
	- XGLU = 0D0
	- XSEA = 0D0
	- ELSE
	- XVAL = (1.5D0/(1D0-0.197D0S+4.33D0S2)X*2 +
	- & (1.5D0+2.10D0S)/(1D0+3.29D0S)X1*2 +
	- & 5.23D0S/(1D0+1.17D0S+19.9D0S3)XX1)
	- & X*(1D0/(1D0+1.5D0S)) * (1D0-X2)(2.667D0*S)
	- XGLU = 4D0S/(1D0+4.76D0S+15.2D0S2+29.3D0S4) *
	- & X*(-2.03D0S/(1D0+2.44D0S)) (X1XL)(1.333D0S) *
	- & ((4D0X2+7D0X+4D0)X1/3D0 - 2D0X(1D0+X)XL)
	- XSEA = S2/(1D0+4.54D0S+8.19D0S2+8.05D0S3)
	- & X*(-1.54D0S/(1D0+1.29D0S)) X1*(2.667D0S) *
	- & ((8D0-73D0X+62D0X*2)X1/9D0 + (3D0-8D0X2/3D0)X*XL +
	- & (2D0X-1D0)XXL*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.252D0S+3.079D0S2) *
	- & X*(0.80D0-0.13D0S) * X1*(0.76D0+0.667D0S) * XL*(2D0S)
	- XGLU = 7.90D0S/(1D0+5.50D0S) * EXP(-5.16D0S)
	- & X*(-1.90D0S/(1D0+3.60D0S)) X1*1.30D0
	- & XL*(0.50D0+3D0S) + 1.273D0 * EXP(-10D0S)
	- & X*0.40D0 X1*(1.76D0+3D0S)
	- XSEA = (0.1D0-0.397D0S2+1.121D0S3)/
	- & (1D0+5.61D0S2+5.26D0S3) * X*(-7.32D0S2/(1D0+10.3D0S2))
	- & X1*((3.76D0+15D0S+12D0S2)/(1D0+4D0S))
	- 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.37D0S+2.18D0S2+3.73D0S3)
	- & X*(0.51D0+0.21D0S) * X1*1.37D0 XL*(2.667D0S)
	- XGLU = 24D0S/(1D0+9.6D0S+0.92D0S2+14.34D0S3) *
	- & EXP(-5.94D0S) X*((-0.013D0-1.80D0S)/(1D0+3.14D0S))
	- & X1*(2.37D0+0.4D0S) * XL*(0.32D0+3.6D0S) + 3.42D0 *
	- & EXP(-12D0S) X*0.255D0 X1*(2.37D0+3D0S)
	- XSEA = 0.842D0S/(1D0+21.3D0S-33.2D0S2+229D0S3) *
	- & X*((0.13D0-2.90D0S)/(1D0+5.44D0S)) X1*(3.45D0+0.5D0S) *
	- & XL*(2.8D0S)
	- 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.186D0S)/(1D0-0.209D0S+1.495D0S2)
	- & X*(0.46D0+0.25D0S) *
	- & X1*((0.64D0+0.14D0S+5D0S2)/(1D0+S)) XL*(1.9D0S) +
	- & (0.76D0+0.4D0S) X * X1*(2.667D0S)
	- XGLU = (1.925D0+5.55D0S+147D0S2)/(1D0-3.59D0S+3.32D0S2) *
	- & EXP(-18.67D0S)
	- & X*((-5.81D0S-5.34D0S2)/(1D0+29D0S-4.26D0*S2))
	- & * X1*((2D0-5.9D0S)/(1D0+1.7D0S))
	- & XL*(9.3D0S/(1D0+1.7D0*S))
	- XSEA = (0.242D0-0.252D0S+1.19D0S2)/
	- & (1D0-0.607D0S+21.95D0S2) *
	- & X*(-12.1D0S2/(1D0+2.62D0S+16.7D0S2)) * 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.771D0S+29.35D0S2) * EXP(-5.776D0S)
	- & X*((0.5D0+0.208D0S)/(1D0-0.794D0S+1.516D0S2)) *
	- & X1*((2.6D0+7.6D0S)/(1D0+5D0S))
	- & XL*(5.15D0S/(1D0+2D0*S)) +
	- & (0.965D0+22.35D0S)/(1D0+18.4D0S) * X * X1*(2.667D0S)
	- XGLU = (1.808D0+29.9D0S)/(1D0+26.4D0S) * EXP(-5.28D0S)
	- & X*((-5.35D0S-10.11D0S2)/(1D0+31.71D0S)) *
	- & X1*((2D0-7.3D0S+4D0S2)/(1D0+2.5D0S)) *
	- & XL*(10.9D0S/(1D0+2.5D0*S))
	- XSEA = (0.209D0+0.644D0S2)/(1D0+0.319D0S+17.6D0S2)
	- & X*((-0.373D0S-7.71D0S2)/(1D0+0.815D0S+11.0D0S2))
	- & X1*(4D0+S) XL*(0.45D0S)
	- XSEA0 = 0.209D0 * X1**4
	- ENDIF
	- ENDIF
	-
	-C...Threshold factors for c and b sea.
	- SLL=LOG(LOG(Q2EFF/ALAM2)/LOG(P2EFF/ALAM2))
	- XCHM=0D0
	- IF(Q2.GT.PMC*2.AND.Q2.GT.1.001D0P2EFF) THEN
	- SCH=MAX(0D0,LOG(LOG(PMC2/ALAM2)/LOG(P2EFF/ALAM**2)))
	- IF(ISET.EQ.0) THEN
	- XCHM=XSEA(1D0-(SCH/SLL)*2)
	- ELSE
	- XCHM=MAX(0D0,XSEA-XSEA0X1(2.667D0S))*(1D0-SCH/SLL)
	- ENDIF
	- ENDIF
	- XBOT=0D0
	- IF(Q2.GT.PMB*2.AND.Q2.GT.1.001D0P2EFF) THEN
	- SBT=MAX(0D0,LOG(LOG(PMB2/ALAM2)/LOG(P2EFF/ALAM**2)))
	- IF(ISET.EQ.0) THEN
	- XBOT=XSEA(1D0-(SBT/SLL)*2)
	- ELSE
	- XBOT=MAX(0D0,XSEA-XSEA0X1(2.667D0S))*(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-2D0NFQ))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-2D0NFQ))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-2D04))LOG(LOG(Q2DIV/ALAMSQ(4))/
	- & LOG(P2EFF/ALAMSQ(4)))
	- SNF3=(6D0/(33D0-2D03))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-2D0NFQ))LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
	- & LOG(P2EFF/ALAMSQ(NFQ)))
	- IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
	- Q2DIV=PMB**2
	- SNFQ=(6D0/(33D0-2D0NFQ))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-2D0NFQ))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=AEM2PI2D0CHSQ*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.49D0S+26.9D0S*2)/(1D0+32.3D0S*2)X**2 +
	- & (1.5D0-0.49D0S+7.83D0S*2)/(1D0+7.68D0S*2)(1D0-X)**2 +
	- & 1.5D0S/(1D0-3.2D0S+7D0S2)X(1D0-X))
	- & X*(1D0/(1D0+0.58D0S)) * (1D0-X2)(2.5D0S/(1D0+10D0S))
	- XGLU= 2D0S/(1D0+4D0S+7D0S2)
	- & X*(-1.67D0S/(1D0+2D0S)) (1D0-X2)(1.2D0S)
	- & ((4D0X2+7D0X+4D0)(1D0-X)/3D0 - 2D0X(1D0+X)XL)
	- XSEA= 0.333D0S2/(1D0+4.90D0S+4.69D0S2+21.4D0S*3)
	- & X*(-1.18D0S/(1D0+1.22D0S)) (1D0-X)*(1.2D0S) *
	- & ((8D0-73D0X+62D0X*2)(1D0-X)/9D0 +
	- & (3D0-8D0X2/3D0)XXL + (2D0X-1D0)XXL**2)
	-
	-C...Threshold factors for c and b sea.
	- SLL=LOG(LOG(Q2EFF/ALAM2)/LOG(P2EFF/ALAM2))
	- XCHM=0D0
	- IF(Q2.GT.PMC*2.AND.Q2.GT.1.001D0P2EFF) THEN
	- SCH=MAX(0D0,LOG(LOG(PMC2/ALAM2)/LOG(P2EFF/ALAM**2)))
	- XCHM=XSEA(1D0-(SCH/SLL)*3)
	- ENDIF
	- XBOT=0D0
	- IF(Q2.GT.PMB*2.AND.Q2.GT.1.001D0P2EFF) THEN
	- SBT=MAX(0D0,LOG(LOG(PMB2/ALAM2)/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)*2W2/(4D0*PM2))
	- ENDIF
	- SIGBH=BETA(8D0X(1D0-X)-1D0-RMQX*(1D0-X))+
	- & XBL(X2+(1D0-X)2+RMQX(1D0-3D0X)-0.5D0RMQ2X**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-4D0X2P2/Q2
	- IF(RPQ.GT.1D-10) THEN
	- RPBE=SQRT(RPQ*BETA2)
	- IF(RPBE.LT.0.99D0) THEN
	- XBL=LOG((1D0+RPBE)/(1D0-RPBE))
	- XBI=2D0RPBE/(1D0-RPBE*2)
	- ELSE
	- RPBESN=4D0PM2/W2+(4D0X*2P2/Q2)*BETA2
	- XBL=LOG((1D0+RPBE)**2/RPBESN)
	- XBI=2D0*RPBE/RPBESN
	- ENDIF
	- SIGBH=BETA(6D0X*(1D0-X)-1D0)+
	- & XBL(X2+(1D0-X)2+RMQX(1D0-3D0X)-0.5D0RMQ2X**2)+
	- & XBI(2D0X/Q2)(PM2X(2D0-RMQ)-P2X)
	- 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=3D0CHSQAEM2PIXSIGBH
	-
	- 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 = (X2+(1D0-X)2) * (-LOG(X)) - 1D0
	- CGAM = 3D0AEM2PIX * (XTMP(1D0+P2/(P2+Q02)) + 6D0X*(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/ALAM2)/LOG(4D0/ALAM2))
	- 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)XTS(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.232D02)/LOG(0.25D0/0.232D02))
	- ENDIF
	- SD2=SD**2
	- XL=-LOG(X)
	- XS=SQRT(X)
	-
	-C...Evaluate valence, gluon and sea distributions.
	- XFVAL=(0.519D0+0.180D0SD-0.011D0SD2)X(0.499D0-0.027D0SD)*
	- & (1D0+(0.381D0-0.419D0SD)XS)(1D0-X)(0.367D0+0.563D0SD)
	- XFGLU=(X*(0.482D0+0.341D0SQRT(SD))((0.678D0+0.877D0
	- & SD-0.175D0*SD2)+
	- & (0.338D0-1.597D0SD)XS+(-0.233D0SD+0.406D0SD2)*X)+
	- & SD*0.599D0EXP(-(0.618D0+2.070D0SD)+SQRT(3.676D0SD*1.263D0
	- & XL)))*
	- & (1D0-X)*(0.390D0+1.053D0SD)
	- XFSEA=SD*0.55D0(1D0-0.748D0XS+(0.313D0+0.935D0SD)X)(1D0-
	- & X)*3.359D0
	- & EXP(-(4.433D0+1.301D0SD)+SQRT((9.30D0-0.887D0SD)SD0.56D0
	- & XL))/
	- & XL*(2.538D0-0.763D0SD)
	- IF(SD.LE.0.888D0) THEN
	- XFCHM=0D0
	- ELSE
	- XFCHM=(SD-0.888D0)*1.02D0(1D0+1.008D0X)(1D0-X)**(1.208D0+
	- & 0.771D0SD)
	- & EXP(-(4.40D0+1.493D0SD)+SQRT((2.032D0+1.901D0SD)SD0.39D0
	- & XL))
	- ENDIF
	- IF(SD.LE.1.351D0) THEN
	- XFBOT=0D0
	- ELSE
	- XFBOT=(SD-1.351D0)*1.03D0(1D0-X)*(0.697D0+0.855D0SD)*
	- & EXP(-(4.51D0+1.490D0SD)+SQRT((3.056D0+1.694D0SD)SD0.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)=XINSUMUDBRATUDB/(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)=XINSUMUDBRATUDB/(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-01SB +0.2752D+00SB2-
	- & 0.3171D+00*SB3)
	- A1= 0.4611D+00+0.2331D-01SB -0.3403D-01SB2+0.3174D-01*SB3
	- A2= 0.3504D+01+0.5739D+00SB +0.2676D+00SB2-0.1553D+00*SB3
	- A3= 0.7452D+01-0.6742D+01SB +0.2849D+01SB2-0.1964D+00*SB3
	- A4= 0.1116D+01-0.3435D+00SB +0.2865D+00SB2-0.1288D+00*SB3
	- A5= 0.6659D-01+0.2714D+00SB -0.2688D+00SB2+0.2763D+00*SB3
	- ELSEIF(IPRT .EQ. 1) THEN
	- A0=Exp( 0.1141D+00+0.4764D+00SB -0.1745D+01SB2+
	- & 0.7728D+00*SB3)
	- A1= 0.4275D+00-0.1290D+00SB +0.3609D+00SB2-0.1689D+00*SB3
	- A2= 0.3000D+01+0.2946D+01SB -0.4117D+01SB2+0.1989D+01*SB3
	- A3=-0.1302D+01+0.2322D+01SB -0.4258D+01SB2+0.2109D+01*SB3
	- A4= 0.2586D+01-0.1920D+00SB -0.3754D+00SB2+0.2731D+00*SB3
	- A5=-0.2251D+00-0.5374D+00SB +0.2245D+01SB2-0.1034D+01*SB3
	- ELSEIF(IPRT .EQ. 0) THEN
	- A0=Exp(-0.7631D+00-0.7241D+00SB -0.1170D+01SB2+
	- & 0.5343D+00*SB3)
	- A1=-0.3573D+00+0.3469D+00SB -0.3396D+00SB2+0.9188D-01*SB3
	- A2= 0.5604D+01+0.7458D+00SB -0.5082D+00SB2+0.1844D+00*SB3
	- A3= 0.1549D+02-0.1809D+02SB +0.1162D+02SB2-0.3483D+01*SB3
	- A4= 0.9881D+00+0.1364D+00SB -0.4421D+00SB2+0.2051D+00*SB3
	- A5=-0.9505D-01+0.3259D+01SB -0.1547D+01SB2+0.2918D+00*SB3
	- ELSEIF(IPRT .EQ. -1) THEN
	- A0=Exp(-0.2449D+01-0.3513D+01SB +0.4529D+01SB2-
	- & 0.2031D+01*SB3)
	- A1=-0.4050D+00+0.3411D+00SB -0.3669D+00SB2+0.1109D+00*SB3
	- A2= 0.7470D+01-0.2982D+01SB +0.5503D+01SB2-0.2419D+01*SB3
	- A3= 0.1503D+02+0.1638D+01SB -0.8772D+01SB2+0.3852D+01*SB3
	- A4= 0.1137D+01-0.1006D+01SB +0.1485D+01SB2-0.6389D+00*SB3
	- A5=-0.5299D+00+0.3160D+01SB -0.3104D+01SB2+0.1219D+01*SB3
	- ELSEIF(IPRT .EQ. -2) THEN
	- A0=Exp(-0.2740D+01-0.7987D-01SB -0.9015D+00SB2-
	- & 0.9872D-01*SB3)
	- A1=-0.3909D+00+0.1244D+00SB -0.4487D-01SB2+0.1277D-01*SB3
	- A2= 0.9163D+01+0.2823D+00SB -0.7720D+00SB2-0.9360D-02*SB3
	- A3= 0.1080D+02-0.3915D+01SB -0.1153D+01SB2+0.2649D+01*SB3
	- A4= 0.9894D+00-0.1647D+00SB -0.9426D-02SB2+0.2945D-02*SB3
	- A5=-0.3395D+00+0.6998D+00SB +0.7000D+00SB2-0.6730D-01*SB3
	- ELSEIF(IPRT .EQ. -3) THEN
	- A0=Exp(-0.3640D+01+0.1250D+01SB -0.2914D+01SB2+
	- & 0.8390D+00*SB3)
	- A1=-0.3595D+00-0.5259D-01SB +0.3122D+00SB2-0.1642D+00*SB3
	- A2= 0.7305D+01+0.9727D+00SB -0.9788D+00SB2-0.5193D-01*SB3
	- A3= 0.1198D+02-0.1799D+02SB +0.2614D+02SB2-0.1091D+02*SB3
	- A4= 0.9882D+00-0.6101D+00SB +0.9737D+00SB2-0.4935D+00*SB3
	- A5=-0.1186D+00-0.3231D+00SB +0.3074D+01SB2-0.1274D+01*SB3
	- ELSEIF(IPRT .EQ. -4) THEN
	- A0=SB** 0.1122D+01Exp(-0.3718D+01-0.1335D+01SB +
	- & 0.1651D-01*SB2)
	- A1=-0.4719D+00+0.7509D+00SB -0.8420D+00SB2+0.2901D+00*SB3
	- A2= 0.6194D+01-0.1641D+01SB +0.4907D+01SB2-0.2523D+01*SB3
	- A3= 0.4426D+01-0.4270D+01SB +0.6581D+01SB2-0.3474D+01*SB3
	- A4= 0.2683D+00+0.9876D+00SB -0.7612D+00SB2+0.1780D+00*SB3
	- A5=-0.4547D+00+0.4410D+01SB -0.3712D+01SB2+0.1245D+01*SB3
	- ELSEIF(IPRT .EQ. -5) THEN
	- A0=SB** 0.9838D+00Exp(-0.2548D+01-0.7660D+01SB +
	- & 0.3702D+01*SB2)
	- A1=-0.3122D+00-0.2120D+00SB +0.5716D+00SB2-0.3773D+00*SB3
	- A2= 0.6257D+01-0.8214D-01SB -0.2537D+01SB2+0.2981D+01*SB3
	- A3=-0.6723D+00+0.2131D+01SB +0.9599D+01SB2-0.7910D+01*SB3
	- A4= 0.9169D-01+0.4295D-01SB -0.5017D+00SB2+0.3811D+00*SB3
	- A5= 0.2402D+00+0.2656D+01SB -0.1586D+01SB2+0.2880D+00*SB3
	- ELSEIF(IPRT .EQ. -6) THEN
	- A0=SB** 0.1001D+01Exp(-0.6934D+01+0.3050D+01SB -
	- & 0.6943D+00*SB2)
	- A1=-0.1713D+00-0.5167D+00SB +0.1241D+01SB2-0.1703D+01*SB3
	- A2= 0.6169D+01+0.3023D+01SB -0.1972D+02SB2+0.1069D+02*SB3
	- A3= 0.4439D+01-0.1746D+02SB +0.1225D+02SB2+0.8350D+00*SB3
	- A4= 0.5458D+00-0.4586D+00SB +0.9089D+00SB2-0.4049D+00*SB3
	- A5= 0.3207D+01-0.3362D+01SB +0.5877D+01SB2-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+00SB +0.3035D+00SB2-
	- & 0.2935D+00*SB3)
	- A1= 0.5085D+00+0.1651D-01SB -0.3592D-01SB2+0.2782D-01*SB3
	- A2= 0.3732D+01+0.4901D+00SB +0.2218D+00SB2-0.1116D+00*SB3
	- A3= 0.7011D+01-0.6620D+01SB +0.2557D+01SB2-0.1360D+00*SB3
	- A4= 0.8969D+00-0.2429D+00SB +0.1811D+00SB2-0.6888D-01*SB3
	- A5= 0.8636D-01+0.2558D+00SB -0.3082D+00SB2+0.2535D+00*SB3
	- ELSEIF(IPRT .EQ. 1) THEN
	- A0=Exp(-0.7266D+00-0.1584D+01SB +0.1259D+01SB2-
	- & 0.4305D-01*SB3)
	- A1= 0.5285D+00-0.3721D+00SB +0.5150D+00SB2-0.1697D+00*SB3
	- A2= 0.4075D+01+0.8282D+00SB -0.4496D+00SB2+0.2107D+00*SB3
	- A3= 0.3279D+01+0.5066D+01SB -0.9134D+01SB2+0.2897D+01*SB3
	- A4= 0.4399D+00-0.5888D+00SB +0.4802D+00SB2-0.1664D+00*SB3
	- A5= 0.3678D+00-0.8929D+00SB +0.1592D+01SB2-0.5713D+00*SB3
	- ELSEIF(IPRT .EQ. 0) THEN
	- A0=Exp(-0.2318D+00-0.9779D+00SB -0.3783D+00SB2+
	- & 0.1037D-01*SB3)
	- A1=-0.2916D+00+0.1754D+00SB -0.1884D+00SB2+0.6116D-01*SB3
	- A2= 0.5349D+01+0.7460D+00SB +0.2319D+00SB2-0.2622D+00*SB3
	- A3= 0.6920D+01-0.3454D+01SB +0.2027D+01SB2-0.7626D+00*SB3
	- A4= 0.1013D+01+0.1423D+00SB -0.1798D+00SB2+0.1872D-01*SB3
	- A5=-0.5465D-01+0.2303D+01SB -0.9584D+00SB2+0.3098D+00*SB3
	- ELSEIF(IPRT .EQ. -1) THEN
	- A0=Exp(-0.2328D+01-0.3061D+01SB +0.3620D+01SB2-
	- & 0.1602D+01*SB3)
	- A1=-0.3358D+00+0.3198D+00SB -0.4210D+00SB2+0.1571D+00*SB3
	- A2= 0.8478D+01-0.3112D+01SB +0.5243D+01SB2-0.2255D+01*SB3
	- A3= 0.1971D+02+0.3389D+00SB -0.5268D+01SB2+0.2099D+01*SB3
	- A4= 0.1128D+01-0.4701D+00SB +0.7779D+00SB2-0.3506D+00*SB3
	- A5=-0.4708D+00+0.3341D+01SB -0.3375D+01SB2+0.1353D+01*SB3
	- ELSEIF(IPRT .EQ. -2) THEN
	- A0=Exp(-0.2906D+01-0.1069D+00SB -0.1055D+01SB2+
	- & 0.2496D+00*SB3)
	- A1=-0.2875D+00+0.6571D-01SB -0.1987D-01SB2-0.1800D-02*SB3
	- A2= 0.9854D+01-0.2715D+00SB -0.7407D+00SB2+0.2888D+00*SB3
	- A3= 0.1583D+02-0.7687D+01SB +0.3428D+01SB2-0.3327D+00*SB3
	- A4= 0.9763D+00+0.7599D-01SB -0.2128D+00SB2+0.6852D-01*SB3
	- A5=-0.8444D-02+0.9434D+00SB +0.4152D+00SB2-0.1481D+00*SB3
	- ELSEIF(IPRT .EQ. -3) THEN
	- A0=Exp(-0.3780D+01+0.2499D+01SB -0.4962D+01SB2+
	- & 0.1936D+01*SB3)
	- A1=-0.2639D+00-0.1575D+00SB +0.3584D+00SB2-0.1646D+00*SB3
	- A2= 0.8082D+01+0.2794D+01SB -0.5438D+01SB2+0.2321D+01*SB3
	- A3= 0.1811D+02-0.2000D+02SB +0.1951D+02SB2-0.6904D+01*SB3
	- A4= 0.9822D+00+0.4972D+00SB -0.8690D+00SB2+0.3415D+00*SB3
	- A5= 0.1772D+00-0.6078D+00SB +0.3341D+01SB2-0.1473D+01*SB3
	- ELSEIF(IPRT .EQ. -4) THEN
	- A0=SB** 0.1122D+01Exp(-0.4232D+01-0.1808D+01SB +
	- & 0.5348D+00*SB2)
	- A1=-0.2824D+00+0.5846D+00SB -0.7230D+00SB2+0.2419D+00*SB3
	- A2= 0.5683D+01-0.2948D+01SB +0.5916D+01SB2-0.2560D+01*SB3
	- A3= 0.2051D+01+0.4795D+01SB -0.4271D+01SB2+0.4174D+00*SB3
	- A4= 0.1737D+00+0.1717D+01SB -0.1978D+01SB2+0.6643D+00*SB3
	- A5= 0.8689D+00+0.3500D+01SB -0.3283D+01SB2+0.1026D+01*SB3
	- ELSEIF(IPRT .EQ. -5) THEN
	- A0=SB** 0.9906D+00Exp(-0.1496D+01-0.6576D+01SB +
	- & 0.1569D+01*SB2)
	- A1=-0.2140D+00-0.6419D-01SB -0.2741D-02SB2+0.3185D-02*SB3
	- A2= 0.5781D+01+0.1049D+00SB -0.3930D+00SB2+0.5174D+00*SB3
	- A3=-0.9420D+00+0.5511D+00SB +0.8817D+00SB2+0.1903D+01*SB3
	- A4= 0.2418D-01+0.4232D-01SB -0.1244D-01SB2-0.2365D-01*SB3
	- A5= 0.7664D+00+0.1794D+01SB -0.4917D+00SB2-0.1284D+00*SB3
	- ELSEIF(IPRT .EQ. -6) THEN
	- A0=SB** 0.1000D+01Exp(-0.8460D+01+0.1154D+01SB +
	- & 0.8838D+01*SB2)
	- A1=-0.4316D-01-0.2976D+00SB +0.3174D+00SB2-0.1429D+01*SB3
	- A2= 0.4910D+01+0.2273D+01SB +0.5631D+01SB2-0.1994D+02*SB3
	- A3= 0.1190D+02-0.2000D+02SB -0.2000D+02SB2+0.1292D+02*SB3
	- A4= 0.5771D+00-0.2552D+00SB +0.7510D+00SB2+0.6923D+00*SB3
	- A5= 0.4402D+01-0.1627D+01SB -0.2085D+01SB2-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-01SB +0.2734D+00SB2-
	- & 0.2902D+00*SB3)
	- A1= 0.4810D+00+0.1657D-01SB -0.3800D-01SB2+0.3125D-01*SB3
	- A2= 0.3509D+01+0.3923D+00SB +0.4010D+00SB2-0.1932D+00*SB3
	- A3= 0.7055D+01-0.6552D+01SB +0.3466D+01SB2-0.5657D+00*SB3
	- A4= 0.1061D+01-0.3453D+00SB +0.4089D+00SB2-0.1817D+00*SB3
	- A5= 0.8687D-01+0.2548D+00SB -0.2967D+00SB2+0.2647D+00*SB3
	- ELSEIF(IPRT .EQ. 1) THEN
	- A0=Exp( 0.3961D+00+0.4914D+00SB -0.1728D+01SB2+
	- & 0.7257D+00*SB3)
	- A1= 0.4162D+00-0.1419D+00SB +0.3680D+00SB2-0.1618D+00*SB3
	- A2= 0.3248D+01+0.3028D+01SB -0.4307D+01SB2+0.1920D+01*SB3
	- A3=-0.1100D+01+0.2184D+01SB -0.3820D+01SB2+0.1717D+01*SB3
	- A4= 0.2082D+01-0.2756D+00SB +0.3043D+00SB2-0.1260D+00*SB3
	- A5=-0.4822D+00-0.5706D+00SB +0.2243D+01SB2-0.9760D+00*SB3
	- ELSEIF(IPRT .EQ. 0) THEN
	- A0=Exp(-0.4665D+00-0.7554D+00SB -0.3323D+00SB2-
	- & 0.2734D-04*SB3)
	- A1=-0.3359D+00+0.2395D+00SB -0.2377D+00SB2+0.7059D-01*SB3
	- A2= 0.5451D+01+0.6086D+00SB +0.8606D-01SB2-0.1425D+00*SB3
	- A3= 0.1026D+02-0.9352D+01SB +0.4879D+01SB2-0.1150D+01*SB3
	- A4= 0.9935D+00-0.5017D-01SB -0.1707D-01SB2-0.1464D-02*SB3
	- A5=-0.4160D-01+0.2305D+01SB -0.1063D+01SB2+0.3211D+00*SB3
	- ELSEIF(IPRT .EQ. -1) THEN
	- A0=Exp(-0.2714D+01-0.2868D+01SB +0.3700D+01SB2-
	- & 0.1671D+01*SB3)
	- A1=-0.3893D+00+0.3341D+00SB -0.3897D+00SB2+0.1420D+00*SB3
	- A2= 0.8359D+01-0.3267D+01SB +0.5327D+01SB2-0.2245D+01*SB3
	- A3= 0.2359D+02-0.5669D+01SB -0.4602D+01SB2+0.3153D+01*SB3
	- A4= 0.1106D+01-0.4745D+00SB +0.7739D+00SB2-0.3417D+00*SB3
	- A5=-0.5557D+00+0.3433D+01SB -0.3390D+01SB2+0.1354D+01*SB3
	- ELSEIF(IPRT .EQ. -2) THEN
	- A0=Exp(-0.3323D+01+0.2296D+00SB -0.1109D+01SB2+
	- & 0.2223D+00*SB3)
	- A1=-0.3410D+00+0.8847D-01SB -0.1111D-01SB2-0.5927D-02*SB3
	- A2= 0.9753D+01-0.5182D+00SB -0.4670D+00SB2+0.1921D+00*SB3
	- A3= 0.1977D+02-0.1600D+02SB +0.9481D+01SB2-0.1864D+01*SB3
	- A4= 0.9818D+00+0.2839D-02SB -0.1188D+00SB2+0.3584D-01*SB3
	- A5=-0.7934D-01+0.1004D+01SB +0.3704D+00SB2-0.1220D+00*SB3
	- ELSEIF(IPRT .EQ. -3) THEN
	- A0=Exp(-0.3985D+01+0.2855D+01SB -0.5208D+01SB2+
	- & 0.1937D+01*SB3)
	- A1=-0.3337D+00-0.1150D+00SB +0.3691D+00SB2-0.1709D+00*SB3
	- A2= 0.7968D+01+0.3641D+01SB -0.6599D+01SB2+0.2642D+01*SB3
	- A3= 0.1873D+02-0.1999D+02SB +0.1734D+02SB2-0.5813D+01*SB3
	- A4= 0.9731D+00+0.5082D+00SB -0.8780D+00SB2+0.3231D+00*SB3
	- A5=-0.5542D-01-0.4189D+00SB +0.3309D+01SB2-0.1439D+01*SB3
	- ELSEIF(IPRT .EQ. -4) THEN
	- A0=SB** 0.1105D+01Exp(-0.3952D+01-0.1901D+01SB +
	- & 0.5137D+00*SB2)
	- A1=-0.3543D+00+0.6055D+00SB -0.6941D+00SB2+0.2278D+00*SB3
	- A2= 0.5955D+01-0.2629D+01SB +0.5337D+01SB2-0.2300D+01*SB3
	- A3= 0.1933D+01+0.4882D+01SB -0.3810D+01SB2+0.2290D+00*SB3
	- A4= 0.1806D+00+0.1655D+01SB -0.1893D+01SB2+0.6395D+00*SB3
	- A5= 0.4790D+00+0.3612D+01SB -0.3152D+01SB2+0.9684D+00*SB3
	- ELSEIF(IPRT .EQ. -5) THEN
	- A0=SB** 0.9818D+00Exp(-0.1825D+01-0.7464D+01SB +
	- & 0.2143D+01*SB2)
	- A1=-0.2604D+00-0.1400D+00SB +0.1702D+00SB2-0.8476D-01*SB3
	- A2= 0.6005D+01+0.6275D+00SB -0.2535D+01SB2+0.2219D+01*SB3
	- A3=-0.9067D+00+0.1149D+01SB +0.1974D+01SB2+0.4716D+01*SB3
	- A4= 0.3915D-01+0.5945D-01SB -0.9844D-01SB2+0.2783D-01*SB3
	- A5= 0.5500D+00+0.1994D+01SB -0.6727D+00SB2-0.1510D+00*SB3
	- ELSEIF(IPRT .EQ. -6) THEN
	- A0=SB** 0.1002D+01Exp(-0.8553D+01+0.3793D+00SB +
	- & 0.9998D+01*SB2)
	- A1=-0.5870D-01-0.2792D+00SB +0.6526D+00SB2-0.1984D+01*SB3
	- A2= 0.4716D+01+0.4473D+00SB +0.1128D+02SB2-0.1937D+02*SB3
	- A3= 0.1289D+02-0.1742D+02SB -0.1983D+02SB2-0.9274D+00*SB3
	- A4= 0.5647D+00-0.2732D+00SB +0.1074D+01SB2+0.5981D+00*SB3
	- A5= 0.4390D+01-0.1262D+01SB -0.9026D+00SB2-0.9394D+01*SB3
	- ENDIF
	- ENDIF
	-
	-C...Calculation of x * f(x, Q).
	- PYCTEQ = MAX(0D0, A0 (XA1) ((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+ AXBK + X (B + CDX))
	- & (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 + XC)) LXBK + SAL
	- & * 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 / LXAK * (1D0+ AGDX + BX) *
	- & (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)
	-C...JRR: Catching arithmetic exception
	- IF(MEXVEC(IFL) .GE. I) THEN
	- AF(I) = AF(I) + SBX*AM(I,K,IFL)
	- ENDIF
	- SBX = SB1*SBX
	- 100 CONTINUE
	- 110 CONTINUE
	-
	- Y = -LOG(X)
	- U = LOG(X/0.00001D0)
	-
	- PART1 = AF(1)Y(1.D0+0.01D0AF(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)
	-C...JRR: Catching arithmetic exception
	- IF (MEXVEC(IFL) .GE. I) THEN
	- AF(I) = AF(I) + SBX*AM(I,K,IFL)
	- ENDIF
	- SBX = SB1*SBX
	- 100 CONTINUE
	- 110 CONTINUE
	-
	- Y = -LOG(X)
	- U = LOG(X/0.00001D0)
	-
	- PART1 = AF(1)Y(1.D0+0.01D0AF(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.232D02)/LOG(0.25D0/0.232D02))
	- SD2=SD**2
	- XL=-LOG(X)
	- XS=SQRT(X)
	-
	-C...Evaluate valence, gluon and sea distributions.
	- XFVUD=(0.663D0+0.191D0SD-0.041D0SD2+0.031D0SD3)
	- & X*0.326D0(1D0+(-1.97D0+6.74D0SD-1.96D0SD2)*XS+
	- & (24.4D0-20.7D0SD+4.08D0SD2)X)
	- & (1D0-X)*(2.86D0+0.70D0SD-0.02D0*SD2)
	- XFVDD=(0.579D0+0.283D0SD+0.047D0SD2)X(0.523D0-0.015D0SD)*
	- & (1D0+(2.22D0-0.59D0SD-0.27D0SD2)XS+(5.95D0-6.19D0SD+
	- & 1.55D0SD2)X)(1D0-X)(3.57D0+0.94D0SD-0.16D0*SD2)
	- XFGLU=(X*(1.00D0-0.17D0SD)((4.879D0SD-1.383D0*SD2)+
	- & (25.92D0-28.97D0SD+5.596D0SD2)X+(-25.69D0+23.68D0SD-
	- & 1.975D0SD2)X2)+SD0.558D0EXP(-(0.595D0+2.138D0SD)+
	- & SQRT(4.066D0SD1.218D0XL)))*
	- & (1D0-X)*(2.537D0+1.718D0SD+0.353D0*SD2)
	- XFSEA=(X*(0.412D0-0.171D0SD)(0.363D0-1.196D0X+(1.029D0+
	- & 1.785D0SD-0.459D0SD2)X2)XL*(0.566D0-0.496D0SD)+
	- & SD*1.396D0EXP(-(3.838D0+1.944D0SD)+SQRT(2.845D0SD*1.331D0
	- & XL)))(1D0-X)(4.696D0+2.109D0SD)
	- XFSTR=SD*0.803D0(1D0+(-3.055D0+1.024D0SD0.67D0)XS+
	- & (27.4D0-20.0D0SD0.154D0)X)(1D0-X)6.22D0
	- & EXP(-(4.33D0+1.408D0SD)+SQRT((8.27D0-0.437D0SD)*
	- & SD*0.563D0XL))/XL*(2.082D0-0.577D0SD)
	- IF(SD.LE.0.888D0) THEN
	- XFCHM=0D0
	- ELSE
	- XFCHM=(SD-0.888D0)*1.01D0(1.+(4.24D0-0.804D0SD)X)*
	- & (1D0-X)*(3.46D0+1.076D0SD)EXP(-(4.61D0+1.49D0SD)+
	- & SQRT((2.555D0+1.961D0SD)SD*0.37D0XL))
	- ENDIF
	- IF(SD.LE.1.351D0) THEN
	- XFBOT=0D0
	- ELSE
	- XFBOT=(SD-1.351D0)(1D0+1.848D0X)(1D0-X)*(2.929D0+
	- & 1.396D0SD)EXP(-(4.71D0+1.514D0*SD)+
	- & SQRT((4.02D0+1.239D0SD)SD*0.51D0XL))
	- 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)=2D0VX*2-1D0
	- TX(4)=4D0VX3-3D0VX
	- TX(5)=8D0VX4-8D0VX**2+1D0
	- TX(6)=16D0VX5-20D0VX*3+5D0VX
	- TT(1)=1D0
	- TT(2)=VT
	- TT(3)=2D0VT*2-1D0
	- TT(4)=4D0VT3-3D0VT
	- TT(5)=8D0VT4-8D0VT**2+1D0
	- TT(6)=16D0VT5-20D0VT*3+5D0VT
	-
	-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)=2D0VT*2-1D0
	- TT(4)=4D0VT3-3D0VT
	- TT(5)=8D0VT4-8D0VT**2+1D0
	- TT(6)=16D0VT5-20D0VT*3+5D0VT
	- 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)=2D0VT*2-1D0
	- TT(4)=4D0VT3-3D0VT
	- TT(5)=8D0VT4-8D0VT**2+1D0
	- TT(6)=16D0VT5-20D0VT*3+5D0VT
	- 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/ALAM2)/LOG(4D0/ALAM2))
	-
	-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)XTS(2)(1D0-X)*TS(3)(1D0+TS(4)*X+
	- & TS(5)X2+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)-2D0SQRT(SQM))**2+
	- & PARP(36)**2)))
	- ALSSG=PYALPS(Q2BN)
	- MSTU(115)=MST115
	- ENDIF
	-
	-C...Evaluate attractive and repulsive factors.
	- XATTR=4D0PARU(1)ALSSG/(3D0SQRT(MAX(1D-20,1D0-4D0SQM/SH)))
	- FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
	- XREPU=PARU(1)ALSSG/(6D0SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
	- FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
	- PYHFTH=FRATTFATTR+(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)
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- ELSEIF((KFA.EQ.111.OR.KFA.EQ.113)) THEN
	- IF(PYR(0).GT.0.5D0) THEN
	- KFL(2)=2
	- KFL(3)=2
	- ENDIF
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- ELSEIF(KFA.EQ.223) THEN
	- IF(PYR(0).GT.0.5D0) THEN
	- KFL(2)=1
	- KFL(3)=1
	- ENDIF
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- ELSEIF((KFA.EQ.130.OR.KFA.EQ.310)) THEN
	- IF(PYR(0).GT.0.5D0) THEN
	- KFL(2)=MOD(KFA/10,10)
	- KFL(3)=MOD(KFA/100,10)
	- ENDIF
	- 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)
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- ELSEIF(KFLR.EQ.21) THEN
	- IF(PYR(0).GT.0.5D0) THEN
	- KFLSP=KFL(2)
	- KFLCH=KFL(3)
	- ENDIF
	- 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
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- IF(IAGR.NE.3) THEN
	- IF(PYR(0).GT.0.25D0) KSP=1
	- ENDIF
	- 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=1000KFL(ID1)+100KFL(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=2D0SQRT(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=2D0SQRT(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=-4D0PARU(1)ACOSH(SQRT(1D0/EPS))
	- ELSE
	- IF(IAUX.EQ.1) WRE=2D0SQRT(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+RATEPS))
	- 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.25D0EPS/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)-
	- & PYSPEN((1D0-0.25D0EPS)/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)+
	- & PYSPEN(0.25D0(RAT+1D0)EPS/(1D0+0.25D0RATEPS),0D0,1)-
	- & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0(LOG(1D0+0.25D0RATEPS)*2-
	- & LOG(0.25D0RATEPS)*2)+LOG(1D0-0.25D0EPS)*
	- & LOG((1D0+0.25D0(RAT-1D0)EPS)/(1D0+0.25D0RATEPS))+
	- & LOG(-0.25D0EPS)LOG(0.25D0RATEPS/(1D0+0.25D0(RAT-1D0)
	- & EPS))
	- ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
	- F3RE=PYSPEN(-0.25D0EPS/(BE-0.25D0EPS),0D0,1)-
	- & PYSPEN((1D0-0.25D0EPS)/(BE-0.25D0EPS),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.25D0EPS)LOG((BE-0.25D0*EPS)/BE)+
	- & LOG(-0.25D0EPS)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.25D0RATEPS),0D0,1)-
	- & PYSPEN(GA/(GA+0.25D0RATEPS),0D0,1)+
	- & PYSPEN((1D0+0.25D0RATEPS-GA)/(1D0+0.25D0RATEPS),0D0,1)-
	- & PYSPEN((1D0+0.25D0RATEPS-GA)/(0.25D0RATEPS),0D0,1)+
	- & 0.5D0(LOG(1D0+0.25D0RATEPS)2-LOG(0.25D0RATEPS)*2)+
	- & LOG(GA)LOG((GA+0.25D0RATEPS)/(1D0+0.25D0RAT*EPS))+
	- & LOG(GA-1D0)LOG(0.25D0RATEPS/(GA+0.25D0RAT*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.25D0EPS/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)-
	- & PYSPEN((1D0-0.25D0EPS)/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)+
	- & PYSPEN((1D0-0.25D0EPS)/(-0.25D0(RAT+1D0)*EPS),0D0,1)-
	- & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
	- & (0.25D0EPS))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.25D0EPS/(BE-0.25D0EPS),0D0,1)-
	- & PYSPEN((1D0-0.25D0EPS)/(BE-0.25D0EPS),0D0,1)+
	- & PYSPEN((1D0-0.25D0EPS)/(1D0-0.25D0EPS-BE),0D0,1)-
	- & PYSPEN(-0.25D0EPS/(1D0-0.25D0EPS-BE),0D0,1)+
	- & LOG((1D0-0.25D0EPS)/(0.25D0EPS))*
	- & LOG((BE-0.25D0EPS)/(BE-1D0+0.25D0EPS))
	- F3IM=-PARU(1)LOG((BE-0.25D0EPS)/(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.25D0RATEPS),0D0,1)-
	- & PYSPEN(GA/(GA+0.25D0RATEPS),0D0,1)+
	- & PYSPEN(GA/(GA-1D0-0.25D0RATEPS),0D0,1)-
	- & PYSPEN((GA-1D0)/(GA-1D0-0.25D0RATEPS),0D0,1)+
	- & LOG(GA/(1D0-GA))LOG((GA+0.25D0RAT*EPS)/
	- & (1D0+0.25D0RATEPS-GA))
	- F3IM=-PARU(1)LOG((GA+0.25D0RAT*EPS)/
	- & (1D0+0.25D0RATEPS-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+(2D0BE-1D0)*2)
	- RCTHE=RSQ(1D0-2D0BE/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/(2D0BE-1D0)F3RE
	- Y3IM=2D0/(2D0BE-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(XRE2+XIM2)
	- 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-(ALGXRE2-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(XRE2+XIM2)
	- XARG=SIGN(ACOS(XRE/XMOD),XIM)
	- ALGYRE=LOG(XMOD)
	- ALGYIM=XARG
	- SP0RE=SP0RE+SGN(PARU(1)2/6D0-(ALGXREALGYRE-ALGXIM*ALGYIM))
	- SP0IM=SP0IM-SGN(ALGXREALGYIM+ALGXIM*ALGYRE)
	- SGN=-SGN
	- ENDIF
	-
	- XRE=1D0-XRE
	- XIM=-XIM
	- XMOD=SQRT(XRE2+XIM2)
	- 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=(SAVEREZRE-SAVEIMZIM)/DBLE(I+1)
	- TERMIM=(SAVEREZIM+SAVEIMZRE)/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)=PTCOS(VINT(198+5I))
	- PP(I,2)=PTSIN(VINT(198+5I))
	- 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.5D0SHPR(-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)=64PQ6+16PQ*4PH*2+32PQ*4(X1+2X2+X4+X9+2
	- & X7+X5)+8PQ2PH*2(-X1-X4+2X7)+16PQ*2(X2X9+4X2*
	- & X7+X2X5-2X4X7-2X9X7)+8PH*2X4X7-16X2X9X7
	- FM(1,2)=16PQ6+8PQ*4(-2X1+X2-2X3-2X4-4X10+X9-X8+2
	- & X7-4X6+X5)+8PQ2(-2X1X2-2X2X4-2X2X10+X2X7-2
	- & X2X6-2X3X7+2X4X7+4X10X7-X9X7-X8X7)+16X2X7(X4+
	- & X10)
	- FM(1,3)=16PQ6-4PQ*4PH*2+8PQ*4(-2X1+2X2-2X3-4
	- & X4-8X10+X9+X8-2X7-4X6+2X5)-(4PQ2PH*2)(X1+X4+X10
	- & +X6)+8PQ2(-2X1X2-2X1X10+X1X9+X1X8-2X1X5+X2**2
	- & -4X2X4-5X2X10+X2X8-X2X7-3X2X6+X2X5+X3X9+2X3X7
	- & -X3X5+X4X8+2X4X6-3X4X5-5X10X5+X9X8+X9X6+X9*X5+
	- & X8X7-4X6X5+X52)-(16X2X5)(X1+X4+X10+X6)
	- FM(1,4)=16PQ6+4PQ*4PH*2+16PQ*4(-X1+X2-X3-X4+X10-
	- & X9-X8+2X7+2X6-X5)+4PQ2PH*2(X1+X3+X4+X10+2X7+2X6
	- & )+8PQ2(4X1X10+4X1X7+4X1X6+2X2X10-X2X9-X2X8+
	- & 4X2X7+4X2X6-X2X5+4X10X5+4X7X5+4X6X5)-(8PH*2
	- & X1)(X10+X7+X6)+16X2X5(X10+X7+X6)
	- FM(1,5)=8PQ4(-2X1-2X4+X10-X9)+4PQ2(4X12-2X1*
	- & X2+8X1X3+6X1X10-2X1X9+4X1X8+4X1X7+4X1X6+2X1
	- & X5+X2X10+4X3X4-X3X9+2X3X7+3X4X8-2X4X6+2X4X5-4
	- & X10X7+3X10X5-3X9X6+3X8X7-4X72+4X7X5)+8(X1**
	- & 2X9-X12X8-X1X2X7+X1X2X6+X1X3X9+X1X3X5-X1X4
	- & X8-X1X4X5+X1X10X9+X1X9X7+X1X9X6-X1X8X7-X2X3X7
	- & +X2X4X6-X2X10X7-X2X72+X3X7X5-X4X10X5-X4X7*X5-
	- & X4X6X5)
	- FM(1,6)=16PQ4(-4X1-X4+X9-X7)+4PQ*2PH*2(-2*X1-X4-
	- & X7)+16PQ2(-2X12-3X1X2-2X1X4-3X1X9-2X1X7-3
	- & X1X5-2X2X4-2X7X5)-8PH*2X4X7+8(-X1X2X9-2X1X2
	- & X5-X1X9*2-X1X9X5+X22X7-X2X4X5+X2X9X7-X2X7X5
	- & +X4X9X5+X4X5*2)
	- FM(1,7)=8PQ4(2X3+X4+3X10+X9+2X8+3X7+6X6)+2PQ*2
	- & PH*2(-2X3-X4+3X10+3X7+6X6)+4PQ2(4X1X10+4X1
	- & X7+8X1X6+6X2X10+X2X9+2X2X8+6X2X7+12X2X6-8X3*
	- & X7+4X4X7+4X4X6+4X10X5+4X9X7+4X9X6-8X8X7+4X7
	- & X5+8X6X5)+4PH2(-X1X10-X1X7-2X1X6+2X3X7-X4*X7-
	- & X4X6)+8X2(X10X5+X9X7+X9X6-2X8X7+X7X5+2X6*X5)
	- FM(1,8)=8PQ4(2X3+X4+3X10+2X9+X8+3X7+6X6)+2PQ*2
	- & PH*2(-2X3-X4+2X10+X7+2X6)+4PQ*2(4X1X10-2X1X9+
	- & 2X1X8+4X1X7+8X1X6+5X2X10+2X2X9+X2X8+4X2X7+8
	- & X2X6-X3X9-8X3X7+2X3X5+2X4X9-X4X8+4X4X7+4X4*X6
	- & +4X4X5+5X10X5+X9*2-X9X8+2X9X7+5X9X6+X9X5-7X8*
	- & X7+2X8X5+2X7X5+10X6X5)+2PH2(-X1X10+X3X7-2X4
	- & X7+X4X6)+4(-X1X92+X1X9X8-2X1X9X5-X1X8X5+2X2
	- & X10X5+X2X9X7+X2X9X6-2X2X8X7+3X2X6X5+X3X9*X5+
	- & X3X52+X4X9X5-2X4X8X5+2X4X5**2)
	- FM(2,2)=16PQ6+16PQ*4(-X1+X3-X4-X10+X7-X6)+16PQ2(
	- & X3X10+X3X7+X3X6+X4X7+X10X7)-16X3X10X7
	- FM(2,3)=16PQ6+8PQ*4(-2X1+X2+2X3-4X4-4X10-X9+X8-2
	- & X7-2X6+X5)+8PQ2(-2X1X5+4X3X10-X3X9-X3X8-2X3
	- & X7+2X3X6+X3X5-2X4X5-2X10X5-2X6X5)+16X3X5(X10+
	- & X6)
	- FM(2,4)=8PQ4(-2X1-2X3+X10-X8)+4PQ2(4X12-2X1*
	- & X2+8X1X4+6X1X10+4X1X9-2X1X8+4X1X7+4X1X6+2X1
	- & X5+X2X10+4X3X4+3X3X9-2X3X7+2X3X5-X4X8+2X4X6-4
	- & X10X6+3X10X5+3X9X6-3X8X7-4X62+4X6X5)+8(-X1
	- & *2X9+X1*2X8+X1X2X7-X1X2X6-X1X3X9-X1X3X5+X1*X4
	- & X8+X1X4X5+X1X10X8-X1X9X6+X1X8X7+X1X8X6+X2X3*
	- & X7-X2X4X6-X2X10X6-X2X62-X3X10X5-X3X7X5-X3X6*
	- & X5+X4X6X5)
	- FM(2,5)=16PQ4X10+8PQ2(2X12+2X1X3+2X1X4+2X1
	- & X10+2X1X7+2X1X6+X3X7+X4X6)+8(-2X13-2X1*2X3-
	- & 2X12X4-2X12X10-2X12X7-2X12X6-2X1X3*X4-
	- & X1X3X10-2X1X3X6-X1X4X10-2X1X4X7-X1X102-X1
	- & X10X7-X1X10X6-2X1X7X6+X3*2X7-X3X4X7-X3X4X6+X3
	- & X10X7+X3X72-X3X7X6+X42X6+X4X10X6-X4X7X6+X4*
	- & X6**2)
	- FM(2,6)=8PQ4(-2X1+X10-X9-2X7)+4PQ2(4X12+2X1*
	- & X2+4X1X3+4X1X4+6X1X10-2X1X9+4X1X8+8X1X6-2X1
	- & X5+4X2X4+3X2X10+2X2X7-3X3X9-2X3X7-4X42-4X4*
	- & X10+3X4X8+2X4X6+X10X5-X9X6+3X8X7+4X7X6)+8(X1*
	- & 2X9-X12X8-X1X2X7+X1X2X6+X1X3X9+X1X3X5+X1X4
	- & X9-X1X4X8-X1X4X5+X1X10X9+X1X9X6-X1X8X7-X2X3X7
	- & -X2X4X7+X2X4X6-X2X10X7+X3X7X5-X4*2X5-X4X10X5-
	- & X4X6X5)
	- FM(2,7)=8PQ4(X3+2X4+3X10+X7+2X6)+4PQ*2(-4X1X3-
	- & 2X1X4-2X1X10+X1X9-X1X8-4X1X7-2X1X6+X2X3+2X2*
	- & X4+3X2X10+X2X7+2X2X6-6X3X4-6X3X10-2X3X9-2X3*
	- & X7-4X3X6-X3X5-6X4*2-6X4X10-3X4X9-X4X8-4X4X7-2
	- & X4X6-2X4X5-3X10X9-3X10X8-6X10X7-6X10X6+X10*X5
	- & +X9X7-2X8X7-2X8X6-6X7X6+X7X5-6X62+2X6X5)+4(
	- & -X1*2X9+X1*2X8-2X1X2X10-3X1X2X7-3X1X2X6+X1
	- & X3X9-X1X3X5+X1X4X9+X1X4X8+X1X4X5+X1X10X9+X1
	- & X10X8-X1X9X6+X1X8X6+X2X3X7-3X2X4X7-X2X4X6-3*
	- & X2X10X7-3X2X10X6-3X2X7X6-3X2X6*2-2X3X4X5-X3
	- & X10X5-X3X6X5-X4*2X5-X4X10X5+X4X6X5)
	- FM(2,8)=8PQ4(X3+2X4+3X10+X7+2X6)+4PQ*2(-4X1X3-
	- & 2X1X4-2X1X10-X1X9+X1X8-4X1X7-2X1X6+X2X3+2X2*
	- & X4+X2X10-X2X7-2X2X6-6X3X4-6X3X10-2X3X9+X3X8-2
	- & X3X7-4X3X6+X3X5-6X42-6X4X10-2X4X9-4X4X7-2X4
	- & X6+2X4X5-3X10X9-3X10X8-6X10X7-6X10X6+3X10*X5-
	- & X9X6-2X8X7-3X8X6-6X7X6+X7X5-6X62+2X6X5)+4(
	- & X1*2X9-X1*2X8-X1X2X7+X1X2X6-3X1X3X5+X1X4*X9-
	- & X1X4X8-3X1X4X5+X1X10X9+X1X10X8-2X1X10X5+X1*X9
	- & X6+X1X8X7+X1X8X6-X2X4X7+X2X4X6-X2X10X7-X2X10*
	- & X6-2X2X7X6-X2X6*2-3X3X4X5-3X3X10X5+X3X7X5-3
	- & X3X6X5-3X42X5-3X4X10X5-X4X6*X5)
	- FM(3,3)=64PQ6+16PQ*4PH*2+32PQ*4(X1+X2+2*X3+X8+X6
	- & +2X5)+8PQ*2PH*2(-X1+2X3-X6)+16PQ*2(X2X5-2X3*
	- & X8-2X3X6+4X3X5+X8X5)+8PH*2X3X6-16X3X8X5
	- FM(3,4)=16PQ4(-4X1-X3+X8-X6)+4PQ*2PH*2(-2*X1-X3-
	- & X6)+16PQ2(-2X12-3X1X2-2X1X3-3X1X8-2X1X6-3
	- & X1X5-2X2X3-2X6X5)-8PH*2X3X6+8(-X1X2X8-2X1X2
	- & X5-X1X8*2-X1X8X5+X22X6-X2X3X5+X2X8X6-X2X6X5
	- & +X3X8X5+X3X5*2)
	- FM(3,5)=8PQ4(-2X1+X10-X8-2X6)+4PQ2(4X12+2X1*
	- & X2+4X1X3+4X1X4+6X1X10+4X1X9-2X1X8+8X1X7-2X1
	- & X5+4X2X3+3X2X10+2X2X6-4X32-4X3X10+3X3X9+2X3
	- & X7-3X4X8-2X4X6+X10X5+3X9X6-X8X7+4X7X6)+8(-X1
	- & *2X9+X1*2X8+X1X2X7-X1X2X6-X1X3X9+X1X3X8-X1*X3
	- & X5+X1X4X8+X1X4X5+X1X10X8-X1X9X6+X1X8X7+X2X3*
	- & X7-X2X3X6-X2X4X6-X2X10X6-X3*2X5-X3X10X5-X3X7
	- & X5+X4X6X5)
	- FM(3,6)=16PQ6+4PQ*4PH*2+16PQ*4(-X1-X2+2X3+2X4+
	- & X10-X9-X8-X7-X6+X5)+4PQ2PH*2(X1+2X3+2X4+X10+X7+X6
	- & )+8PQ2(4X1X3+4X1X4+4X1X10+4X2X3+4X2X4+4X2
	- & X10-X2X5+4X3X5+4X4X5+2X10X5-X9X5-X8X5)-(8PH*2
	- & X1)(X3+X4+X10)+16X2X5(X3+X4+X10)
	- FM(3,7)=8PQ4(3X3+6X4+3X10+X9+2X8+2X7+X6)+2PQ*2
	- & PH*2(X3+2X4+2X10-2X7-X6)+4PQ*2(4X1X3+8X1X4+4*
	- & X1X10+2X1X9-2X1X8+2X2X3+10X2X4+5X2X10+2X2*X9+
	- & X2X8+2X2X7+4X2X6-7X3X9+2X3X8-8X3X7+4X3X6+4
	- & X3X5+5X4X8+4X4X6+8X4X5+5X10X5-X9X8-X9X6+X9X5+
	- & X8*2-X8X7+2X8X6+2X8X5)+2PH2(-X1X10+X3X7-2X3
	- & X6+X4X6)+4(-X1X2X9-2X1X2X8+X1X9X8-X1X82+X22
	- & X7+2X2*2X6+3X2X4X5+2X2X10X5-2X2X9X6+X2X8*X7
	- & +X2X8X6-2X3X9X5+X3X8X5+X4X8*X5)
	- FM(3,8)=8PQ4(3X3+6X4+3X10+2X9+X8+2X7+X6)+2PQ*2
	- & PH*2(3X3+6X4+3X10-2X7-X6)+4PQ2(4X1X3+8X1X4+
	- & 4X1X10+4X2X3+8X2X4+4X2X10-8X3X9+4X3X8-8X3X7
	- & +4X3X6+6X3X5+4X4X8+4X4X6+12X4X5+6X10X5+2X9
	- & X5+X8X5)+4PH*2(-X1X3-2X1X4-X1X10+2X3X7-X3*X6-X4
	- & X6)+8X5(X2X3+2X2X4+X2X10-2X3X9+X3X8+X4*X8)
	- FM(4,4)=64PQ6+16PQ*4PH*2+32PQ*4(X1+2X2+X3+X8+2
	- & X6+X5)+8PQ2PH*2(-X1-X3+2X6)+16PQ*2(X2X8+4X2*
	- & X6+X2X5-2X3X6-2X8X6)+8PH*2X3X6-16X2X8X6
	- FM(4,5)=16PQ6+8PQ*4(-2X1+X2-2X3-2X4-4X10-X9+X8-4
	- & X7+2X6+X5)+8PQ2(-2X1X2-2X2X3-2X2X10-2X2X7+
	- & X2X6+2X3X6-2X4X6+4X10X6-X9X6-X8X6)+16X2X6(X3+
	- & X10)
	- FM(4,6)=16PQ6-4PQ*4PH*2+8PQ*4(-2X1+2X2-4X3-2
	- & X4-8X10+X9+X8-4X7-2X6+2X5)-(4PQ2PH*2)(X1+X3+X10
	- & +X7)+8PQ2(-2X1X2-2X1X10+X1X9+X1X8-2X1X5+X2**2
	- & -4X2X3-5X2X10+X2X9-3X2X7-X2X6+X2X5+X3X9+2X3X7
	- & -3X3X5+X4X8+2X4X6-X4X5-5X10X5+X9X8+X9X6+X8*X7+
	- & X8X5-4X7X5+X52)-(16X2X5)(X1+X3+X10+X7)
	- FM(4,7)=8PQ4(-X3-2X4-3X10-2X9-X8-6X7-3X6)+2PQ**2
	- & PH2(X3+2X4-3X10-6X7-3X6)+4PQ2(-4X1X10-8X1
	- & X7-4X1X6-6X2X10-2X2X9-X2X8-12X2X7-6X2X6-4X3*
	- & X7-4X3X6+8X4X6-4X10X5+8X9X6-4X8X7-4X8X6-8X7
	- & X5-4X6X5)+4PH2(X1X10+2X1X7+X1X6+X3X7+X3X6-2*
	- & X4X6)+8X2(-X10X5+2X9X6-X8X7-X8X6-2X7X5-X6*X5)
	- FM(4,8)=8PQ4(-X3-2X4-3X10-X9-2X8-6X7-3X6)+2PQ**2
	- & PH2(X3+2X4-2X10-2X7-X6)+4PQ*2(-4X1X10-2X1X9
	- & +2X1X8-8X1X7-4X1X6-5X2X10-X2X9-2X2X8-8X2*X7-4
	- & X2X6+X3X9-2X3X8-4X3X7-4X3X6-4X3X5+X4X8+8X4
	- & X6-2X4X5-5X10X5+X9X8+7X9X6-2X9X5-X82-5X8*X7-2
	- & X8X6-X8X5-10X7X5-2X6X5)+2PH*2(X1X10-X3X7+2*X3
	- & X6-X4X6)+4(-X1X9X8+X1X9X5+X1X8*2+2X1X8X5-2*X2
	- & X10X5+2X2X9X6-X2X8X7-X2X8X6-3X2X7X5+2X3X9*
	- & X5-X3X8X5-2X3X5*2-X4X8X5-X4X5**2)
	- FM(5,5)=16PQ6+16PQ*4(-X1-X3+X4-X10-X7+X6)+16PQ2(
	- & X3X6+X4X10+X4X7+X4X6+X10X6)-16X4X10X6
	- FM(5,6)=16PQ6+8PQ*4(-2X1+X2-4X3+2X4-4X10+X9-X8-2
	- & X7-2X6+X5)+8PQ2(-2X1X5-2X3X5+4X4X10-X4X9-X4
	- & X8+2X4X7-2X4X6+X4X5-2X10X5-2X7X5)+16X4X5(X10+
	- & X7)
	- FM(5,7)=8PQ4(-2X3-X4-3X10-2X7-X6)+4PQ*2(2X1X3+
	- & 4X1X4+2X1X10+X1X9-X1X8+2X1X7+4X1X6-2X2X3-X2*
	- & X4-3X2X10-2X2X7-X2X6+6X3*2+6X3X4+6X3X10+X3X9+
	- & 3X3X8+2X3X7+4X3X6+2X3X5+6X4X10+2X4X8+4X4X7+
	- & 2X4X6+X4X5+3X10X9+3X10X8+6X10X7+6X10X6-X10X5+
	- & 2X9X7+2X9X6-X8X6+6X7*2+6X7X6-2X7X5-X6X5)+4*(-
	- & X1*2X9+X1*2X8+2X1X2X10+3X1X2X7+3X1X2X6-X1X3
	- & X9-X1X3X8-X1X3X5-X1X4X8+X1X4X5-X1X10X9-X1X10*
	- & X8-X1X9X7+X1X8X7+X2X3X7+3X2X3X6-X2X4X6+3X2*
	- & X10X7+3X2X10X6+3X2X7*2+3X2X7X6+X3*2X5+2X3X4
	- & X5+X3X10X5-X3X7X5+X4X10X5+X4X7*X5)
	- FM(5,8)=8PQ4(-2X3-X4-3X10-2X7-X6)+4PQ*2(2X1X3+
	- & 4X1X4+2X1X10-X1X9+X1X8+2X1X7+4X1X6-2X2X3-X2*
	- & X4-X2X10+2X2X7+X2X6+6X32+6X3X4+6X3X10+2X3*X8+
	- & 2X3X7+4X3X6-2X3X5+6X4X10-X4X9+2X4X8+4X4X7+2
	- & X4X6-X4X5+3X10X9+3X10X8+6X10X7+6X10X6-3X10X5+
	- & 3X9X7+2X9X6+X8X7+6X7*2+6X7X6-2X7X5-X6X5)+4*(
	- & X1*2X9-X1*2X8-X1X2X7+X1X2X6+X1X3X9-X1X3X8+3*
	- & X1X3X5+3X1X4X5-X1X10X9-X1X10X8+2X1X10X5-X1*X9
	- & X7-X1X9X6-X1X8X7-X2X3X7+X2X3X6+X2X10X7+X2X10*
	- & X6+X2X72+2X2X7X6+3X32X5+3X3X4X5+3X3X10X5+
	- & X3X7X5+3X4X10X5+3X4X7X5-X4X6X5)
	- FM(6,6)=64PQ6+16PQ*4PH*2+32PQ*4(X1+X2+2*X4+X9+X7
	- & +2X5)+8PQ*2PH*2(-X1+2X4-X7)+16PQ*2(X2X5-2X4*
	- & X9-2X4X7+4X4X5+X9X5)+8PH*2X4X7-16X4X9X5
	- FM(6,7)=8PQ4(-6X3-3X4-3X10-2X9-X8-X7-2X6)+2PQ**2
	- & PH2(-2X3-X4-2X10+X7+2X6)+4PQ*2(-8X1X3-4X1X4
	- & -4X1X10+2X1X9-2X1X8-10X2X3-2X2X4-5X2X10-X2*X9
	- & -2X2X8-4X2X7-2X2X6-5X3X9-4X3X7-8X3X5-2X4X9+
	- & 7X4X8-4X4X7+8X4X6-4X4X5-5X10X5-X9*2+X9X8-2*X9
	- & X7+X9X6-2X9X5+X8X7-X8X5)+2PH2(X1X10-X3X7+2*X4
	- & X7-X4X6)+4(2X1X2X9+X1X2X8+X1X92-X1X9X8-2X2
	- & *2X7-X2*2X6-3X2X3X5-2X2X10X5-X2X9X7-X2X9X6+
	- & 2X2X8X7-X3X9X5-X4X9X5+2X4X8X5)
	- FM(6,8)=8PQ4(-6X3-3X4-3X10-X9-2X8-X7-2X6)+2PQ**2
	- & PH2(-6X3-3X4-3X10+X7+2X6)+4PQ2(-8X1X3-4X1
	- & X4-4X1X10-8X2X3-4X2X4-4X2X10-4X3X9-4X3X7-12*
	- & X3X5-4X4X9+8X4X8-4X4X7+8X4X6-6X4X5-6X10*X5-X9
	- & X5-2X8X5)+4PH*2(2X1X3+X1X4+X1X10+X3X7+X4X7-2*
	- & X4X6)+8X5(-2X2X3-X2X4-X2X10-X3X9-X4X9+2X4*X8)
	- FM(7,7)=72PQ4X10+18PQ2PH*2X10+8PQ2(X1X10+9
	- & X2X10+7X3X7+2X3X6+2X4X7+7X4X6+X10X5+2X9X7+7*
	- & X9X6+7X8X7+2X8X6)+2PH*2(-X1X10-7X3X7-2X3*X6-2
	- & X4X7-7X4X6)+4X2(X10X5+2X9X7+7X9X6+7X8X7+2X8
	- & *X6)
	- FM(7,8)=72PQ4X10+2PQ2PH*2X10+4PQ2(2X1X10+
	- & 10X2X10+7X3X9+2X3X8+14X3X7+4X3X6+2X4X9+7X4
	- & X8+4X4X7+14X4X6+10X10X5+X9*2+7X9X8+2X9X7+7X9*
	- & X6+X8*2+7X8X7+2X8X6)+2PH*2(7X1X10-7X3X7-2X3
	- & X6-2X4X7-7X4X6)+2(-2X1X92-14X1X9X8-2X1X8**2
	- & +2X2X10X5+2X2X9X7+7X2X9X6+7X2X8X7+2X2X8*X6+
	- & 7X3X9X5+2X3X8X5+2X4X9X5+7X4X8X5)
	- FM(8,8)=72PQ4X10+18PQ2PH*2X10+8PQ2(X1*X10+X2
	- & X10+7X3X9+2X3X8+7X3X7+2X3X6+2X4X9+7X4X8+2X4
	- & X7+7X4X6+9X10X5)+2PH*2(-X1X10-7X3X7-2X3X6-2
	- & X4X7-7X4X6)+4X5(X2X10+7X3X9+2X3X8+2X4X9+7X4
	- & X8)
	- FM(9,9)=-4PQ4X10-PQ*2PH*2X10+4PQ2(-X1X10-X2X10+
	- & X3X7+X4X6-X10X5+X9X6+X8X7)+PH2(X1X10-X3X7-X4*X6
	- & )+2X2(-X10X5+X9X6+X8*X7)
	- FM(9,10)=-4PQ4X10-PQ*2PH*2X10+2PQ2(-2X1X10-2X2
	- & X10+2X3X9+2X3X7+2X4X6-2X10X5+X9X8+2X8X7)+PH*2
	- & (X1X10-X3X7-X4X6)+2(-X1X9X8-X2X10X5+X2X8X7+X3
	- & X9*X5)
	- FMXX=-4PQ4X10-PQ*2PH*2X10+2PQ2(-2X1X10-2X2
	- & X10+2X4X8+2X4X6+2X3X7-2X10X5+X9X8+2X9X6)+PH*2
	- & (X1X10-X3X7-X4X6)+2(-X1X9X8-X2X10X5+X2X9X6+X4
	- & X8*X5)
	- FM(9,10)=0.5D0*(FMXX+FM(9,10))
	- FM(10,10)=-4PQ4X10-PQ*2PH*2X10+4PQ2(-X1X10-X2X10+
	- & X3X7+X4X6-X10X5+X9X3+X8X4)+PH2(X1X10-X3X7-X4*X6
	- & )+2X5(-X10X2+X9X3+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)FACCLR(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=-8D0PQ4X10-2D0PQ2PH*2X10-(8D0PQ2)(X2*X10+X3
	- & X7+X4X6+X9X6+X8X7)+2D0PH2(X3X7+X4X6)-(4D0X2)(X9
	- & X6+X8X7)
	- A12=-8D0PQ4X10+4D0PQ2(-X2X10-X3X9-2D0X3X7-X4*X8-
	- & 2D0X4X6-X10X5-X9X8-X9X6-X8X7)+2D0PH2(-X1X10+X3X7
	- & +X4X6)+2D0(2D0X1X9X8-X2X9X6-X2X8X7-X3X9X5-X4X8*
	- & X5)
	- A22=-8D0PQ4X10-2D0PQ2PH*2X10-(8D0PQ2)(X3X9+X3
	- & X7+X4X8+X4X6+X10X5)+2D0PH*2(X3X7+X4X6)-(4D0X5)(X3
	- & X9+X4X8)
	-
	-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+2D0A12)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)=PTCOS(VINT(198+5I))
	- PP(2,I)=PTSIN(VINT(198+5I))
	- 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*2ALPHA/(16SW2)MT/XWBETW
	- & (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*2ALPHA/(16SW2)MT/XWBETW
	- & (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(MHPMB/MT2)2 )
	- GAMTBH= ALPHA/SW2/8.D0VTB2KFUN/MT *
	- & (V*2((MT+MB)2-MHP2)+A*2((MT-MB)2-MHP2))
	- 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.D08.D0 2.D0*2.D0)
	-C COUPLING CONSTANT (OVERALL NORMALIZATION)
	- FACT=(4.D0PIALPHA)(4.D0PIALPHAS)*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)GFSW2MW*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 -2P1Q1 -2P1Q2
	- A1 =A1INV/(A1INV*2+ (GAMTMT)**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+ (GAMTMT)**2)
	- A2 =1.D0/(S +2P2Q1 +2P2Q2)
	-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= 640A1/3+640A2/3+32A1A2MB2-368A12MBMT-
	- &512A1A2MBMT/3-
	- &368A22MBMT+32A1A2MT*2+496A12*P1P2/3+
	- &320A1A2P1P2+496A2*2P1P2/3+128A1MBMT3/(3P1Q1**2)+
	- &128A1MT*4/(3P1Q1*2)-256A12MBMT*5/(3P1Q1**2)+
	- &256A1MT*2P1P2/(3P1Q12)-256A12MT4P1P2/(3P1Q1*2)+
	- &8/(3P1Q1)-32A1MBMT/P1Q1-56A2MBMT/(3P1Q1)+
	- &88A1MT*2/(3P1Q1)+72A2MT**2/P1Q1+
	- &704A12MBMT3/(3P1Q1)-224A1A2MBMT*3/(3P1Q1)+
	- &104A1P1P2/(3P1Q1)+48A2*P1P2/P1Q1+
	- &128A1A2MBMTP1P2/(3P1Q1)+512A12MT*2P1P2/(3*P1Q1)-
	- &448A1A2MT2P1P2/(3P1Q1)-32A1A2P1P2**2/P1Q1-
	- &656A1A2P1Q1/3-224A2*2P1Q1+128A1MBMT3/(3P1Q2**2)+
	- &128A1MT*4/(3P1Q2*2)-256A12MBMT*5/(3P1Q2**2)+
	- &256A1MT*2P1P2/(3P1Q22)-256A12MT4P1P2/(3P1Q2*2)+
	- &256A1MT*2P1Q1/(3P1Q22)+256A12MBMT*3P1Q1/(3P1Q2*2)+
	- &8/(3P1Q2)-32A1MBMT/P1Q2-56A2MBMT/(3P1Q2)
	- V18=V18+88A1MT*2/(3P1Q2)+72A2MT**2/P1Q2+
	- &704A12MBMT3/(3P1Q2)-224A1A2MBMT*3/(3P1Q2)+
	- &104A1P1P2/(3P1Q2)+48A2*P1P2/P1Q2+
	- &128A1A2MBMTP1P2/(3P1Q2)+512A12MT*2P1P2/(3*P1Q2)-
	- &448A1A2MT2P1P2/(3P1Q2)-32A1A2P1P2**2/P1Q2-
	- &32A1MBMT3/(3P1Q1P1Q2)-32A1MT4/(3P1Q1*P1Q2)+
	- &64A12MBMT5/(3P1Q1P1Q2)+16P1P2/(3P1Q1P1Q2)-
	- &64A1MT*2P1P2/(3P1Q1P1Q2)+64A12MT*4P1P2/(3P1Q1P1Q2)+
	- &112A1P1Q1/P1Q2+272A2P1Q1/(3*P1Q2)-
	- &272A1A2MB2P1Q1/(3P1Q2)+208A12MBMTP1Q1/(3P1Q2)-
	- &400A1A2MBMTP1Q1/(3P1Q2)-80A1A2MT2P1Q1/P1Q2+
	- &96A12P1P2P1Q1/P1Q2-320A1A2P1P2*P1Q1/P1Q2-
	- &544A1A2P1Q12/(3P1Q2)-656A1A2P1Q2/3-224A2*2P1Q2+
	- &256A1MT*2P1Q2/(3P1Q12)+256A12MBMT*3P1Q2/(3P1Q1*2)+
	- &112A1P1Q2/P1Q1+272A2P1Q2/(3*P1Q1)-
	- &272A1A2MB2P1Q2/(3P1Q1)+208A12MBMTP1Q2/(3P1Q1)-
	- &400A1A2MBMTP1Q2/(3P1Q1)-80A1A2MT2P1Q2/P1Q1
	- V18=V18+96A12P1P2P1Q2/P1Q1-320A1A2P1P2*P1Q2/P1Q1-
	- &544A1A2P1Q22/(3P1Q1)+128A2MB*4/(3P2Q1**2)+
	- &128A2MB*3MT/(3P2Q12)-256A2*2MB*5MT/(3P2Q1*2)+
	- &256A2MB*2P1P2/(3P2Q12)-256A2*2MB*4P1P2/(3P2Q1*2)+
	- &256A2MB*2P1Q1/(3P2Q12)-256A2*2MB*4P1Q1/(3P2Q1*2)-
	- &64MB3MT*3/(3P1Q2*2P2Q1**2)-
	- &64MB2MT*2P1P2/(3P1Q22P2Q1**2)-
	- &64MB2MT*2P1Q1/(3P1Q22P2Q1**2)+
	- &64MB3MT/(3P1Q2P2Q1**2)+
	- &256A2MB*3MTP1P2/(3P1Q2P2Q1*2)+
	- &256A2MB*2P1P2*2/(3P1Q2P2Q1*2)+
	- &256A2MB*3MTP1Q1/(3P1Q2P2Q1*2)+
	- &512A2MB*2P1P2P1Q1/(3P1Q2P2Q1*2)+
	- &256A2MB*2P1Q1*2/(3P1Q2P2Q1*2)-
	- &256A22MB*4P1Q2/(3P2Q12)-8/(3P2Q1)-72A1MB**2/P2Q1-
	- &88A2MB*2/(3P2Q1)+56A1MBMT/(3P2Q1)+32A2MB*MT/P2Q1+
	- &224A1A2MB3MT/(3P2Q1)-704A2*2MB*3MT/(3*P2Q1)
	- V18=V18-48A1P1P2/P2Q1-104A2P1P2/(3*P2Q1)+
	- &448A1A2MB2P1P2/(3P2Q1)-512A2*2MB*2P1P2/(3*P2Q1)-
	- &128A1A2MBMTP1P2/(3P2Q1)+32A1A2P1P2*2/P2Q1-
	- &16P1P2/(3P1Q1P2Q1)-32A1MBMTP1P2/(3P1Q1*P2Q1)-
	- &32A2MBMTP1P2/(3P1Q1P2Q1)-
	- &64A1A2MBMTP1P22/(3P1Q1*P2Q1)-
	- &64A1A2P1P23/(3P1Q1P2Q1)-256A2P1Q1/(3P2Q1)+
	- &448A1A2MB2P1Q1/(3P2Q1)-368A2*2MB*2P1Q1/(3*P2Q1)+
	- &224A1A2MBMTP1Q1/(3P2Q1)+304A1A2P1P2P1Q1/(3*P2Q1)-
	- &64MBMT*3/(3P1Q2*2P2Q1)-
	- &256A1MBMT3P1P2/(3P1Q22P2Q1)-
	- &256A1MT*2P1P2*2/(3P1Q2*2P2Q1)+
	- &64MT2P1Q1/(3P1Q22P2Q1)-
	- &128A1MB*2MT*2P1Q1/(3P1Q22P2Q1)-
	- &128A1MBMT3P1Q1/(3P1Q22P2Q1)-
	- &256A1MT*2P1P2P1Q1/(3P1Q2*2P2Q1)-4MB2/(3P1Q2*P2Q1)+
	- &64MBMT/(3P1Q2P2Q1)-128A2MB*3MT/(3P1Q2P2Q1)
	- V18=V18-4MT2/(3P1Q2P2Q1)-128A1MB2MT*2/(3P1Q2*P2Q1)-
	- &128A2MB*2MT*2/(3P1Q2P2Q1)-128A1MBMT*3/(3P1Q2*P2Q1)-
	- &112A2MB*2P1P2/(3P1Q2P2Q1)-32A1MBMTP1P2/(3P1Q2P2Q1)-
	- &32A2MBMTP1P2/(3P1Q2P2Q1)-112A1MT*2P1P2/(3P1Q2P2Q1)-
	- &48A1P1P2*2/(P1Q2P2Q1)-48A2P1P2*2/(P1Q2P2Q1)+
	- &512A1A2MBMTP1P22/(3P1Q2*P2Q1)+
	- &512A1A2P1P23/(3P1Q2P2Q1)-8MBMTP1P2/(3P1Q1P1Q2*P2Q1)-
	- &8MT2P1P2/(3P1Q1P1Q2*P2Q1)+
	- &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q1)-
	- &16P1P22/(3P1Q1P1Q2P2Q1)+
	- &32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q1)+8P1Q1/(3P1Q2*P2Q1)-
	- &160A1MB*2P1Q1/(3P1Q2P2Q1)-272A2MB*2P1Q1/(3P1Q2P2Q1)+
	- &56A1MBMTP1Q1/(3P1Q2P2Q1)+200A2MBMTP1Q1/(3P1Q2P2Q1)-
	- &48A1P1P2P1Q1/(P1Q2P2Q1)-256A2P1P2P1Q1/(3P1Q2*P2Q1)+
	- &256A1A2MB2P1P2P1Q1/(3P1Q2*P2Q1)+
	- &256A1A2MBMTP1P2P1Q1/(P1Q2*P2Q1)+
	- &1024A1A2P1P22P1Q1/(3P1Q2P2Q1)
	- V18=V18-272A2P1Q1*2/(3P1Q2*P2Q1)+
	- &256A1A2MB2P1Q1*2/(3P1Q2*P2Q1)+
	- &256A1A2MBMTP1Q12/(3P1Q2*P2Q1)+
	- &512A1A2P1P2P1Q1*2/(3P1Q2P2Q1)+16A2P1Q2/(3P2Q1)+
	- &64A1A2MB2P1Q2/P2Q1+32A22MB*2P1Q2/(3*P2Q1)+
	- &112A1A2MBMTP1Q2/(3P2Q1)+368A1A2P1P2P1Q2/(3*P2Q1)+
	- &32A2P1P2P1Q2/(3P1Q1*P2Q1)-
	- &32A1A2MB2P1P2P1Q2/(3P1Q1*P2Q1)-
	- &32A1A2MBMTP1P2P1Q2/(3P1Q1P2Q1)-
	- &64A1A2P1P22P1Q2/(3P1Q1P2Q1)+224A12P2Q1+
	- &656A1A2P2Q1/3-256A1MT2P2Q1/(3P1Q1*2)+
	- &256A12MT*4P2Q1/(3P1Q12)-256A1P2Q1/(3P1Q1)+
	- &224A1A2MBMTP2Q1/(3P1Q1)-368A12MT*2P2Q1/(3*P1Q1)+
	- &448A1A2MT2P2Q1/(3P1Q1)+304A1A2P1P2P2Q1/(3P1Q1)+
	- &256A12MT*4P2Q1/(3P1Q2*2)+
	- &256A12MT*2P1Q1P2Q1/(3P1Q2*2)+16A1P2Q1/(3P1Q2)+
	- &112A1A2MBMTP2Q1/(3P1Q2)+32A12MT*2P2Q1/(3*P1Q2)
	- V18=V18+64A1A2MT2P2Q1/P1Q2+368A1A2P1P2P2Q1/(3*P1Q2)+
	- &16A1MT*2P2Q1/(3P1Q1P1Q2)-64A12MT*4P2Q1/(3P1Q1P1Q2)+
	- &640A12P1Q1P2Q1/(3P1Q2)+544A1A2P1Q1P2Q1/(3*P1Q2)+
	- &32A12P1Q2P2Q1/P1Q1+944A1A2P1Q2P2Q1/(3P1Q1)+
	- &128A2MB*4/(3P2Q2*2)+128A2MB3MT/(3P2Q2*2)-
	- &256A22MB*5MT/(3P2Q22)+256A2MB2P1P2/(3P2Q2*2)-
	- &256A22MB*4P1P2/(3P2Q2*2)-
	- &64MB3MT*3/(3P1Q1*2P2Q2**2)-
	- &64MB2MT*2P1P2/(3P1Q12P2Q2**2)+
	- &64MB3MT/(3P1Q1P2Q2**2)+
	- &256A2MB*3MTP1P2/(3P1Q1P2Q2*2)+
	- &256A2MB*2P1P2*2/(3P1Q1P2Q2*2)-
	- &256A22MB*4P1Q1/(3P2Q22)+256A2MB2P1Q2/(3P2Q2*2)-
	- &256A22MB*4P1Q2/(3P2Q2*2)-
	- &64MB2MT*2P1Q2/(3P1Q12P2Q2**2)+
	- &256A2MB*3MTP1Q2/(3P1Q1P2Q2*2)+
	- &512A2MB*2P1P2P1Q2/(3P1Q1P2Q2*2)
	- V18=V18+256A2MB*2P1Q2*2/(3P1Q1P2Q2*2)-
	- &256A2MB*2P2Q1/(3P2Q22)-256A2*2MB*3MTP2Q1/(3P2Q2**2)+
	- &64MB2MT*2P2Q1/(3P1Q12P2Q2**2)+
	- &64MB2P2Q1/(3P1Q1P2Q2**2)-
	- &128A2MB*3MTP2Q1/(3P1Q1P2Q2*2)-
	- &128A2MB*2MT*2P2Q1/(3P1Q1P2Q2**2)-
	- &256A2MB*2P1P2P2Q1/(3P1Q1P2Q2*2)+
	- &256A22MB*2P1Q1P2Q1/(3P2Q2**2)-
	- &256A2MB*2P1Q2P2Q1/(3P1Q1P2Q22)-8/(3P2Q2)-
	- &72A1MB*2/P2Q2-88A2MB2/(3P2Q2)+56A1MBMT/(3P2Q2)+
	- &32A2MBMT/P2Q2+224A1A2MB*3MT/(3*P2Q2)-
	- &704A22MB*3MT/(3P2Q2)-48A1*P1P2/P2Q2-
	- &104A2P1P2/(3P2Q2)+448A1A2MB*2P1P2/(3*P2Q2)-
	- &512A22MB*2P1P2/(3P2Q2)-128A1A2MBMTP1P2/(3*P2Q2)+
	- &32A1A2P1P22/P2Q2-64MBMT3/(3P1Q1*2P2Q2)-
	- &256A1MBMT3P1P2/(3P1Q12P2Q2)-
	- &256A1MT*2P1P2*2/(3P1Q1*2P2Q2)-4MB2/(3P1Q1*P2Q2)
	- V18=V18+64MBMT/(3P1Q1P2Q2)-128A2MB*3MT/(3P1Q1P2Q2)-
	- &4MT2/(3P1Q1P2Q2)-128A1MB2MT*2/(3P1Q1*P2Q2)-
	- &128A2MB*2MT*2/(3P1Q1P2Q2)-128A1MBMT*3/(3P1Q1*P2Q2)-
	- &112A2MB*2P1P2/(3P1Q1P2Q2)-32A1MBMTP1P2/(3P1Q1P2Q2)-
	- &32A2MBMTP1P2/(3P1Q1P2Q2)-112A1MT*2P1P2/(3P1Q1P2Q2)-
	- &48A1P1P2*2/(P1Q1P2Q2)-48A2P1P2*2/(P1Q1P2Q2)+
	- &512A1A2MBMTP1P22/(3P1Q1*P2Q2)+
	- &512A1A2P1P23/(3P1Q1P2Q2)+16A2P1Q1/(3P2Q2)+
	- &64A1A2MB2P1Q1/P2Q2+32A22MB*2P1Q1/(3*P2Q2)+
	- &112A1A2MBMTP1Q1/(3P2Q2)+368A1A2P1P2P1Q1/(3*P2Q2)-
	- &16P1P2/(3P1Q2P2Q2)-32A1MBMTP1P2/(3P1Q2*P2Q2)-
	- &32A2MBMTP1P2/(3P1Q2P2Q2)-
	- &64A1A2MBMTP1P22/(3P1Q2*P2Q2)-
	- &64A1A2P1P23/(3P1Q2P2Q2)-8MBMTP1P2/(3P1Q1P1Q2*P2Q2)-
	- &8MT2P1P2/(3P1Q1P1Q2*P2Q2)+
	- &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q2)-
	- &16P1P22/(3P1Q1P1Q2P2Q2)
	- V18=V18+32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q2)+
	- &32A2P1P2P1Q1/(3P1Q2*P2Q2)-
	- &32A1A2MB2P1P2P1Q1/(3P1Q2*P2Q2)-
	- &32A1A2MBMTP1P2P1Q1/(3P1Q2P2Q2)-
	- &64A1A2P1P22P1Q1/(3P1Q2P2Q2)-256A2P1Q2/(3*P2Q2)+
	- &448A1A2MB2P1Q2/(3P2Q2)-368A2*2MB*2P1Q2/(3*P2Q2)+
	- &224A1A2MBMTP1Q2/(3P2Q2)+304A1A2P1P2P1Q2/(3*P2Q2)+
	- &64MT2P1Q2/(3P1Q12P2Q2)-
	- &128A1MB*2MT*2P1Q2/(3P1Q12P2Q2)-
	- &128A1MBMT3P1Q2/(3P1Q12P2Q2)-
	- &256A1MT*2P1P2P1Q2/(3P1Q1*2P2Q2)+8P1Q2/(3P1Q1*P2Q2)-
	- &160A1MB*2P1Q2/(3P1Q1P2Q2)-272A2MB*2P1Q2/(3P1Q1P2Q2)+
	- &56A1MBMTP1Q2/(3P1Q1P2Q2)+200A2MBMTP1Q2/(3P1Q1P2Q2)-
	- &48A1P1P2P1Q2/(P1Q1P2Q2)-256A2P1P2P1Q2/(3P1Q1*P2Q2)+
	- &256A1A2MB2P1P2P1Q2/(3P1Q1*P2Q2)+
	- &256A1A2MBMTP1P2P1Q2/(P1Q1*P2Q2)+
	- &1024A1A2P1P22P1Q2/(3P1Q1P2Q2)
	- V18=V18-272A2P1Q2*2/(3P1Q1*P2Q2)+
	- &256A1A2MB2P1Q2*2/(3P1Q1*P2Q2)+
	- &256A1A2MBMTP1Q22/(3P1Q1*P2Q2)+
	- &512A1A2P1P2P1Q2*2/(3P1Q1P2Q2)-32A2MB4/(3P2Q1*P2Q2)-
	- &32A2MB*3MT/(3P2Q1P2Q2)+64A22MB*5MT/(3P2Q1P2Q2)+
	- &16P1P2/(3P2Q1P2Q2)-64A2MB2P1P2/(3P2Q1P2Q2)+
	- &64A22MB*4P1P2/(3P2Q1P2Q2)+8MB2P1P2/(3P1Q1P2Q1*P2Q2)+
	- &8MBMTP1P2/(3P1Q1P2Q1P2Q2)-
	- &32A2MB*3MTP1P2/(3P1Q1P2Q1P2Q2)+
	- &16P1P22/(3P1Q1P2Q1P2Q2)-
	- &32A2MB*2P1P2*2/(3P1Q1P2Q1P2Q2)-
	- &16A2MB*2P1Q1/(3P2Q1P2Q2)+64A22MB*4P1Q1/(3P2Q1P2Q2)+
	- &8MB2P1P2/(3P1Q2P2Q1P2Q2)+8MBMTP1P2/(3P1Q2P2Q1*P2Q2)-
	- &32A2MB*3MTP1P2/(3P1Q2P2Q1P2Q2)+
	- &16P1P22/(3P1Q2P2Q1P2Q2)-
	- &32A2MB*2P1P2*2/(3P1Q2P2Q1P2Q2)+
	- &16MBMTP1P22/(3P1Q1P1Q2P2Q1*P2Q2)
	- V18=V18+16P1P23/(3P1Q1P1Q2P2Q1*P2Q2)-
	- &32A2MB*2P1P2P1Q1/(3P1Q2P2Q1P2Q2)-
	- &16A2MB*2P1Q2/(3P2Q1P2Q2)+64A22MB*4P1Q2/(3P2Q1P2Q2)-
	- &32A2MB*2P1P2P1Q2/(3P1Q1P2Q1P2Q2)+272A1P2Q1/(3*P2Q2)+
	- &112A2P2Q1/P2Q2-80A1A2MB2P2Q1/P2Q2-
	- &400A1A2MBMTP2Q1/(3P2Q2)+208A22MBMTP2Q1/(3*P2Q2)-
	- &272A1A2MT2P2Q1/(3P2Q2)-320A1A2P1P2*P2Q1/P2Q2+
	- &96A22P1P2P2Q1/P2Q2+256A1MBMT*3P2Q1/(3P1Q12P2Q2)+
	- &512A1MT*2P1P2P2Q1/(3P1Q1*2P2Q2)-8P2Q1/(3P1Q1*P2Q2)-
	- &200A1MBMTP2Q1/(3P1Q1P2Q2)-56A2MBMTP2Q1/(3P1Q1P2Q2)+
	- &272A1MT*2P2Q1/(3P1Q1P2Q2)+160A2MT*2P2Q1/(3P1Q1P2Q2)+
	- &256A1P1P2P2Q1/(3P1Q1P2Q2)+48A2P1P2P2Q1/(P1Q1*P2Q2)-
	- &256A1A2MBMTP1P2P2Q1/(P1Q1*P2Q2)-
	- &256A1A2MT2P1P2P2Q1/(3P1Q1*P2Q2)-
	- &1024A1A2P1P22P2Q1/(3P1Q1P2Q2)-
	- &544A1A2P1Q1P2Q1/(3P2Q2)-640A2*2P1Q1P2Q1/(3P2Q2)-
	- &32A1P1P2P2Q1/(3P1Q2*P2Q2)
	- V18=V18+32A1A2MBMTP1P2P2Q1/(3P1Q2P2Q2)+
	- &32A1A2MT2P1P2P2Q1/(3P1Q2*P2Q2)+
	- &64A1A2P1P22P2Q1/(3P1Q2P2Q2)-
	- &32A1MT*2P1P2P2Q1/(3P1Q1P1Q2P2Q2)+
	- &64A1A2P1P2P1Q1P2Q1/(3P1Q2*P2Q2)-
	- &944A1A2P1Q2P2Q1/(3P2Q2)-32A2*2P1Q2*P2Q1/P2Q2+
	- &256A1MT*2P1Q2P2Q1/(3P1Q1*2P2Q2)+
	- &96A1P1Q2P2Q1/(P1Q1P2Q2)+96A2P1Q2P2Q1/(P1Q1P2Q2)-
	- &128A1A2MB2P1Q2P2Q1/(3P1Q1*P2Q2)-
	- &256A1A2MBMTP1Q2P2Q1/(P1Q1*P2Q2)-
	- &128A1A2MT2P1Q2P2Q1/(3P1Q1*P2Q2)-
	- &512A1A2P1P2P1Q2P2Q1/(P1Q1P2Q2)-
	- &512A1A2P1Q22P2Q1/(3P1Q1P2Q2)+544A1A2P2Q12/(3P2Q2)-
	- &256A1MT*2P2Q1*2/(3P1Q1*2P2Q2)-
	- &272A1P2Q1*2/(3P1Q1*P2Q2)+
	- &256A1A2MBMTP2Q12/(3P1Q1*P2Q2)+
	- &256A1A2MT2P2Q1*2/(3P1Q1*P2Q2)
	- V18=V18+512A1A2P1P2P2Q1*2/(3P1Q1*P2Q2)+
	- &512A1A2P1Q2P2Q1*2/(3P1Q1P2Q2)+224A12*P2Q2+
	- &656A1A2P2Q2/3+256A12MT4P2Q2/(3P1Q1*2)+
	- &16A1P2Q2/(3P1Q1)+112A1A2MBMTP2Q2/(3*P1Q1)+
	- &32A12MT*2P2Q2/(3P1Q1)+64A1A2MT*2P2Q2/P1Q1+
	- &368A1A2P1P2P2Q2/(3P1Q1)-256A1MT2P2Q2/(3P1Q2*2)+
	- &256A12MT*4P2Q2/(3P1Q22)-256A1P2Q2/(3P1Q2)+
	- &224A1A2MBMTP2Q2/(3P1Q2)-368A12MT*2P2Q2/(3*P1Q2)+
	- &448A1A2MT2P2Q2/(3P1Q2)+304A1A2P1P2P2Q2/(3P1Q2)+
	- &16A1MT*2P2Q2/(3P1Q1P1Q2)-64A12MT*4P2Q2/(3P1Q1P1Q2)+
	- &32A12P1Q1P2Q2/P1Q2+944A1A2P1Q1P2Q2/(3P1Q2)+
	- &256A12MT*2P1Q2P2Q2/(3P1Q1**2)+
	- &640A12P1Q2P2Q2/(3P1Q1)+544A1A2P1Q2P2Q2/(3*P1Q1)-
	- &256A2MB*2P2Q2/(3P2Q12)-256A2*2MB*3MTP2Q2/(3P2Q1**2)+
	- &64MB2MT*2P2Q2/(3P1Q22P2Q1**2)+
	- &64MB2P2Q2/(3P1Q2P2Q1**2)-
	- &128A2MB*3MTP2Q2/(3P1Q2P2Q1*2)
	- V18=V18-128A2MB*2MT*2P2Q2/(3P1Q2P2Q1**2)-
	- &256A2MB*2P1P2P2Q2/(3P1Q2P2Q1*2)-
	- &256A2MB*2P1Q1P2Q2/(3P1Q2P2Q1*2)+
	- &256A22MB*2P1Q2P2Q2/(3P2Q1*2)+272A1P2Q2/(3P2Q1)+
	- &112A2P2Q2/P2Q1-80A1A2MB2P2Q2/P2Q1-
	- &400A1A2MBMTP2Q2/(3P2Q1)+208A22MBMTP2Q2/(3*P2Q1)-
	- &272A1A2MT2P2Q2/(3P2Q1)-320A1A2P1P2*P2Q2/P2Q1+
	- &96A22P1P2P2Q2/P2Q1-32A1P1P2P2Q2/(3P1Q1P2Q1)+
	- &32A1A2MBMTP1P2P2Q2/(3P1Q1P2Q1)+
	- &32A1A2MT2P1P2P2Q2/(3P1Q1*P2Q1)+
	- &64A1A2P1P22P2Q2/(3P1Q1P2Q1)-944A1A2P1Q1P2Q2/(3*P2Q1)-
	- &32A22P1Q1P2Q2/P2Q1+256A1MBMT*3P2Q2/(3P1Q22P2Q1)+
	- &512A1MT*2P1P2P2Q2/(3P1Q2*2P2Q1)+
	- &256A1MT*2P1Q1P2Q2/(3P1Q2*2P2Q1)-8P2Q2/(3P1Q2*P2Q1)-
	- &200A1MBMTP2Q2/(3P1Q2P2Q1)-56A2MBMTP2Q2/(3P1Q2P2Q1)+
	- &272A1MT*2P2Q2/(3P1Q2P2Q1)+160A2MT*2P2Q2/(3P1Q2P2Q1)+
	- &256A1P1P2P2Q2/(3P1Q2P2Q1)+48A2P1P2P2Q2/(P1Q2*P2Q1)
	- V18=V18-256A1A2MBMTP1P2P2Q2/(P1Q2*P2Q1)-
	- &256A1A2MT2P1P2P2Q2/(3P1Q2*P2Q1)-
	- &1024A1A2P1P22P2Q2/(3P1Q2P2Q1)-
	- &32A1MT*2P1P2P2Q2/(3P1Q1P1Q2P2Q1)+
	- &96A1P1Q1P2Q2/(P1Q2P2Q1)+96A2P1Q1P2Q2/(P1Q2P2Q1)-
	- &128A1A2MB2P1Q1P2Q2/(3P1Q2*P2Q1)-
	- &256A1A2MBMTP1Q1P2Q2/(P1Q2*P2Q1)-
	- &128A1A2MT2P1Q1P2Q2/(3P1Q2*P2Q1)-
	- &512A1A2P1P2P1Q1P2Q2/(P1Q2P2Q1)-
	- &512A1A2P1Q12P2Q2/(3P1Q2P2Q1)-544A1A2P1Q2P2Q2/(3*P2Q1)-
	- &640A22P1Q2P2Q2/(3P2Q1)+
	- &64A1A2P1P2P1Q2P2Q2/(3P1Q1P2Q1)+544A1A2P2Q2*2/(3P2Q1)-
	- &256A1MT*2P2Q2*2/(3P1Q2*2P2Q1)-
	- &272A1P2Q2*2/(3P1Q2*P2Q1)+
	- &256A1A2MBMTP2Q22/(3P1Q2*P2Q1)+
	- &256A1A2MT2P2Q2*2/(3P1Q2*P2Q1)+
	- &512A1A2P1P2P2Q2*2/(3P1Q2*P2Q1)
	- V18=V18+512A1A2P1Q1P2Q2*2/(3P1Q2*P2Q1)+
	- &384A12MBMTP1Q12/S2+
	- &384A12P1P2P1Q12/S2+2688A12MBMTP1Q1P1Q2/S**2+
	- &2688A12P1P2P1Q1P1Q2/S*2+384A12MBMTP1Q22/S*2+
	- &384A12P1P2P1Q22/S2+768A1A2MBMTP1Q1P2Q1/S*2+
	- &768A1A2P1P2P1Q1P2Q1/S2+2688A1A2MBMTP1Q2P2Q1/S*2+
	- &2688A1A2P1P2P1Q2P2Q1/S2-960A12P1Q1P1Q2P2Q1/S*2-
	- &960A1A2P1Q1P1Q2P2Q1/S2+960A12P1Q22P2Q1/S**2+
	- &960A1A2P1Q22P2Q1/S*2+384A2*2MBMTP2Q12/S2+
	- &384A22P1P2P2Q12/S2-960A1A2P1Q2P2Q12/S*2-
	- &960A22P1Q2P2Q12/S2+2688A1A2MBMTP1Q1P2Q2/S*2+
	- &2688A1A2P1P2P1Q1P2Q2/S2+960A12P1Q12P2Q2/S**2+
	- &960A1A2P1Q12P2Q2/S*2+768A1A2MBMTP1Q2P2Q2/S*2+
	- &768A1A2P1P2P1Q2P2Q2/S2-960A12P1Q1P1Q2P2Q2/S*2-
	- &960A1A2P1Q1P1Q2P2Q2/S2+2688A2*2MBMTP2Q1P2Q2/S*2+
	- &2688A22P1P2P2Q1P2Q2/S*2+960A1A2P1Q1P2Q1P2Q2/S**2+
	- &960A22P1Q1P2Q1P2Q2/S*2+960A1A2P1Q2P2Q1P2Q2/S**2+
	- &960A22P1Q2P2Q1P2Q2/S*2+384A2*2MBMTP2Q22/S2
	- V18=V18+384A22P1P2P2Q22/S2-960A1A2P1Q1P2Q22/S*2-
	- &960A22P1Q1P2Q22/S2+96A1MBMT/S+96A2MB*MT/S-
	- &768A22MB*3MT/S-768A12MBMT3/S-192A1*P1P2/S-
	- &192A2P1P2/S-768A22MB*2P1P2/S-2304A1A2MBMT*P1P2/S-
	- &768A12MT*2P1P2/S-2304A1A2P1P2*2/S-
	- &96A1MBMT3/(P1Q1S)-192A2MBMTP1P2/(P1Q1*S)-
	- &96A1MT*2P1P2/(P1Q1S)-192A2P1P22/(P1Q1S)-192A1P1Q1/S-
	- &144A2P1Q1/S-384A1A2MB2P1Q1/S-480A22MB*2P1Q1/S-
	- &480A12MBMTP1Q1/S+96A1A2MBMT*P1Q1/S-
	- &864A12P1P2P1Q1/S-672A1A2P1P2P1Q1/S-96A1A2P1Q1**2/S-
	- &96A1MBMT3/(P1Q2S)-192A2MBMTP1P2/(P1Q2*S)-
	- &96A1MT*2P1P2/(P1Q2S)-192A2P1P22/(P1Q2S)-
	- &48A1MBMTP1Q1/(P1Q2S)+96A2MBMTP1Q1/(P1Q2S)-
	- &48A1MT*2P1Q1/(P1Q2S)-192A1P1P2P1Q1/(P1Q2*S)-
	- &192A2P1P2P1Q1/(P1Q2S)+192A1A2MBMTP1P2P1Q1/(P1Q2*S)+
	- &192A1A2P1P22P1Q1/(P1Q2S)-192A1P1Q12/(P1Q2S)-
	- &192A2P1Q1*2/(P1Q2S)+192A1A2MB2P1Q1*2/(P1Q2S)
	- V18=V18-192A12MBMTP1Q1*2/(P1Q2S)+
	- &96A1A2MBMTP1Q12/(P1Q2S)+
	- &192A1A2P1P2P1Q1*2/(P1Q2S)-192A1P1Q2/S-144A2P1Q2/S-
	- &384A1A2MB2P1Q2/S-480A22MB*2P1Q2/S-
	- &480A12MBMTP1Q2/S+96A1A2MBMT*P1Q2/S-
	- &864A12P1P2P1Q2/S-672A1A2P1P2*P1Q2/S-
	- &48A1MBMTP1Q2/(P1Q1S)+96A2MBMTP1Q2/(P1Q1S)-
	- &48A1MT*2P1Q2/(P1Q1S)-192A1P1P2P1Q2/(P1Q1*S)-
	- &192A2P1P2P1Q2/(P1Q1S)+192A1A2MBMTP1P2P1Q2/(P1Q1*S)+
	- &192A1A2P1P22P1Q2/(P1Q1S)-576A1A2P1Q1*P1Q2/S-
	- &96A1A2P1Q22/S-192A1P1Q22/(P1Q1S)-
	- &192A2P1Q2*2/(P1Q1S)+192A1A2MB2P1Q2*2/(P1Q1S)-
	- &192A12MBMTP1Q2*2/(P1Q1S)+96A1A2MBMTP1Q22/(P1Q1S)+
	- &192A1A2P1P2P1Q2*2/(P1Q1S)+96A2MB*3MT/(P2Q1*S)+
	- &96A2MB*2P1P2/(P2Q1S)+192A1MBMTP1P2/(P2Q1S)+
	- &192A1P1P2*2/(P2Q1S)+96A1MB*2P1Q1/(P2Q1*S)+
	- &192A2MB*2P1Q1/(P2Q1S)+96A1MBMTP1Q1/(P2Q1S)+
	- &192A1A2MB3MTP1Q1/(P2Q1S)+192A1P1P2P1Q1/(P2Q1S)
	- V18=V18+192A1A2MB2P1P2P1Q1/(P2Q1S)+
	- &96A1A2MB2P1Q1*2/(P2Q1S)+
	- &192A2MB*3MTP1Q1/(P1Q2P2Q1*S)+
	- &192A2MB*2P1P2P1Q1/(P1Q2P2Q1*S)+
	- &96A1MBMTP1P2P1Q1/(P1Q2P2Q1*S)+
	- &96A1P1P2*2P1Q1/(P1Q2P2Q1S)+
	- &96A1MB*2P1Q1*2/(P1Q2P2Q1*S)+
	- &192A2MB*2P1Q1*2/(P1Q2P2Q1*S)+
	- &48A1MBMTP1Q1*2/(P1Q2P2Q1*S)+
	- &96A1P1P2P1Q12/(P1Q2P2Q1S)+96A1MB2P1Q2/(P2Q1*S)+
	- &48A2MB*2P1Q2/(P2Q1S)-192A1A2MB*3MTP1Q2/(P2Q1S)-
	- &192A1A2MB2P1P2P1Q2/(P2Q1S)-
	- &96A1A2MB2P1Q2*2/(P2Q1S)+144A1P2Q1/S+192A2P2Q1/S-
	- &96A1A2MBMTP2Q1/S+480A2*2MBMTP2Q1/S+
	- &480A12MT*2P2Q1/S+384A1A2MT2P2Q1/S+
	- &672A1A2P1P2P2Q1/S+864A22P1P2*P2Q1/S+
	- &96A2MBMTP2Q1/(P1Q1S)+192A1MT2P2Q1/(P1Q1*S)
	- V18=V18+96A2MT*2P2Q1/(P1Q1*S)+
	- &192A1A2MBMT*3P2Q1/(P1Q1*S)+
	- &192A2P1P2P2Q1/(P1Q1S)+192A1A2MT2P1P2P2Q1/(P1Q1S)-
	- &192A12P1Q1P2Q1/S-192A2*2P1Q1*P2Q1/S+
	- &48A1MT*2P2Q1/(P1Q2S)+96A2MT2P2Q1/(P1Q2*S)-
	- &192A1A2MBMT*3P2Q1/(P1Q2*S)-
	- &192A1A2MT2P1P2P2Q1/(P1Q2S)-
	- &96A1A2MBMTP1Q1P2Q1/(P1Q2*S)-
	- &192A12MT*2P1Q1P2Q1/(P1Q2S)-
	- &96A1A2MT2P1Q1P2Q1/(P1Q2S)-
	- &384A1A2P1P2P1Q1P2Q1/(P1Q2S)-384A12P1Q1*2P2Q1/(P1Q2*S)-
	- &384A1A2P1Q12P2Q1/(P1Q2S)-480A12P1Q2P2Q1/S-
	- &960A1A2P1Q2P2Q1/S-480A22P1Q2*P2Q1/S+
	- &144A1P1Q2P2Q1/(P1Q1S)+96A2P1Q2P2Q1/(P1Q1S)-
	- &384A1A2MBMTP1Q2P2Q1/(P1Q1*S)-
	- &96A12MT*2P1Q2P2Q1/(P1Q1S)+
	- &96A1A2MT2P1Q2P2Q1/(P1Q1S)-
	- &576A1A2P1P2P1Q2P2Q1/(P1Q1S)-192A12P1Q2*2P2Q1/(P1Q1*S)
	- V18=V18-384A1A2P1Q22P2Q1/(P1Q1S)-96A1A2P2Q1**2/S-
	- &96A1A2MT2P2Q1*2/(P1Q1S)+96A1A2MT2P2Q1*2/(P1Q2S)+
	- &288A1A2P1Q2P2Q1*2/(P1Q1S)+96A2MB*3MT/(P2Q2*S)+
	- &96A2MB*2P1P2/(P2Q2S)+192A1MBMTP1P2/(P2Q2S)+
	- &192A1P1P2*2/(P2Q2S)+96A1MB*2P1Q1/(P2Q2*S)+
	- &48A2MB*2P1Q1/(P2Q2S)-192A1A2MB*3MTP1Q1/(P2Q2S)-
	- &192A1A2MB2P1P2P1Q1/(P2Q2S)-
	- &96A1A2MB2P1Q1*2/(P2Q2S)+96A1MB*2P1Q2/(P2Q2*S)+
	- &192A2MB*2P1Q2/(P2Q2S)+96A1MBMTP1Q2/(P2Q2S)+
	- &192A1A2MB3MTP1Q2/(P2Q2S)+192A1P1P2P1Q2/(P2Q2S)+
	- &192A1A2MB2P1P2P1Q2/(P2Q2S)+
	- &192A2MB*3MTP1Q2/(P1Q1P2Q2*S)+
	- &192A2MB*2P1P2P1Q2/(P1Q1P2Q2*S)+
	- &96A1MBMTP1P2P1Q2/(P1Q1P2Q2*S)+
	- &96A1P1P2*2P1Q2/(P1Q1P2Q2S)+96A1A2MB2P1Q2*2/(P2Q2S)+
	- &96A1MB*2P1Q2*2/(P1Q1P2Q2*S)+
	- &192A2MB*2P1Q2*2/(P1Q1P2Q2*S)
	- V18=V18+48A1MBMTP1Q2*2/(P1Q1P2Q2*S)+
	- &96A1P1P2P1Q22/(P1Q1P2Q2S)-48A2MB2P2Q1/(P2Q2*S)+
	- &96A1MBMTP2Q1/(P2Q2S)-48A2MBMTP2Q1/(P2Q2S)-
	- &192A1P1P2P2Q1/(P2Q2S)-192A2P1P2P2Q1/(P2Q2S)+
	- &192A1A2MBMTP1P2P2Q1/(P2Q2*S)+
	- &192A1A2P1P22P2Q1/(P2Q2*S)-
	- &192A1MBMT3P2Q1/(P1Q1P2Q2S)-
	- &96A2MBMTP1P2P2Q1/(P1Q1P2Q2*S)-
	- &192A1MT*2P1P2P2Q1/(P1Q1P2Q2*S)-
	- &96A2P1P2*2P2Q1/(P1Q1P2Q2S)+
	- &96A1A2MB2P1Q1P2Q1/(P2Q2S)+
	- &192A22MB*2P1Q1P2Q1/(P2Q2S)+
	- &96A1A2MBMTP1Q1P2Q1/(P2Q2*S)+
	- &384A1A2P1P2P1Q1P2Q1/(P2Q2S)-96A1P1Q2P2Q1/(P2Q2S)-
	- &144A2P1Q2P2Q1/(P2Q2S)-96A1A2MB2P1Q2P2Q1/(P2Q2S)+
	- &96A22MB*2P1Q2P2Q1/(P2Q2S)+
	- &384A1A2MBMTP1Q2P2Q1/(P2Q2*S)
	- V18=V18+576A1A2P1P2P1Q2P2Q1/(P2Q2S)-
	- &96A2MB*2P1Q2P2Q1/(P1Q1P2Q2*S)+
	- &48A1MBMTP1Q2P2Q1/(P1Q1P2Q2*S)+
	- &48A2MBMTP1Q2P2Q1/(P1Q1P2Q2*S)-
	- &96A1MT*2P1Q2P2Q1/(P1Q1P2Q2*S)-
	- &96A1P1P2P1Q2P2Q1/(P1Q1P2Q2S)-
	- &96A2P1P2P1Q2P2Q1/(P1Q1P2Q2S)+
	- &96A1A2P1Q1P1Q2P2Q1/(P2Q2S)+288A1A2P1Q22P2Q1/(P2Q2*S)-
	- &96A1P1Q2*2P2Q1/(P1Q1P2Q2S)-96A2P1Q2*2P2Q1/(P1Q1P2Q2S)+
	- &192A1P2Q1*2/(P2Q2S)+192A2P2Q1*2/(P2Q2S)-
	- &96A1A2MBMTP2Q12/(P2Q2S)+192A22MBMTP2Q1*2/(P2Q2S)-
	- &192A1A2MT2P2Q1*2/(P2Q2S)-192A1A2P1P2P2Q1*2/(P2Q2S)+
	- &48A2MBMTP2Q1*2/(P1Q1P2Q2*S)+
	- &192A1MT*2P2Q1*2/(P1Q1P2Q2*S)+
	- &96A2MT*2P2Q1*2/(P1Q1P2Q2*S)+
	- &96A2P1P2P2Q12/(P1Q1P2Q2S)-384A1A2P1Q1P2Q12/(P2Q2S)-
	- &384A22P1Q1P2Q12/(P2Q2S)-384A1A2P1Q2P2Q1*2/(P2Q2S)
	- V18=V18-192A22P1Q2P2Q12/(P2Q2S)+
	- &96A1P1Q2P2Q12/(P1Q1P2Q2*S)+
	- &96A2P1Q2P2Q12/(P1Q1P2Q2S)+144A1P2Q2/S+192A2*P2Q2/S-
	- &96A1A2MBMTP2Q2/S+480A2*2MBMTP2Q2/S+
	- &480A12MT*2P2Q2/S+384A1A2MT2P2Q2/S+
	- &672A1A2P1P2P2Q2/S+864A22P1P2*P2Q2/S+
	- &48A1MT*2P2Q2/(P1Q1S)+96A2MT2P2Q2/(P1Q1*S)-
	- &192A1A2MBMT*3P2Q2/(P1Q1*S)-
	- &192A1A2MT2P1P2P2Q2/(P1Q1S)-480A12P1Q1*P2Q2/S-
	- &960A1A2P1Q1P2Q2/S-480A22P1Q1*P2Q2/S+
	- &96A2MBMTP2Q2/(P1Q2S)+192A1MT2P2Q2/(P1Q2*S)+
	- &96A2MT*2P2Q2/(P1Q2S)+192A1A2MBMT3P2Q2/(P1Q2*S)+
	- &192A2P1P2P2Q2/(P1Q2S)+192A1A2MT2P1P2P2Q2/(P1Q2S)+
	- &144A1P1Q1P2Q2/(P1Q2S)+96A2P1Q1P2Q2/(P1Q2S)-
	- &384A1A2MBMTP1Q1P2Q2/(P1Q2*S)-
	- &96A12MT*2P1Q1P2Q2/(P1Q2S)+
	- &96A1A2MT2P1Q1P2Q2/(P1Q2S)
	- V18=V18-576A1A2P1P2P1Q1P2Q2/(P1Q2S)-
	- &192A12P1Q1*2P2Q2/(P1Q2*S)-
	- &384A1A2P1Q12P2Q2/(P1Q2S)-192A12P1Q2P2Q2/S-
	- &192A22P1Q2P2Q2/S-96A1A2MBMTP1Q2P2Q2/(P1Q1S)-
	- &192A12MT*2P1Q2P2Q2/(P1Q1S)-
	- &96A1A2MT2P1Q2P2Q2/(P1Q1S)-
	- &384A1A2P1P2P1Q2P2Q2/(P1Q1S)-384A12P1Q2*2P2Q2/(P1Q1*S)-
	- &384A1A2P1Q22P2Q2/(P1Q1S)-48A2MB2P2Q2/(P2Q1*S)+
	- &96A1MBMTP2Q2/(P2Q1S)-48A2MBMTP2Q2/(P2Q1S)-
	- &192A1P1P2P2Q2/(P2Q1S)-192A2P1P2P2Q2/(P2Q1S)+
	- &192A1A2MBMTP1P2P2Q2/(P2Q1*S)+
	- &192A1A2P1P22P2Q2/(P2Q1S)-96A1P1Q1P2Q2/(P2Q1*S)-
	- &144A2P1Q1P2Q2/(P2Q1S)-96A1A2MB2P1Q1P2Q2/(P2Q1S)+
	- &96A22MB*2P1Q1P2Q2/(P2Q1S)+
	- &384A1A2MBMTP1Q1P2Q2/(P2Q1*S)+
	- &576A1A2P1P2P1Q1P2Q2/(P2Q1S)+288A1A2P1Q12P2Q2/(P2Q1*S)-
	- &192A1MBMT3P2Q2/(P1Q2P2Q1S)
	- V18=V18-96A2MBMTP1P2P2Q2/(P1Q2P2Q1*S)-
	- &192A1MT*2P1P2P2Q2/(P1Q2P2Q1*S)-
	- &96A2P1P2*2P2Q2/(P1Q2P2Q1S)-
	- &96A2MB*2P1Q1P2Q2/(P1Q2P2Q1*S)+
	- &48A1MBMTP1Q1P2Q2/(P1Q2P2Q1*S)
	-
	- V18BIS=
	- &48A2MBMTP1Q1P2Q2/(P1Q2P2Q1*S)-
	- &96A1MT*2P1Q1P2Q2/(P1Q2P2Q1*S)-
	- &96A1P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	- &96A2P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	- &96A1P1Q1*2P2Q2/(P1Q2P2Q1S)-96A2P1Q1*2P2Q2/(P1Q2P2Q1S)+
	- &96A1A2MB2P1Q2P2Q2/(P2Q1S)+
	- &192A22MB*2P1Q2P2Q2/(P2Q1S)+
	- &96A1A2MBMTP1Q2P2Q2/(P2Q1*S)+
	- &384A1A2P1P2P1Q2P2Q2/(P2Q1S)+
	- &96A1A2P1Q1P1Q2P2Q2/(P2Q1S)-576A1A2P2Q1P2Q2/S+
	- &96A1A2P1Q1P2Q1P2Q2/(P1Q2S)+96A1A2P1Q2P2Q1P2Q2/(P1Q1S)-
	- &96A1A2P2Q22/S+96A1A2MT*2P2Q2*2/(P1Q1S)-
	- &96A1A2MT2P2Q2*2/(P1Q2S)+288A1A2P1Q1P2Q2*2/(P1Q2S)+
	- &192A1P2Q2*2/(P2Q1S)+192A2P2Q2*2/(P2Q1S)-
	- &96A1A2MBMTP2Q22/(P2Q1S)+192A22MBMTP2Q2*2/(P2Q1S)-
	- &192A1A2MT2P2Q2*2/(P2Q1S)-192A1A2P1P2P2Q2*2/(P2Q1S)
	- V18BIS=V18BIS-384A1A2P1Q1P2Q2*2/(P2Q1S)-
	- &192A22P1Q1P2Q22/(P2Q1S)+
	- &48A2MBMTP2Q2*2/(P1Q2P2Q1*S)+
	- &192A1MT*2P2Q2*2/(P1Q2P2Q1*S)+
	- &96A2MT*2P2Q2*2/(P1Q2P2Q1*S)+
	- &96A2P1P2P2Q22/(P1Q2P2Q1S)+96A1P1Q1P2Q2*2/(P1Q2P2Q1*S)+
	- &96A2P1Q1P2Q22/(P1Q2P2Q1S)-384A1A2P1Q2P2Q22/(P2Q1S)-
	- &384A22P1Q2P2Q22/(P2Q1S)+512A1A2*S/3-
	- &128A1MT*2S/(3P1Q12)-128A12MBMT*3S/(3P1Q1*2)-
	- &152A1S/(3P1Q1)+152A12MBMTS/(3P1Q1)+
	- &128A1A2MBMTS/(3P1Q1)+112A1A2MT2S/(3*P1Q1)-
	- &16A12P1P2S/P1Q1+152A1A2P1P2S/(3P1Q1)-
	- &128A1MT*2S/(3P1Q22)-128A12MBMT*3S/(3P1Q2*2)-
	- &152A1S/(3P1Q2)+152A12MBMTS/(3P1Q2)+
	- &128A1A2MBMTS/(3P1Q2)+112A1A2MT2S/(3*P1Q2)-
	- &16A12P1P2S/P1Q2+152A1A2P1P2S/(3P1Q2)-
	- &16A1MBMTS/(3P1Q1P1Q2)+32A12MBMT3S/(3P1Q1P1Q2)
	- V18BIS=V18BIS-16A1P1P2S/(3P1Q1*P1Q2)+
	- &272A1A2P1Q1S/(3*P1Q2)+
	- &272A1A2P1Q2S/(3P1Q1)-128A2MB2S/(3P2Q1*2)-
	- &128A22MB*3MTS/(3P2Q1**2)+
	- &32MB2MT*2S/(3P1Q22P2Q1*2)+32MB*2S/(3P1Q2P2Q1**2)-
	- &64A2MB*3MTS/(3P1Q2P2Q1*2)-
	- &64A2MB*2MT*2S/(3P1Q2P2Q1**2)-
	- &128A2MB*2P1P2S/(3P1Q2P2Q1*2)-
	- &128A2MB*2P1Q1S/(3P1Q2P2Q1*2)+
	- &128A22MB*2P1Q2S/(3P2Q1*2)+152A2S/(3P2Q1)-
	- &112A1A2MB2S/(3P2Q1)-128A1A2MBMTS/(3*P2Q1)-
	- &152A22MBMTS/(3P2Q1)-152A1A2P1P2S/(3P2Q1)+
	- &16A22P1P2S/P2Q1+8A1A2MB*3MTS/(3P1Q1*P2Q1)+
	- &16A1A2MB2MT*2S/(3P1Q1P2Q1)+
	- &8A1A2MBMT*3S/(3P1Q1P2Q1)-8A1P1P2S/(3P1Q1*P2Q1)-
	- &8A2P1P2S/(3P1Q1P2Q1)+8A1A2MB*2P1P2S/(3P1Q1*P2Q1)+
	- &16A1A2MBMTP1P2S/(3P1Q1P2Q1)
	- V18BIS=V18BIS+8A1A2MT2P1P2S/(3P1Q1*P2Q1)+
	- &32A1A2P1P22S/(3P1Q1P2Q1)-32A22P1Q1S/(3P2Q1)-
	- &32MT2S/(3P1Q22P2Q1)+64A1MB*2MT*2S/(3P1Q22P2Q1)+
	- &64A1MBMT3S/(3P1Q22P2Q1)+
	- &128A1MT*2P1P2S/(3P1Q2*2P2Q1)-12S/(P1Q2P2Q1)+
	- &24A1MB*2S/(P1Q2P2Q1)-64A1A2MB*3MTS/(3P1Q2*P2Q1)+
	- &24A2MT*2S/(P1Q2P2Q1)-128A1A2MB*2MT*2S/(3P1Q2P2Q1)-
	- &64A1A2MBMT*3S/(3P1Q2P2Q1)+56A1P1P2S/(3P1Q2*P2Q1)+
	- &56A2P1P2S/(3P1Q2P2Q1)-64A1A2MB*2P1P2S/(3P1Q2*P2Q1)-
	- &128A1A2MBMTP1P2S/(3P1Q2P2Q1)-
	- &64A1A2MT2P1P2S/(3P1Q2*P2Q1)-
	- &256A1A2P1P22S/(3P1Q2P2Q1)+4P1P2S/(3P1Q1P1Q2*P2Q1)+
	- &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q1)-
	- &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q1)+136A2P1Q1S/(3P1Q2*P2Q1)-
	- &128A1A2MB2P1Q1S/(3P1Q2*P2Q1)-
	- &128A1A2MBMTP1Q1S/(3P1Q2P2Q1)-
	- &256A1A2P1P2P1Q1S/(3P1Q2P2Q1)-160A2*2P1Q2S/(3P2Q1)
	- V18BIS=V18BIS+16A1A2P1P2P1Q2S/(3P1Q1*P2Q1)-
	- &32A12P2Q1S/(3P1Q1)-
	- &128A12MT*2P2Q1S/(3P1Q2*2)-160A12P2Q1S/(3*P1Q2)-
	- &128A2MB*2S/(3P2Q22)-128A2*2MB*3MTS/(3P2Q2**2)+
	- &32MB2MT*2S/(3P1Q12P2Q2*2)+32MB*2S/(3P1Q1P2Q2**2)-
	- &64A2MB*3MTS/(3P1Q1P2Q2*2)-
	- &64A2MB*2MT*2S/(3P1Q1P2Q2**2)-
	- &128A2MB*2P1P2S/(3P1Q1P2Q2*2)+
	- &128A22MB*2P1Q1S/(3P2Q2**2)-
	- &128A2MB*2P1Q2S/(3P1Q1P2Q22)+152A2S/(3P2Q2)-
	- &112A1A2MB2S/(3P2Q2)-128A1A2MBMTS/(3*P2Q2)-
	- &152A22MBMTS/(3P2Q2)-152A1A2P1P2S/(3P2Q2)+
	- &16A22P1P2S/P2Q2-32MT*2S/(3P1Q12P2Q2)+
	- &64A1MB*2MT*2S/(3P1Q12P2Q2)+
	- &64A1MBMT3S/(3P1Q12P2Q2)+
	- &128A1MT*2P1P2S/(3P1Q1*2P2Q2)-12S/(P1Q1P2Q2)+
	- &24A1MB*2S/(P1Q1P2Q2)-64A1A2MB*3MTS/(3P1Q1*P2Q2)
	- V18BIS=V18BIS+24A2MT*2S/(P1Q1*P2Q2)-
	- &128A1A2MB2MT*2S/(3P1Q1P2Q2)-
	- &64A1A2MBMT*3S/(3P1Q1P2Q2)+56A1P1P2S/(3P1Q1*P2Q2)+
	- &56A2P1P2S/(3P1Q1P2Q2)-64A1A2MB*2P1P2S/(3P1Q1*P2Q2)-
	- &128A1A2MBMTP1P2S/(3P1Q1P2Q2)-
	- &64A1A2MT2P1P2S/(3P1Q1*P2Q2)-
	- &256A1A2P1P22S/(3P1Q1P2Q2)-160A22P1Q1S/(3P2Q2)+
	- &8A1A2MB3MTS/(3P1Q2*P2Q2)+
	- &16A1A2MB2MT*2S/(3P1Q2P2Q2)+
	- &8A1A2MBMT*3S/(3P1Q2P2Q2)-8A1P1P2S/(3P1Q2*P2Q2)-
	- &8A2P1P2S/(3P1Q2P2Q2)+8A1A2MB*2P1P2S/(3P1Q2*P2Q2)+
	- &16A1A2MBMTP1P2S/(3P1Q2P2Q2)+
	- &8A1A2MT2P1P2S/(3P1Q2*P2Q2)+
	- &32A1A2P1P22S/(3P1Q2P2Q2)+4P1P2S/(3P1Q1P1Q2*P2Q2)+
	- &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q2)-
	- &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q2)+
	- &16A1A2P1P2P1Q1S/(3P1Q2P2Q2)-32A2*2P1Q2S/(3P2Q2)
	- V18BIS=V18BIS+136A2P1Q2S/(3P1Q1*P2Q2)-
	- &128A1A2MB2P1Q2S/(3P1Q1*P2Q2)-
	- &128A1A2MBMTP1Q2S/(3P1Q1P2Q2)-
	- &256A1A2P1P2P1Q2S/(3P1Q1P2Q2)-16A2MBMTS/(3P2Q1*P2Q2)+
	- &32A22MB*3MTS/(3P2Q1P2Q2)-16A2P1P2S/(3P2Q1P2Q2)-
	- &4P1P2S/(3P1Q1P2Q1P2Q2)+8A2MB2P1P2S/(3P1Q1P2Q1P2Q2)-
	- &8A2MBMTP1P2S/(3P1Q1P2Q1P2Q2)-4P1P2S/(3P1Q2P2Q1*P2Q2)+
	- &8A2MB*2P1P2S/(3P1Q2P2Q1P2Q2)-
	- &8A2MBMTP1P2S/(3P1Q2P2Q1P2Q2)+
	- &2MB3MTS/(3P1Q1P1Q2P2Q1*P2Q2)+
	- &4MB2MT*2S/(3P1Q1P1Q2P2Q1P2Q2)+
	- &2MBMT*3S/(3P1Q1P1Q2P2Q1P2Q2)-
	- &2MB2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)-
	- &4MBMTP1P2S/(3P1Q1P1Q2P2Q1P2Q2)-
	- &2MT2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)-
	- &8P1P22S/(3P1Q1P1Q2P2Q1P2Q2)+
	- &8A2P1P2P1Q1S/(3P1Q2P2Q1*P2Q2)
	- V18BIS=V18BIS+8A2P1P2P1Q2S/(3P1Q1P2Q1*P2Q2)+
	- &272A1A2P2Q1S/(3*P2Q2)-
	- &128A1MT*2P2Q1S/(3P1Q1*2P2Q2)-136A1P2Q1S/(3P1Q1*P2Q2)+
	- &128A1A2MBMTP2Q1S/(3P1Q1P2Q2)+
	- &128A1A2MT2P2Q1S/(3P1Q1*P2Q2)+
	- &256A1A2P1P2P2Q1S/(3P1Q1*P2Q2)-
	- &16A1A2P1P2P2Q1S/(3P1Q2*P2Q2)+
	- &8A1P1P2P2Q1S/(3P1Q1P1Q2*P2Q2)+
	- &256A1A2P1Q2P2Q1S/(3P1Q1*P2Q2)-
	- &128A12MT*2P2Q2S/(3P1Q1*2)-160A12P2Q2S/(3*P1Q1)-
	- &32A12P2Q2S/(3P1Q2)+272A1A2P2Q2S/(3*P2Q1)-
	- &16A1A2P1P2P2Q2S/(3P1Q1*P2Q1)-
	- &128A1MT*2P2Q2S/(3P1Q2*2P2Q1)-136A1P2Q2S/(3P1Q2*P2Q1)+
	- &128A1A2MBMTP2Q2S/(3P1Q2P2Q1)+
	- &128A1A2MT2P2Q2S/(3P1Q2*P2Q1)+
	- &256A1A2P1P2P2Q2S/(3P1Q2*P2Q1)+
	- &8A1P1P2P2Q2S/(3P1Q1P1Q2*P2Q1)
	- V18BIS=V18BIS+256A1A2P1Q1P2Q2S/(3P1Q2*P2Q1)+
	- &8A12MBMTS*2/(3P1Q1P1Q2)+16A12P1P2S*2/(3P1Q1*P1Q2)-
	- &8A1A2P1P2S*2/(3P1Q1P2Q1)+4A1P1P2S*2/(3P1Q1P1Q2P2Q1)-
	- &8A1A2P1P2S*2/(3P1Q2P2Q2)+4A1P1P2S*2/(3P1Q1P1Q2P2Q2)+
	- &8A22MBMTS*2/(3P2Q1P2Q2)+16A2*2P1P2S2/(3P2Q1*P2Q2)-
	- &4A2P1P2S2/(3P1Q1P2Q1P2Q2)-
	- &4A2P1P2S2/(3P1Q2P2Q1P2Q2)+
	- &2P1P2S*2/(3P1Q1P1Q2P2Q1*P2Q2)
	-C
	-
	- A18 = 640A1/3+640A2/3+32A1A2MB2+368A12MBMT+
	- &512A1A2MBMT/3+
	- &368A22MBMT+32A1A2MT*2+496A12*P1P2/3+
	- &320A1A2P1P2+496A2*2P1P2/3-128A1MBMT3/(3P1Q1**2)+
	- &128A1MT*4/(3P1Q1*2)+256A12MBMT*5/(3P1Q1**2)+
	- &256A1MT*2P1P2/(3P1Q12)-256A12MT4P1P2/(3P1Q1*2)+
	- &8/(3P1Q1)+32A1MBMT/P1Q1+56A2MBMT/(3P1Q1)+
	- &88A1MT*2/(3P1Q1)+72A2MT**2/P1Q1-
	- &704A12MBMT3/(3P1Q1)+224A1A2MBMT*3/(3P1Q1)+
	- &104A1P1P2/(3P1Q1)+48A2*P1P2/P1Q1-
	- &128A1A2MBMTP1P2/(3P1Q1)+512A12MT*2P1P2/(3*P1Q1)-
	- &448A1A2MT2P1P2/(3P1Q1)-32A1A2P1P2**2/P1Q1-
	- &656A1A2P1Q1/3-224A2*2P1Q1-128A1MBMT3/(3P1Q2**2)+
	- &128A1MT*4/(3P1Q2*2)+256A12MBMT*5/(3P1Q2**2)+
	- &256A1MT*2P1P2/(3P1Q22)-256A12MT4P1P2/(3P1Q2*2)+
	- &256A1MT*2P1Q1/(3P1Q22)-256A12MBMT*3P1Q1/(3P1Q2*2)+
	- &8/(3P1Q2)+32A1MBMT/P1Q2+56A2MBMT/(3P1Q2)
	- A18=A18+88A1MT*2/(3P1Q2)+72A2MT**2/P1Q2-
	- &704A12MBMT3/(3P1Q2)+224A1A2MBMT*3/(3P1Q2)+
	- &104A1P1P2/(3P1Q2)+48A2*P1P2/P1Q2-
	- &128A1A2MBMTP1P2/(3P1Q2)+512A12MT*2P1P2/(3*P1Q2)-
	- &448A1A2MT2P1P2/(3P1Q2)-32A1A2P1P2**2/P1Q2+
	- &32A1MBMT3/(3P1Q1P1Q2)-32A1MT4/(3P1Q1*P1Q2)-
	- &64A12MBMT5/(3P1Q1P1Q2)+16P1P2/(3P1Q1P1Q2)-
	- &64A1MT*2P1P2/(3P1Q1P1Q2)+64A12MT*4P1P2/(3P1Q1P1Q2)+
	- &112A1P1Q1/P1Q2+272A2P1Q1/(3*P1Q2)-
	- &272A1A2MB2P1Q1/(3P1Q2)-208A12MBMTP1Q1/(3P1Q2)+
	- &400A1A2MBMTP1Q1/(3P1Q2)-80A1A2MT2P1Q1/P1Q2+
	- &96A12P1P2P1Q1/P1Q2-320A1A2P1P2*P1Q1/P1Q2-
	- &544A1A2P1Q12/(3P1Q2)-656A1A2P1Q2/3-224A2*2P1Q2+
	- &256A1MT*2P1Q2/(3P1Q12)-256A12MBMT*3P1Q2/(3P1Q1*2)+
	- &112A1P1Q2/P1Q1+272A2P1Q2/(3*P1Q1)-
	- &272A1A2MB2P1Q2/(3P1Q1)-208A12MBMTP1Q2/(3P1Q1)+
	- &400A1A2MBMTP1Q2/(3P1Q1)-80A1A2MT2P1Q2/P1Q1
	- A18=A18+96A12P1P2P1Q2/P1Q1-320A1A2P1P2*P1Q2/P1Q1-
	- &544A1A2P1Q22/(3P1Q1)+128A2MB*4/(3P2Q1**2)-
	- &128A2MB*3MT/(3P2Q12)+256A2*2MB*5MT/(3P2Q1*2)+
	- &256A2MB*2P1P2/(3P2Q12)-256A2*2MB*4P1P2/(3P2Q1*2)+
	- &256A2MB*2P1Q1/(3P2Q12)-256A2*2MB*4P1Q1/(3P2Q1*2)+
	- &64MB3MT*3/(3P1Q2*2P2Q1**2)-
	- &64MB2MT*2P1P2/(3P1Q22P2Q1**2)-
	- &64MB2MT*2P1Q1/(3P1Q22P2Q1**2)-
	- &64MB3MT/(3P1Q2P2Q1**2)-
	- &256A2MB*3MTP1P2/(3P1Q2P2Q1*2)+
	- &256A2MB*2P1P2*2/(3P1Q2P2Q1*2)-
	- &256A2MB*3MTP1Q1/(3P1Q2P2Q1*2)+
	- &512A2MB*2P1P2P1Q1/(3P1Q2P2Q1*2)+
	- &256A2MB*2P1Q1*2/(3P1Q2P2Q1*2)-
	- &256A22MB*4P1Q2/(3P2Q12)-8/(3P2Q1)-72A1MB**2/P2Q1-
	- &88A2MB*2/(3P2Q1)-56A1MBMT/(3P2Q1)-32A2MB*MT/P2Q1-
	- &224A1A2MB3MT/(3P2Q1)+704A2*2MB*3MT/(3*P2Q1)
	- A18=A18-48A1P1P2/P2Q1-104A2P1P2/(3*P2Q1)+
	- &448A1A2MB2P1P2/(3P2Q1)-512A2*2MB*2P1P2/(3*P2Q1)+
	- &128A1A2MBMTP1P2/(3P2Q1)+32A1A2P1P2*2/P2Q1-
	- &16P1P2/(3P1Q1P2Q1)+32A1MBMTP1P2/(3P1Q1*P2Q1)+
	- &32A2MBMTP1P2/(3P1Q1P2Q1)+
	- &64A1A2MBMTP1P22/(3P1Q1*P2Q1)-
	- &64A1A2P1P23/(3P1Q1P2Q1)-256A2P1Q1/(3P2Q1)+
	- &448A1A2MB2P1Q1/(3P2Q1)-368A2*2MB*2P1Q1/(3*P2Q1)-
	- &224A1A2MBMTP1Q1/(3P2Q1)+304A1A2P1P2P1Q1/(3*P2Q1)+
	- &64MBMT*3/(3P1Q2*2P2Q1)+
	- &256A1MBMT3P1P2/(3P1Q22P2Q1)-
	- &256A1MT*2P1P2*2/(3P1Q2*2P2Q1)+
	- &64MT2P1Q1/(3P1Q22P2Q1)-
	- &128A1MB*2MT*2P1Q1/(3P1Q22P2Q1)+
	- &128A1MBMT3P1Q1/(3P1Q22P2Q1)-
	- &256A1MT*2P1P2P1Q1/(3P1Q2*2P2Q1)-4MB2/(3P1Q2*P2Q1)-
	- &64MBMT/(3P1Q2P2Q1)+128A2MB*3MT/(3P1Q2P2Q1)
	- A18=A18-4MT2/(3P1Q2P2Q1)-128A1MB2MT*2/(3P1Q2*P2Q1)-
	- &128A2MB*2MT*2/(3P1Q2P2Q1)+128A1MBMT*3/(3P1Q2*P2Q1)-
	- &112A2MB*2P1P2/(3P1Q2P2Q1)+32A1MBMTP1P2/(3P1Q2P2Q1)+
	- &32A2MBMTP1P2/(3P1Q2P2Q1)-112A1MT*2P1P2/(3P1Q2P2Q1)-
	- &48A1P1P2*2/(P1Q2P2Q1)-48A2P1P2*2/(P1Q2P2Q1)-
	- &512A1A2MBMTP1P22/(3P1Q2*P2Q1)+
	- &512A1A2P1P23/(3P1Q2P2Q1)+8MBMTP1P2/(3P1Q1P1Q2*P2Q1)-
	- &8MT2P1P2/(3P1Q1P1Q2*P2Q1)-
	- &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q1)-
	- &16P1P22/(3P1Q1P1Q2P2Q1)+
	- &32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q1)+8P1Q1/(3P1Q2*P2Q1)-
	- &160A1MB*2P1Q1/(3P1Q2P2Q1)-272A2MB*2P1Q1/(3P1Q2P2Q1)-
	- &56A1MBMTP1Q1/(3P1Q2P2Q1)-200A2MBMTP1Q1/(3P1Q2P2Q1)-
	- &48A1P1P2P1Q1/(P1Q2P2Q1)-256A2P1P2P1Q1/(3P1Q2*P2Q1)+
	- &256A1A2MB2P1P2P1Q1/(3P1Q2*P2Q1)-
	- &256A1A2MBMTP1P2P1Q1/(P1Q2*P2Q1)+
	- &1024A1A2P1P22P1Q1/(3P1Q2P2Q1)
	- A18=A18-272A2P1Q1*2/(3P1Q2*P2Q1)+
	- &256A1A2MB2P1Q1*2/(3P1Q2*P2Q1)-
	- &256A1A2MBMTP1Q12/(3P1Q2*P2Q1)+
	- &512A1A2P1P2P1Q1*2/(3P1Q2P2Q1)+16A2P1Q2/(3P2Q1)+
	- &64A1A2MB2P1Q2/P2Q1+32A22MB*2P1Q2/(3*P2Q1)-
	- &112A1A2MBMTP1Q2/(3P2Q1)+368A1A2P1P2P1Q2/(3*P2Q1)+
	- &32A2P1P2P1Q2/(3P1Q1*P2Q1)-
	- &32A1A2MB2P1P2P1Q2/(3P1Q1*P2Q1)+
	- &32A1A2MBMTP1P2P1Q2/(3P1Q1P2Q1)-
	- &64A1A2P1P22P1Q2/(3P1Q1P2Q1)+224A12P2Q1+
	- &656A1A2P2Q1/3-256A1MT2P2Q1/(3P1Q1*2)+
	- &256A12MT*4P2Q1/(3P1Q12)-256A1P2Q1/(3P1Q1)-
	- &224A1A2MBMTP2Q1/(3P1Q1)-368A12MT*2P2Q1/(3*P1Q1)+
	- &448A1A2MT2P2Q1/(3P1Q1)+304A1A2P1P2P2Q1/(3P1Q1)+
	- &256A12MT*4P2Q1/(3P1Q2*2)+
	- &256A12MT*2P1Q1P2Q1/(3P1Q2*2)+16A1P2Q1/(3P1Q2)-
	- &112A1A2MBMTP2Q1/(3P1Q2)+32A12MT*2P2Q1/(3*P1Q2)
	- A18=A18+64A1A2MT2P2Q1/P1Q2+368A1A2P1P2P2Q1/(3*P1Q2)+
	- &16A1MT*2P2Q1/(3P1Q1P1Q2)-64A12MT*4P2Q1/(3P1Q1P1Q2)+
	- &640A12P1Q1P2Q1/(3P1Q2)+544A1A2P1Q1P2Q1/(3*P1Q2)+
	- &32A12P1Q2P2Q1/P1Q1+944A1A2P1Q2P2Q1/(3P1Q1)+
	- &128A2MB*4/(3P2Q2*2)-128A2MB3MT/(3P2Q2*2)+
	- &256A22MB*5MT/(3P2Q22)+256A2MB2P1P2/(3P2Q2*2)-
	- &256A22MB*4P1P2/(3P2Q2*2)+
	- &64MB3MT*3/(3P1Q1*2P2Q2**2)-
	- &64MB2MT*2P1P2/(3P1Q12P2Q2**2)-
	- &64MB3MT/(3P1Q1P2Q2**2)-
	- &256A2MB*3MTP1P2/(3P1Q1P2Q2*2)+
	- &256A2MB*2P1P2*2/(3P1Q1P2Q2*2)-
	- &256A22MB*4P1Q1/(3P2Q22)+256A2MB2P1Q2/(3P2Q2*2)-
	- &256A22MB*4P1Q2/(3P2Q2*2)-
	- &64MB2MT*2P1Q2/(3P1Q12P2Q2**2)-
	- &256A2MB*3MTP1Q2/(3P1Q1P2Q2*2)+
	- &512A2MB*2P1P2P1Q2/(3P1Q1P2Q2*2)
	- A18=A18+256A2MB*2P1Q2*2/(3P1Q1P2Q2*2)-
	- &256A2MB*2P2Q1/(3P2Q22)+256A2*2MB*3MTP2Q1/(3P2Q2**2)+
	- &64MB2MT*2P2Q1/(3P1Q12P2Q2**2)+
	- &64MB2P2Q1/(3P1Q1P2Q2**2)+
	- &128A2MB*3MTP2Q1/(3P1Q1P2Q2*2)-
	- &128A2MB*2MT*2P2Q1/(3P1Q1P2Q2**2)-
	- &256A2MB*2P1P2P2Q1/(3P1Q1P2Q2*2)+
	- &256A22MB*2P1Q1P2Q1/(3P2Q2**2)-
	- &256A2MB*2P1Q2P2Q1/(3P1Q1P2Q22)-8/(3P2Q2)-
	- &72A1MB*2/P2Q2-88A2MB2/(3P2Q2)-56A1MBMT/(3P2Q2)-
	- &32A2MBMT/P2Q2-224A1A2MB*3MT/(3*P2Q2)+
	- &704A22MB*3MT/(3P2Q2)-48A1*P1P2/P2Q2-
	- &104A2P1P2/(3P2Q2)+448A1A2MB*2P1P2/(3*P2Q2)-
	- &512A22MB*2P1P2/(3P2Q2)+128A1A2MBMTP1P2/(3*P2Q2)+
	- &32A1A2P1P22/P2Q2+64MBMT3/(3P1Q1*2P2Q2)+
	- &256A1MBMT3P1P2/(3P1Q12P2Q2)-
	- &256A1MT*2P1P2*2/(3P1Q1*2P2Q2)-4MB2/(3P1Q1*P2Q2)
	- A18=A18-64MBMT/(3P1Q1P2Q2)+128A2MB*3MT/(3P1Q1P2Q2)-
	- &4MT2/(3P1Q1P2Q2)-128A1MB2MT*2/(3P1Q1*P2Q2)-
	- &128A2MB*2MT*2/(3P1Q1P2Q2)+128A1MBMT*3/(3P1Q1*P2Q2)-
	- &112A2MB*2P1P2/(3P1Q1P2Q2)+32A1MBMTP1P2/(3P1Q1P2Q2)+
	- &32A2MBMTP1P2/(3P1Q1P2Q2)-112A1MT*2P1P2/(3P1Q1P2Q2)-
	- &48A1P1P2*2/(P1Q1P2Q2)-48A2P1P2*2/(P1Q1P2Q2)-
	- &512A1A2MBMTP1P22/(3P1Q1*P2Q2)+
	- &512A1A2P1P23/(3P1Q1P2Q2)+16A2P1Q1/(3P2Q2)+
	- &64A1A2MB2P1Q1/P2Q2+32A22MB*2P1Q1/(3*P2Q2)-
	- &112A1A2MBMTP1Q1/(3P2Q2)+368A1A2P1P2P1Q1/(3*P2Q2)-
	- &16P1P2/(3P1Q2P2Q2)+32A1MBMTP1P2/(3P1Q2*P2Q2)+
	- &32A2MBMTP1P2/(3P1Q2P2Q2)+
	- &64A1A2MBMTP1P22/(3P1Q2*P2Q2)-
	- &64A1A2P1P23/(3P1Q2P2Q2)+8MBMTP1P2/(3P1Q1P1Q2*P2Q2)-
	- &8MT2P1P2/(3P1Q1P1Q2*P2Q2)-
	- &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q2)-
	- &16P1P22/(3P1Q1P1Q2P2Q2)
	- A18=A18+32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q2)+
	- &32A2P1P2P1Q1/(3P1Q2*P2Q2)-
	- &32A1A2MB2P1P2P1Q1/(3P1Q2*P2Q2)+
	- &32A1A2MBMTP1P2P1Q1/(3P1Q2P2Q2)-
	- &64A1A2P1P22P1Q1/(3P1Q2P2Q2)-256A2P1Q2/(3*P2Q2)+
	- &448A1A2MB2P1Q2/(3P2Q2)-368A2*2MB*2P1Q2/(3*P2Q2)-
	- &224A1A2MBMTP1Q2/(3P2Q2)+304A1A2P1P2P1Q2/(3*P2Q2)+
	- &64MT2P1Q2/(3P1Q12P2Q2)-
	- &128A1MB*2MT*2P1Q2/(3P1Q12P2Q2)+
	- &128A1MBMT3P1Q2/(3P1Q12P2Q2)-
	- &256A1MT*2P1P2P1Q2/(3P1Q1*2P2Q2)+8P1Q2/(3P1Q1*P2Q2)-
	- &160A1MB*2P1Q2/(3P1Q1P2Q2)-272A2MB*2P1Q2/(3P1Q1P2Q2)-
	- &56A1MBMTP1Q2/(3P1Q1P2Q2)-200A2MBMTP1Q2/(3P1Q1P2Q2)-
	- &48A1P1P2P1Q2/(P1Q1P2Q2)-256A2P1P2P1Q2/(3P1Q1*P2Q2)+
	- &256A1A2MB2P1P2P1Q2/(3P1Q1*P2Q2)-
	- &256A1A2MBMTP1P2P1Q2/(P1Q1*P2Q2)+
	- &1024A1A2P1P22P1Q2/(3P1Q1P2Q2)
	- A18=A18-272A2P1Q2*2/(3P1Q1*P2Q2)+
	- &256A1A2MB2P1Q2*2/(3P1Q1*P2Q2)-
	- &256A1A2MBMTP1Q22/(3P1Q1*P2Q2)+
	- &512A1A2P1P2P1Q2*2/(3P1Q1P2Q2)-32A2MB4/(3P2Q1*P2Q2)+
	- &32A2MB*3MT/(3P2Q1P2Q2)-64A22MB*5MT/(3P2Q1P2Q2)+
	- &16P1P2/(3P2Q1P2Q2)-64A2MB2P1P2/(3P2Q1P2Q2)+
	- &64A22MB*4P1P2/(3P2Q1P2Q2)+8MB2P1P2/(3P1Q1P2Q1*P2Q2)-
	- &8MBMTP1P2/(3P1Q1P2Q1P2Q2)+
	- &32A2MB*3MTP1P2/(3P1Q1P2Q1P2Q2)+
	- &16P1P22/(3P1Q1P2Q1P2Q2)-
	- &32A2MB*2P1P2*2/(3P1Q1P2Q1P2Q2)-
	- &16A2MB*2P1Q1/(3P2Q1P2Q2)+64A22MB*4P1Q1/(3P2Q1P2Q2)+
	- &8MB2P1P2/(3P1Q2P2Q1P2Q2)-8MBMTP1P2/(3P1Q2P2Q1*P2Q2)+
	- &32A2MB*3MTP1P2/(3P1Q2P2Q1P2Q2)+
	- &16P1P22/(3P1Q2P2Q1P2Q2)-
	- &32A2MB*2P1P2*2/(3P1Q2P2Q1P2Q2)-
	- &16MBMTP1P22/(3P1Q1P1Q2P2Q1*P2Q2)
	- A18=A18+16P1P23/(3P1Q1P1Q2P2Q1*P2Q2)-
	- &32A2MB*2P1P2P1Q1/(3P1Q2P2Q1P2Q2)-
	- &16A2MB*2P1Q2/(3P2Q1P2Q2)+64A22MB*4P1Q2/(3P2Q1P2Q2)-
	- &32A2MB*2P1P2P1Q2/(3P1Q1P2Q1P2Q2)+272A1P2Q1/(3*P2Q2)+
	- &112A2P2Q1/P2Q2-80A1A2MB2P2Q1/P2Q2+
	- &400A1A2MBMTP2Q1/(3P2Q2)-208A22MBMTP2Q1/(3*P2Q2)-
	- &272A1A2MT2P2Q1/(3P2Q2)-320A1A2P1P2*P2Q1/P2Q2+
	- &96A22P1P2P2Q1/P2Q2-256A1MBMT*3P2Q1/(3P1Q12P2Q2)+
	- &512A1MT*2P1P2P2Q1/(3P1Q1*2P2Q2)-8P2Q1/(3P1Q1*P2Q2)+
	- &200A1MBMTP2Q1/(3P1Q1P2Q2)+56A2MBMTP2Q1/(3P1Q1P2Q2)+
	- &272A1MT*2P2Q1/(3P1Q1P2Q2)+160A2MT*2P2Q1/(3P1Q1P2Q2)+
	- &256A1P1P2P2Q1/(3P1Q1P2Q2)+48A2P1P2P2Q1/(P1Q1*P2Q2)+
	- &256A1A2MBMTP1P2P2Q1/(P1Q1*P2Q2)-
	- &256A1A2MT2P1P2P2Q1/(3P1Q1*P2Q2)-
	- &1024A1A2P1P22P2Q1/(3P1Q1P2Q2)-
	- &544A1A2P1Q1P2Q1/(3P2Q2)-640A2*2P1Q1P2Q1/(3P2Q2)-
	- &32A1P1P2P2Q1/(3P1Q2*P2Q2)
	- A18=A18-32A1A2MBMTP1P2P2Q1/(3P1Q2P2Q2)+
	- &32A1A2MT2P1P2P2Q1/(3P1Q2*P2Q2)+
	- &64A1A2P1P22P2Q1/(3P1Q2P2Q2)-
	- &32A1MT*2P1P2P2Q1/(3P1Q1P1Q2P2Q2)+
	- &64A1A2P1P2P1Q1P2Q1/(3P1Q2*P2Q2)-
	- &944A1A2P1Q2P2Q1/(3P2Q2)-32A2*2P1Q2*P2Q1/P2Q2+
	- &256A1MT*2P1Q2P2Q1/(3P1Q1*2P2Q2)+
	- &96A1P1Q2P2Q1/(P1Q1P2Q2)+96A2P1Q2P2Q1/(P1Q1P2Q2)-
	- &128A1A2MB2P1Q2P2Q1/(3P1Q1*P2Q2)+
	- &256A1A2MBMTP1Q2P2Q1/(P1Q1*P2Q2)-
	- &128A1A2MT2P1Q2P2Q1/(3P1Q1*P2Q2)-
	- &512A1A2P1P2P1Q2P2Q1/(P1Q1P2Q2)-
	- &512A1A2P1Q22P2Q1/(3P1Q1P2Q2)+544A1A2P2Q12/(3P2Q2)-
	- &256A1MT*2P2Q1*2/(3P1Q1*2P2Q2)-
	- &272A1P2Q1*2/(3P1Q1*P2Q2)-
	- &256A1A2MBMTP2Q12/(3P1Q1*P2Q2)+
	- &256A1A2MT2P2Q1*2/(3P1Q1*P2Q2)
	- A18=A18+512A1A2P1P2P2Q1*2/(3P1Q1*P2Q2)+
	- &512A1A2P1Q2P2Q1*2/(3P1Q1P2Q2)+224A12*P2Q2+
	- &656A1A2P2Q2/3+256A12MT4P2Q2/(3P1Q1*2)+
	- &16A1P2Q2/(3P1Q1)-112A1A2MBMTP2Q2/(3*P1Q1)+
	- &32A12MT*2P2Q2/(3P1Q1)+64A1A2MT*2P2Q2/P1Q1+
	- &368A1A2P1P2P2Q2/(3P1Q1)-256A1MT2P2Q2/(3P1Q2*2)+
	- &256A12MT*4P2Q2/(3P1Q22)-256A1P2Q2/(3P1Q2)-
	- &224A1A2MBMTP2Q2/(3P1Q2)-368A12MT*2P2Q2/(3*P1Q2)+
	- &448A1A2MT2P2Q2/(3P1Q2)+304A1A2P1P2P2Q2/(3P1Q2)+
	- &16A1MT*2P2Q2/(3P1Q1P1Q2)-64A12MT*4P2Q2/(3P1Q1P1Q2)+
	- &32A12P1Q1P2Q2/P1Q2+944A1A2P1Q1P2Q2/(3P1Q2)+
	- &256A12MT*2P1Q2P2Q2/(3P1Q1**2)+
	- &640A12P1Q2P2Q2/(3P1Q1)+544A1A2P1Q2P2Q2/(3*P1Q1)-
	- &256A2MB*2P2Q2/(3P2Q12)+256A2*2MB*3MTP2Q2/(3P2Q1**2)+
	- &64MB2MT*2P2Q2/(3P1Q22P2Q1**2)+
	- &64MB2P2Q2/(3P1Q2P2Q1**2)+
	- &128A2MB*3MTP2Q2/(3P1Q2P2Q1*2)
	- A18=A18-128A2MB*2MT*2P2Q2/(3P1Q2P2Q1**2)-
	- &256A2MB*2P1P2P2Q2/(3P1Q2P2Q1*2)-
	- &256A2MB*2P1Q1P2Q2/(3P1Q2P2Q1*2)+
	- &256A22MB*2P1Q2P2Q2/(3P2Q1*2)+272A1P2Q2/(3P2Q1)+
	- &112A2P2Q2/P2Q1-80A1A2MB2P2Q2/P2Q1+
	- &400A1A2MBMTP2Q2/(3P2Q1)-208A22MBMTP2Q2/(3*P2Q1)-
	- &272A1A2MT2P2Q2/(3P2Q1)-320A1A2P1P2*P2Q2/P2Q1+
	- &96A22P1P2P2Q2/P2Q1-32A1P1P2P2Q2/(3P1Q1P2Q1)-
	- &32A1A2MBMTP1P2P2Q2/(3P1Q1P2Q1)+
	- &32A1A2MT2P1P2P2Q2/(3P1Q1*P2Q1)+
	- &64A1A2P1P22P2Q2/(3P1Q1P2Q1)-944A1A2P1Q1P2Q2/(3*P2Q1)-
	- &32A22P1Q1P2Q2/P2Q1-256A1MBMT*3P2Q2/(3P1Q22P2Q1)+
	- &512A1MT*2P1P2P2Q2/(3P1Q2*2P2Q1)+
	- &256A1MT*2P1Q1P2Q2/(3P1Q2*2P2Q1)-8P2Q2/(3P1Q2*P2Q1)+
	- &200A1MBMTP2Q2/(3P1Q2P2Q1)+56A2MBMTP2Q2/(3P1Q2P2Q1)+
	- &272A1MT*2P2Q2/(3P1Q2P2Q1)+160A2MT*2P2Q2/(3P1Q2P2Q1)+
	- &256A1P1P2P2Q2/(3P1Q2P2Q1)+48A2P1P2P2Q2/(P1Q2*P2Q1)
	- A18=A18+256A1A2MBMTP1P2P2Q2/(P1Q2*P2Q1)-
	- &256A1A2MT2P1P2P2Q2/(3P1Q2*P2Q1)-
	- &1024A1A2P1P22P2Q2/(3P1Q2P2Q1)-
	- &32A1MT*2P1P2P2Q2/(3P1Q1P1Q2P2Q1)+
	- &96A1P1Q1P2Q2/(P1Q2P2Q1)+96A2P1Q1P2Q2/(P1Q2P2Q1)-
	- &128A1A2MB2P1Q1P2Q2/(3P1Q2*P2Q1)+
	- &256A1A2MBMTP1Q1P2Q2/(P1Q2*P2Q1)-
	- &128A1A2MT2P1Q1P2Q2/(3P1Q2*P2Q1)-
	- &512A1A2P1P2P1Q1P2Q2/(P1Q2P2Q1)-
	- &512A1A2P1Q12P2Q2/(3P1Q2P2Q1)-544A1A2P1Q2P2Q2/(3*P2Q1)-
	- &640A22P1Q2P2Q2/(3P2Q1)+
	- &64A1A2P1P2P1Q2P2Q2/(3P1Q1P2Q1)+544A1A2P2Q2*2/(3P2Q1)-
	- &256A1MT*2P2Q2*2/(3P1Q2*2P2Q1)-
	- &272A1P2Q2*2/(3P1Q2*P2Q1)-
	- &256A1A2MBMTP2Q22/(3P1Q2*P2Q1)+
	- &256A1A2MT2P2Q2*2/(3P1Q2*P2Q1)+
	- &512A1A2P1P2P2Q2*2/(3P1Q2*P2Q1)
	- A18=A18+512A1A2P1Q1P2Q2*2/(3P1Q2*P2Q1)-
	- &384A12MBMTP1Q12/S2+
	- &384A12P1P2P1Q12/S2-2688A12MBMTP1Q1P1Q2/S**2+
	- &2688A12P1P2P1Q1P1Q2/S*2-384A12MBMTP1Q22/S*2+
	- &384A12P1P2P1Q22/S2-768A1A2MBMTP1Q1P2Q1/S*2+
	- &768A1A2P1P2P1Q1P2Q1/S2-2688A1A2MBMTP1Q2P2Q1/S*2+
	- &2688A1A2P1P2P1Q2P2Q1/S2-960A12P1Q1P1Q2P2Q1/S*2-
	- &960A1A2P1Q1P1Q2P2Q1/S2+960A12P1Q22P2Q1/S**2+
	- &960A1A2P1Q22P2Q1/S*2-384A2*2MBMTP2Q12/S2+
	- &384A22P1P2P2Q12/S2-960A1A2P1Q2P2Q12/S*2-
	- &960A22P1Q2P2Q12/S2-2688A1A2MBMTP1Q1P2Q2/S*2+
	- &2688A1A2P1P2P1Q1P2Q2/S2+960A12P1Q12P2Q2/S**2+
	- &960A1A2P1Q12P2Q2/S*2-768A1A2MBMTP1Q2P2Q2/S*2+
	- &768A1A2P1P2P1Q2P2Q2/S2-960A12P1Q1P1Q2P2Q2/S*2-
	- &960A1A2P1Q1P1Q2P2Q2/S2-2688A2*2MBMTP2Q1P2Q2/S*2+
	- &2688A22P1P2P2Q1P2Q2/S*2+960A1A2P1Q1P2Q1P2Q2/S**2+
	- &960A22P1Q1P2Q1P2Q2/S*2+960A1A2P1Q2P2Q1P2Q2/S**2
	- A18=A18+960A22P1Q2P2Q1P2Q2/S**2-
	- &384A22MBMTP2Q22/S2+
	- &384A22P1P2P2Q22/S2-960A1A2P1Q1P2Q22/S*2-
	- &960A22P1Q1P2Q22/S2-96A1MBMT/S-96A2MB*MT/S+
	- &768A22MB*3MT/S+768A12MBMT3/S-192A1*P1P2/S-
	- &192A2P1P2/S-768A22MB*2P1P2/S+2304A1A2MBMT*P1P2/S-
	- &768A12MT*2P1P2/S-2304A1A2P1P2*2/S+
	- &96A1MBMT3/(P1Q1S)+192A2MBMTP1P2/(P1Q1*S)-
	- &96A1MT*2P1P2/(P1Q1S)-192A2P1P22/(P1Q1S)-192A1P1Q1/S-
	- &144A2P1Q1/S-384A1A2MB2P1Q1/S-480A22MB*2P1Q1/S+
	- &480A12MBMTP1Q1/S-96A1A2MBMT*P1Q1/S-
	- &864A12P1P2P1Q1/S-672A1A2P1P2P1Q1/S-96A1A2P1Q1**2/S+
	- &96A1MBMT3/(P1Q2S)+192A2MBMTP1P2/(P1Q2*S)-
	- &96A1MT*2P1P2/(P1Q2S)-192A2P1P22/(P1Q2S)+
	- &48A1MBMTP1Q1/(P1Q2S)-96A2MBMTP1Q1/(P1Q2S)-
	- &48A1MT*2P1Q1/(P1Q2S)-192A1P1P2P1Q1/(P1Q2*S)-
	- &192A2P1P2P1Q1/(P1Q2S)-192A1A2MBMTP1P2P1Q1/(P1Q2*S)
	- A18=A18+192A1A2P1P22P1Q1/(P1Q2S)-192A1P1Q12/(P1Q2S)-
	- &192A2P1Q1*2/(P1Q2S)+192A1A2MB2P1Q1*2/(P1Q2S)+
	- &192A12MBMTP1Q1*2/(P1Q2S)-96A1A2MBMTP1Q12/(P1Q2S)+
	- &192A1A2P1P2P1Q1*2/(P1Q2S)-192A1P1Q2/S-144A2P1Q2/S-
	- &384A1A2MB2P1Q2/S-480A22MB*2P1Q2/S+
	- &480A12MBMTP1Q2/S-96A1A2MBMT*P1Q2/S-
	- &864A12P1P2P1Q2/S-672A1A2P1P2*P1Q2/S+
	- &48A1MBMTP1Q2/(P1Q1S)-96A2MBMTP1Q2/(P1Q1S)-
	- &48A1MT*2P1Q2/(P1Q1S)-192A1P1P2P1Q2/(P1Q1*S)-
	- &192A2P1P2P1Q2/(P1Q1S)-192A1A2MBMTP1P2P1Q2/(P1Q1*S)+
	- &192A1A2P1P22P1Q2/(P1Q1S)-576A1A2P1Q1*P1Q2/S-
	- &96A1A2P1Q22/S-192A1P1Q22/(P1Q1S)-
	- &192A2P1Q2*2/(P1Q1S)+192A1A2MB2P1Q2*2/(P1Q1S)+
	- &192A12MBMTP1Q2*2/(P1Q1S)-96A1A2MBMTP1Q22/(P1Q1S)+
	- &192A1A2P1P2P1Q2*2/(P1Q1S)-96A2MB*3MT/(P2Q1*S)+
	- &96A2MB*2P1P2/(P2Q1S)-192A1MBMTP1P2/(P2Q1S)+
	- &192A1P1P2*2/(P2Q1S)+96A1MB*2P1Q1/(P2Q1*S)
	- A18=A18+192A2MB*2P1Q1/(P2Q1S)-96A1MBMTP1Q1/(P2Q1S)-
	- &192A1A2MB3MTP1Q1/(P2Q1S)+192A1P1P2P1Q1/(P2Q1S)+
	- &192A1A2MB2P1P2P1Q1/(P2Q1S)+
	- &96A1A2MB2P1Q1*2/(P2Q1S)-
	- &192A2MB*3MTP1Q1/(P1Q2P2Q1*S)+
	- &192A2MB*2P1P2P1Q1/(P1Q2P2Q1*S)-
	- &96A1MBMTP1P2P1Q1/(P1Q2P2Q1*S)+
	- &96A1P1P2*2P1Q1/(P1Q2P2Q1S)+
	- &96A1MB*2P1Q1*2/(P1Q2P2Q1*S)+
	- &192A2MB*2P1Q1*2/(P1Q2P2Q1*S)-
	- &48A1MBMTP1Q1*2/(P1Q2P2Q1*S)+
	- &96A1P1P2P1Q12/(P1Q2P2Q1S)+96A1MB2P1Q2/(P2Q1*S)+
	- &48A2MB*2P1Q2/(P2Q1S)+192A1A2MB*3MTP1Q2/(P2Q1S)-
	- &192A1A2MB2P1P2P1Q2/(P2Q1S)-
	- &96A1A2MB2P1Q2*2/(P2Q1S)+144A1P2Q1/S+192A2P2Q1/S+
	- &96A1A2MBMTP2Q1/S-480A2*2MBMTP2Q1/S+
	- &480A12MT*2P2Q1/S+384A1A2MT2P2Q1/S
	- A18=A18+672A1A2P1P2P2Q1/S+864A22P1P2*P2Q1/S-
	- &96A2MBMTP2Q1/(P1Q1S)+192A1MT2P2Q1/(P1Q1*S)+
	- &96A2MT*2P2Q1/(P1Q1S)-192A1A2MBMT3P2Q1/(P1Q1*S)+
	- &192A2P1P2P2Q1/(P1Q1S)+192A1A2MT2P1P2P2Q1/(P1Q1S)-
	- &192A12P1Q1P2Q1/S-192A2*2P1Q1*P2Q1/S+
	- &48A1MT*2P2Q1/(P1Q2S)+96A2MT2P2Q1/(P1Q2*S)+
	- &192A1A2MBMT*3P2Q1/(P1Q2*S)-
	- &192A1A2MT2P1P2P2Q1/(P1Q2S)+
	- &96A1A2MBMTP1Q1P2Q1/(P1Q2*S)-
	- &192A12MT*2P1Q1P2Q1/(P1Q2S)-
	- &96A1A2MT2P1Q1P2Q1/(P1Q2S)-
	- &384A1A2P1P2P1Q1P2Q1/(P1Q2S)-384A12P1Q1*2P2Q1/(P1Q2*S)-
	- &384A1A2P1Q12P2Q1/(P1Q2S)-480A12P1Q2P2Q1/S-
	- &960A1A2P1Q2P2Q1/S-480A22P1Q2*P2Q1/S+
	- &144A1P1Q2P2Q1/(P1Q1S)+96A2P1Q2P2Q1/(P1Q1S)+
	- &384A1A2MBMTP1Q2P2Q1/(P1Q1*S)-
	- &96A12MT*2P1Q2P2Q1/(P1Q1S)
	- A18=A18+96A1A2MT2P1Q2P2Q1/(P1Q1S)-
	- &576A1A2P1P2P1Q2P2Q1/(P1Q1S)-192A12P1Q2*2P2Q1/(P1Q1*S)-
	- &384A1A2P1Q22P2Q1/(P1Q1S)-96A1A2P2Q1**2/S-
	- &96A1A2MT2P2Q1*2/(P1Q1S)+96A1A2MT2P2Q1*2/(P1Q2S)+
	- &288A1A2P1Q2P2Q1*2/(P1Q1S)-96A2MB*3MT/(P2Q2*S)+
	- &96A2MB*2P1P2/(P2Q2S)-192A1MBMTP1P2/(P2Q2S)+
	- &192A1P1P2*2/(P2Q2S)+96A1MB*2P1Q1/(P2Q2*S)+
	- &48A2MB*2P1Q1/(P2Q2S)+192A1A2MB*3MTP1Q1/(P2Q2S)-
	- &192A1A2MB2P1P2P1Q1/(P2Q2S)-
	- &96A1A2MB2P1Q1*2/(P2Q2S)+96A1MB*2P1Q2/(P2Q2*S)+
	- &192A2MB*2P1Q2/(P2Q2S)-96A1MBMTP1Q2/(P2Q2S)-
	- &192A1A2MB3MTP1Q2/(P2Q2S)+192A1P1P2P1Q2/(P2Q2S)+
	- &192A1A2MB2P1P2P1Q2/(P2Q2S)-
	- &192A2MB*3MTP1Q2/(P1Q1P2Q2*S)+
	- &192A2MB*2P1P2P1Q2/(P1Q1P2Q2*S)-
	- &96A1MBMTP1P2P1Q2/(P1Q1P2Q2*S)+
	- &96A1P1P2*2P1Q2/(P1Q1P2Q2S)+96A1A2MB2P1Q2*2/(P2Q2S)
	- A18=A18+96A1MB*2P1Q2*2/(P1Q1P2Q2*S)+
	- &192A2MB*2P1Q2*2/(P1Q1P2Q2*S)-
	- &48A1MBMTP1Q2*2/(P1Q1P2Q2*S)+
	- &96A1P1P2P1Q22/(P1Q1P2Q2S)-48A2MB2P2Q1/(P2Q2*S)-
	- &96A1MBMTP2Q1/(P2Q2S)+48A2MBMTP2Q1/(P2Q2S)-
	- &192A1P1P2P2Q1/(P2Q2S)-192A2P1P2P2Q1/(P2Q2S)-
	- &192A1A2MBMTP1P2P2Q1/(P2Q2*S)+
	- &192A1A2P1P22P2Q1/(P2Q2*S)+
	- &192A1MBMT3P2Q1/(P1Q1P2Q2S)+
	- &96A2MBMTP1P2P2Q1/(P1Q1P2Q2*S)-
	- &192A1MT*2P1P2P2Q1/(P1Q1P2Q2*S)-
	- &96A2P1P2*2P2Q1/(P1Q1P2Q2S)+
	- &96A1A2MB2P1Q1P2Q1/(P2Q2S)+
	- &192A22MB*2P1Q1P2Q1/(P2Q2S)-
	- &96A1A2MBMTP1Q1P2Q1/(P2Q2*S)+
	- &384A1A2P1P2P1Q1P2Q1/(P2Q2S)-96A1P1Q2P2Q1/(P2Q2S)-
	- &144A2P1Q2P2Q1/(P2Q2S)-96A1A2MB2P1Q2P2Q1/(P2Q2S)
	- A18=A18+96A22MB*2P1Q2P2Q1/(P2Q2S)-
	- &384A1A2MBMTP1Q2P2Q1/(P2Q2*S)+
	- &576A1A2P1P2P1Q2P2Q1/(P2Q2S)-
	- &96A2MB*2P1Q2P2Q1/(P1Q1P2Q2*S)-
	- &48A1MBMTP1Q2P2Q1/(P1Q1P2Q2*S)-
	- &48A2MBMTP1Q2P2Q1/(P1Q1P2Q2*S)-
	- &96A1MT*2P1Q2P2Q1/(P1Q1P2Q2*S)-
	- &96A1P1P2P1Q2P2Q1/(P1Q1P2Q2S)-
	- &96A2P1P2P1Q2P2Q1/(P1Q1P2Q2S)+
	- &96A1A2P1Q1P1Q2P2Q1/(P2Q2S)+288A1A2P1Q22P2Q1/(P2Q2*S)-
	- &96A1P1Q2*2P2Q1/(P1Q1P2Q2S)-96A2P1Q2*2P2Q1/(P1Q1P2Q2S)+
	- &192A1P2Q1*2/(P2Q2S)+192A2P2Q1*2/(P2Q2S)+
	- &96A1A2MBMTP2Q12/(P2Q2S)-192A22MBMTP2Q1*2/(P2Q2S)-
	- &192A1A2MT2P2Q1*2/(P2Q2S)-192A1A2P1P2P2Q1*2/(P2Q2S)-
	- &48A2MBMTP2Q1*2/(P1Q1P2Q2*S)+
	- &192A1MT*2P2Q1*2/(P1Q1P2Q2*S)+
	- &96A2MT*2P2Q1*2/(P1Q1P2Q2*S)
	- A18=A18+96A2P1P2P2Q12/(P1Q1P2Q2*S)-
	- &384A1A2P1Q1P2Q1*2/(P2Q2S)-
	- &384A22P1Q1P2Q12/(P2Q2S)-384A1A2P1Q2P2Q1*2/(P2Q2S)-
	- &192A22P1Q2P2Q12/(P2Q2S)+96A1P1Q2P2Q12/(P1Q1P2Q2*S)+
	- &96A2P1Q2P2Q12/(P1Q1P2Q2S)+144A1P2Q2/S+192A2*P2Q2/S+
	- &96A1A2MBMTP2Q2/S-480A2*2MBMTP2Q2/S+
	- &480A12MT*2P2Q2/S+384A1A2MT2P2Q2/S+
	- &672A1A2P1P2P2Q2/S+864A22P1P2*P2Q2/S+
	- &48A1MT*2P2Q2/(P1Q1S)+96A2MT2P2Q2/(P1Q1*S)+
	- &192A1A2MBMT*3P2Q2/(P1Q1*S)-
	- &192A1A2MT2P1P2P2Q2/(P1Q1S)-480A12P1Q1*P2Q2/S-
	- &960A1A2P1Q1P2Q2/S-480A22P1Q1*P2Q2/S-
	- &96A2MBMTP2Q2/(P1Q2S)+192A1MT2P2Q2/(P1Q2*S)+
	- &96A2MT*2P2Q2/(P1Q2S)-192A1A2MBMT3P2Q2/(P1Q2*S)+
	- &192A2P1P2P2Q2/(P1Q2S)+192A1A2MT2P1P2P2Q2/(P1Q2S)+
	- &144A1P1Q1P2Q2/(P1Q2S)+96A2P1Q1P2Q2/(P1Q2S)+
	- &384A1A2MBMTP1Q1P2Q2/(P1Q2*S)
	- A18=A18-96A12MT*2P1Q1P2Q2/(P1Q2S)+
	- &96A1A2MT2P1Q1P2Q2/(P1Q2S)-
	- &576A1A2P1P2P1Q1P2Q2/(P1Q2S)-192A12P1Q1*2P2Q2/(P1Q2*S)-
	- &384A1A2P1Q12P2Q2/(P1Q2S)-192A12P1Q2P2Q2/S-
	- &192A22P1Q2P2Q2/S+96A1A2MBMTP1Q2P2Q2/(P1Q1S)-
	- &192A12MT*2P1Q2P2Q2/(P1Q1S)-
	- &96A1A2MT2P1Q2P2Q2/(P1Q1S)-
	- &384A1A2P1P2P1Q2P2Q2/(P1Q1S)-384A12P1Q2*2P2Q2/(P1Q1*S)-
	- &384A1A2P1Q22P2Q2/(P1Q1S)-48A2MB2P2Q2/(P2Q1*S)-
	- &96A1MBMTP2Q2/(P2Q1S)+48A2MBMTP2Q2/(P2Q1S)-
	- &192A1P1P2P2Q2/(P2Q1S)-192A2P1P2P2Q2/(P2Q1S)-
	- &192A1A2MBMTP1P2P2Q2/(P2Q1*S)+
	- &192A1A2P1P22P2Q2/(P2Q1S)-96A1P1Q1P2Q2/(P2Q1*S)-
	- &144A2P1Q1P2Q2/(P2Q1S)-96A1A2MB2P1Q1P2Q2/(P2Q1S)+
	- &96A22MB*2P1Q1P2Q2/(P2Q1S)-
	- &384A1A2MBMTP1Q1P2Q2/(P2Q1*S)+
	- &576A1A2P1P2P1Q1P2Q2/(P2Q1S)+288A1A2P1Q12P2Q2/(P2Q1*S)
	- A18=A18+192A1MBMT3P2Q2/(P1Q2P2Q1S)+
	- &96A2MBMTP1P2P2Q2/(P1Q2P2Q1*S)-
	- &192A1MT*2P1P2P2Q2/(P1Q2P2Q1*S)-
	- &96A2P1P2*2P2Q2/(P1Q2P2Q1S)-
	- &96A2MB*2P1Q1P2Q2/(P1Q2P2Q1*S)-
	- &48A1MBMTP1Q1P2Q2/(P1Q2P2Q1*S)-
	- &48A2MBMTP1Q1P2Q2/(P1Q2P2Q1*S)-
	- &96A1MT*2P1Q1P2Q2/(P1Q2P2Q1*S)-
	- &96A1P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	- &96A2P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	- &96A1P1Q1*2P2Q2/(P1Q2P2Q1S)-96A2P1Q1*2P2Q2/(P1Q2P2Q1S)+
	- &96A1A2MB2P1Q2P2Q2/(P2Q1S)+
	- &192A22MB*2P1Q2P2Q2/(P2Q1S)-
	- &96A1A2MBMTP1Q2P2Q2/(P2Q1*S)+
	- &384A1A2P1P2P1Q2P2Q2/(P2Q1S)+
	- &96A1A2P1Q1P1Q2P2Q2/(P2Q1S)-576A1A2P2Q1P2Q2/S+
	- &96A1A2P1Q1P2Q1P2Q2/(P1Q2S)+96A1A2P1Q2P2Q1P2Q2/(P1Q1S)
	- A18=A18-96A1A2P2Q22/S+96A1A2MT*2P2Q2*2/(P1Q1S)-
	- &96A1A2MT2P2Q2*2/(P1Q2S)+288A1A2P1Q1P2Q2*2/(P1Q2S)+
	- &192A1P2Q2*2/(P2Q1S)+192A2P2Q2*2/(P2Q1S)+
	- &96A1A2MBMTP2Q22/(P2Q1S)-192A22MBMTP2Q2*2/(P2Q1S)-
	- &192A1A2MT2P2Q2*2/(P2Q1S)-192A1A2P1P2P2Q2*2/(P2Q1S)-
	- &384A1A2P1Q1P2Q2*2/(P2Q1S)-192A22P1Q1P2Q22/(P2Q1S)-
	- &48A2MBMTP2Q2*2/(P1Q2P2Q1*S)+
	- &192A1MT*2P2Q2*2/(P1Q2P2Q1*S)+
	- &96A2MT*2P2Q2*2/(P1Q2P2Q1*S)+
	- &96A2P1P2P2Q22/(P1Q2P2Q1S)+96A1P1Q1P2Q2*2/(P1Q2P2Q1*S)+
	- &96A2P1Q1P2Q22/(P1Q2P2Q1S)-384A1A2P1Q2P2Q22/(P2Q1S)-
	- &384A22P1Q2P2Q22/(P2Q1S)+512A1A2*S/3-
	- &128A1MT*2S/(3P1Q12)+128A12MBMT*3S/(3P1Q1*2)-
	- &152A1S/(3P1Q1)-152A12MBMTS/(3P1Q1)-
	- &128A1A2MBMTS/(3P1Q1)+112A1A2MT2S/(3*P1Q1)-
	- &16A12P1P2S/P1Q1+152A1A2P1P2S/(3P1Q1)-
	- &128A1MT*2S/(3P1Q22)+128A12MBMT*3S/(3P1Q2*2)
	- A18=A18-152A1S/(3P1Q2)-152A12MBMTS/(3P1Q2)-
	- &128A1A2MBMTS/(3P1Q2)+112A1A2MT2S/(3*P1Q2)-
	- &16A12P1P2S/P1Q2+152A1A2P1P2S/(3P1Q2)+
	- &16A1MBMTS/(3P1Q1P1Q2)-32A12MBMT3S/(3P1Q1P1Q2)-
	- &16A1P1P2S/(3P1Q1P1Q2)+272A1A2P1Q1S/(3P1Q2)+
	- &272A1A2P1Q2S/(3P1Q1)-128A2MB2S/(3P2Q1*2)+
	- &128A22MB*3MTS/(3P2Q1**2)+
	- &32MB2MT*2S/(3P1Q22P2Q1*2)+32MB*2S/(3P1Q2P2Q1**2)
	-
	- A18BIS=
	- &64A2MB*3MTS/(3P1Q2P2Q1*2)-
	- &64A2MB*2MT*2S/(3P1Q2P2Q1**2)-
	- &128A2MB*2P1P2S/(3P1Q2P2Q1*2)-
	- &128A2MB*2P1Q1S/(3P1Q2P2Q1*2)+
	- &128A22MB*2P1Q2S/(3P2Q1*2)+152A2S/(3P2Q1)-
	- &112A1A2MB2S/(3P2Q1)+128A1A2MBMTS/(3*P2Q1)+
	- &152A22MBMTS/(3P2Q1)-152A1A2P1P2S/(3P2Q1)+
	- &16A22P1P2S/P2Q1-8A1A2MB*3MTS/(3P1Q1*P2Q1)+
	- &16A1A2MB2MT*2S/(3P1Q1P2Q1)-
	- &8A1A2MBMT*3S/(3P1Q1P2Q1)-8A1P1P2S/(3P1Q1*P2Q1)-
	- &8A2P1P2S/(3P1Q1P2Q1)+8A1A2MB*2P1P2S/(3P1Q1*P2Q1)-
	- &16A1A2MBMTP1P2S/(3P1Q1P2Q1)+
	- &8A1A2MT2P1P2S/(3P1Q1*P2Q1)+
	- &32A1A2P1P22S/(3P1Q1P2Q1)-32A22P1Q1S/(3P2Q1)-
	- &32MT2S/(3P1Q22P2Q1)+64A1MB*2MT*2S/(3P1Q22P2Q1)-
	- &64A1MBMT3S/(3P1Q22P2Q1)
	- A18BIS=A18BIS+128A1MT*2P1P2S/(3P1Q2*2P2Q1)-
	- &12S/(P1Q2P2Q1)+
	- &24A1MB*2S/(P1Q2P2Q1)+64A1A2MB*3MTS/(3P1Q2*P2Q1)+
	- &24A2MT*2S/(P1Q2P2Q1)-128A1A2MB*2MT*2S/(3P1Q2P2Q1)+
	- &64A1A2MBMT*3S/(3P1Q2P2Q1)+56A1P1P2S/(3P1Q2*P2Q1)+
	- &56A2P1P2S/(3P1Q2P2Q1)-64A1A2MB*2P1P2S/(3P1Q2*P2Q1)+
	- &128A1A2MBMTP1P2S/(3P1Q2P2Q1)-
	- &64A1A2MT2P1P2S/(3P1Q2*P2Q1)-
	- &256A1A2P1P22S/(3P1Q2P2Q1)+4P1P2S/(3P1Q1P1Q2*P2Q1)-
	- &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q1)-
	- &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q1)+136A2P1Q1S/(3P1Q2*P2Q1)-
	- &128A1A2MB2P1Q1S/(3P1Q2*P2Q1)+
	- &128A1A2MBMTP1Q1S/(3P1Q2P2Q1)-
	- &256A1A2P1P2P1Q1S/(3P1Q2P2Q1)-160A2*2P1Q2S/(3P2Q1)+
	- &16A1A2P1P2P1Q2S/(3P1Q1P2Q1)-32A12P2Q1S/(3*P1Q1)-
	- &128A12MT*2P2Q1S/(3P1Q2*2)-160A12P2Q1S/(3*P1Q2)-
	- &128A2MB*2S/(3P2Q22)+128A2*2MB*3MTS/(3P2Q2**2)
	- A18BIS=A18BIS+32MB2MT*2S/(3P1Q12P2Q2**2)+
	- &32MB2S/(3P1Q1P2Q2**2)+
	- &64A2MB*3MTS/(3P1Q1P2Q2*2)-
	- &64A2MB*2MT*2S/(3P1Q1P2Q2**2)-
	- &128A2MB*2P1P2S/(3P1Q1P2Q2*2)+
	- &128A22MB*2P1Q1S/(3P2Q2**2)-
	- &128A2MB*2P1Q2S/(3P1Q1P2Q22)+152A2S/(3P2Q2)-
	- &112A1A2MB2S/(3P2Q2)+128A1A2MBMTS/(3*P2Q2)+
	- &152A22MBMTS/(3P2Q2)-152A1A2P1P2S/(3P2Q2)+
	- &16A22P1P2S/P2Q2-32MT*2S/(3P1Q12P2Q2)+
	- &64A1MB*2MT*2S/(3P1Q12P2Q2)-
	- &64A1MBMT3S/(3P1Q12P2Q2)+
	- &128A1MT*2P1P2S/(3P1Q1*2P2Q2)-12S/(P1Q1P2Q2)+
	- &24A1MB*2S/(P1Q1P2Q2)+64A1A2MB*3MTS/(3P1Q1*P2Q2)+
	- &24A2MT*2S/(P1Q1P2Q2)-128A1A2MB*2MT*2S/(3P1Q1P2Q2)+
	- &64A1A2MBMT*3S/(3P1Q1P2Q2)+56A1P1P2S/(3P1Q1*P2Q2)+
	- &56A2P1P2S/(3P1Q1P2Q2)-64A1A2MB*2P1P2S/(3P1Q1*P2Q2)
	- A18BIS=A18BIS+128A1A2MBMTP1P2S/(3P1Q1P2Q2)-
	- &64A1A2MT2P1P2S/(3P1Q1*P2Q2)-
	- &256A1A2P1P22S/(3P1Q1P2Q2)-160A22P1Q1S/(3P2Q2)-
	- &8A1A2MB3MTS/(3P1Q2*P2Q2)+
	- &16A1A2MB2MT*2S/(3P1Q2P2Q2)-
	- &8A1A2MBMT*3S/(3P1Q2P2Q2)-8A1P1P2S/(3P1Q2*P2Q2)-
	- &8A2P1P2S/(3P1Q2P2Q2)+8A1A2MB*2P1P2S/(3P1Q2*P2Q2)-
	- &16A1A2MBMTP1P2S/(3P1Q2P2Q2)+
	- &8A1A2MT2P1P2S/(3P1Q2*P2Q2)+
	- &32A1A2P1P22S/(3P1Q2P2Q2)+4P1P2S/(3P1Q1P1Q2*P2Q2)-
	- &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q2)-
	- &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q2)+
	- &16A1A2P1P2P1Q1S/(3P1Q2P2Q2)-32A2*2P1Q2S/(3P2Q2)+
	- &136A2P1Q2S/(3P1Q1P2Q2)-128A1A2MB*2P1Q2S/(3P1Q1*P2Q2)+
	- &128A1A2MBMTP1Q2S/(3P1Q1P2Q2)-
	- &256A1A2P1P2P1Q2S/(3P1Q1P2Q2)+16A2MBMTS/(3P2Q1*P2Q2)-
	- &32A22MB*3MTS/(3P2Q1P2Q2)-16A2P1P2S/(3P2Q1P2Q2)
	- A18BIS=A18BIS-4P1P2S/(3P1Q1P2Q1*P2Q2)+
	- &8A2MB*2P1P2S/(3P1Q1P2Q1P2Q2)+
	- &8A2MBMTP1P2S/(3P1Q1P2Q1P2Q2)-4P1P2S/(3P1Q2P2Q1*P2Q2)+
	- &8A2MB*2P1P2S/(3P1Q2P2Q1P2Q2)+
	- &8A2MBMTP1P2S/(3P1Q2P2Q1P2Q2)-
	- &2MB3MTS/(3P1Q1P1Q2P2Q1*P2Q2)+
	- &4MB2MT*2S/(3P1Q1P1Q2P2Q1P2Q2)-
	- &2MBMT*3S/(3P1Q1P1Q2P2Q1P2Q2)-
	- &2MB2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)+
	- &4MBMTP1P2S/(3P1Q1P1Q2P2Q1P2Q2)-
	- &2MT2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)-
	- &8P1P22S/(3P1Q1P1Q2P2Q1P2Q2)+
	- &8A2P1P2P1Q1S/(3P1Q2P2Q1*P2Q2)+
	- &8A2P1P2P1Q2S/(3P1Q1P2Q1P2Q2)+272A1A2P2Q1S/(3P2Q2)-
	- &128A1MT*2P2Q1S/(3P1Q1*2P2Q2)-136A1P2Q1S/(3P1Q1*P2Q2)-
	- &128A1A2MBMTP2Q1S/(3P1Q1P2Q2)+
	- &128A1A2MT2P2Q1S/(3P1Q1*P2Q2)
	- A18BIS=A18BIS+256A1A2P1P2P2Q1S/(3P1Q1*P2Q2)-
	- &16A1A2P1P2P2Q1S/(3P1Q2*P2Q2)+
	- &8A1P1P2P2Q1S/(3P1Q1P1Q2*P2Q2)+
	- &256A1A2P1Q2P2Q1S/(3P1Q1*P2Q2)-
	- &128A12MT*2P2Q2S/(3P1Q1*2)-160A12P2Q2S/(3*P1Q1)-
	- &32A12P2Q2S/(3P1Q2)+272A1A2P2Q2S/(3*P2Q1)-
	- &16A1A2P1P2P2Q2S/(3P1Q1*P2Q1)-
	- &128A1MT*2P2Q2S/(3P1Q2*2P2Q1)-136A1P2Q2S/(3P1Q2*P2Q1)-
	- &128A1A2MBMTP2Q2S/(3P1Q2P2Q1)+
	- &128A1A2MT2P2Q2S/(3P1Q2*P2Q1)+
	- &256A1A2P1P2P2Q2S/(3P1Q2*P2Q1)+
	- &8A1P1P2P2Q2S/(3P1Q1P1Q2*P2Q1)+
	- &256A1A2P1Q1P2Q2S/(3P1Q2*P2Q1)-
	- &8A12MBMTS*2/(3P1Q1P1Q2)+16A12P1P2S*2/(3P1Q1*P1Q2)-
	- &8A1A2P1P2S*2/(3P1Q1P2Q1)+4A1P1P2S*2/(3P1Q1P1Q2P2Q1)-
	- &8A1A2P1P2S*2/(3P1Q2P2Q2)+4A1P1P2S*2/(3P1Q1P1Q2P2Q2)-
	- &8A22MBMTS*2/(3P2Q1P2Q2)+16A2*2P1P2S2/(3P2Q1*P2Q2)
	- A18BIS=A18BIS-4A2P1P2S2/(3P1Q1P2Q1P2Q2)-
	- &4A2P1P2S2/(3P1Q2P2Q1P2Q2)+
	- &2P1P2S*2/(3P1Q1P1Q2P2Q1*P2Q2)
	-C
	- V18=V18+V18BIS
	- A18=A18+A18BIS
	- V910 =-48A12MBMT-48A2*2MBMT-48A12P1P2-48A2*2P1P2-
	- &384A12MBMTP1Q1P1Q2/S2-384A12P1P2P1Q1P1Q2/S*2-
	- &384A1A2MBMTP1Q2P2Q1/S*2-384A1A2P1P2P1Q2P2Q1/S**2+
	- &192A12P1Q1P1Q2P2Q1/S*2+192A1A2P1Q1P1Q2P2Q1/S**2-
	- &192A12P1Q2*2P2Q1/S*2-192A1A2P1Q2*2P2Q1/S**2+
	- &192A1A2P1Q2P2Q12/S2+192A22P1Q2P2Q12/S*2-
	- &384A1A2MBMTP1Q1P2Q2/S*2-384A1A2P1P2P1Q1P2Q2/S**2-
	- &192A12P1Q1*2P2Q2/S*2-192A1A2P1Q1*2P2Q2/S**2+
	- &192A12P1Q1P1Q2P2Q2/S*2+192A1A2P1Q1P1Q2P2Q2/S**2-
	- &384A22MBMTP2Q1P2Q2/S2-384A2*2P1P2P2Q1P2Q2/S**2-
	- &192A1A2P1Q1P2Q1P2Q2/S2-192A2*2P1Q1P2Q1P2Q2/S**2-
	- &192A1A2P1Q2P2Q1P2Q2/S2-192A2*2P1Q2P2Q1P2Q2/S**2+
	- &192A1A2P1Q1P2Q22/S2+192A22P1Q1P2Q22/S*2+
	- &96A12MBMTP1Q1/S-96A1A2MBMT*P1Q1/S+
	- &96A12P1P2P1Q1/S-96A1A2P1P2P1Q1/S+96A12MBMT*P1Q2/S-
	- &96A1A2MBMTP1Q2/S+96A12P1P2P1Q2/S-96A1A2P1P2P1Q2/S+
	- &96A1A2MBMTP2Q1/S-96A2*2MBMTP2Q1/S
	- V910=V910+96A1A2P1P2P2Q1/S-
	- &96A22P1P2P2Q1/S+96A12P1Q2P2Q1/S+
	- &192A1A2P1Q2P2Q1/S+96A22P1Q2*P2Q1/S+
	- &96A1A2MBMTP2Q2/S-96A2*2MBMTP2Q2/S+
	- &96A1A2P1P2P2Q2/S-96A22P1P2P2Q2/S+96A12P1Q1P2Q2/S+
	- &192A1A2P1Q1P2Q2/S+96A22P1Q1*P2Q2/S
	-C
	- A910 = 48A12MBMT+48A2*2MBMT-48A12P1P2-48A2*2P1P2+
	- &384A12MBMTP1Q1P1Q2/S2-384A12P1P2P1Q1P1Q2/S*2+
	- &384A1A2MBMTP1Q2P2Q1/S*2-384A1A2P1P2P1Q2P2Q1/S**2+
	- &192A12P1Q1P1Q2P2Q1/S*2+192A1A2P1Q1P1Q2P2Q1/S**2-
	- &192A12P1Q2*2P2Q1/S*2-192A1A2P1Q2*2P2Q1/S**2+
	- &192A1A2P1Q2P2Q12/S2+192A22P1Q2P2Q12/S*2+
	- &384A1A2MBMTP1Q1P2Q2/S*2-384A1A2P1P2P1Q1P2Q2/S**2-
	- &192A12P1Q1*2P2Q2/S*2-192A1A2P1Q1*2P2Q2/S**2+
	- &192A12P1Q1P1Q2P2Q2/S*2+192A1A2P1Q1P1Q2P2Q2/S**2+
	- &384A22MBMTP2Q1P2Q2/S2-384A2*2P1P2P2Q1P2Q2/S**2-
	- &192A1A2P1Q1P2Q1P2Q2/S2-192A2*2P1Q1P2Q1P2Q2/S**2-
	- &192A1A2P1Q2P2Q1P2Q2/S2-192A2*2P1Q2P2Q1P2Q2/S**2+
	- &192A1A2P1Q1P2Q22/S2+192A22P1Q1P2Q22/S*2-
	- &96A12MBMTP1Q1/S+96A1A2MBMT*P1Q1/S+
	- &96A12P1P2P1Q1/S-96A1A2P1P2P1Q1/S-96A12MBMT*P1Q2/S+
	- &96A1A2MBMTP1Q2/S+96A12P1P2P1Q2/S-96A1A2P1P2P1Q2/S-
	- &96A1A2MBMTP2Q1/S+96A2*2MBMTP2Q1/S
	- A910=A910+96A1A2P1P2P2Q1/S-
	- &96A22P1P2P2Q1/S+96A12P1Q2P2Q1/S+
	- &192A1A2P1Q2P2Q1/S+96A22P1Q2*P2Q1/S-
	- &96A1A2MBMTP2Q2/S+96A2*2MBMTP2Q2/S+
	- &96A1A2P1P2P2Q2/S-96A22P1P2P2Q2/S+96A12P1Q1P2Q2/S+
	- &192A1A2P1Q1P2Q2/S+96A22P1Q1*P2Q2/S
	-C
	-C FINAL RESULT;
	-C
	- AMP2= FACTPSVTB*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.D03.D0 2.D0*2.D0)
	-C COUPLING CONSTANT (OVERALL NORMALIZATION)
	- FACT=(4.D0PIALPHA)(4.D0PIALPHAS)*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)GFSW2MW*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 -2P1Q1 -2P1Q2
	- A1 =A1INV/(A1INV*2+ (GAMTMT)**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+ (GAMTMT)**2)
	- A2 =1.D0/(S +2P2Q1 +2P2Q2)
	-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) = -16A2A2*2MB*MT+
	- &64A2A2*2P1Q2P2Q12/S*2+
	- &128A2A2*2MBMTP2Q1P2Q2/S*2-
	- &128A2A2*2P1P2P2Q1P2Q2/S**2-
	- &64A2A2*2P1Q1P2Q1P2Q2/S**2-
	- &64A2A2*2P1Q2P2Q1P2Q2/S**2+
	- &64A2A2*2P1Q1P2Q22/S*2-
	- &32A2A2*2MB*3MT/S+32A2A2*2MB*2P1P2/S+
	- &32A2A2*2MB*2P1Q1/S+32A2A2*2MB*2P1Q2/S-
	- &32A2A2*2P1P2P2Q1/S-32A*2A2*2P1Q1*P2Q1/S-
	- &32A2A2*2P1P2P2Q2/S-32A*2A2*2P1Q2*P2Q2/S+
	- &16A22MBMTV*2+64A2*2P1Q2P2Q12V2/S2-
	- &128A22MBMTP2Q1P2Q2V2/S2-
	- &128A22P1P2P2Q1P2Q2V2/S*2-
	- &64A22P1Q1P2Q1P2Q2V2/S*2-
	- &64A22P1Q2P2Q1P2Q2V2/S*2+
	- &64A22P1Q1P2Q22V2/S2
	- YY(1, 1)=YY(1, 1)+32A22MB*3MTV*2/S+
	- &32A22MB*2P1P2V*2/S+
	- &32A22MB*2P1Q1V2/S+32A2*2MB*2P1Q2V*2/S-
	- &32A22P1P2P2Q1V*2/S-32A2*2P1Q1P2Q1V**2/S-
	- &32A22P1P2P2Q2V*2/S-32A2*2P1Q2P2Q2V**2/S
	- YY(1, 1)=2*YY(1, 1)
	-
	- YY(1, 2) = -32A2A1A2MB*MT+
	- &128A2A1A2MBMTP1Q2P2Q1/S*2-
	- &128A2A1A2P1P2P1Q2P2Q1/S**2+
	- &64A2A1A2P1Q1P1Q2P2Q1/S**2-
	- &64A2A1A2P1Q2*2P2Q1/S**2+
	- &64A2A1A2P1Q2P2Q12/S*2+
	- &128A2A1A2MBMTP1Q1P2Q2/S*2-
	- &128A2A1A2P1P2P1Q1P2Q2/S**2-
	- &64A2A1A2P1Q1*2P2Q2/S**2+
	- &64A2A1A2P1Q1P1Q2P2Q2/S**2-
	- &64A2A1A2P1Q1P2Q1P2Q2/S**2-
	- &64A2A1A2P1Q2P2Q1P2Q2/S**2+
	- &64A2A1A2P1Q1P2Q22/S*2-
	- &64A2A1A2MBMTP1P2/S+
	- &64A2A1A2P1P2*2/S+32A*2A1A2MB*2P1Q1/S+
	- &32A2A1A2P1P2P1Q1/S+32A*2A1A2MB*2P1Q2/S+
	- &32A2A1A2P1P2P1Q2/S-32A*2A1A2MT*2P2Q1/S
	- YY(1, 2)=YY(1, 2)-32A2A1A2P1P2*P2Q1/S-
	- &64A2A1A2P1Q1*P2Q1/S-
	- &32A2A1A2MT*2P2Q2/S-32A2A1A2P1P2*P2Q2/S-
	- &64A2A1A2P1Q2P2Q2/S+32A1A2MBMTV**2-
	- &128A1A2MBMTP1Q2P2Q1V2/S*2 -
	- &128A1A2P1P2P1Q2P2Q1V2/S2+
	- &64A1A2P1Q1P1Q2P2Q1V2/S2-
	- &64A1A2P1Q22P2Q1V2/S*2+
	- &64A1A2P1Q2P2Q1*2V2/S2-
	- &128A1A2MBMTP1Q1P2Q2V2/S*2-
	- &128A1A2P1P2P1Q1P2Q2V2/S2-
	- &64A1A2P1Q12P2Q2V2/S*2+
	- &64A1A2P1Q1P1Q2P2Q2V2/S2-
	- &64A1A2P1Q1P2Q1P2Q2V2/S2-
	- &64A1A2P1Q2P2Q1P2Q2V2/S2+
	- &64A1A2P1Q1P2Q2*2V2/S2+
	- &64A1A2MBMTP1P2V*2/S+64A1A2P1P2*2V**2/S
	- YY(1, 2)=YY(1, 2)+32A1A2MB2P1Q1V*2/S+
	- &32A1A2P1P2P1Q1V*2/S+
	- &32A1A2MB2P1Q2V2/S+32A1A2P1P2P1Q2V**2/S-
	- &32A1A2MT2P2Q1V2/S-32A1A2P1P2P2Q1V**2/S-
	- &64A1A2P1Q1P2Q1V2/S-32A1A2MT*2P2Q2V*2/S-
	- &32A1A2P1P2P2Q2V2/S-64A1A2P1Q2P2Q2V**2/S
	-
	-
	- YY(2, 2) =-16A2A12MBMT+
	- &128A2A12MBMTP1Q1P1Q2/S**2-
	- &128A2A12P1P2P1Q1P1Q2/S*2+
	- &64A2A12P1Q1P1Q2P2Q1/S*2-
	- &64A2A12P1Q22P2Q1/S*2-64A*2A12P1Q12P2Q2/S**2+
	- &64A2A12P1Q1P1Q2P2Q2/S2-32A*2A12MBMT**3/S+
	- &32A2A12MT2P1P2/S+32A2A12P1P2P1Q1/S+
	- &32A2A12P1P2P1Q2/S-32A2A12MT2P2Q1/S-
	- &32A2A12P1Q1P2Q1/S-32A2A12MT2P2Q2/S-
	- &32A2A12P1Q2P2Q2/S+16A12MBMTV**2-
	- &128A12MBMTP1Q1P1Q2V2/S2-
	- &128A12P1P2P1Q1P1Q2V2/S*2+
	- &64A12P1Q1P1Q2P2Q1V2/S*2-
	- &64A12P1Q2*2P2Q1V2/S2-64A12P1Q12P2Q2V2/S*2+
	- &64A12P1Q1P1Q2P2Q2V2/S2+32A12MBMT*3V**2/S+
	- &32A12MT*2P1P2V2/S+32A12P1P2P1Q1V*2/S+
	- &32A12P1P2P1Q2V*2/S-32A12MT2P2Q1V*2/S
	- YY(2, 2)=YY(2, 2)-32A12P1Q1P2Q1V**2/S-
	- &32A12MT*2P2Q2V*2/S-
	- &32A12P1Q2P2Q2V**2/S
	- YY(2, 2)=2*YY(2, 2)
	-
	- RES=YY(1,1)+2*YY(1,2)+YY(2,2)
	- AMP2= FACTPSVTB*2RES
	-
	- 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-(2D0XMW2+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+(4D0XMW2-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)2ABS(COS(2D0BETA))
	- 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=RDY-4D0/33D0(1D0-R)DX+(1D0-R)/33D0DS
	- 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+2D0DX/3D0+2D0DS/3D0
	- DHD2=-DY/2D0-2D0*DX/3D0+DS
	- DMU2=(-DY/2D0-2D0/3D0DX+(COSB2-2D0SINB*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)=SGNMUSQRT(RMSS(4)*2+DMU2)
	- ARG=RMSS(10)*2SIGN(1D0,RMSS(10))+DQ2
	- RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
	- ARG=RMSS(11)*2SIGN(1D0,RMSS(11))+DD2
	- RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
	- ARG=RMSS(12)*2SIGN(1D0,RMSS(12))+DU2
	- RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
	- ARG=RMSS(13)*2SIGN(1D0,RMSS(13))+DL2
	- RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
	- ARG=RMSS(14)*2SIGN(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=COSB2-SINB2
	-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(2D0AL)COS(BE+AL)-2D0SIN(2D0AL)*SIN(BE+AL)
	- ELSE
	- HHH(3)=HHH(3)+HHH(4)+HHH(5)
	- PARU(176)=-3D0/HHH(1)(HHH(1)SINA*2COSB*COSA+
	- 1 HHH(2)COSA2SINBSINA+HHH(3)(SINA*3SINB+COSA*3COSB-
	- 2 2D0/3D0CBMA)-HHH(6)SINA(COSBC2A+COSA*CAPB)+
	- 3 HHH(7)COSA(SINBC2A+SINACAPB))
	- ENDIF
	-C...Coupling to H+
	-C...Define later
	- IF(IMSS(4).GE.2) THEN
	- PARU(168)=-SBMA-COS(2D0BE)SAPB/2D0/(1D0-XW)
	- ELSE
	- PARU(168)=1D0/HHH(1)(HHH(1)SINB*2COSB*SINA-
	- 1 HHH(2)COSB2SINBCOSA-HHH(3)(SINB*3COSA-COSB*3SINA)+
	- 2 2D0HHH(5)SBMA-HHH(6)SINB(COSBSAPB+SINAC2B)-
	- 3 HHH(7)COSB(COSAC2B-SINBSAPB)-(HHH(5)-HHH(4))*SBMA)
	- ENDIF
	-C...Coupling to A
	- IF(IMSS(4).GE.2) THEN
	- PARU(177)=COS(2D0BE)COS(BE+AL)
	- ELSE
	- PARU(177)=-1D0/HHH(1)(HHH(1)SINB*2COSB*COSA+
	- 1 HHH(2)COSB2SINBSINA+HHH(3)(SINB*3SINA+COSB*3COSA)-
	- 2 2D0HHH(5)CBMA-HHH(6)SINB(COSBCAPB+COSAC2B)+
	- 3 HHH(7)COSB(SINBCAPB+SINAC2B))
	- 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+2IRI,1)PMAS(9+2IRJ,1)
	- & PMAS(9+2IRK,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+2IRI,1)0.5D0(PMAS(2IRJ,1)+
	- & PMAS(2IRJ-1,1))PMAS(2IRK-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(2IRI,1)PMAS(2IRJ-1,1)*
	- & PMAS(2IRK-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 CPRO12,CVER12,CHNLIN*6
	- CHARACTER DOC11, CHDUM120, CHBLCK*60
	- CHARACTER CHINL120,CHKF9,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
	-C DATA NQNUM /0/ C Change by WHIZARD due to nagfor error
	- 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
	-C... Also store gravitino mass in RMSS(21), translated to eV unit
	- IF (KF.EQ.1000039) RMSS(21) = 1D9 * 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
	-C MDME(NDC,1)=1
	- IF(MDME(NDC,1).LT.0.AND.MDME(NDC,1).GE.-5) THEN
	- MDME(NDC,1)=-MDME(NDC,1)
	- ELSE
	- MDME(NDC,1)=1
	- ENDIF
	-
	-C...Switch off decay channels with < 0 branching fraction
	- IF (BRAT(NDC).LE.0D0) THEN
	- MDME(NDC,1)=0
	-C...Else check if decays to gravitinos should be switched on
	- ELSE
	- DO 345 IDA=1,NDA
	- IF (IDC(IDA).EQ.1000039) THEN
	-C... Inform user
	- IF (IMSS(11).LE.0) WRITE(MSTU(11),*)
	- & '* (PYSLHA:) Switching on decays to gravitinos'
	- IMSS(11) = 2
	- ENDIF
	- 345 CONTINUE
	- ENDIF
	-
	-C...Store decay products ordered in decreasing ABS(KF)
	- 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=XMZ2COS(2D0BETA)
	- XMER=SQRT(XM02+0.15D0XMG2-XWDTERM)
	- XMEL=SQRT(XM02+0.52D0XMG2-(0.5D0-XW)DTERM)
	- RMSS(6)=XMEL
	- RMSS(7)=XMER
	- XMUR=SQRT(PYRNMQ(2,2D0/3D0XWDTERM))
	- XMDR=SQRT(PYRNMQ(3,-1D0/3D0XWDTERM))
	- XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0XW)DTERM))
	- XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0XW)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-XMW2ABS(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(.9D0XM02+2.1D0XMG2+
	- &(1D0-(RMT/190D0/SINB)*3)(.24D0AT2+ATXMG))
	- RMB=PYMRUN(5,PMAS(6,1)**2)
	- XBOT=(RMB/150D0/COSB)*2(.9D0XM02+2.1D0XMG2+
	- &(1D0-(RMB/190D0/COSB)*3)(.24D0AT2+ATXMG))
	- XTAU=1D-4/COSB*2(XM02+0.15D0XMG2+AT*2/3D0)
	- ATP=AT(1D0-(RMT/190D0/SINB)2)+XMG(3.47D0-1.9D0*(RMT/190D0/
	- &SINB)**2)
	- RMSS(16)=-ATP
	- XMU2=-.5D0XMZ2+(SINB2(XM02+.52D0*XMG2-XTOP)-
	- &COSB*2(XM02+.52D0XMG2-XBOT-XTAU/3D0))/(COSB2-SINB*2)
	- XMA2=2D0(XM02+.52D0XMG2+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.15D0XMG2-2D0XTAU/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.52D0XMG2-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=M0MHFXCMGV/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.5D0BX)
	- CX=MAX(2000D0*2,2D0BX)
	-
	- 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=RX1+CX3
	- 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=RX2+CX0
	- 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=CTT2XM12+STT2XM22
	- XMQR2=STT2XM12+CTT2XM22
	- XMF2=PYMRUN(6,PMAS(6,1)2)2
	- ATOP=-XMU/TANB+CTTSTT(XM12-XM22)/SQRT(XMF2)
	- RMSS(16)=ATOP
	-C......SUBTRACT OUT D-TERM AND FERMION MASS
	- XMQL2=XMQL2-XMF2-(4D0XMW2-XMZ2)COS2B/6D0
	- XMQR2=XMQR2-XMF2+(XMW2-XMZ2)COS2B2D0/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))-(2D0XMW2+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=STT2XM12+CTT2XM22
	- ABOT=-XMUTANB+CTTSTT*(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=CTT2XM12+STT2XM22
	- XMQR2=STT2XM12+CTT2XM22
	- XMFR=PMAS(15,1)
	- XMF2=XMFR**2
	- ATAU=-XMUTANB+CTTSTT*(XM12-XM22)/SQRT(XMF2)
	- RMSS(17)=ATAU
	-C......SUBTRACT OUT D-TERM AND FERMION MASS
	- XMQL2=XMQL2-XMF2+(-.5D0XMZ2+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)-(2D0XMW2+XMZ2)COS2B/6D0
	- AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
	- AM2(1,2)=XMF(ATR+XMUTANB)
	- ELSEIF(L.EQ.2) THEN
	- AM2(1,1)=AM2(1,1)+(4D0XMW2-XMZ2)COS2B/6D0
	- AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)COS2B2D0/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)-(-.5D0XMZ2+XMW2)COS2B
	- AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
	- AM2(1,2)=XMF(ATR+XMUTANB)
	- 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.5D0SQRT((AM2(1,1)-AM2(2,2))2+4D0AM2(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)A15D0/3D0
	- IF(IOPT.EQ.1) THEN
	- XM2=XM1A2/A13D0/5D0
	- RMSS(2)=XM2
	- ELSEIF(IOPT.EQ.3) THEN
	- XM1=XM25D0/3D0A1/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(ILRKSUSY1+I),1)2/XM3*2
	- AQ=AQ+0.5D0((2D0-RM1)(RM1*LOG(RM1)-1D0)
	- & +(1D0-RM1)*2LOG(ABS(1D0-RM1)))
	- 100 CONTINUE
	- 110 CONTINUE
	-
	- DO 130 I=5,6
	- DO 120 ILR=1,2
	- RM1=PMAS(PYCOMP(ILRKSUSY1+I),1)2/XM3*2
	- RM2=PMAS(I,1)2/XM32
	- ARG=(RM1-RM2-1D0)*2-4D0RM2**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.5D0LOG(ABS(1D0-X0))(1D0-X0**2)+
	- & 0.5D0X02LOG(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.5D0LOG(ABS(1D0-X1))(1D0-X1*2)+0.5D0
	- & X1*2LOG(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(X02+Y02)
	- AM1X0=SQRT((1D0-X0)2+Y02)
	- 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.5D0LOG(AM1X0)(1D0-X0*2+3D0Y0**2)
	- & +0.5D0(X02-Y02)LOG(AMGX0)
	- BT=(-1D0-2D0X0)/4D0+X0Y0*( AR1X0-ARGX0 )
	- AT=AT+0.5D0LOG(AM1X1)(1D0-X1*2+3D0Y1**2)
	- & +0.5D0(X12-Y12)LOG(AMGX1)
	- BT=BT+(-1D0-2D0X1)/4D0+X1Y1*( AR1X1-ARGX1 )
	- AQ=AQ+AT+BT
	- ENDIF
	- 120 CONTINUE
	- 130 CONTINUE
	- PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)(1D0+PYALPS(XM3*2)
	- & /(2D0PARU(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) = -XMZSINWCOSB
	- AR(3,1) = AR(1,3)
	- AR(1,4) = XMZSINWSINB
	- AR(4,1) = AR(1,4)
	- AR(2,3) = XMZCOSWCOSB
	- AR(3,2) = AR(2,3)
	- AR(2,4) = -XMZCOSWSINB
	- 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+2D0XMW*2SINB**2
	- AR(2,2) = XMU*2+2D0XMW*2COSB**2
	- AR(1,2) = SQRT(2D0)XMW(XM2COS(RMSS(31))COSB+
	- &XMUCOS(RMSS(33))SINB)
	- AI(1,2) = SQRT(2D0)XMW(XM2SIN(RMSS(31))COSB-
	- &XMUSIN(RMSS(33))SINB)
	- AR(2,1) = SQRT(2D0)XMW(XM2COS(RMSS(31))COSB+
	- &XMUCOS(RMSS(33))SINB)
	- AI(2,1) = SQRT(2D0)XMW(-XM2SIN(RMSS(31))COSB+
	- &XMUSIN(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+2D0XMW*2COSB**2
	- AR(2,2) = XMU*2+2D0XMW*2SINB**2
	- AR(1,2) = SQRT(2D0)XMW(XM2COS(RMSS(31))SINB+
	- &XMUCOS(RMSS(33))COSB)
	- AI(1,2) = SQRT(2D0)XMW(-XM2SIN(RMSS(31))SINB+
	- &XMUSIN(RMSS(33))COSB)
	- AR(2,1) = SQRT(2D0)XMW(XM2COS(RMSS(31))SINB+
	- &XMUCOS(RMSS(33))COSB)
	- AI(2,1) = SQRT(2D0)XMW(XM2SIN(RMSS(31))SINB-
	- &XMUSIN(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)XMWSINB
	- AR(2,1) = SQRT(2D0)XMWCOSB
	- 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)XMWSINB*CMPLX(1D0,0D0)
	- CAR(2,1) = SQRT(2D0)XMWCOSB*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)=TEMPRDBLE(CA1)-TEMPIDIMAG(CA1)
	- VMIXI(1,1)=TEMPIDBLE(CA1)+TEMPRDIMAG(CA1)
	- TEMPR=VMIX(1,2)
	- TEMPI=VMIXI(1,2)
	- VMIX(1,2)=TEMPRDBLE(CA1)-TEMPIDIMAG(CA1)
	- VMIXI(1,2)=TEMPIDBLE(CA1)+TEMPRDIMAG(CA1)
	- TEMPR=VMIX(2,1)
	- TEMPI=VMIXI(2,1)
	- VMIX(2,1)=TEMPRDBLE(CA2)-TEMPIDIMAG(CA2)
	- VMIXI(2,1)=TEMPIDBLE(CA2)+TEMPRDIMAG(CA2)
	- TEMPR=VMIX(2,2)
	- TEMPI=VMIXI(2,2)
	- VMIX(2,2)=TEMPRDBLE(CA2)-TEMPIDIMAG(CA2)
	- VMIXI(2,2)=TEMPIDBLE(CA2)+TEMPRDIMAG(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(DIMAG(CA1)).GT.1D-3.OR.ABS(DIMAG(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=RGUTPYALPS(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=RX1+CX3
	- F1=F2
	- AS2=PYALPS(X2**2)
	- F2=ABS(X2-RGUT*AS2)
	- ELSE
	- X3=X2
	- X2=X1
	- X1=RX2+CX0
	- 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=B1B3-4D0B0
	- C0=-B1*2-B0B3*2+4D0B0*B2
	- CQ=C1/3D0-C2**2/9D0
	- CR=C1C2/6D0-C0/2D0-C2*3/27D0
	- CQR=CQ3+CR2
	-
	-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(P1Q1+P2Q2-B1).LT.ABS(P1Q2+P2Q1-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...(STOP12 - STOP22)/(STOP22 + STOP12) < 0.5
	-C...(SBOT12 - SBOT22)/(SBOT22 + SBOT22) < 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_SUSY2 = (STOP12 + STOP2**2)/2. The sbottom
	-C...masses have been assumed to be of order of the stop ones
	-C...M_SUSY2 = (MQ2 + 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/PIALPH3Z
	- &LOG(XMTOP2/XMZ2))
	-
	-C...RMTOP= RUNNING TOP QUARK MASS
	- RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
	- XMS = ((XMQ2 + XMUR2)/2D0 + XMTOP2)0.5D0
	- T = LOG(XMS2/XMTOP2)
	- SINB = TANB/((1D0 + TANB2)0.5D0)
	- COSB = SINB/TANB
	-C...IF(MA.LE.XMTOP) TANBA = TANBT
	- IF(XMA.GT.XMTOP)
	- &TANBA = TANBT(1D0-3D0/32D0/PI2
	- &(RMTOP2/V2/SINB2-XMB2/V2/COSB2)*
	- &LOG(XMA2/XMTOP2))
	-
	- SINBT = TANBT/SQRT(1D0 + TANBT**2)
	- COSBT = 1D0/SQRT(1D0 + TANBT**2)
	-C COS2BT = (TANBT2 - 1D0)/(TANBT2 + 1D0)
	- G1 = SQRT(ALP14D0PI)
	- G2 = SQRT(ALP24D0PI)
	- G3 = SQRT(ALP34D0PI)
	- 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 = (2D0AU2/XMS2)(1D0 - AU2/12D0/XMS2)
	- XAD = (2D0AD2/XMS2)(1D0 - AD2/12D0/XMS2)
	- AUD = (-6D0XMU2/XMS2 - ( XMU2- ADAU)**2/XMS4
	- &+ 3D0(AU + AD)*2/XMS2)/6D0
	- XLAM1 = ((G12 + G22)/4D0)(1D0-3D0HD2*T/8D0/PI2)
	- &+(3D0HD4/8D0/PI2) (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
	- &- 8D0G32) (XADT + T*2)/16D0/PI2)
	- &-(3D0HU4 XMU*4/96D0/PI2/XMS4) (1+ (9D0HU2 -5D0 HD2
	- &- 16D0G32) T/16D0/PI2)
	- XLAM2 = ((G12 + G22)/4D0)(1D0-3D0HU2*T/8D0/PI2)
	- &+(3D0HU4/8D0/PI2) (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
	- &- 8D0G32) (XAUT + T*2)/16D0/PI2)
	- &-(3D0HD4 XMU*4/96D0/PI2/XMS4) (1+ (9D0HD2 -5D0 HU2
	- &- 16D0G32) T/16D0/PI2)
	- XLAM3 = ((G22 - G12)/4D0)(1D0-3D0
	- &(HU2 + HD2)*T/16D0/PI2)
	- &+(6D0HU2HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
	- &- 8D0G32) (AUDT + T*2)/16D0/PI2)
	- &+(3D0HU4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AU2/
	- &XMS4)* (1D0+ (6D0HU2 -2D0 HD2/2D0
	- &- 16D0G32) T/16D0/PI2)
	- &+(3D0HD4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AD2/
	- &XMS4)(1D0+ (6D0HD2 -2D0* HU2
	- &- 16D0G32) T/16D0/PI2)
	- XLAM4 = (- G2*2/2D0)(1D0-3D0(HU2 + HD2)T/16D0/PI2)
	- &-(6D0HU2HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
	- &- 8D0G32) (AUDT + T*2)/16D0/PI2)
	- &+(3D0HU4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AU2/
	- &XMS4)*
	- &(1+ (6D0HU2 -2D0 HD2
	- &- 16D0G32) T/16D0/PI2)
	- &+(3D0HD4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AD2/
	- &XMS4)*
	- &(1+ (6D0HD2 -2D0 HU2/2D0
	- &- 16D0G32) T/16D0/PI2)
	- XLAM5 = -(3D0HU4 XMU2AU2/96D0/PI2/XMS4)
	- &(1- (2D0HD2 -6D0 HU2 + 16D0G32) T/16D0/PI2)
	- &-(3D0HD4 XMU2AD2/96D0/PI2/XMS4)
	- &(1- (2D0HU2 -6D0 HD2 + 16D0G32) T/16D0/PI2)
	- XLAM6 = (3D0HU4 XMU*3AU/96D0/PI2/XMS4) *
	- &(1- (7D0HD2/2D0 -15D0 HU2/2D0 + 16D0G32) T/16D0/PI2)
	- &+(3D0HD4 XMU (AD3/XMS3 - 6D0AD/XMS )/96D0/PI2/XMS) *
	- &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0G32) T/16D0/PI2)
	- XLAM7 = (3D0HD4 XMU*3AD/96D0/PI2/XMS4) *
	- &(1- (7D0HU2/2D0 -15D0 HD2/2D0 + 16D0G32) T/16D0/PI2)
	- &+(3D0HU4 XMU (AU3/XMS3 - 6D0AU/XMS )/96D0/PI2/XMS) *
	- &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0G32) 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 + 2D0V*2 (XLAM1* COSBT**2 +
	- &2D0* XLAM6SINBTCOSBT
	- &+ XLAM5SINBT2 + XLAM2 SINBT*2 + 2D0 XLAM7SINBTCOSBT
	- &+ XLAM5COSBT*2)
	- DETM2 = 4D0V4(-(SINBTCOSBT(XLAM3 + XLAM4) +
	- &XLAM6COSBT*2
	- &+ XLAM7* SINBT2)2 + (XLAM1* COSBT**2 +
	- &2D0* XLAM6* COSBT*SINBT
	- &+ XLAM5SINBT2)(XLAM2* SINBT*2 +2D0 XLAM7* COSBT*SINBT
	- &+ XLAM5COSBT2)) + XMA22D0V2
	- &((XLAM1* COSBT*2 +2D0
	- &XLAM6* COSBTSINBT + XLAM5SINBT*2)COSBT**2 +
	- &(XLAM2* SINBT*2 +2D0 XLAM7* COSBTSINBT + XLAM5COSBT**2)
	- &SINBT*2
	- &+2D0SINBTCOSBT* (SINBTCOSBT(XLAM3
	- &+ XLAM4) + XLAM6COSBT*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) -
	- &((2D0V2(XLAM1* COSBT*2 + 2D0
	- &XLAM6* COSBT*SINBT
	- &+ XLAM5SINBT2) + XMA2SINBT**2)
	- &- (2D0V2(XLAM2* SINBT*2 +2D0 XLAM7* COSBT*SINBT
	- &+ XLAM5COSBT2) + XMA2COSBT**2)))/
	- &SQRT(((TRM2*2 - 4D0 DETM2)0.5D0))/2D00.5D0
	-
	- COSALP = (2D0(2D0V*2(SINBTCOSBT(XLAM3 + XLAM4) +
	- &XLAM6COSBT2 + XLAM7 SINBT**2) -
	- &XMA*2SINBTCOSBT))/2D0*0.5D0/
	- &SQRT(((TRM2*2 - 4D0 DETM2)*0.5D0)
	- &(((TRM2*2 - 4D0 DETM2)**0.5D0) -
	- &((2D0V2(XLAM1* COSBT*2 + 2D0
	- &XLAM6* COSBT*SINBT
	- &+ XLAM5SINBT2) + XMA2SINBT**2)
	- &- (2D0V2(XLAM2* SINBT*2 +2D0 XLAM7* COSBT*SINBT
	- &+ XLAM5COSBT2) + XMA2COSBT**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/(TANB2+1D0)0.5D0
	- COSB = 1D0/(TANB2+1D0)0.5D0
	- COS2B = SINB2 - COSB2
	- SINBPA = SINBCA + COSBSA
	- COSBPA = COSBCA - SINBSA
	- 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.35D0XMZ*2COS2B
	- XMST22 = RXMT*2 + XMUR2 - 0.15D0XMZ*2COS2B
	- IF(XMST11.LT.0D0) GOTO 500
	- IF(XMST22.LT.0D0) GOTO 500
	- XMSB11 = RMBOT*2 + XMQ2 + 0.42D0XMZ*2COS2B
	- XMSB22 = RMBOT*2 + XMDR2 + 0.08D0XMZ*2COS2B
	- 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 - XMUTANB)
	-
	-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	-C...STOP EIGENVALUES CALCULATION
	-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	-
	- STOP12 = 0.5D0*(XMST11+XMST22) +
	- &0.5D0((XMST11+XMST22)*2 -
	- &4D0(XMST11XMST22 - XMST122))0.5D0
	- STOP22 = 0.5D0*(XMST11+XMST22) -
	- &0.5D0((XMST11+XMST22)2 - 4D0(XMST11*XMST22 -
	- &XMST122))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/(XMST122+(XMST11-STOP12)2)**0.5D0
	- XST12 = - (XMST11-STOP12)/(XMST122+(XMST11-STOP12)2)**0.5D0
	- XST21 = XMST12/(XMST122+(XMST11-STOP22)2)**0.5D0
	- XST22 = - (XMST11-STOP22)/(XMST122+(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(XMSB11XMSB22 - XMSB122))0.5D0
	- SBOT22 = 0.5D0*(XMSB11+XMSB22) -
	- &0.5D0((XMSB11+XMSB22)2 - 4D0(XMSB11*XMSB22 -
	- &XMSB122))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/(XMSB122+(XMSB11-SBOT12)2)**0.5D0
	- XSB12 = - (XMSB11-SBOT12)/(XMSB122+(XMSB11-SBOT12)2)**0.5D0
	- XSB21 = XMSB12/(XMSB122+(XMSB11-SBOT22)2)**0.5D0
	- XSB22 = - (XMSB11-SBOT22)/(XMSB122+(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) =
	- & SINTXMZ22D0SQR/174.1D0/3D0SINBPA*(DELTA(I,J) +
	- & (3D0 - 8D0SINT)/4D0/SINTT(1,I)*T(1,J))
	- & -RXMT2/174.1D02VP/SINBCA*DELTA(I,J)
	- & -RXMT/VP/SINB(ATCA + XMUSA)(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) =
	- & -SINTXMZ22D0SQR/174.1D0/6D0SINBPA*(DELTA(I,J) +
	- & (3D0 - 4D0SINT)/2D0/SINTB(1,I)*B(1,J))
	- & +RMBOT2/174.1D02VP/COSBSA*DELTA(I,J)
	- & +RMBOT/VP/COSB(ABSA + XMUCA)(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)*23D0*
	- & 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)*23D0*
	- & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
	- 210 CONTINUE
	- 220 CONTINUE
	-C RXMT2 = RXMT**2
	- XMT2=XMT**2
	-
	- POLTT =
	- & 3D0RXMT2/8D0/PI2/ V 2
	- & CA2/SINB2 *
	- & (-2D0XMT2+0.5D0P2)*
	- & 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) =
	- & -SINTXMZ22D0SQR/174.1D0/3D0COSBPA*(DELTA(I,J) +
	- & (3D0 - 8D0SINT)/4D0/SINTT(1,I)*T(1,J))
	- & -RXMT2/174.1D02VP/SINBSA*DELTA(I,J)
	- & -RXMT/VP/SINB(ATSA - XMUCA)(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) =
	- & SINTXMZ22D0SQR/174.1D0/6D0COSBPA*(DELTA(I,J) +
	- & (3D0 - 4D0SINT)/2D0/SINTB(1,I)*B(1,J))
	- & -RMBOT2/174.1D02VP/COSBCA*DELTA(I,J)
	- & -RMBOT/VP/COSB(ABCA - XMUSA)(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)*23D0*
	- & 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)*23D0*
	- & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
	- 330 CONTINUE
	- 340 CONTINUE
	-
	-C RXMT2 = RXMT**2
	- XMT2 = XMT**2
	-
	- HPOLTT =
	- & 3D0RXMT2/8D0/PI2/ V 2
	- & SA2/SINB2 *
	- & (-2D0XMT2+0.5D0HP2)*
	- & 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(ATCOSB + XMUSINB)
	- & (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(ABSINB + XMUCOSB)
	- & (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)*23D0*
	- & 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)*23D0*
	- & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
	- 450 CONTINUE
	- 460 CONTINUE
	-C RXMT2 = RXMT**2
	- XMT2=XMT**2
	- APOLTT =
	- & 3D0RXMT2/8D0/PI2/ V 2
	- & COSB2/SINB2 *
	- & (-0.5D0AP2)
	- & 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/PIALPHA3Z
	- LOG(MTOP2/MZ*2))
	-C RMTOP= RUNNING TOP QUARK MASS
	- RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
	- TQ = LOG((MQ2+MTOP2)/MTOP**2)
	- TU = LOG((MUR2 + MTOP2)/MTOP**2)
	- TD = LOG((MD2 + MTOP2)/MTOP**2)
	-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	-C
	-C NEW DEFINITION, TGLU.
	-C
	-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	- TGLU = LOG(MGLU2/MTOP2)
	- SINB = TANB/DSQRT(1D0 + TANB**2)
	- COSB = SINB/TANB
	- IF(MA.GT.MTOP)
	- TANBA = TANB(1D0-3D0/32D0/PI*2
	- (RMTOP2/V2/SINB2-MB2/V2/COSB2)
	- LOG(MA2/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(ALPHA14D0PI)
	- G2 = SQRT(ALPHA24D0PI)
	- G3 = SQRT(ALPHA34D0PI)
	- 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*2G1*2HD*2TPD
	- IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI*2
	- * HD*2(G12/3D0+G22)*TPD
	-
	- IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI*2G1*2HU*2TP
	- IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI*2
	- * HU*2(-G12/3D0+G22)*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/(16D0PI2)2HU*4(TQ2-TGLU2)
	- ENDIF
	-
	- IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
	- DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TQ2-TU2)
	- ENDIF
	-
	- IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
	- DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TQ2-TU2)
	- ENDIF
	-
	- IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
	- DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TU2-TGLU2)
	- ENDIF
	-
	- IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
	- DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TU2-TQ2)
	- ENDIF
	-
	- IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
	- DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TU2-TQ2)
	- ENDIF
	- ENDIF
	- DLAMBDA3 = 0D0
	- DLAMBDA4 = 0D0
	- IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI*2G1*2HD*2TPD
	- IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI*2HD*2
	- (G22-G12/3D0)TPD
	- IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
	- 1D0/16D0/PI2G1*2HU*2TP
	- IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
	- * 3D0/64D0/PI*2HU*2(G22+G12/3D0)*TP
	- IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI*2G2*2HU*2TP
	- IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI*2G2*2
	- HD2TPD
	- LAMBDA1 = ((G12 + G22)/4D0)*
	- * (1D0-3D0HD2(TPD + TDPD)/8D0/PI**2)
	- +(3D0HD4D0/16D0/PI2) TPD(1D0
	- + (3D0HD2/2D0 + HU2/2D0
	- - 8D0G3*2) (TPD + 2D0TDPD)/16D0/PI*2)
	- +(3D0HD4D0/8D0/PI2) TDPD(1D0 + (3D0HD2/2D0 + HU*2/2D0
	- - 8D0G3*2) TDPD/16D0/PI**2) + DLAMBDA1
	- LAMBDA2 = ((G12 + G22)/4D0)(1D0-3D0HU*2
	- (TP + TDP)/8D0/PI*2)
	- +(3D0HU4D0/16D0/PI2) TP(1D0
	- + (3D0HU2/2D0 + HD2/2D0
	- - 8D0G3*2) (TP + 2D0TDP)/16D0/PI*2)
	- +(3D0HU4D0/8D0/PI2) TDP(1D0 + (3D0HU2/2D0 + HD*2/2D0
	- - 8D0G3*2) TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
	- LAMBDA3 = ((G22 - G12)/4D0)(1D0-3D0
	- (HU2)(TP + TDP)/16D0/PI*2 -3D0
	- (HD2)(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) = 2D0V2(LAMBDA1COSB2+2D0LAMBDA6*
	- COSBSINB + LAMBDA5SINB2) + MA2SINB**2
	-
	- M2(2,2) = 2D0V2(LAMBDA5COSB2+2D0LAMBDA7*
	- COSBSINB + LAMBDA2SINB2) + MA2COSB**2
	- M2(1,2) = 2D0V2(LAMBDA6COSB2+(LAMBDA3+LAMBDA4)
	- COSBSINB + LAMBDA7SINB2) - MA2SINB*COSB
	-
	- M2(2,1) = M2(1,2)
	-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	-CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
	-CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	-
	- MSSUSY=DSQRT(.5D0(MQ2+MUR2)+MTOP*2)
	-
	- IF(MCHI.GT.MSSUSY) GOTO 100
	- IF(MCHI.LT.MTOP) MCHI=MTOP
	-
	- TCHAR=LOG(MSSUSY2/MCHI2)
	-
	- DELTAL12=(9D0/64D0/PI*2G24+5D0/192D0/PI2G14)TCHAR
	- DELTAL3P4=(3D0/64D0/PI*2G24+7D0/192D0/PI2G1*4
	- +4D0/32D0/PI2G1*2G2*2)TCHAR
	-
	- DELTAM112=2D0DELTAL12V*2COSB**2
	- DELTAM222=2D0DELTAL12V*2SINB**2
	- DELTAM122=2D0DELTAL3P4V*2SINB*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 = 2D0M2P(1,2)/SQRT(TRM2P2-4D0DETM2P)
	- COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P*2-4D0DETM2P)
	- 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*2Y*2LOG(X2/Y2) + X*2Z*2LOG(Z2/X2)
	- * + Y*2Z*2LOG(Y2/Z2))/((X2-Y2)(Y2-Z2)(X2-Z2))
	-
	- 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-MW2/MZ2
	- V = 174.1D0
	-
	- ALPHA3 = 0.12D0/(1D0+23/12D0/PI0.12D0LOG(MTOP2/MZ2))
	- G2 = DSQRT(0.0336D04D0PI)
	- G1 = DSQRT(0.0101D04D0PI)
	-
	- IF(MQ.GT.MUR) MST = MQ
	- IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
	-
	- MSUSYT = DSQRT(MST2 + MTOP2)
	-
	- IF(MQ.GT.MD) MSB = MQ
	- IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
	-
	- MB = PYMRUN(5,MSB**2)
	- MSUSYB = DSQRT(MSB2 + MB2)
	- TT = LOG(MSUSYT2/MTOP2)
	- TB = LOG(MSUSYB2/MTOP2)
	-
	- RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
	- HT = RMTOP/(V*SINB)
	- HTST = RMTOP/V
	- HB = MB/V/COSB
	- G32 = ALPHA34D0PI
	- BT2 = -(8D0G32 - 9D0HT2/2D0 - HB2/2D0)/(4D0PI)*2
	- BB2 = -(8D0G32 - 9D0HB2/2D0 - HT2/2D0)/(4D0PI)*2
	- AL2 = 3D0/8D0/PI*2HT**2
	-C BT2ST = -(8.G32 - 9.HTST*2/2.)/(4.PI)**2
	-C ALST = 3./8./PI*2HTST**2
	- AL1 = 3D0/8D0/PI*2HB**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/PI2HTST*2
	- * LOG(MTOP2/MA2))
	- H1I = VI* COSBA
	- H2I = VI*SINBA
	- H1T = H1I(1D0+3D0/8D0/PI2HB*2LOG(MA2/MSUSYT2))**.25D0
	- H2T = H2I(1D0+3D0/8D0/PI2HT*2LOG(MA2/MSUSYT2))**.25D0
	- H1B = H1I(1D0+3D0/8D0/PI2HB*2LOG(MA2/MSUSYB2))**.25D0
	- H2B = H2I(1D0+3D0/8D0/PI2HT*2LOG(MA2/MSUSYB2))**.25D0
	- ELSE
	- VI = V
	- H1I = VI*COSB
	- H2I = VI*SINB
	- H1T=H1I(1D0+3D0/8D0/PI2HB*2LOG(MTOP2/MSUSYT2))**.25D0
	- H2T=H2I(1D0+3D0/8D0/PI2HT*2LOG(MTOP2/MSUSYT2))**.25D0
	- H1B=H1I(1D0+3D0/8D0/PI2HB*2LOG(MTOP2/MSUSYB2))**.25D0
	- H2B=H2I(1D0+3D0/8D0/PI2HT*2LOG(MTOP2/MSUSYB2))**.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+2D0BT2TT- AL2TT - 4D0DELTAMT)
	- MTOP2 = DSQRT(MTOP4)
	- MBOT4 = MB*4(1D0+2D0BB2TB - AL1*TB)
	- * /(1D0+DELTAMB)**4
	- MBOT2 = DSQRT(MBOT4)
	-
	- STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
	- * +1D0/8D0(G22+G12)(H1T2-H2T2)
	- * +SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	- * MQ2 - MUR2)*20.25D0 + MTOP2(AT-XMU/TANBST)*2)
	- STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
	- * +1D0/8D0(G22+G12)(H1T2-H2T2)
	- * - SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	- * MQ2 - MUR2)*20.25D0
	- * + MTOP2(AT-XMU/TANBST)*2)
	- IF(STOP22.LT.0.) GOTO 120
	- SBOT12 = (MQ2 + MD2)*.5D0
	- * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	- * + SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	- * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**2)
	- SBOT22 = (MQ2 + MD2)*.5D0
	- * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	- * - SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	- * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**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 = -2ALPHA3/3D0/PIXMGL(AB-XMUTANB)*T1
	- * + HT*2/(4D0PI)*2(AT-XMU/TANB)XMUTANB*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 = -2D0ALPHA3/3D0/PI(AT-XMU/TANB)XMGLT3
	-
	-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+2D0BT2TT- AL2TT - 4D0DELTAMT)
	- MTOP2 = DSQRT(MTOP4)
	- MBOT4 = MB*4(1D0+2D0BB2TB - AL1*TB)
	- * /(1D0+DELTAMB)**4
	- MBOT2 = DSQRT(MBOT4)
	-
	- STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
	- * +1D0/8D0(G22+G12)(H1T2-H2T2)
	- * +SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	- * MQ2 - MUR2)*20.25D0 + MTOP2(AT-XMU/TANBST)*2)
	- STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
	- * +1D0/8D0(G22+G12)(H1T2-H2T2)
	- * - SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	- * MQ2 - MUR2)*20.25D0
	- * + MTOP2(AT-XMU/TANBST)*2)
	-
	- IF(STOP22.LT.0.) GOTO 120
	- SBOT12 = (MQ2 + MD2)*.5D0
	- * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	- * + SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	- * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**2)
	- SBOT22 = (MQ2 + MD2)*.5D0
	- * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	- * - SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	- * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**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/3D0STW)*
	- * LOG(STOP1/STOP2)
	- * +(.5D0-2D0/3D0STW)LOG(STOP1*STOP2/(MQ2+MTOP2))
	- * + 2D0/3D0STWLOG(STOP1*STOP2/(MUR2+MTOP2))
	-
	- F1B=(MQ2-MD2)/(SBOT12-SBOT22)(-.5D0+2D0/3D0STW)*
	- * LOG(SBOT1/SBOT2)
	- * +(-.5D0+1D0/3D0STW)LOG(SBOT1*SBOT2/(MQ2+MBOT2))
	- * - 1D0/3D0STWLOG(SBOT1*SBOT2/(MD2+MBOT2))
	-
	- F2T=DSQRT(MTOP2)(AT-XMU/TANBST)/(STOP12-STOP22)
	- * (-.5D0*LOG(STOP12/STOP22)
	- * +(4D0/3D0STW-.5D0)(MQ2-MUR2)/(STOP12-STOP22)*
	- * G(STOP12,STOP22))
	-
	- F2B=DSQRT(MBOT2)(AB-XMUTANBSB)/(SBOT12-SBOT22)*
	- * (.5D0*LOG(SBOT12/SBOT22)
	- * +(-2D0/3D0STW+.5D0)(MQ2-MD2)/(SBOT12-SBOT22)*
	- * G(SBOT12,SBOT22))
	-
	- VH3B(1,1) = MBOT4/(COSBB*2)(LOG(SBOT1*2SBOT2**2/
	- * (MQ2+MBOT2)/(MD2+MBOT2))
	- * + 2D0(AB(AB-XMUTANBSB)/(SBOT12-SBOT22))
	- * LOG(SBOT12/SBOT22)) +
	- * MBOT4/(COSBB*2)(AB(AB-XMUTANBSB)/
	- * (SBOT12-SBOT22))*2G(SBOT12,SBOT22)
	-
	- VH3T(1,1) =
	- * MTOP4/(SINBT*2)(XMU(-AT+XMU/TANBST)/(STOP1*2
	- * -STOP22))2*G(STOP12,STOP22)
	-
	- VH3B(1,1)=VH3B(1,1)+
	- * MZ*2(2MBOT2F1B-DSQRT(MBOT2)ABF2B)
	-
	- VH3T(1,1) = VH3T(1,1) +
	- * MZ*2(DSQRT(MTOP2)XMU/TANBSTF2T)
	-
	- VH3T(2,2) = MTOP4/(SINBT*2)(LOG(STOP1*2STOP2**2/
	- * (MQ2+MTOP2)/(MUR2+MTOP2))
	- * + 2D0(AT(AT-XMU/TANBST)/(STOP12-STOP22))*
	- * LOG(STOP12/STOP22)) +
	- * MTOP4/(SINBT*2)(AT*(AT-XMU/TANBST)/
	- * (STOP12-STOP22))*2G(STOP12,STOP22)
	-
	- VH3B(2,2) =
	- * MBOT4/(COSBB*2)(XMU(-AB+XMUTANBSB)/(SBOT1**2
	- * -SBOT22))2*G(SBOT12,SBOT22)
	-
	- VH3T(2,2)=VH3T(2,2)+
	- * MZ*2(-2MTOP2F1T+DSQRT(MTOP2)ATF2T)
	- VH3B(2,2) = VH3B(2,2) -MZ*2DSQRT(MBOT2)XMUTANBSB*F2B
	- VH3T(1,2) = -
	- * MTOP4/(SINBT*2)XMU*(AT-XMU/TANBST)/
	- * (STOP12-STOP22)(LOG(STOP12/STOP22) + AT
	- * (AT - XMU/TANBST)/(STOP12-STOP22)*G(STOP12,STOP22))
	-
	- VH3B(1,2) =
	- * - MBOT4/(COSBB*2)XMU(AB-XMUTANBSB)/
	- * (SBOT12-SBOT22)(LOG(SBOT12/SBOT22) + AB
	- * (AB - XMUTANBSB)/(SBOT12-SBOT22)G(SBOT12,SBOT22))
	-
	-
	- VH3T(1,2)=VH3T(1,2) +
	- MZ2(MTOP2/TANBSTF1T-DSQRT(MTOP2)(AT/TANBST+XMU)/2D0*F2T)
	-
	- VH3B(1,2)=VH3B(1,2) +
	- MZ2(-MBOT2TANBSBF1B+DSQRT(MBOT2)(ABTANBSB+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 + MB2)/MB2)
	-C TD = LOG((MD2+MB2)/MB2)
	-
	- DO 110 I = 1,2
	- DO 100 J = 1,2
	- VH(I,J) =
	- * 6D0/(8D0PI2(H1T2+H2T2))
	- * VH3T(I,J)0.5D0(1D0-AL(I,J)TT/2D0) +
	- * 6D0/(8D0PI2(H1B2+H2B2))
	- * 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(XXXM(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/(XMPXMGR))2XMI/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-XMF2/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)=2D0C1/8D0/XMI3SQRT(XL)((XMI2-XMB2-XMA2)
	- & (ABS(CA)2+ABS(CB)2)-4D0DBLE(CADCONJG(CB))XMJXMFP)
	- 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)+TANWZMIXC(IX,1)(2D0*EI+1)
	- CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
	- CAR=-2D0EITANW*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)+TANWZMIXC(IX,1)(2D0*EI-1)
	- CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
	- CAR=-2D0EITANW*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/XMI3SQRT(XL)((XMI2-XMB2-XMA2)*
	- & (ABS(CA)2+ABS(CB)2)-4D0DBLE(CADCONJG(CB))XMJXMF)
	- 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-EIXW)*(-SIN(ALFA+BETA))+
	- & XMF*2/XMWCOSA/SBETA
	- GHRR=XMZ/CW(EIXW)*(-SIN(ALFA+BETA))+
	- & XMF*2/XMWCOSA/SBETA
	- ELSE
	- GHLL=XMZ/CW(0.5D0-EIXW)*(-SIN(ALFA+BETA))+
	- & XMF*2/XMW(-SINA)/CBETA
	- GHRR=XMZ/CW(EIXW)*(-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(-XMUSINA+
	- & AT*COSA)
	- ELSE
	- GHLR=XMF/2D0/XMW/CBETA(XMUCOSA-
	- & 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-EIXW)*COS(ALFA+BETA)+
	- & XMF*2/XMWSINA/SBETA
	- GHRR=XMZ/CW(EIXW)*COS(ALFA+BETA)+
	- & XMF*2/XMWSINA/SBETA
	- ELSE
	- GHLL=XMZ/CW(0.5D0-EIXW)*COS(ALFA+BETA)+
	- & XMF*2/XMWCOSA/CBETA
	- GHRR=XMZ/CW(EIXW)*COS(ALFA+BETA)+
	- & XMF*2/XMWCOSA/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(XMUCOSA+
	- & AT*SINA)
	- ELSE
	- GHLR=XMF/2D0/XMW/CBETA(XMUSINA+
	- & 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,XMSF12,XMB2)
	- LKNT=LKNT+1
	- IF(IG.EQ.23) THEN
	- XLAM(LKNT)=C1/4D0/XMI3XL1.5D0/XMB2AL**2
	- ELSE
	- XLAM(LKNT)=C1/4D0/XMI3SQRT(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/SR2SFMIX(IFL,1)SFMIX(IFL-1,1)
	- ELSE
	- AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL-1,1)
	- ENDIF
	- ELSE
	- IF(ILR.EQ.1) THEN
	- AL=1D0/SR2SFMIX(IFL,1)SFMIX(IFL+1,1)
	- ELSE
	- AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL+1,1)
	- ENDIF
	- ENDIF
	- XL=PYLAMF(XMI2,XMSF12,XMB2)
	- LKNT=LKNT+1
	- XLAM(LKNT)=C1/4D0/XMI3XL1.5D0/XMB2AL**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/SR2SFMIX(IFL,1)SFMIX(IFL-1,3)
	- ELSE
	- AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL-1,3)
	- ENDIF
	- ELSE
	- IF(ILR.EQ.1) THEN
	- AL=1D0/SR2SFMIX(IFL,1)SFMIX(IFL+1,3)
	- ELSE
	- AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL+1,3)
	- ENDIF
	- ENDIF
	- XL=PYLAMF(XMI2,XMSF22,XMB2)
	- LKNT=LKNT+1
	- XLAM(LKNT)=C1/4D0/XMI3XL1.5D0/XMB2AL**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,XMSF12,XMB2)
	- LKNT=LKNT+1
	-C.......Need to complexify
	- AL=CH1(XMW22D0CBETASBETA-XMFP*2TANB-XMF**2/TANB)+
	- & CH22D0XMFXMFP/(2D0CBETA*SBETA)+
	- & CH3XMFP(-XMU+ABTANB)+CH4XMF*(-XMU+AT/TANB)
	- XLAM(LKNT)=C1/8D0/XMI3SQRT(XL)/XMW2AL**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,XMSF12,XMB2)
	- LKNT=LKNT+1
	-C.......Need to complexify
	- AL=CH1(XMW22D0CBETASBETA-XMFP*2TANB-XMF**2/TANB)+
	- & CH22D0XMFXMFP/(2D0CBETA*SBETA)+
	- & CH3XMFP(-XMU+ABTANB)+CH4XMF*(-XMU+AT/TANB)
	- XLAM(LKNT)=C1/8D0/XMI3SQRT(XL)/XMW2AL**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/3D0AS/2D0/XMI3SQRT(XL)((XMI2-XMB2-XMA2)
	- & (XCA2+XCB2)+4D0XCAXCBXMJXMF)
	- 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/(16PI2)G3 = G2/(4PI) G/(4PI) = C1 G/(4PI)
	-C...MM = C12 G2/(16PI2)
	-C...G = 1/(8PI)P/MI*2 MM = C13/(32PI2)LAM/(2MI*3)
	- LKNT=LKNT+1
	- XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
	- XLAM(LKNT)=C13/64D0/PI2/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/(XMPXMGR))2AXMI/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/8D0AS/4D0/XMI3SQRT(XL)((XMI2+XMB2-XMA2)
	- & (CA2+CB2)-4D0CACBXMIXMF)
	- 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	- GRIJ=ZMIXC(IX,1)(EITANW)*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)=C1AS/XMI3/(16D0PI)*
	- & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	- GRIJ=ZMIXC(IX,1)(EITANW)*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)=C1AS/XMI3/(16D0PI)*
	- & 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.5D0C1AS/XMI3/(16D0PI)
	- & 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(-SINBAN(J,3)+COSB*AN(J,4))
	- ZN(2)=-2D0W2/3D0SINW(TANWAN(J,2)-AN(J,1))
	- ZN(3)=-2W2/3D0SINWAN(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(COSBAN(J,3)+SINB*AN(J,4))
	- ZN(2)=W2/3D0SINW(TANW*AN(J,2)-AN(J,1))
	- ZN(3)=W2/3D0SINWAN(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=SINDCOSD2D0
	- 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=XMGXM2XMR
	- 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(FFSIND2-HHCOSD2))W
	- G(1)=((HL2+FL2)(XMQA-2D0XMS2(1)-2D0XMXMG*SIN2D)
	- & +4D0HFLXMXMR)XLN1
	- & +((HL2+FL2)((XMQA-XMS2(1))XMS2(1)-XM24
	- & +2D0XMXMG(XM2+XMR2-XMS2(1))SIN2D)
	- & -4D0HFLXMRXM(XMG2+XM2-XMS2(1))
	- & +8D0HFLXMQ4SIN2D)B1
	- G(2)=((HR2+FR2)(XMQA-2D0XMS2(2)+2D0XMXMG*SIN2D)
	- & +4D0HFRXMRXM)XLN2
	- & +((HR2+FR2)((XMQA-XMS2(2))XMS2(2)-XM24
	- & +2D0XMGXMSIN2D(XMS2(2)-XM2-XMR2))
	- & +4D0HFRXMXMR(XMS2(2)-XMG2-XM2)
	- & -8D0HFRXMQ4SIN2D)B2
	- G(3)=(2D0HFLSIN2D(XMS2(1)(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
	- & +XMG2XMR2+XM2XM2)-2D0XMRXMG(HL2SIND2+FL2COSD2)SBAR
	- & -2D0XMGXMHFL(SBAR+XMR2-XMG2)
	- & +XMRXM(HL2+FL2)SIN2D(SBAR+XMG2-XMR2)
	- & -4D0XMQ4(HL2-FL2)COS2D)/(GRS+2D0XMS2(1))*XLN1
	- G(4)=4D0COS2DXMXMG/(XMS2(1)-XMS2(2))
	- & (((HLFR+HRFL)(XM2+XMR2)+2D0XMXMR(HH+FF))*(XLN1-XLN2)
	- & +(HLFR+HRFL)(XMS2(2)XLN2-XMS2(1)*XLN1))
	- G(5)=(2D0(HHCOSD2-FF*SIND2)
	- & ((XMS2(2)(XMS2(2)+GRS)+XM2XM2+XMG2XMR2)*XLN2
	- & +(XMS2(1)(XMS2(1)+GRS)+XM2XM2+XMG2XMR2)XLN1)
	- & +XM((HH-FF)SIN2DXMG-(HRFL-HLFR)XMR)
	- & ((GRS+XMS2(1)2D0)XLN1-(GRS+XMS2(2)2D0)*XLN2)
	- & +((HRFL-HLFR)XMR(SIN2DXMG(SBAR-4D0*XM2)
	- & +COS2DXM(SBAR+XMG2-XMR2))
	- & +2D0(FFCOSD2-HHSIND2)XM2*(SBAR-XMG2-XMR2))
	- & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
	- G(6)=(-2D0HFRSIN2D(XMS2(2)(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
	- & +XMG2XMR2+XM2XM2)-2D0XMRXMG(HR2SIND2+FR2COSD2)SBAR
	- & -2D0XMGXMHFR(SBAR+XMR2-XMG2)
	- & -XMRXM(HR2+FR2)SIN2D(SBAR+XMG2-XMR2)
	- & -4D0XMQ4(HR2-FR2)COS2D)/(GRS+2D0XMS2(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)=FAKT1UMIX(JJ,2)SINC-UMIX(JJ,1)*COSC
	- EEE(JJ)=FAKT2VMIX(JJ,2)COSC
	- DDD(JJ)=FAKT1UMIX(JJ,2)COSC+UMIX(JJ,1)*SINC
	- FFF(JJ)=FAKT2VMIX(JJ,2)SINC
	- XX1(JJ)=FAKT2VMIX(JJ,2)SINA-VMIX(JJ,1)*COSA
	- AAA(JJ)=FAKT1UMIX(JJ,2)COSA
	- XX2(JJ)=FAKT2VMIX(JJ,2)COSA+VMIX(JJ,1)*SINA
	- BBB(JJ)=FAKT1UMIX(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=COSA2-SINA2
	- SIN2A=SINACOSA2D0
	- COS2C=COSC2-SINC2
	- SIN2C=SINCCOSC2D0
	-
	- 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=XMGXMTXMB*XMR
	- XMQ3=XMG2XMR2+XMT2XMB2
	- 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)=-COSASINCCCC(I)AAA(I)-SINACOSCEEE(I)XX1(I)
	- A(1,2)=XMGXMB(COSACOSCCCC(I)AAA(I)+SINASINCEEE(I)XX1(I))
	- A(1,3)=-XMGXMR(COSACOSCCCC(I)XX1(I)+SINASINCEEE(I)AAA(I))
	- A(1,4)=XMBXMR(COSASINCCCC(I)XX1(I)+SINACOSCEEE(I)AAA(I))
	- A(1,5)=XMGXMT(COSACOSCEEE(I)XX1(I)+SINASINCCCC(I)AAA(I))
	- A(1,6)=-XMTXMB(COSASINCEEE(I)XX1(I)+SINACOSCCCC(I)AAA(I))
	- A(1,7)=XMTXMR(COSASINCEEE(I)AAA(I)+SINACOSCCCC(I)XX1(I))
	- A(1,8)=-XMQ4(COSACOSCEEE(I)AAA(I)+SINASINCCCC(I)*XX1(I))
	-
	- A(2,1)=-COSACOSCDDD(I)AAA(I)-SINASINCFFF(I)XX1(I)
	- A(2,2)=-XMGXMB(COSASINCDDD(I)AAA(I)+SINACOSCFFF(I)XX1(I))
	- A(2,3)=XMGXMR(COSASINCDDD(I)XX1(I)+SINACOSCFFF(I)AAA(I))
	- A(2,4)=XMBXMR(COSACOSCDDD(I)XX1(I)+SINASINCFFF(I)AAA(I))
	- A(2,5)=XMGXMT(COSASINCFFF(I)XX1(I)+SINACOSCDDD(I)AAA(I))
	- A(2,6)=XMTXMB(COSACOSCFFF(I)XX1(I)+SINASINCDDD(I)AAA(I))
	- A(2,7)=-XMTXMR(COSACOSCFFF(I)AAA(I)+SINASINCDDD(I)XX1(I))
	- A(2,8)=-XMQ4(COSASINCFFF(I)AAA(I)+SINACOSCDDD(I)*XX1(I))
	-
	- A(3,1)=-COSACOSCEEE(I)XX2(I)-SINASINCCCC(I)BBB(I)
	- A(3,2)=XMGXMB(COSASINCEEE(I)XX2(I)+SINACOSCCCC(I)BBB(I))
	- A(3,3)=XMGXMR(COSASINCEEE(I)BBB(I)+SINACOSCCCC(I)XX2(I))
	- A(3,4)=-XMBXMR(COSACOSCEEE(I)BBB(I)+SINASINCCCC(I)XX2(I))
	- A(3,5)=-XMGXMT(COSASINCCCC(I)BBB(I)+SINACOSCEEE(I)XX2(I))
	- A(3,6)=XMTXMB(COSACOSCCCC(I)BBB(I)+SINASINCEEE(I)XX2(I))
	- A(3,7)=XMTXMR(COSACOSCCCC(I)XX2(I)+SINASINCEEE(I)BBB(I))
	- A(3,8)=-XMQ4(COSASINCCCC(I)XX2(I)+SINACOSCEEE(I)*BBB(I))
	-
	- A(4,1)=-COSASINCFFF(I)XX2(I)-SINACOSCDDD(I)BBB(I)
	- A(4,2)=-XMGXMB(COSACOSCFFF(I)XX2(I)+SINASINCDDD(I)BBB(I))
	- A(4,3)=-XMGXMR(COSACOSCFFF(I)BBB(I)+SINASINCDDD(I)XX2(I))
	- A(4,4)=-XMBXMR(COSASINCFFF(I)BBB(I)+SINACOSCDDD(I)XX2(I))
	- A(4,5)=-XMGXMT(COSACOSCDDD(I)BBB(I)+SINASINCFFF(I)XX2(I))
	- A(4,6)=-XMTXMB(COSASINCDDD(I)BBB(I)+SINACOSCFFF(I)XX2(I))
	- A(4,7)=-XMTXMR(COSASINCDDD(I)XX2(I)+SINACOSCFFF(I)BBB(I))
	- A(4,8)=-XMQ4(COSACOSCDDD(I)XX2(I)+SINASINCFFF(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)-XMGXMTSIN2A)
	- & +2D0XX1(I)AAA(I)XMRXMB)*ANT1
	- & +(ULR(1)/2D0(XMST(1)(XMQ2-XMST(1))-XMGTBR
	- & -2D0XMGXMTSIN2A(XMST(1)-XMB2-XMR2))
	- & +2D0XX1(I)AAA(I)XMRXMB*(XMST(1)-XMG2-XMT2)
	- & +4D0SIN2AXX1(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)+XMGXMT*SIN2A)
	- & -2D0XX2(I)BBB(I)XMRXMB)*ANT2
	- & +(ULR(2)/2D0(XMST(3)(XMQ2-XMST(3))-XMGTBR
	- & +2D0XMGXMTSIN2A(XMST(3)-XMB2-XMR2))
	- & -2D0XX2(I)BBB(I)XMRXMB*(XMST(3)-XMG2-XMT2)
	- & +4D0SIN2AXX2(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)-XMGXMB*SIN2C)
	- & +2D0CCC(I)EEE(I)XMRXMT)*ANB1
	- & +(VLR(1)/2D0(XMSB(1)(XMQ2-XMSB(1))-XMGBTR
	- & -2D0XMGXMBSIN2C(XMSB(1)-XMT2-XMR2))
	- & +2D0CCC(I)EEE(I)XMRXMT*(XMSB(1)-XMG2-XMB2)
	- & +4D0SIN2CCCC(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)+XMGXMB*SIN2C)
	- & -2D0DDD(I)FFF(I)XMRXMT)*ANB2
	- & +(VLR(2)/2D0(XMSB(2)(XMQ2-XMSB(2))-XMGBTR
	- & +2D0XMGXMBSIN2C(XMSB(2)-XMT2-XMR2))
	- & -2D0DDD(I)FFF(I)XMRXMT*(XMSB(2)-XMG2-XMB2)
	- & +4D0SIN2CDDD(I)FFF(I)XMQ4)
	- & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
	- SUMME(LIN)=SUMME(LIN)+2D0XMGXMT*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))XMBXMR(ANT2-ANT1))
	- SUMME(LIN)=SUMME(LIN)+2D0XMGXMB*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))XMTXMR(ANB2-ANB1))
	- DO 110 J=1,4
	- SUMME(LIN)=SUMME(LIN)-2D0A(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)+2D0A(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)-2D0A(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/(XMPXMGR))2AXMI/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)=XFACABS(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 +
	- $ .5D0ABS(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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	- & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	- GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	- CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	- CXC(2)=-GLIJ
	- CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	- CXC(4)=DCONJG(GLIJ)
	- CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	- CXC(6)=GRIJ
	- CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	- & 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/(16D0PI)*
	- & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	- & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	- GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	- CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	- CXC(2)=-GLIJ
	- CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	- CXC(4)=DCONJG(GLIJ)
	- CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	- CXC(6)=GRIJ
	- CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	- & 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/(16D0PI)*
	- & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	- & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	- GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	- CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	- CXC(2)=-GLIJ
	- CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	- CXC(4)=DCONJG(GLIJ)
	- CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	- CXC(6)=GRIJ
	- CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	- & 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/(16D0PI)*
	- & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	- & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	- GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	- CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	- CXC(2)=-GLIJ
	- CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	- CXC(4)=DCONJG(GLIJ)
	- CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	- CXC(6)=GRIJ
	- CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	- & 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(QIJEH(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/(16D0PI)*
	- & 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/(16D0PI)*
	- & 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)=3D0C12/XMI3/(16D0PI)*
	- & 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=T3TZMIXC(IX,2)+TANWZMIXC(IX,1)(2D0EI-T3T)
	- CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
	- CAR=-2D0EITANW*ZMIXC(IX,1)
	- CBR=CAL
	- ELSE
	- CBL=T3TZMIXC(IX,2)+TANWZMIXC(IX,1)(2D0EI-T3T)
	- CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
	- CAR=-2D0EITANW*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=CALSFMIX(J,1)+CARSFMIX(J,2)
	- CB=CBLSFMIX(J,1)+CBRSFMIX(J,2)
	- XLAM(LKNT)=0.5D0FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)*
	- & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	- 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=CALSFMIX(J,3)+CARSFMIX(J,4)
	- CB=CBLSFMIX(J,3)+CBRSFMIX(J,4)
	- XL=PYLAMF(XMI2,XMA2,XMB2)
	- XLAM(LKNT)=0.5D0FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)*
	- & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	- 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	- GRIJ=ZMIXC(IX,1)(EITANW)*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)=4D0C1AS/XMI3/(16D0PI)
	- & 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.5D0C1AS/XMI3/(16D0PI)
	- & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	- GRIJ=ZMIXC(IX,1)(EITANW)*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.5D0C1AS/XMI3/(16D0PI)
	- & 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/(XMPXMGR))2AXMI/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-XWEI)/XW/XW1)ORPP
	- CXC(2)=DCMPLX(0D0,0D0)
	- CXC(3)=DCMPLX((T3I-XWEI)/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/(16D0PI)*
	- & 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-XWEI)/XW/XW1)ORPP
	- CXC(3)=DCMPLX((T3I-XWEI)/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/(16D0PI)*
	- & 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/(16D0PI)*
	- & 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-XWEI)/XW/XW1)ORPP
	- CXC(2)=DCMPLX(0D0,0D0)
	- CXC(3)=DCMPLX((T3I-XWEI)/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)=3D0C12/XMI3/(16D0PI)*
	- & 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)=3D0C12/XMI3/(16D0PI)*
	- & 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-XWEI)/XW/XW1)ORPP
	- CXC(2)=DCMPLX(0D0,0D0)
	- CXC(3)=DCMPLX((T3I-XWEI)/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)=3D0C12/XMI3/(16D0PI)*
	- & 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/(32M3)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/(16D0PI)*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/(16D0PI)*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)=3D0C12/XMI3/(16D0PI)*
	- & 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=CALSFMIX(ISF,1)+CARSFMIX(ISF,2)
	- CB=CBLSFMIX(ISF,1)+CBRSFMIX(ISF,2)
	- XLAM(LKNT)=FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)
	- & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	- 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=CALSFMIX(ISF,3)+CARSFMIX(ISF,4)
	- CB=CBLSFMIX(ISF,3)+CBRSFMIX(ISF,4)
	- XL=PYLAMF(XMI2,XMA2,XMB2)
	- XLAM(LKNT)=FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)
	- & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	- 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)=4D0C1AS/XMI3/(16D0PI)
	- & 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)(-(X2+XY+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-2D0C)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/XSQRT( ( (X-XM12-XM32)2-4D0XM12XM32)
	- &( (X-XM22-S)*2 -4D0XM22*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-XMV2)2+(XMVXMG)*2
	- SIJ=2D0XXC(2)XXC(4)*S13
	- IF(XMV.LE.1000D0) THEN
	- OL2=ABS(QLLS)2+ABS(QRRS)2+ABS(QLRS)2+ABS(QRLS)2
	- OLR=-2D0DBLE(QLRSDCONJG(QLLS)+QRLS*DCONJG(QRRS))
	- WW=(OL22D0TINT(S23MAX,S23MIN,XM22,S)
	- & +OLRSIJ(S23MAX-S23MIN))/WPROP2
	- IF(XXC(5).LE.10000D0) THEN
	- WFL1=4D0(DBLE(QLLSDCONJG(QLLU))*
	- & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
	- & .5D0DBLE(QLLSDCONJG(QLRT))SIJTPROP(S23MAX,S23MIN,XMSD2)+
	- & DBLE(QLRSDCONJG(QLRT))TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
	- & .5D0DBLE(QLRSDCONJG(QLLU))SIJTPROP(S23MAX,S23MIN,XMSD1))
	- & (S13-XMV*2)/WPROP2
	- ELSE
	- WFL1=0D0
	- ENDIF
	-
	- IF(XXC(6).LE.10000D0) THEN
	- WFL2=4D0(DBLE(QRRSDCONJG(QRRU))*
	- & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
	- & .5D0DBLE(QRRSDCONJG(QRLT))SIJTPROP(S23MAX,S23MIN,XMSU2)+
	- & DBLE(QRLSDCONJG(QRLT))TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
	- & .5D0DBLE(QRLSDCONJG(QRRU))SIJTPROP(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=2D0ABS(QLLU)2TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
	- & +2D0ABS(QLRT)2TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
	- & - 2D0DBLE(QLRTDCONJG(QLLU))*
	- & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
	- ELSE
	- WF1=0D0
	- ENDIF
	- IF(XXC(6).LE.10000D0) THEN
	- WF2=2D0ABS(QRRU)2TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
	- & +2D0ABS(QRLT)2TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
	- & - 2D0DBLE(QRLTDCONJG(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((XM12-XM22)/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+3D0XMV2(XMI2+XMJ2-XMV2))-
	- &12D0GLRXM1XM2XMV2)
	-
	- 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)+
	- &4D0GLRXM1*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.5D0DCONJG(QIJDH(IH)-RIJ*EH(IH))
	- F12K=0.5D0(QIJDH(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+EIXW)*SIN(ALFA+BETA)+
	- & XMF*2/XMWSINA/CBETA
	- GHRR=XMZ/CW(EIXW)*SIN(ALFA+BETA)+
	- & XMF*2/XMWSINA/CBETA
	- IF(IFL.EQ.5) THEN
	- GHLR=-XMF/2D0/XMW/CBETA(XMUZCOSA-
	- & ATRIB*SINA)
	- ELSEIF(IFL.EQ.15) THEN
	- GHLR=-XMF/2D0/XMW/CBETA(XMUZCOSA-
	- & ATRIL*SINA)
	- ELSE
	- GHLR=0D0
	- ENDIF
	- ELSE
	- GHLL=XMZ/CW(0.5D0-EIXW)*SIN(ALFA+BETA)-
	- & XMF*2/XMWCOSA/SBETA
	- GHRR=XMZ/CW(EIXW)*SIN(ALFA+BETA)-
	- & XMF*2/XMWCOSA/SBETA
	- IF(IFL.EQ.6) THEN
	- GHLR=XMF/2D0/XMW/SBETA(XMUZSINA-
	- & ATRIT*COSA)
	- ELSE
	- GHLR=0D0
	- ENDIF
	- ENDIF
	-
	- ELSEIF(IH.EQ.2) THEN
	- IF(IDU.EQ.1) THEN
	- GHLL=XMZ/CW(0.5D0+EIXW)*COS(ALFA+BETA)-
	- & XMF*2/XMWCOSA/CBETA
	- GHRR=-XMZ/CW(EIXW)*COS(ALFA+BETA)-
	- & XMF*2/XMWCOSA/CBETA
	- IF(IFL.EQ.5) THEN
	- GHLR=-XMF/2D0/XMW/CBETA(XMUZSINA+
	- & ATRIB*COSA)
	- ELSEIF(IFL.EQ.15) THEN
	- GHLR=-XMF/2D0/XMW/CBETA(XMUZSINA+
	- & ATRIL*COSA)
	- ELSE
	- GHLR=0D0
	- ENDIF
	- ELSE
	- GHLL=-XMZ/CW(0.5D0-EIXW)*COS(ALFA+BETA)-
	- & XMF*2/XMWSINA/SBETA
	- GHRR=-XMZ/CW(EIXW)*COS(ALFA+BETA)-
	- & XMF*2/XMWSINA/SBETA
	- IF(IFL.EQ.6) THEN
	- GHLR=-XMF/2D0/XMW/SBETA(XMUZCOSA+
	- & 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(ATRIBTANB-XMUZ)
	- ELSEIF(IFL.EQ.15) THEN
	- GHLR=XMF/2D0/XMW(ATRILTANB-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)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GHLLAL+GHRRAR
	- & +2D0GHLRALR)**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)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GHLLAL+GHRRAR
	- & +2D0GHLRALR)**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)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GHLLAL+GHRRAR)**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=CBETADCONJG(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(2D0BETA)-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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GLSFMIX(6,1)SFMIX(5,1)+GRSFMIX(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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GLSFMIX(6,3)SFMIX(5,1)+GRSFMIX(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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GLSFMIX(6,1)SFMIX(5,3)+GRSFMIX(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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	- & (GLSFMIX(6,3)SFMIX(5,3)+GRSFMIX(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/SR2SIN(2D0BETA)
	- 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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL*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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL*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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL2SFMIX(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,XM12,XM22)
	- LKNT=LKNT+1
	- XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL2SFMIX(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)-
	- &4D0GLRXM3*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-C2S8) .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-C2S8) .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-4D0Y*Z
	- IF(PYLAMF.LT.0D0) PYLAMF=0D0
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYTBDY
	-C...Generates 3-body decays of gauginos.
	-
	- SUBROUTINE PYTBDY(IDIN)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	-C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- 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=(T3IZMIXC(IZID1,2)-TANW(T3I-EI)ZMIXC(IZID1,1))
	- & DCONJG(T3IZMIXC(IZID2,2)-TANW(T3I-EI)*ZMIXC(IZID2,1))
	- GRIJ=ZMIXC(IZID1,1)DCONJG(ZMIXC(IZID2,1))(EITANW)*2
	- XM1M2=SMZ(IZID1)*SMZ(IZID2)
	- QLLS=DCMPLX((T3I-EIXW)/XW1)OLPP
	- QLLU=-GLIJ
	- QLRS=-DCMPLX((T3I-EIXW)/XW1)ORPP
	- QLRT=DCONJG(GLIJ)
	- QRLS=-DCMPLX((EIXW)/XW1)OLPP
	- QRLT=GRIJ
	- QRRS=DCMPLX((EIXW)/XW1)ORPP
	- QRRU=-DCONJG(GRIJ)
	- ELSEIF(IZID1IWID2.NE.0.OR.IZID2IWID1.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-XWEI)/XW/XW1)ORPP
	- QRRS=-DCMPLX(EI/XW1)*OLPP
	- QLRS=DCMPLX((T3I-XWEI)/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)/(2D0S12)
	- S23DF1=(S12-XM(2)2-XM(1)2)**2
	- & -(2D0XM(1)XM(2))**2
	- S23DF2=(S12-XM(3)2-XM(5)2)**2
	- & -(2D0XM(3)XM(5))**2
	- S23DF1=S23DF1*EPS
	- S23DF2=S23DF2*EPS
	- S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0S12)
	- 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 + GMMZ2
	- 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+
	- & 2D0DBLE(QLRDCONJG(QLL)+QRLDCONJG(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
	- &-(2D0XM(1)XM(2))**2
	- S23DF2=(X1-XM(3)2-XM(5)2)**2
	- &-(2D0XM(3)XM(5))**2
	- S23DF1=S23DF1*EPS
	- S23DF2=S23DF2*EPS
	- S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X1)
	- F1=-2D0*S23DEL/EPS
	- S23DF1=(X2-XM(2)2-XM(1)2)**2
	- &-(2D0XM(1)XM(2))**2
	- S23DF2=(X2-XM(3)2-XM(5)2)**2
	- &-(2D0XM(3)XM(5))**2
	- S23DF1=S23DF1*EPS
	- S23DF2=S23DF2*EPS
	- S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X2)
	- 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=RX1+CX3
	- F1=F2
	- S23DF1=(X2-XM(2)2-XM(1)2)**2
	- & -(2D0XM(1)XM(2))**2
	- S23DF2=(X2-XM(3)2-XM(5)2)**2
	- & -(2D0XM(3)XM(5))**2
	- S23DF1=S23DF1*EPS
	- S23DF2=S23DF2*EPS
	- S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X2)
	- F2=-2D0*S23DEL/EPS
	- ELSE
	- X3=X2
	- X2=X1
	- X1=RX2+CX0
	- F2=F1
	- S23DF1=(X1-XM(2)2-XM(1)2)**2
	- & -(2D0XM(1)XM(2))**2
	- S23DF2=(X1-XM(3)2-XM(5)2)**2
	- & -(2D0XM(3)XM(5))**2
	- S23DF1=S23DF1*EPS
	- S23DF2=S23DF2*EPS
	- S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X1)
	- 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)/(2D0S12)
	- S23DF1=(S12-XM(2)2-XM(1)2)**2
	- &-(2D0XM(1)XM(2))**2
	- S23DF2=(S12-XM(3)2-XM(5)2)**2
	- &-(2D0XM(3)XM(5))**2
	- S23DF1=S23DF1*EPS
	- S23DF2=S23DF2*EPS
	- S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0S12)
	- 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 + GMMZ2
	- 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-EIXW)/XW1)OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
	-c QLR=-DCMPLX((T3I-EIXW)/XW1)ORPP*PROPZ+DCONJG(GLIJ)
	-c &/DCMPLX(TH-XML2)
	-c QRL=-DCMPLX((EIXW)/XW1)OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
	-c QRR=DCMPLX((EIXW)/XW1)ORPP*PROPZ
	-c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
	- WT=-((ABS(QLL)2+ABS(QRR)2)*WU2+
	- &(ABS(QRL)2+ABS(QLR)2)*WT2+
	- &2D0DBLE(QLRDCONJG(QLL)+QRLDCONJG(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(D1D1-XM(1)*2)
	- P2=SQRT(D2D2-XM(2)*2)
	- P3=SQRT(D3D3-XM(3)*2)
	- CTHE1=2D0*PYR(0)-1D0
	- ANG1=2D0PYR(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)=P1STHE1CPHI1
	- P(N+1,2)=P1STHE1SPHI1
	- P(N+1,3)=P1*CTHE1
	- P(N+1,4)=D1
	-
	-C...GET CPHI3
	- ANG3=2D0PYR(0)PARU(1)
	- CPHI3=COS(ANG3)
	- SPHI3=SIN(ANG3)
	- CTHE3=(P22-P12-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)=-P3STHE3CPHI3CTHE1CPHI1
	- &+P3STHE3SPHI3*SPHI1
	- &+P3CTHE3STHE1*CPHI1
	- P(N+3,2)=-P3STHE3CPHI3CTHE1SPHI1
	- &-P3STHE3SPHI3*CPHI1
	- &+P3CTHE3STHE1*SPHI1
	- P(N+3,3)=P3STHE3CPHI3*STHE1
	- &+P3CTHE3CTHE1
	- 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-2D0PARU(102))/(2D0PARU(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)/(2D0SINWCOSW)
	- 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 = RMZ2DSQRT(SW2CW2)
	- SQRDEL = DSQRT( (A-B)*2 + 4C**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= SWW12/(SWW12 + 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.D0XMNKK*2/SHAT)
	- PI=DACOS(-1.D0)
	-c++lnk
	-c Q2=RUED(0)*2+(TPUP-RUED(0)**4)/SP
	- Q2=RUED(1)*2+(TPUP-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.ALPHAS2/(SPTPUP)*2
	- XMUED=FAC1(XMNKK4(6.TP4+18.TP*3UP+
	- & 24.TP2UP*2+18.TPUP3+6.UP**4)
	- & +XMNKK*2(6.TP4UP+12.TP3UP**2+
	- & 12.TP2UP*3+6TPUP*4)
	- & +2.TP6+6TP*5UP+13TP4UP**2+
	- & 15.TP3UP*3+13TP*2UP**4+
	- & 6.TPUP*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.ALPHAS2/(SPTPUP)*2
	- XMUED=FAC1(12.SPUP5+5.SP*2UP*4+22.SP*3UP**3+
	- & 5.SP4UP*2+12.SP*5UP)
	- XMUED=COMFAC2.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.ALPHAS2/(TPUP)**2
	- XMUED=FAC1*
	- & (XMNKK*2(8TP3+4./3.TP*2UP+4./3.TPUP**2
	- & +8.UP3)+8.TP*4+56./3.TP*3UP+
	- & 20.TP2UP*2+56./3.
	- & TPUP3+8.UP**4)
	- SIGH(NCHN)=COMFAC2.XMUED
	- ISIG(NCHN,3)=1
	- IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
	- ELSE
	- FAC1=2./9.ALPHAS2/TP*2
	- XMUED=FAC1(-XMNKK2SP+SP*2+0.25TP**2)
	- SIGH(NCHN)=COMFAC2.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.ALPHAS2/(SPTPUP)*2
	- XMUED=FAC1(-XMNKK4(8.TPUP*3+8.TP*2UP*2+8.TP*3UP
	- + +4.UP4+4TP**4)
	- + -XMNKK*2(0.5TPUP*4+4.TP*2UP*3+15./2.TP**3
	- + UP2+ 4.TP*4UP)+TPUP5-0.25TP*2UP**4+
	- + 2.TP3UP*3-0.25TP*4UP2+TP5*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.ALPHAS21./(SPTP)*2
	- XMUED=FAC1(XMNKK2SP(4.TP*2-SPTP-SP**2)+
	- & 4.TP4+3.SPTP3+11./12.TP*2SP**2-
	- & 2./3.SP3TP+SP**4)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=COMFAC2.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.ALPHAS2/TP*2
	- XMUED=FAC1(-XMNKK2SP+SP*2+0.25TP**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.ALPHAS2/TP*2
	- XMUED=FAC1(4.XMNKK*2SP+4.SP2+8.SPTP+5TP**2)
	- SIGH(NCHN)=COMFAC2.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.ALPHAS2/(TPUP)**2
	- XMUED=FAC1(-8.XMNKK*2(TP3+TP2UP+TPUP2+UP3)
	- & +8.TP4+4.TP*2UP*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.ALPHAS2/TP*2
	- XMUED=FAC1(4.XMNKK*2SP+4.SP2+8.SPTP+5TP**2)
	- SIGH(NCHN)=COMFAC2.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.ALPHAS21./(SP)**2
	- XMUED=FAC1(2.XMNKK*2SP+SP*2+2.SPTP+2.TP**2)
	- NCHN=NCHN+1
	- ISIG(NCHN,1)=I
	- ISIG(NCHN,2)=-I
	- ISIG(NCHN,3)=1
	- SIGH(NCHN)=COMFAC2.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-2D0XMGAMK*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-2D0XMGAMK*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(xx2+yy2) 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*2RINVNDIM/XMD(NDIM+2)
	- XND=(NDIM-1.)/2.
	- GAMMN=PYGAMM(XND)
	- FAC=FAC/GAMMN
	- XXA=DSQRT(XX2+YY2)
	- GRADEN=4./PI2 * (YY2/(1.-YY2)*2)(1.+DCOS(PI*YY))
	-
	- PYGRAW=DJAC*
	- + FACXX(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(xx2+yy2) 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)XMNKK3/X4
	- + ((1.-X2)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(AA + BB) .
	-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(YR2-YI2+XR,2.0D0YRYI+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(AA + BB) .
	-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(YR2-YI2+XR,2.0D0YRYI+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 = BRS2 + BIS2
	- CR = (ARSBRS + AISBIS)/S
	- CI = (AISBRS - ARSBIS)/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(A2+B2) 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(AA + BB) .
	-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-(UUT)/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-(UUT)/H)A(I-(UUT)/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/60/,WIDWSV/60D0/,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)*2XW/PARU(1)
	- AS=PYALPS(SH)
	- RADC=1D0+AS/PARU(1)
	-
	- IF(KFLA.EQ.23) THEN
	-C...Z0:
	- XWC=1D0/(16D0XWXW1)
	- FAC=(AEMXWC/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-4D0EFXWV
	- FCOF=3D0*RADC
	- IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOFPYHFTH(SH,SHRM1,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-4D0EFXWV
	- FCOF=1D0
	- ENDIF
	- BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
	- WDTP(I)=FACFCOF(VF*2(1D0+2D0RM1)+AF2(1D0-4D0RM1))
	- & BE34
	- WDTP(0)=WDTP(0)+WDTP(I)
	- 130 CONTINUE
	-
	-
	- ELSEIF(KFLA.EQ.24) THEN
	-C...W+/-:
	- FAC=(AEM/(24D0XW))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=3D0RADCVCKM((I-1)/4+1,MOD(I-1,4)+1)
	- ELSEIF(I.LE.20) THEN
	-C...W+/- -> l+/- + nu
	- FCOF=1D0
	- ENDIF
	- WDTP(I)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	- & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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+2D0RM1)SQRT(1D0-4D0RM1)*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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT-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=3RVLAMP(I,J,K)2SFMIX(KFSM,2ICNT-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=3RVLAMP(I,J,K)2SFMIX(KFSM,2ICNT-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=3RVLAMP(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)*2SFMIX(KFSM,2ICNT-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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT-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,2ICNT)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=2RVLAMB(I,J,K)2SFMIX(KFSM,2ICNT)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=2RVLAMB(I,J,K)2SFMIX(KFSM,2ICNT)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 = 2SQRT(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=2D0SQRT(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=GWZPMIX(NCHI,3)/(2D0COSB*WMASS)
	- C1U=GWZPMIX(NCHI,4)/(2D0SINB*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(CMSC1*SFMIX(I,1) + SFMIX(I,2)
	- & (C2-C3SINW**2))
	- AB(1,I,2)=ISM(CMSC1*SFMIX(I,3) + SFMIX(I,4)
	- & (C2-C3SINW**2))
	- AB(2,I,1)= CMSC1SFMIX(I,2) - SFMIX(I,1)(C2+C3(5D-1-SINW
	- & **2))
	- AB(2,I,2)=CMSC1SFMIX(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(CMSC1*SFMIX(J,1) - SFMIX(J,2)
	- & ED(C2-C3SINW*2))
	- AB(1,J,2)=ISM(CMSC1*SFMIX(J,3) - SFMIX(J,4)
	- & ED(C2-C3SINW*2))
	- AB(2,J,1)=CMSC1SFMIX(J,2) + SFMIX(J,1)
	- & (EDC2-C3(1D0/2D0+EDSINW**2))
	- AB(2,J,2)=CMSC1SFMIX(J,4) + SFMIX(J,3)
	- & (EDC2-C3(1D0/2D0+EDSINW**2))
	-C...Inermediate sup
	- J=J+1
	- CMS=RMQ(J)
	- AB(1,J,1)=ISM(CMSC1U*SFMIX(J,1) - SFMIX(J,2)
	- & EU(C2-C3SINW*2))
	- AB(1,J,2)=ISM(CMSC1U*SFMIX(J,3) - SFMIX(J,4)
	- & EU(C2-C3SINW*2))
	- AB(2,J,1)=CMSC1USFMIX(J,2) + SFMIX(J,1)
	- & (EUC2+C3(1D0/2D0-EUSINW**2))
	- AB(2,J,2)=CMSC1USFMIX(J,4) + SFMIX(J,3)
	- & (EUC2+C3(1D0/2D0-EUSINW**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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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 = 4PARU(103)PARU(1)/PARU(102)
	- C1U = UMIX(NCHI,2)/(SQRT(2D0)COSBWMASS)
	- C1V = VMIX(NCHI,2)/(SQRT(2D0)SINBWMASS)
	- 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)C1USFMIX(I,2) +
	- & SFMIX(I,1)*C2
	- AB(2,I,2) = -PMAS(PYCOMP(I),1)C1USFMIX(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)C1VSFMIX(J,1)
	- AB(1,J,2) = -RMQ(J+1)C1VSFMIX(J,3)
	- AB(2,J,1) = -ISM(RMQ(J)C1USFMIX(J,2) - SFMIX(J,1)C2)
	- AB(2,J,2) = -ISM(RMQ(J)C1USFMIX(J,4) - SFMIX(J,3)C2)
	-C...Intermediate sup
	- J=J+1
	- AB(1,J,1) = -RMQ(J-1)C1USFMIX(J,1)
	- AB(1,J,2) = -RMQ(J-1)C1USFMIX(J,3)
	- AB(2,J,1) = -ISM(RMQ(J)C1VSFMIX(J,2) - SFMIX(J,1)C3)
	- AB(2,J,2) = -ISM(RMQ(J)C1VSFMIX(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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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
	- & /((2PARU(1)RMS(0))*332)
	-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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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
	- & + RVLJIKRVLIJK XRESIJ
	- XLAM(LKNT)=XLAM(LKNT)RVLAMC/((2PARU(1)RMS(0))332)
	-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
	- & + RVLIJKRVLJKI XRESIJ
	- & + RVLIJKRVLKIJ XRESIK
	- & + RVLJKIRVLKIJ XRESJK
	- XLAM(LKNT)=XLAM(LKNT)RVLAMC/((2.PARU(1)RMS(0))332)
	-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 = 4D0PARU(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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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/((2PARU(1)RMS(0))332)
	-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./(4SM(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./(4SM(1))(SM(1)-(PMAS(KC(3),1))2)2
	- ELSE IF (MODE.EQ.3) THEN
	- P2CM=1./(4SM(1))(SM(1)-(PMAS(KC(2),1))2)2
	- ELSE
	- P2CM=SM(1)/4.
	- ENDIF
	-C...Calculate Width
	- PYRVSB=RM2SQRT(MAX(0D0,P2CM))/(8PARU(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),2J+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),2J+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),2J+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 + PREFPYRVI3(1,3,2)
	- & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
	- & SFMIX(INTRES(IDR2,1),2IKR2+INTRES(IDR2,3)-1)
	- ENDIF
	-
	- IDR = IKR1+4
	- IDR2 = IKR2
	- IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
	- XLAM = XLAM + PREFPYRVI3(1,2,3)
	- & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
	- & SFMIX(INTRES(IDR2,1),2IKR2+INTRES(IDR2,3)-1)
	- ENDIF
	-
	- IDR = IKR1+4
	- IDR2 = IKR2+2
	- IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
	- XLAM = XLAM + PREFPYRVI3(2,1,3)
	- & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
	- & SFMIX(INTRES(IDR2,1),2IKR2+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 = 4D0E2E3
	- PYRVG1 = DELTAYRVRX(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,E22-RM(2)2))
	- SR2 = SQRT(MAX(0D0,E32-RM(3)2))
	- DELTAY = 4D0SR1SR2
	- 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 = DELTAYRVR(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 = 4D0E2E3
	- PYRVG2 = DELTAYRVSX(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,E22-RM(2)2))
	- SR2 = SQRT(MAX(0D0,E32-RM(3)2))
	- DELTAY = 4D0SR1SR2
	- PYRVG2 = DELTAYRVS(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 = 4D0E2E3
	- 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,E22-RM(2)2))
	- SR2 = SQRT(MAX(0D0,E32-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 = RVSB(1)B(2)XY
	- 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)(XY-(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-RM2)2+RM*2RW**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)
	- & +W1W2M1*M2)
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY1ENT
	-C...Stores one parton/particle in commonblock PYJETS.
	-
	- SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Standard checks.
	- MSTU(28)=0
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IPA=MAX(1,IABS(IP))
	- IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
	- &'(PY1ENT:) writing outside PYJETS memory')
	- KC=PYCOMP(KF)
	- IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
	-
	-C...Find mass. Reset K, P and V vectors.
	- PM=0D0
	- IF(MSTU(10).EQ.1) PM=P(IPA,5)
	- IF(MSTU(10).GE.2) PM=PYMASS(KF)
	- DO 100 J=1,5
	- K(IPA,J)=0
	- P(IPA,J)=0D0
	- V(IPA,J)=0D0
	- 100 CONTINUE
	-
	-C...Store parton/particle in K and P vectors.
	- K(IPA,1)=1
	- IF(IP.LT.0) K(IPA,1)=2
	- K(IPA,2)=KF
	- P(IPA,5)=PM
	- P(IPA,4)=MAX(PE,PM)
	- PA=SQRT(P(IPA,4)2-P(IPA,5)2)
	- P(IPA,1)=PASIN(THE)COS(PHI)
	- P(IPA,2)=PASIN(THE)SIN(PHI)
	- P(IPA,3)=PA*COS(THE)
	-
	-C...Set N. Optionally fragment/decay.
	- N=IPA
	- IF(IP.EQ.0) CALL PYEXEC
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY2ENT
	-C...Stores two partons/particles in their CM frame,
	-C...with the first along the +z axis.
	-
	- SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Standard checks.
	- MSTU(28)=0
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IPA=MAX(1,IABS(IP))
	- IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
	- &'(PY2ENT:) writing outside PYJETS memory')
	- KC1=PYCOMP(KF1)
	- KC2=PYCOMP(KF2)
	- IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
	- &'(PY2ENT:) unknown flavour code')
	-
	-C...Find masses. Reset K, P and V vectors.
	- PM1=0D0
	- IF(MSTU(10).EQ.1) PM1=P(IPA,5)
	- IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
	- PM2=0D0
	- IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
	- IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
	- DO 110 I=IPA,IPA+1
	- DO 100 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	-
	-C...Check flavours.
	- KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
	- KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
	- IF(MSTU(19).EQ.1) THEN
	- MSTU(19)=0
	- ELSE
	- IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
	- & '(PY2ENT:) unphysical flavour combination')
	- ENDIF
	- K(IPA,2)=KF1
	- K(IPA+1,2)=KF2
	-
	-C...Store partons/particles in K vectors for normal case.
	- IF(IP.GE.0) THEN
	- K(IPA,1)=1
	- IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
	- K(IPA+1,1)=1
	-
	-C...Store partons in K vectors for parton shower evolution.
	- ELSE
	- K(IPA,1)=3
	- K(IPA+1,1)=3
	- K(IPA,4)=MSTU(5)*(IPA+1)
	- K(IPA,5)=K(IPA,4)
	- K(IPA+1,4)=MSTU(5)*IPA
	- K(IPA+1,5)=K(IPA+1,4)
	- ENDIF
	-
	-C...Check kinematics and store partons/particles in P vectors.
	- IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
	- &'(PY2ENT:) energy smaller than sum of masses')
	- PA=SQRT(MAX(0D0,(PECM2-PM12-PM22)2-(2D0PM1PM2)**2))/
	- &(2D0*PECM)
	- P(IPA,3)=PA
	- P(IPA,4)=SQRT(PM12+PA2)
	- P(IPA,5)=PM1
	- P(IPA+1,3)=-PA
	- P(IPA+1,4)=SQRT(PM22+PA2)
	- P(IPA+1,5)=PM2
	-
	-C...Set N. Optionally fragment/decay.
	- N=IPA+1
	- IF(IP.EQ.0) CALL PYEXEC
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY3ENT
	-C...Stores three partons or particles in their CM frame,
	-C...with the first along the +z axis and the third in the (x,z)
	-C...plane with x > 0.
	-
	- SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Standard checks.
	- MSTU(28)=0
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IPA=MAX(1,IABS(IP))
	- IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
	- &'(PY3ENT:) writing outside PYJETS memory')
	- KC1=PYCOMP(KF1)
	- KC2=PYCOMP(KF2)
	- KC3=PYCOMP(KF3)
	- IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
	- &'(PY3ENT:) unknown flavour code')
	-
	-C...Find masses. Reset K, P and V vectors.
	- PM1=0D0
	- IF(MSTU(10).EQ.1) PM1=P(IPA,5)
	- IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
	- PM2=0D0
	- IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
	- IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
	- PM3=0D0
	- IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
	- IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
	- DO 110 I=IPA,IPA+2
	- DO 100 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	-
	-C...Check flavours.
	- KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
	- KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
	- KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
	- IF(MSTU(19).EQ.1) THEN
	- MSTU(19)=0
	- ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
	- ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
	- & KQ1+KQ3.EQ.4)) THEN
	- ELSE
	- CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
	- ENDIF
	- K(IPA,2)=KF1
	- K(IPA+1,2)=KF2
	- K(IPA+2,2)=KF3
	-
	-C...Store partons/particles in K vectors for normal case.
	- IF(IP.GE.0) THEN
	- K(IPA,1)=1
	- IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
	- K(IPA+1,1)=1
	- IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
	- K(IPA+2,1)=1
	-
	-C...Store partons in K vectors for parton shower evolution.
	- ELSE
	- K(IPA,1)=3
	- K(IPA+1,1)=3
	- K(IPA+2,1)=3
	- KCS=4
	- IF(KQ1.EQ.-1) KCS=5
	- K(IPA,KCS)=MSTU(5)*(IPA+1)
	- K(IPA,9-KCS)=MSTU(5)*(IPA+2)
	- K(IPA+1,KCS)=MSTU(5)*(IPA+2)
	- K(IPA+1,9-KCS)=MSTU(5)*IPA
	- K(IPA+2,KCS)=MSTU(5)*IPA
	- K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
	- ENDIF
	-
	-C...Check kinematics.
	- MKERR=0
	- IF(0.5D0X1PECM.LE.PM1.OR.0.5D0(2D0-X1-X3)PECM.LE.PM2.OR.
	- &0.5D0X3PECM.LE.PM3) MKERR=1
	- PA1=SQRT(MAX(1D-10,(0.5D0X1PECM)2-PM12))
	- PA2=SQRT(MAX(1D-10,(0.5D0(2D0-X1-X3)PECM)2-PM22))
	- PA3=SQRT(MAX(1D-10,(0.5D0X3PECM)2-PM32))
	- CTHE2=(PA32-PA12-PA2*2)/(2D0PA1*PA2)
	- CTHE3=(PA22-PA12-PA3*2)/(2D0PA1*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(PA12+PM12)
	- P(IPA,5)=PM1
	- P(IPA+2,1)=PA3SQRT(1D0-CTHE3*2)
	- P(IPA+2,3)=PA3*CTHE3
	- P(IPA+2,4)=SQRT(PA32+PM32)
	- P(IPA+2,5)=PM3
	- P(IPA+1,1)=-P(IPA+2,1)
	- P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
	- P(IPA+1,4)=SQRT(P(IPA+1,1)2+P(IPA+1,3)2+PM2**2)
	- P(IPA+1,5)=PM2
	-
	-C...Set N. Optionally fragment/decay.
	- N=IPA+2
	- IF(IP.EQ.0) CALL PYEXEC
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY4ENT
	-C...Stores four partons or particles in their CM frame, with
	-C...the first along the +z axis, the last in the xz plane with x > 0
	-C...and the second having y < 0 and y > 0 with equal probability.
	-
	- SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Standard checks.
	- MSTU(28)=0
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IPA=MAX(1,IABS(IP))
	- IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
	- &'(PY4ENT:) writing outside PYJETS momory')
	- KC1=PYCOMP(KF1)
	- KC2=PYCOMP(KF2)
	- KC3=PYCOMP(KF3)
	- KC4=PYCOMP(KF4)
	- IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
	- &'(PY4ENT:) unknown flavour code')
	-
	-C...Find masses. Reset K, P and V vectors.
	- PM1=0D0
	- IF(MSTU(10).EQ.1) PM1=P(IPA,5)
	- IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
	- PM2=0D0
	- IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
	- IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
	- PM3=0D0
	- IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
	- IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
	- PM4=0D0
	- IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
	- IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
	- DO 110 I=IPA,IPA+3
	- DO 100 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	-
	-C...Check flavours.
	- KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
	- KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
	- KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
	- KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
	- IF(MSTU(19).EQ.1) THEN
	- MSTU(19)=0
	- ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
	- ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
	- & KQ1+KQ4.EQ.4)) THEN
	- ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
	- & THEN
	- ELSE
	- CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
	- ENDIF
	- K(IPA,2)=KF1
	- K(IPA+1,2)=KF2
	- K(IPA+2,2)=KF3
	- K(IPA+3,2)=KF4
	-
	-C...Store partons/particles in K vectors for normal case.
	- IF(IP.GE.0) THEN
	- K(IPA,1)=1
	- IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
	- K(IPA+1,1)=1
	- IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
	- & K(IPA+1,1)=2
	- K(IPA+2,1)=1
	- IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
	- K(IPA+3,1)=1
	-
	-C...Store partons for parton shower evolution from q-g-g-qbar or
	-C...g-g-g-g event.
	- ELSEIF(KQ1+KQ2.NE.0) THEN
	- K(IPA,1)=3
	- K(IPA+1,1)=3
	- K(IPA+2,1)=3
	- K(IPA+3,1)=3
	- KCS=4
	- IF(KQ1.EQ.-1) KCS=5
	- K(IPA,KCS)=MSTU(5)*(IPA+1)
	- K(IPA,9-KCS)=MSTU(5)*(IPA+3)
	- K(IPA+1,KCS)=MSTU(5)*(IPA+2)
	- K(IPA+1,9-KCS)=MSTU(5)*IPA
	- K(IPA+2,KCS)=MSTU(5)*(IPA+3)
	- K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
	- K(IPA+3,KCS)=MSTU(5)*IPA
	- K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
	-
	-C...Store partons for parton shower evolution from q-qbar-q-qbar event.
	- ELSE
	- K(IPA,1)=3
	- K(IPA+1,1)=3
	- K(IPA+2,1)=3
	- K(IPA+3,1)=3
	- K(IPA,4)=MSTU(5)*(IPA+1)
	- K(IPA,5)=K(IPA,4)
	- K(IPA+1,4)=MSTU(5)*IPA
	- K(IPA+1,5)=K(IPA+1,4)
	- K(IPA+2,4)=MSTU(5)*(IPA+3)
	- K(IPA+2,5)=K(IPA+2,4)
	- K(IPA+3,4)=MSTU(5)*(IPA+2)
	- K(IPA+3,5)=K(IPA+3,4)
	- ENDIF
	-
	-C...Check kinematics.
	- MKERR=0
	- IF(0.5D0X1PECM.LE.PM1.OR.0.5D0X2PECM.LE.PM2.OR.
	- &0.5D0(2D0-X1-X2-X4)PECM.LE.PM3.OR.0.5D0X4PECM.LE.PM4)
	- &MKERR=1
	- PA1=SQRT(MAX(1D-10,(0.5D0X1PECM)2-PM12))
	- PA2=SQRT(MAX(1D-10,(0.5D0X2PECM)2-PM22))
	- PA4=SQRT(MAX(1D-10,(0.5D0X4PECM)2-PM42))
	- X24=X1+X2+X4-1D0-X12-X14+(PM32-PM12-PM22-PM42)/PECM**2
	- CTHE4=(X1X4-2D0X14)PECM2/(4D0PA1*PA4)
	- IF(ABS(CTHE4).GE.1.002D0) MKERR=1
	- CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
	- STHE4=SQRT(1D0-CTHE4**2)
	- CTHE2=(X1X2-2D0X12)PECM2/(4D0PA1*PA2)
	- IF(ABS(CTHE2).GE.1.002D0) MKERR=1
	- CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
	- STHE2=SQRT(1D0-CTHE2**2)
	- CPHI2=((X2X4-2D0X24)PECM2-4D0PA2CTHE2PA4*CTHE4)/
	- &MAX(1D-8PECM2,4D0PA2STHE2PA4*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(PA12+PM12)
	- P(IPA,5)=PM1
	- P(IPA+3,1)=PA4*STHE4
	- P(IPA+3,3)=PA4*CTHE4
	- P(IPA+3,4)=SQRT(PA42+PM42)
	- P(IPA+3,5)=PM4
	- P(IPA+1,1)=PA2STHE2CPHI2
	- P(IPA+1,2)=PA2STHE2SQRT(1D0-CPHI2*2)(-1D0)**INT(PYR(0)+0.5D0)
	- P(IPA+1,3)=PA2*CTHE2
	- P(IPA+1,4)=SQRT(PA22+PM22)
	- 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+PM32)
	- P(IPA+2,5)=PM3
	-
	-C...Set N. Optionally fragment/decay.
	- N=IPA+3
	- IF(IP.EQ.0) CALL PYEXEC
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY2FRM
	-C...An interface from a two-fermion generator to include
	-C...parton showers and hadronization.
	-
	- SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYJETS/,/PYDAT1/
	-C...Local arrays.
	- DIMENSION IJOIN(2),INTAU(2)
	-
	-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(2)
	- ENDIF
	-
	-C...Loop through entries and pick up all final fermions/antifermions.
	- I1=0
	- I2=0
	- DO 100 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	- KFA=IABS(K(I,2))
	- IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
	- IF(K(I,2).GT.0) THEN
	- IF(I1.EQ.0) THEN
	- I1=I
	- ELSE
	- CALL PYERRM(16,'(PY2FRM:) more than one fermion')
	- ENDIF
	- ELSE
	- IF(I2.EQ.0) THEN
	- I2=I
	- ELSE
	- CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
	- ENDIF
	- ENDIF
	- ENDIF
	- 100 CONTINUE
	-
	-C...Check that event is arranged according to conventions.
	- IF(I1.EQ.0.OR.I2.EQ.0) THEN
	- CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
	- ENDIF
	- IF(I2.LT.I1) THEN
	- CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
	- ENDIF
	-
	-C...Check whether fermion pair is quarks or leptons.
	- IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
	- IQL12=1
	- ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
	- IQL12=2
	- ELSE
	- CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
	- ENDIF
	-
	-C...Decide whether to allow or not photon radiation in showers.
	- MSTJ(41)=2
	- IF(IRAD.EQ.0) MSTJ(41)=1
	-
	-C...Do colour joining and parton showers.
	- IP1=I1
	- IP2=I2
	- IF(IQL12.EQ.1) THEN
	- IJOIN(1)=IP1
	- IJOIN(2)=IP2
	- CALL PYJOIN(2,IJOIN)
	- ENDIF
	- IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
	- PM12S=(P(IP1,4)+P(IP2,4))2-(P(IP1,1)+P(IP2,1))2-
	- & (P(IP1,2)+P(IP2,2))2-(P(IP1,3)+P(IP2,3))2
	- CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
	- ENDIF
	-
	-C...Do fragmentation and decays. Possibly except tau decay.
	- IF(ITAU.EQ.0) THEN
	- NTAU=0
	- DO 110 I=1,N
	- IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
	- NTAU=NTAU+1
	- INTAU(NTAU)=I
	- K(I,1)=11
	- ENDIF
	- 110 CONTINUE
	- ENDIF
	- CALL PYEXEC
	- IF(ITAU.EQ.0) THEN
	- DO 120 I=1,NTAU
	- K(INTAU(I),1)=1
	- 120 CONTINUE
	- ENDIF
	-
	-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(1)
	- ENDIF
	-
	- END
	-
	-C*********************************************************************
	-
	-C...PY4FRM
	-C...An interface from a four-fermion generator to include
	-C...parton showers and hadronization.
	-
	- SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
	-C...Local arrays.
	- DIMENSION IJOIN(2),INTAU(4)
	-
	-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(2)
	- ENDIF
	-
	-C...Loop through entries and pick up all final fermions/antifermions.
	- I1=0
	- I2=0
	- I3=0
	- I4=0
	- DO 100 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	- KFA=IABS(K(I,2))
	- IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
	- IF(K(I,2).GT.0) THEN
	- IF(I1.EQ.0) THEN
	- I1=I
	- ELSEIF(I3.EQ.0) THEN
	- I3=I
	- ELSE
	- CALL PYERRM(16,'(PY4FRM:) more than two fermions')
	- ENDIF
	- ELSE
	- IF(I2.EQ.0) THEN
	- I2=I
	- ELSEIF(I4.EQ.0) THEN
	- I4=I
	- ELSE
	- CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
	- ENDIF
	- ENDIF
	- ENDIF
	- 100 CONTINUE
	-
	-C...Check that event is arranged according to conventions.
	- IF(I3.EQ.0.OR.I4.EQ.0) THEN
	- CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
	- ENDIF
	- IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
	- CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
	- ENDIF
	-
	-C...Check which fermion pairs are quarks and which leptons.
	- IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
	- IQL12=1
	- ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
	- IQL12=2
	- ELSE
	- CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
	- ENDIF
	- IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
	- IQL34=1
	- ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
	- IQL34=2
	- ELSE
	- CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
	- ENDIF
	-
	-C...Decide whether to allow or not photon radiation in showers.
	- MSTJ(41)=2
	- IF(IRAD.EQ.0) MSTJ(41)=1
	-
	-C...Decide on dipole pairing.
	- IP1=I1
	- IP2=I2
	- IP3=I3
	- IP4=I4
	- IF(IQL12.EQ.IQL34) THEN
	- R1SQ=A1SQ
	- R2SQ=A2SQ
	- DELTA=ATOTSQ-A1SQ-A2SQ
	- IF(ISTRAT.EQ.1) THEN
	- IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
	- IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
	- ELSEIF(ISTRAT.EQ.2) THEN
	- IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
	- IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
	- ENDIF
	- IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
	- IP2=I4
	- IP4=I2
	- ENDIF
	- ENDIF
	-
	-C...If colour reconnection then bookkeep W+W- or Z0Z0
	-C...and copy q qbar q qbar consecutively.
	- IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
	- K(N+1,1)=11
	- K(N+1,3)=IP1
	- K(N+1,4)=N+3
	- K(N+1,5)=N+4
	- K(N+2,1)=11
	- K(N+2,3)=IP3
	- K(N+2,4)=N+5
	- K(N+2,5)=N+6
	- IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
	- K(N+1,2)=23
	- K(N+2,2)=23
	- MINT(1)=22
	- ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
	- K(N+1,2)=24
	- K(N+2,2)=-24
	- MINT(1)=25
	- ELSE
	- K(N+1,2)=-24
	- K(N+2,2)=24
	- MINT(1)=25
	- ENDIF
	- DO 110 J=1,5
	- K(N+3,J)=K(IP1,J)
	- K(N+4,J)=K(IP2,J)
	- K(N+5,J)=K(IP3,J)
	- K(N+6,J)=K(IP4,J)
	- P(N+1,J)=P(IP1,J)+P(IP2,J)
	- P(N+2,J)=P(IP3,J)+P(IP4,J)
	- P(N+3,J)=P(IP1,J)
	- P(N+4,J)=P(IP2,J)
	- P(N+5,J)=P(IP3,J)
	- P(N+6,J)=P(IP4,J)
	- V(N+1,J)=V(IP1,J)
	- V(N+2,J)=V(IP3,J)
	- V(N+3,J)=V(IP1,J)
	- V(N+4,J)=V(IP2,J)
	- V(N+5,J)=V(IP3,J)
	- V(N+6,J)=V(IP4,J)
	- 110 CONTINUE
	- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	- & P(N+1,3)**2))
	- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)2-P(N+2,1)2-P(N+2,2)**2-
	- & P(N+2,3)**2))
	- K(N+3,3)=N+1
	- K(N+4,3)=N+1
	- K(N+5,3)=N+2
	- K(N+6,3)=N+2
	-C...Remove original q qbar q qbar and update counters.
	- K(IP1,1)=K(IP1,1)+10
	- K(IP2,1)=K(IP2,1)+10
	- K(IP3,1)=K(IP3,1)+10
	- K(IP4,1)=K(IP4,1)+10
	- IW1=N+1
	- IW2=N+2
	- NSD1=N+2
	- IP1=N+3
	- IP2=N+4
	- IP3=N+5
	- IP4=N+6
	- N=N+6
	- ENDIF
	-
	-C...Do colour joinings and parton showers.
	- IF(IQL12.EQ.1) THEN
	- IJOIN(1)=IP1
	- IJOIN(2)=IP2
	- CALL PYJOIN(2,IJOIN)
	- ENDIF
	- IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
	- PM12S=(P(IP1,4)+P(IP2,4))2-(P(IP1,1)+P(IP2,1))2-
	- & (P(IP1,2)+P(IP2,2))2-(P(IP1,3)+P(IP2,3))2
	- CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
	- ENDIF
	- NAFT1=N
	- IF(IQL34.EQ.1) THEN
	- IJOIN(1)=IP3
	- IJOIN(2)=IP4
	- CALL PYJOIN(2,IJOIN)
	- ENDIF
	- IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
	- PM34S=(P(IP3,4)+P(IP4,4))2-(P(IP3,1)+P(IP4,1))2-
	- & (P(IP3,2)+P(IP4,2))2-(P(IP3,3)+P(IP4,3))2
	- CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
	- ENDIF
	-
	-C...Optionally do colour reconnection.
	- MINT(32)=0
	- MSTI(32)=0
	- IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
	- CALL PYRECO(IW1,IW2,NSD1,NAFT1)
	- MSTI(32)=MINT(32)
	- ENDIF
	-
	-C...Do fragmentation and decays. Possibly except tau decay.
	- IF(ITAU.EQ.0) THEN
	- NTAU=0
	- DO 120 I=1,N
	- IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
	- NTAU=NTAU+1
	- INTAU(NTAU)=I
	- K(I,1)=11
	- ENDIF
	- 120 CONTINUE
	- ENDIF
	- CALL PYEXEC
	- IF(ITAU.EQ.0) THEN
	- DO 130 I=1,NTAU
	- K(INTAU(I),1)=1
	- 130 CONTINUE
	- ENDIF
	-
	-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(1)
	- ENDIF
	-
	- END
	-
	-C*********************************************************************
	-
	-C...PY6FRM
	-C...An interface from a six-fermion generator to include
	-C...parton showers and hadronization.
	-
	- SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYJETS/,/PYDAT1/
	-C...Local arrays.
	- DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
	-
	-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(2)
	- ENDIF
	-
	-C...Loop through entries and pick up all final fermions/antifermions.
	- I1=0
	- I2=0
	- I3=0
	- I4=0
	- I5=0
	- I6=0
	- DO 100 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	- KFA=IABS(K(I,2))
	- IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
	- IF(K(I,2).GT.0) THEN
	- IF(I1.EQ.0) THEN
	- I1=I
	- ELSEIF(I3.EQ.0) THEN
	- I3=I
	- ELSEIF(I5.EQ.0) THEN
	- I5=I
	- ELSE
	- CALL PYERRM(16,'(PY6FRM:) more than three fermions')
	- ENDIF
	- ELSE
	- IF(I2.EQ.0) THEN
	- I2=I
	- ELSEIF(I4.EQ.0) THEN
	- I4=I
	- ELSEIF(I6.EQ.0) THEN
	- I6=I
	- ELSE
	- CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
	- ENDIF
	- ENDIF
	- ENDIF
	- 100 CONTINUE
	-
	-C...Check that event is arranged according to conventions.
	- IF(I5.EQ.0.OR.I6.EQ.0) THEN
	- CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
	- ENDIF
	- IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
	- CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
	- ENDIF
	-
	-C...Check which fermion pairs are quarks and which leptons.
	- IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
	- IQL12=1
	- ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
	- IQL12=2
	- ELSE
	- CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
	- ENDIF
	- IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
	- IQL34=1
	- ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
	- IQL34=2
	- ELSE
	- CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
	- ENDIF
	- IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
	- IQL56=1
	- ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
	- IQL56=2
	- ELSE
	- CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
	- ENDIF
	-
	-C...Decide whether to allow or not photon radiation in showers.
	- MSTJ(41)=2
	- IF(IRAD.EQ.0) MSTJ(41)=1
	-
	-C...Allow dipole pairings only among leptons and quarks separately.
	- P12D=P12
	- P13D=0D0
	- IF(IQL34.EQ.IQL56) P13D=P13
	- P21D=0D0
	- IF(IQL12.EQ.IQL34) P21D=P21
	- P23D=0D0
	- IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
	- P31D=0D0
	- IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
	- P32D=0D0
	- IF(IQL12.EQ.IQL56) P32D=P32
	-
	-C...Decide whether t+tbar.
	- ITOP=0
	- IF(PYR(0).LT.PTOP) THEN
	- ITOP=1
	-
	-C...If t+tbar: reconstruct t's.
	- IT=N+1
	- ITB=N+2
	- DO 110 J=1,5
	- K(IT,J)=0
	- K(ITB,J)=0
	- P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
	- P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
	- V(IT,J)=0D0
	- V(ITB,J)=0D0
	- 110 CONTINUE
	- K(IT,1)=1
	- K(ITB,1)=1
	- K(IT,2)=6
	- K(ITB,2)=-6
	- P(IT,5)=SQRT(MAX(0D0,P(IT,4)2-P(IT,1)2-P(IT,2)**2-
	- & P(IT,3)**2))
	- P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)2-P(ITB,1)2-P(ITB,2)**2-
	- & P(ITB,3)**2))
	- N=N+2
	-
	-C...If t+tbar: colour join t's and let them shower.
	- IJOIN(1)=IT
	- IJOIN(2)=ITB
	- CALL PYJOIN(2,IJOIN)
	- PMTTS=(P(IT,4)+P(ITB,4))2-(P(IT,1)+P(ITB,1))2-
	- & (P(IT,2)+P(ITB,2))2-(P(IT,3)+P(ITB,3))2
	- CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
	-
	-C...If t+tbar: pick up the t's after shower.
	- ITNEW=IT
	- ITBNEW=ITB
	- DO 120 I=ITB+1,N
	- IF(K(I,2).EQ.6) ITNEW=I
	- IF(K(I,2).EQ.-6) ITBNEW=I
	- 120 CONTINUE
	-
	-C...If t+tbar: loop over two top systems.
	- DO 200 IT1=1,2
	- IF(IT1.EQ.1) THEN
	- ITO=IT
	- ITN=ITNEW
	- IBO=I1
	- IW1=I3
	- IW2=I4
	- ELSE
	- ITO=ITB
	- ITN=ITBNEW
	- IBO=I2
	- IW1=I5
	- IW2=I6
	- ENDIF
	- IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
	- & '(PY6FRM:) not b in t decay')
	-
	-C...If t+tbar: find boost from original to new top frame.
	- DO 130 J=1,3
	- BETAO(J)=P(ITO,J)/P(ITO,4)
	- BETAN(J)=P(ITN,J)/P(ITN,4)
	- 130 CONTINUE
	-
	-C...If t+tbar: boost copy of b by t shower and connect it in colour.
	- N=N+1
	- IB=N
	- K(IB,1)=3
	- K(IB,2)=K(IBO,2)
	- K(IB,3)=ITN
	- DO 140 J=1,5
	- P(IB,J)=P(IBO,J)
	- V(IB,J)=0D0
	- 140 CONTINUE
	- CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
	- CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
	- K(IB,4)=MSTU(5)*ITN
	- K(IB,5)=MSTU(5)*ITN
	- K(ITN,4)=K(ITN,4)+IB
	- K(ITN,5)=K(ITN,5)+IB
	- K(ITN,1)=K(ITN,1)+10
	- K(IBO,1)=K(IBO,1)+10
	-
	-C...If t+tbar: construct W recoiling against b.
	- N=N+1
	- IW=N
	- DO 150 J=1,5
	- K(IW,J)=0
	- V(IW,J)=0D0
	- 150 CONTINUE
	- K(IW,1)=1
	- KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
	- IF(IABS(KCHW).EQ.3) THEN
	- K(IW,2)=ISIGN(24,KCHW)
	- ELSE
	- CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
	- ENDIF
	- K(IW,3)=IW1
	-
	-C...If t+tbar: construct W momentum, including boost by t shower.
	- DO 160 J=1,4
	- P(IW,J)=P(IW1,J)+P(IW2,J)
	- 160 CONTINUE
	- P(IW,5)=SQRT(MAX(0D0,P(IW,4)2-P(IW,1)2-P(IW,2)**2-
	- & P(IW,3)**2))
	- CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
	- CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
	-
	-C...If t+tbar: boost b and W to top rest frame.
	- DO 170 J=1,3
	- BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
	- 170 CONTINUE
	- CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	- CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	-
	-C...If t+tbar: let b shower and pick up modified W.
	- PMTS=(P(IB,4)+P(IW,4))2-(P(IB,1)+P(IW,1))2-
	- & (P(IB,2)+P(IW,2))2-(P(IB,3)+P(IW,3))2
	- CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
	- DO 180 I=IW,N
	- IF(IABS(K(I,2)).EQ.24) IWM=I
	- 180 CONTINUE
	-
	-C...If t+tbar: take copy of W decay products.
	- DO 190 J=1,5
	- K(N+1,J)=K(IW1,J)
	- P(N+1,J)=P(IW1,J)
	- V(N+1,J)=V(IW1,J)
	- K(N+2,J)=K(IW2,J)
	- P(N+2,J)=P(IW2,J)
	- V(N+2,J)=V(IW2,J)
	- 190 CONTINUE
	- K(IW1,1)=K(IW1,1)+10
	- K(IW2,1)=K(IW2,1)+10
	- K(IWM,1)=K(IWM,1)+10
	- K(IWM,4)=N+1
	- K(IWM,5)=N+2
	- K(N+1,3)=IWM
	- K(N+2,3)=IWM
	- IF(IT1.EQ.1) THEN
	- I3=N+1
	- I4=N+2
	- ELSE
	- I5=N+1
	- I6=N+2
	- ENDIF
	- N=N+2
	-
	-C...If t+tbar: boost W decay products, first by effects of t shower,
	-C...then by those of b shower. b and its shower simple boost back.
	- CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
	- CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
	- CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	- CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
	- & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
	- CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
	- & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
	- CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- 200 CONTINUE
	- ENDIF
	-
	-C...Decide on dipole pairing.
	- IP1=I1
	- IP3=I3
	- IP5=I5
	- PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
	- IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
	- IP2=I2
	- IP4=I4
	- IP6=I6
	- ELSEIF(PRN.LT.P12D+P13D) THEN
	- IP2=I2
	- IP4=I6
	- IP6=I4
	- ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
	- IP2=I4
	- IP4=I2
	- IP6=I6
	- ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
	- IP2=I4
	- IP4=I6
	- IP6=I2
	- ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
	- IP2=I6
	- IP4=I2
	- IP6=I4
	- ELSE
	- IP2=I6
	- IP4=I4
	- IP6=I2
	- ENDIF
	-
	-C...Do colour joinings and parton showers
	-C...(except ones already made for t+tbar).
	- IF(ITOP.EQ.0) THEN
	- IF(IQL12.EQ.1) THEN
	- IJOIN(1)=IP1
	- IJOIN(2)=IP2
	- CALL PYJOIN(2,IJOIN)
	- ENDIF
	- IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
	- PM12S=(P(IP1,4)+P(IP2,4))2-(P(IP1,1)+P(IP2,1))2-
	- & (P(IP1,2)+P(IP2,2))2-(P(IP1,3)+P(IP2,3))2
	- CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
	- ENDIF
	- ENDIF
	- IF(IQL34.EQ.1) THEN
	- IJOIN(1)=IP3
	- IJOIN(2)=IP4
	- CALL PYJOIN(2,IJOIN)
	- ENDIF
	- IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
	- PM34S=(P(IP3,4)+P(IP4,4))2-(P(IP3,1)+P(IP4,1))2-
	- & (P(IP3,2)+P(IP4,2))2-(P(IP3,3)+P(IP4,3))2
	- CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
	- ENDIF
	- IF(IQL56.EQ.1) THEN
	- IJOIN(1)=IP5
	- IJOIN(2)=IP6
	- CALL PYJOIN(2,IJOIN)
	- ENDIF
	- IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
	- PM56S=(P(IP5,4)+P(IP6,4))2-(P(IP5,1)+P(IP6,1))2-
	- & (P(IP5,2)+P(IP6,2))2-(P(IP5,3)+P(IP6,3))2
	- CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
	- ENDIF
	-
	-C...Do fragmentation and decays. Possibly except tau decay.
	- IF(ITAU.EQ.0) THEN
	- NTAU=0
	- DO 210 I=1,N
	- IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
	- NTAU=NTAU+1
	- INTAU(NTAU)=I
	- K(I,1)=11
	- ENDIF
	- 210 CONTINUE
	- ENDIF
	- CALL PYEXEC
	- IF(ITAU.EQ.0) THEN
	- DO 220 I=1,NTAU
	- K(INTAU(I),1)=1
	- 220 CONTINUE
	- ENDIF
	-
	-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(1)
	- ENDIF
	-
	- END
	-
	-C*********************************************************************
	-
	-C...PY4JET
	-C...An interface from a four-parton generator to include
	-C...parton showers and hadronization.
	-
	- SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYJETS/,/PYDAT1/
	-C...Local arrays.
	- DIMENSION IJOIN(2),PTOT(4),BETA(3)
	-
	-C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(2)
	- ENDIF
	-
	-C...Loop through entries and pick up all final partons.
	- I1=0
	- I2=0
	- I3=0
	- I4=0
	- DO 100 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	- KFA=IABS(K(I,2))
	- IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
	- IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
	- IF(I1.EQ.0) THEN
	- I1=I
	- ELSEIF(I3.EQ.0) THEN
	- I3=I
	- ELSE
	- CALL PYERRM(16,'(PY4JET:) more than two quarks')
	- ENDIF
	- ELSEIF(K(I,2).LT.0) THEN
	- IF(I2.EQ.0) THEN
	- I2=I
	- ELSEIF(I4.EQ.0) THEN
	- I4=I
	- ELSE
	- CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
	- ENDIF
	- ELSE
	- IF(I3.EQ.0) THEN
	- I3=I
	- ELSEIF(I4.EQ.0) THEN
	- I4=I
	- ELSE
	- CALL PYERRM(16,'(PY4JET:) more than two gluons')
	- ENDIF
	- ENDIF
	- ENDIF
	- 100 CONTINUE
	-
	-C...Check that event is arranged according to conventions.
	- IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
	- CALL PYERRM(16,'(PY4JET:) event contains too few partons')
	- ENDIF
	- IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
	- CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
	- ENDIF
	-
	-C...Check whether second pair are quarks or gluons.
	- IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
	- IQG34=1
	- ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
	- IQG34=2
	- ELSE
	- CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
	- ENDIF
	-
	-C...Boost partons to their cm frame.
	- DO 110 J=1,4
	- PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
	- 110 CONTINUE
	- ECM=SQRT(MAX(0D0,PTOT(4)2-PTOT(1)2-PTOT(2)2-PTOT(3)2))
	- DO 120 J=1,3
	- BETA(J)=PTOT(J)/PTOT(4)
	- 120 CONTINUE
	- CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	- CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	- CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	- CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	- NSAV=N
	-
	-C...Decide and set up shower history for q qbar q' qbar' events.
	- IF(IQG34.EQ.1) THEN
	- W1=PY4JTW(0,I1,I3,I4)
	- W2=PY4JTW(0,I2,I3,I4)
	- IF(W1.GT.PYR(0)*(W1+W2)) THEN
	- CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
	- ELSE
	- CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
	- ENDIF
	-
	-C...Decide and set up shower history for q qbar g g events.
	- ELSE
	- W1=PY4JTW(I1,I3,I2,I4)
	- W2=PY4JTW(I1,I4,I2,I3)
	- W3=PY4JTW(0,I3,I1,I4)
	- W4=PY4JTW(0,I4,I1,I3)
	- W5=PY4JTW(0,I3,I2,I4)
	- W6=PY4JTW(0,I4,I2,I3)
	- W7=PY4JTW(0,I1,I3,I4)
	- W8=PY4JTW(0,I2,I3,I4)
	- WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
	- IF(W1.GT.WR) THEN
	- CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
	- ELSEIF(W1+W2.GT.WR) THEN
	- CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
	- ELSEIF(W1+W2+W3.GT.WR) THEN
	- CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
	- ELSEIF(W1+W2+W3+W4.GT.WR) THEN
	- CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
	- ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
	- CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
	- ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
	- CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
	- ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
	- CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
	- ELSE
	- CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
	- ENDIF
	- ENDIF
	-
	-C...Boost back original partons and mark them as deleted.
	- CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
	- K(I1,1)=K(I1,1)+10
	- K(I2,1)=K(I2,1)+10
	- K(I3,1)=K(I3,1)+10
	- K(I4,1)=K(I4,1)+10
	-
	-C...Rotate shower initiating partons to be along z axis.
	- PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
	- CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
	- THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
	- CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
	-
	-C...Set up copy of shower initiating partons as on mass shell.
	- DO 140 I=N+1,N+2
	- DO 130 J=1,5
	- K(I,J)=0
	- P(I,J)=0D0
	- V(I,J)=V(I1,J)
	- 130 CONTINUE
	- K(I,1)=1
	- K(I,2)=K(I-6,2)
	- 140 CONTINUE
	- IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
	- K(N+1,3)=I1
	- P(N+1,5)=P(I1,5)
	- K(N+2,3)=I2
	- P(N+2,5)=P(I2,5)
	- ELSE
	- K(N+1,3)=I2
	- P(N+1,5)=P(I2,5)
	- K(N+2,3)=I1
	- P(N+2,5)=P(I1,5)
	- ENDIF
	- PABS=SQRT(MAX(0D0,(ECM2-P(N+1,5)2-P(N+2,5)2)2-
	- &(2D0P(N+1,5)P(N+2,5))*2))/(2D0ECM)
	- P(N+1,3)=PABS
	- P(N+1,4)=SQRT(PABS2+P(N+1,5)2)
	- P(N+2,3)=-PABS
	- P(N+2,4)=SQRT(PABS2+P(N+2,5)2)
	- N=N+2
	-
	-C...Decide whether to allow or not photon radiation in showers.
	-C...Connect up colours.
	- MSTJ(41)=2
	- IF(IRAD.EQ.0) MSTJ(41)=1
	- IJOIN(1)=N-1
	- IJOIN(2)=N
	- CALL PYJOIN(2,IJOIN)
	-
	-C...Decide on maximum virtuality and do parton shower.
	- IF(PMAX.LT.PARJ(82)) THEN
	- PQMAX=QMAX
	- ELSE
	- PQMAX=PMAX
	- ENDIF
	- CALL PYSHOW(NSAV+1,-100,PQMAX)
	-
	-C...Rotate and boost back system.
	- CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
	-
	-C...Do fragmentation and decays.
	- CALL PYEXEC
	-
	-C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	- IF(ICOM.EQ.0) THEN
	- MSTU(28)=0
	- CALL PYHEPC(1)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY4JTW
	-C...Auxiliary to PY4JET, to evaluate weight of configuration.
	-
	- FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- SAVE /PYJETS/
	-
	-C...First case: when both original partons radiate.
	-C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
	- IF(IA1.NE.0) THEN
	- DO 100 J=1,4
	- P(N+1,J)=P(IA1,J)+P(IA2,J)
	- P(N+2,J)=P(IA3,J)+P(IA4,J)
	- 100 CONTINUE
	- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	- & P(N+1,3)**2))
	- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)2-P(N+2,1)2-P(N+2,2)**2-
	- & P(N+2,3)**2))
	- Z1=P(IA1,4)/P(N+1,4)
	- WT1=(4D0/3D0)((1D0+Z12)/(1D0-Z1))/(P(N+1,5)2-P(IA1,5)*2)
	- Z2=P(IA3,4)/P(N+2,4)
	- WT2=(4D0/3D0)((1D0+Z22)/(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+Z12)/(1D0-Z1))/(P(N+1,5)*2-
	- & P(IA3,5)**2)
	- ELSE
	- Z1=P(IA2,4)/P(N+1,4)
	- WT1=(4D0/3D0)((1D0+Z12)/(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+Z22)/(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(Z22+(1D0-Z2)*2)
	- ENDIF
	- ENDIF
	-
	-C...Total weight.
	- PY4JTW=WT1*WT2
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PY4JTS
	-C...Auxiliary to PY4JET, to set up chosen configuration.
	-
	- SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- SAVE /PYJETS/
	-
	-C...Reset info.
	- DO 110 I=N+1,N+6
	- DO 100 J=1,5
	- K(I,J)=0
	- V(I,J)=V(IA2,J)
	- 100 CONTINUE
	- K(I,1)=16
	- 110 CONTINUE
	-
	-C...First case: when both original partons radiate.
	-C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
	- IF(IA1.NE.0) THEN
	-
	-C...Set up flavour and history pointers for new partons.
	- K(N+1,2)=K(IA1,2)
	- K(N+2,2)=K(IA3,2)
	- K(N+3,2)=K(IA1,2)
	- K(N+4,2)=K(IA2,2)
	- K(N+5,2)=K(IA3,2)
	- K(N+6,2)=K(IA4,2)
	- K(N+1,3)=IA1
	- K(N+1,4)=N+3
	- K(N+1,5)=N+4
	- K(N+2,3)=IA3
	- K(N+2,4)=N+5
	- K(N+2,5)=N+6
	- K(N+3,3)=N+1
	- K(N+4,3)=N+1
	- K(N+5,3)=N+2
	- K(N+6,3)=N+2
	-
	-C...Set up momenta for new partons.
	- DO 120 J=1,5
	- P(N+1,J)=P(IA1,J)+P(IA2,J)
	- P(N+2,J)=P(IA3,J)+P(IA4,J)
	- P(N+3,J)=P(IA1,J)
	- P(N+4,J)=P(IA2,J)
	- P(N+5,J)=P(IA3,J)
	- P(N+6,J)=P(IA4,J)
	- 120 CONTINUE
	- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	- & P(N+1,3)**2))
	- P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)2-P(N+2,1)2-P(N+2,2)**2-
	- & P(N+2,3)**2))
	- QMAX=MIN(P(N+1,5),P(N+2,5))
	-
	-C...Second case: q radiates twice.
	-C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
	-C...IA5=N+2 does not radiate.
	- ELSEIF(K(IA2,2).EQ.21) THEN
	-
	-C...Set up flavour and history pointers for new partons.
	- K(N+1,2)=K(IA3,2)
	- K(N+2,2)=K(IA5,2)
	- K(N+3,2)=K(IA3,2)
	- K(N+4,2)=K(IA2,2)
	- K(N+5,2)=K(IA3,2)
	- K(N+6,2)=K(IA4,2)
	- K(N+1,3)=IA3
	- K(N+1,4)=N+3
	- K(N+1,5)=N+4
	- K(N+2,3)=IA5
	- K(N+3,3)=N+1
	- K(N+3,4)=N+5
	- K(N+3,5)=N+6
	- K(N+4,3)=N+1
	- K(N+5,3)=N+3
	- K(N+6,3)=N+3
	-
	-C...Set up momenta for new partons.
	- DO 130 J=1,5
	- P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
	- P(N+2,J)=P(IA5,J)
	- P(N+3,J)=P(IA3,J)+P(IA4,J)
	- P(N+4,J)=P(IA2,J)
	- P(N+5,J)=P(IA3,J)
	- P(N+6,J)=P(IA4,J)
	- 130 CONTINUE
	- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	- & P(N+1,3)**2))
	- P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)2-P(N+3,1)2-P(N+3,2)**2-
	- & P(N+3,3)**2))
	- QMAX=P(N+3,5)
	-
	-C...Third case: q radiates g, g branches.
	-C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
	-C...IA5=N+2 does not radiate.
	- ELSE
	-
	-C...Set up flavour and history pointers for new partons.
	- K(N+1,2)=K(IA2,2)
	- K(N+2,2)=K(IA5,2)
	- K(N+3,2)=K(IA2,2)
	- K(N+4,2)=21
	- K(N+5,2)=K(IA3,2)
	- K(N+6,2)=K(IA4,2)
	- K(N+1,3)=IA2
	- K(N+1,4)=N+3
	- K(N+1,5)=N+4
	- K(N+2,3)=IA5
	- K(N+3,3)=N+1
	- K(N+4,3)=N+1
	- K(N+4,4)=N+5
	- K(N+4,5)=N+6
	- K(N+5,3)=N+4
	- K(N+6,3)=N+4
	-
	-C...Set up momenta for new partons.
	- DO 140 J=1,5
	- P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
	- P(N+2,J)=P(IA5,J)
	- P(N+3,J)=P(IA2,J)
	- P(N+4,J)=P(IA3,J)+P(IA4,J)
	- P(N+5,J)=P(IA3,J)
	- P(N+6,J)=P(IA4,J)
	- 140 CONTINUE
	- P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	- & P(N+1,3)**2))
	- P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)2-P(N+4,1)2-P(N+4,2)**2-
	- & P(N+4,3)**2))
	- QMAX=P(N+4,5)
	-
	- ENDIF
	- N=N+6
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYJOIN
	-C...Connects a sequence of partons with colour flow indices,
	-C...as required for subsequent shower evolution (or other operations).
	-
	- SUBROUTINE PYJOIN(NJOIN,IJOIN)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local array.
	- DIMENSION IJOIN(*)
	-
	-C...Check that partons are of right types to be connected.
	- IF(NJOIN.LT.2) GOTO 120
	- KQSUM=0
	- DO 100 IJN=1,NJOIN
	- I=IJOIN(IJN)
	- IF(I.LE.0.OR.I.GT.N) GOTO 120
	- IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0) GOTO 120
	- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
	- IF(KQ.EQ.0) GOTO 120
	- IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
	- IF(KQ.NE.2) KQSUM=KQSUM+KQ
	- IF(IJN.EQ.1) KQS=KQ
	- 100 CONTINUE
	- IF(KQSUM.NE.0) GOTO 120
	-
	-C...Connect the partons sequentially (closing for gluon loop).
	- KCS=(9-KQS)/2
	- IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
	- DO 110 IJN=1,NJOIN
	- I=IJOIN(IJN)
	- K(I,1)=3
	- IF(IJN.NE.1) IP=IJOIN(IJN-1)
	- IF(IJN.EQ.1) IP=IJOIN(NJOIN)
	- IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
	- IF(IJN.EQ.NJOIN) IN=IJOIN(1)
	- K(I,KCS)=MSTU(5)*IN
	- K(I,9-KCS)=MSTU(5)*IP
	- IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
	- IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
	- 110 CONTINUE
	-
	-C...Error exit: no action taken.
	- RETURN
	- 120 CALL PYERRM(12,
	- &'(PYJOIN:) given entries can not be joined by one string')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYGIVE
	-C...Sets values of commonblock variables.
	-
	- SUBROUTINE PYGIVE(CHIN)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYDAT4/CHAF(500,2)
	- CHARACTER CHAF*16
	- COMMON/PYDATR/MRPY(6),RRPY(100)
	- COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	- COMMON/PYINT6/PROC(0:500)
	- CHARACTER PROC*28
	- COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	- COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
	- &XPDIR(-6:6)
	- COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	- COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
	- COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	- COMMON/PYPUED/IUED(0:99),RUED(0:99)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
	- &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
	- &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
	-C...Local arrays and character variables.
	- CHARACTER CHIN(),CHFIX104,CHBIT104,CHOLD8,CHNEW8,CHOLD2*28,
	- &CHNEW228,CHNAM6,CHVAR(56)6,CHALP(2)26,CHIND8,CHINI10,
	- &CHINR16,CHDIG10
	- 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,70, 1,2,1,4000,1,5,20,
	- &2,2,1,4000,1,5,20, 2,2,1,4000,1,5,20, 1,1,1,200,4*0,
	- &2,1,1,200,40, 1,1,1,200,40, 2,1,1,200,4*0,
	- &1,2,1,500,1,4,20, 2,2,1,500,1,4,20, 2,1,1,2000,4*0,
	- &2,2,1,4,1,4,20, 1,2,1,500,1,3,20, 1,2,1,8000,1,2,2*0,
	- &2,1,1,8000,40, 1,2,1,8000,1,5,20, 3,2,1,500,1,2,2*0,
	- &1,1,1,6,40, 2,1,1,100,40,
	- &1,70, 1,1,1,500,40, 1,2,1,2,-40,40,20, 2,1,1,200,40,
	- &1,1,1,200,40, 2,1,1,200,40, 1,1,1,200,40, 2,1,1,200,40,
	- &1,1,1,400,40, 2,1,1,400,40, 1,1,1,500,4*0,
	- &1,2,1,500,1,2,20, 2,2,1,500,1,20,20, 1,3,1,40,1,4,1,2,
	- &2,2,1,2,-40,40,20, 1,2,1,1000,1,3,20, 2,1,1,1000,4*0,
	- &1,1,1,500,40, 2,2,1,500,1,5,20, 1,2,0,500,1,3,2*0,
	- &2,2,0,500,1,3,20, 4,1,0,500,40, 2,3,0,6,0,6,0,5,
	- &2,1,-6,6,40, 2,1,-6,6,40, 2,1,-6,6,4*0,
	- &2,1,-6,6,40, 2,1,-6,6,40, 1,1,0,99,40, 2,1,0,99,40,
	- &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,40, 2,1,0,99,40, 1,1,0,99,40, 2,1,0,99,40/
	- 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(),CHTMP104,CHFIX104,CHMODE10,CHCODE8,
	- &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(MYTUNE)
	-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 ---- LHC tune variations on Pro-Q2O
	-C 136 Q12-F1 : Variation with wide fragmentation function (Mar 2012)
	-C 137 Q12-F2 : Variation with narrow fragmentation function (Mar 2012)
	-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 345 AMBT2B-CT6L : 2nd ATLAS MB tune, vers 'B', w CTEQ6L1 (Jul 2011)
	-C 346 AUET2B-CT6L : UE tune accompanying AMBT2B (Jul 2011)
	-C 347 AUET2B-CT66 : AUET2 with CTEQ 6.6 NLO PDFs (Nov 2011)
	-C 348 AUET2B-CT10 : AUET2 with CTEQ 10 NLO PDFs (Nov 2011)
	-C 349 AUET2B-NN21 : AUET2 with NNPDF 2.1 NLO PDFs (Nov 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 370 P12 : Retune of Perugia 2011 w CTEQ6L1 (Oct 2012)
	-C 371 P12-radHi : Variation with alphaS(pT/2)
	-C 372 P12-radLo : Variation with alphaS(2pT)
	-C 373 P12-mpiHi : Variation with more semi-hard MPI -> more UE
	-C 374 P12-loCR : Variation using lower CR strength -> more Nch
	-C 375 P12-noCR : Variation without any color reconnections
	-C 376 P12-FL : Variation with more longitudinal fragmentation
	-C 377 P12-FT : Variation with more transverse fragmentation
	-C 378 P12-M8LO : Variation using MSTW 2008 LO PDFs
	-C 379 P12-LO : Variation using MRST LO PDFs
	-
	-C ======= The Uppsala models ===========================================
	-C 1201 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
	-C 1202 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
	-C 1401 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
	-C 1402 GAL 1 : GAL 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...SAVE statements
	- SAVE /PYDAT1/,/PYPARS/
	-
	-C...Internal parameters
	- PARAMETER(MXTUNS=500)
	- CHARACTER*8 CHDOC
	- PARAMETER (CHDOC='Oct 2012')
	- 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=130,139)/
	- & 'Q12','Q12-radHi','Q12-radLo','Q12-mpiHi','Q12-noCR',
	- & 'Q12-M','Q12-F1','Q12-F2','Q12-LE','Q12-TeV'/
	- 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 'AMBT2B-CT6L1','AUET2B-CT6L1','AUET2B-CT66','AUET2B-CT10',
	- 4 'AUET2B-NN21'/
	- 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=370,379)/
	- & 'P12','P12-radHi','P12-radLo','P12-mpiHi','P12-loCR',
	- & 'P12-noCR','P12-FL','P12-FT','P12-M8LO','P12-LO**'/
	- 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 (MYTUNE.LE.MXTUNS.AND.MYTUNE.GE.0) THEN
	- CHNAME=CHNAMS(MYTUNE)
	- IF (MYTUNE.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
	- ITUNE = MYTUNE
	-
	-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
	-
	- 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 P. Skands & D. Wicke, hep-ph/0703081'
	- 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, AMBT2B, AUET2B + NLO PDF vars
	-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.349) 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...pT-ordered shower default for everything
	- MSTJ(41) = 12
	-
	-C...FSR inside resonance decays, base value (modified by individual tunes)
	- PARJ(81) = 0.29
	-
	-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 IF (ITUNE.LE.344) THEN
	-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
	- ELSE
	-C... A*T2 tunes, from ATL-PHYS-PUB-2011-008
	- PARJ( 1) = 0.073
	- PARJ( 2) = 0.202
	- PARJ( 3) = 0.950
	- PARJ( 4) = 0.033
	- PARJ(11) = 0.309
	- PARJ(12) = 0.402
	- PARJ(13) = 0.544
	- PARJ(25) = 0.628
	- PARJ(26) = 0.129
	-C...# Switch on Bowler:
	- MSTJ(11) = 5
	-C... # Fragmentation
	- PARJ(21) = 0.30
	- PARJ(41) = 0.368
	- PARJ(42) = 1.004
	- PARJ(47) = 0.873
	- PARJ(81) = 0.256
	- PARJ(82) = 0.830
	- ENDIF
	-
	-C...Default scales and alphaS choices
	- IF (ITUNE.GE.345) THEN
	- MSTP(3) = 1
	- PARU(112) = 0.192
	- PARP(1) = 0.192
	- PARP(61) = 0.192
	- 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
	- ELSEIF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
	-C...AMBT2B, AUET2B use CTEQ6L1
	- MSTP(52) = 2
	- MSTP(51) = 10042
	- ELSEIF (ITUNE.EQ.347) THEN
	-C...AUET2B-CT66 uses CTEQ66 NLO PDFs
	- MSTP(52) = 2
	- MSTP(51) = 10550
	- ELSEIF (ITUNE.EQ.348) THEN
	-C...AUET2B-CT10 uses CTEQ10 NLO PDFs
	- MSTP(52) = 2
	- MSTP(51) = 10800
	- ELSEIF (ITUNE.EQ.349) THEN
	-C...AUET2B-NN21 uses NNPDF 2.1 NLO PDF
	- MSTP(52) = 2
	- MSTP(51) = 192800
	- 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
	- ELSEIF (ITUNE.EQ.345) THEN
	-C...AMBT2B
	- PARP(77) = 0.357D0
	- PARP(78) = 0.235D0
	- ELSEIF (ITUNE.EQ.346) THEN
	-C...AUET2B
	- PARP(77) = 0.491D0
	- PARP(78) = 0.311D0
	- ELSEIF (ITUNE.EQ.347) THEN
	-C...AUET2B-CT66
	- PARP(77) = 0.505D0
	- PARP(78) = 0.385D0
	- ELSEIF (ITUNE.EQ.348) THEN
	-C...AUET2B-CT10
	- PARP(77) = 0.125D0
	- PARP(78) = 0.309D0
	- ELSEIF (ITUNE.EQ.349) THEN
	-C...AUET2B-NN21
	- PARP(77) = 0.498D0
	- PARP(78) = 0.354D0
	- 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
	- ELSEIF (ITUNE.EQ.345) THEN
	- PARP(82) = 2.34
	- PARP(83) = 0.356
	- PARP(84) = 0.605
	- PARP(90) = 0.246
	- ELSEIF (ITUNE.EQ.346) THEN
	- PARP(82) = 2.26
	- PARP(83) = 0.356
	- PARP(84) = 0.443
	- PARP(90) = 0.249
	- ELSEIF (ITUNE.EQ.347) THEN
	- PARP(82) = 1.87
	- PARP(83) = 0.356
	- PARP(84) = 0.561
	- PARP(90) = 0.189
	- ELSEIF (ITUNE.EQ.348) THEN
	- PARP(82) = 1.89
	- PARP(83) = 0.356
	- PARP(84) = 0.415
	- PARP(90) = 0.182
	- ELSEIF (ITUNE.EQ.349) THEN
	- PARP(82) = 1.86
	- PARP(83) = 0.356
	- PARP(84) = 0.588
	- PARP(90) = 0.177
	- ENDIF
	-
	-C...Primordial kT
	- PARP(91) = 2.0D0
	- PARP(93) = 5D0
	- IF (ITUNE.GE.340) THEN
	- PARP(93) = 10D0
	- ENDIF
	- IF (ITUNE.GE.345) THEN
	- PARP(91) = 2.0
	- ENDIF
	-
	-C...ISR
	- IF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
	- MSTP(64) = 2
	- PARP(62) = 1.13
	- PARP(64) = 0.68
	- PARP(67) = 1.0
	- ELSE IF (ITUNE.EQ.347) THEN
	- MSTP(64) = 2
	- PARP(62) = 0.946
	- PARP(64) = 1.032
	- PARP(67) = 1.0
	- ELSE IF (ITUNE.EQ.348) THEN
	- MSTP(64) = 2
	- PARP(62) = 0.312
	- PARP(64) = 0.939
	- PARP(67) = 1.0
	- ELSE IF (ITUNE.EQ.349) THEN
	- MSTP(64) = 2
	- PARP(62) = 1.246
	- PARP(64) = 0.771
	- PARP(67) = 1.0
	- ELSE IF (ITUNE.GE.340) THEN
	- PARP(62) = 1.025
	- ENDIF
	-
	-C...FSR off ISR (LambdaQCD) for A*ET2B tunes
	- IF (ITUNE.GE.345) THEN
	- MSTP(72) = 2
	- PARP(72) = 0.527
	- IF (ITUNE.EQ.348) THEN
	- PARP(72) = 0.537
	- ENDIF
	- 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'
	- ELSEIF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
	- CH60='A*T2B tunes by ATLAS, ATL-PHYS-PUB-2011-009'
	- ELSEIF (ITUNE.GE.347) THEN
	- CH60='A*T2B-NLO tunes by ATLAS, ATL-PHYS-PUB-2011-014'
	- WRITE(M11,5030) CH60
	- CH60='Warning: NLO PDFs are NOT recommended!'
	- ENDIF
	- WRITE(M11,5030) CH60
	- CH60='Physics Model: '//
	- & 'T. Sjostrand & P. Skands, hep-ph/0408302'
	- WRITE(M11,5030) CH60
	- CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
	- 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(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) THEN
	- WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
	- 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,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)
	- IF (MSTP(70).EQ.0) THEN
	- WRITE(M11,5050) 62, PARP(62), CHPARP(62)
	- ENDIF
	- WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
	- WRITE(M11,5050) 71, PARP(71), CHPARP(71)
	- WRITE(M11,5050) 72, PARP(72), CHPARP(72)
	- 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.379)) 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 and 370-379 (Perugia 2011 and 2012)
	- ITUNSV = ITUNE
	- IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
	- IF (ITUNE.GE.370.AND.ITUNE.LE.379) 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 and 2012 tunes
	-C...(written as modifications on top of Perugia 2010)
	-C================
	- IF ( (ITUNSV.GE.350.AND.ITUNSV.LE.359)
	- & .OR.(ITUNSV.GE.370.AND.ITUNSV.LE.379) ) 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... Perugia 2012 Variations
	-C================
	- IF (ITUNE.GE.370) THEN
	-C... CTEQ6L1 Baseline
	- MSTP(52) = 2
	- MSTP(51) = 10042
	- PARP(82) = 2.65D0
	-C... Needs slower cutoff scaling than CTEQ5L
	- PARP(90) = 0.24D0
	-C... Slightly lower CR strength than Perugia 2011
	- PARP(78) = 0.035D0
	-C... Adjusted fragmentation parameters wrt 2011
	- PARJ(1) = 0.085D0
	- PARJ(2) = 0.2
	- PARJ(3) = 0.92
	- PARJ(25) = 0.70
	- PARJ(26) = 0.135
	- PARJ(41) = 0.45
	- PARJ(42) = 1.0
	- PARJ(45) = 0.86
	- ENDIF
	-C... Variations
	- IF (ITUNE.EQ.371) 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) = 2.725D0
	-C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
	-C... (since more radiation otherwise generates faster mult growth)
	- PARP(90) = 0.25
	- ELSEIF (ITUNE.EQ.372) 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.6D0
	-C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
	-C... (since less radiation otherwise generates slower mult growth)
	- PARP(90) = 0.23
	- ELSEIF (ITUNE.EQ.373) THEN
	-C... mpiHi: high Lambda scale for MPI
	- PARP(1) = 0.26D0
	- PARU(112) = 0.26D0
	- PARP(82) = 3.0D0
	- PARP(90) = 0.24D0
	- ELSEIF (ITUNE.EQ.374) THEN
	-C... LOCR : uses global CR model. Less extreme alternative to noCR.
	- MSTP(95) = 6
	- PARP(78) = 0.25D0
	- PARP(82) = 2.7D0
	- PARP(83) = 1.50D0
	- PARP(90) = 0.24
	- ELSEIF (ITUNE.EQ.375) THEN
	-C... NOCR : with higher pT0
	- MSTP(95) = 0
	- PARP(82) = 2.80D0
	- ELSEIF (ITUNE.EQ.376) THEN
	-C... hadF1 (harder frag function, smaller n.p. pT)
	- PARJ(21) = 0.30
	- PARJ(41) = 0.36
	- PARJ(42) = 1.0
	- PARJ(45) = 0.75
	- ELSEIF (ITUNE.EQ.377) THEN
	-C... hadF2 (softer frag function, larger n.p. pT)
	- PARJ(21) = 0.36
	- PARJ(41) = 0.45
	- PARJ(42) = 0.75
	- PARJ(45) = 0.9
	- ELSEIF (ITUNE.EQ.378) THEN
	-C... MSTW08LO
	- MSTP(52) = 2
	- MSTP(51) = 21000
	- PARP(82) = 2.9D0
	-C...Uses a large LambdaQCD MSbar value (close to CMW one)
	-C...(Nominally, MSTW 2008 alphaS(mZ) = 0.139)
	- PARP(1) = 0.26D0
	- PARU(112) = 0.26D0
	-C...Tentative (fast) energy scaling
	- PARP(90) = 0.29
	- ELSEIF (ITUNE.EQ.379) THEN
	-C... MSTW LO**
	- MSTP(52) = 2
	- MSTP(51) = 20651
	- PARP(62) = 1.5D0
	-C... Use a smaller LambdaQCD MSbar than with CTEQ
	- PARP(1) = 0.14D0
	- PARU(112) = 0.14D0
	-C... Compensate for higher <pT> with less CR
	- PARP(78) = 0.034
	- PARP(82) = 3.25D0
	-C...Tentative scaling
	- PARP(90) = 0.25
	- 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 P. Skands & D. Wicke, hep-ph/0703081'
	- 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 P. Skands & D. Wicke, hep-ph/0703081'
	- 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 P. Skands & D. Wicke, hep-ph/0703081'
	- 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 P. Skands & D. Wicke, hep-ph/0703081'
	- 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) THEN
	- WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
	- 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
	- CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
	- WRITE(M11,5030) CH60
	- ENDIF
	-C...GAL Recommended settings from Uppsala web page
	- MSTP(95) = 13
	- PARP(78) = 0.10
	- 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)
	- WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
	- WRITE(M11,5050) 78, PARP(78), CHPARP(78)
	- 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
	- MSTP(95) = 11
	- PARP(78) = 0.50
	- 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)
	- WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
	- WRITE(M11,5050) 78, PARP(78), CHPARP(78)
	- 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(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT4/MWID(500),WIDS(500,5)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
	-C...Local array.
	- DIMENSION PS(2,6),IJOIN(100)
	-
	-C...Initialize and reset.
	- MSTU(24)=0
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- MSTU(29)=0
	- MSTU(31)=MSTU(31)+1
	- MSTU(1)=0
	- MSTU(2)=0
	- MSTU(3)=0
	- IF(MSTU(17).LE.0) MSTU(90)=0
	- MCONS=1
	-
	-C...Sum up momentum, energy and charge for starting entries.
	- NSAV=N
	- DO 110 I=1,2
	- DO 100 J=1,6
	- PS(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	- DO 130 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
	- DO 120 J=1,4
	- PS(1,J)=PS(1,J)+P(I,J)
	- 120 CONTINUE
	- PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
	- 130 CONTINUE
	- PARU(21)=PS(1,4)
	-
	-C...Start by all decays of coloured resonances involved in shower.
	- NORIG=N
	- DO 140 I=1,NORIG
	- IF(K(I,1).EQ.3) THEN
	- KC=PYCOMP(K(I,2))
	- IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
	- ENDIF
	- 140 CONTINUE
	-
	-C...Prepare system for subsequent fragmentation/decay.
	- CALL PYPREP(0)
	- IF(MINT(51).NE.0) RETURN
	-
	-C...Loop through jet fragmentation and particle decays.
	- MBE=0
	- 150 MBE=MBE+1
	- IP=0
	- 160 IP=IP+1
	- KC=0
	- IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
	- IF(KC.EQ.0) THEN
	-
	-C...Deal with any remaining undecayed resonance
	-C...(normally the task of PYEVNT, so seldom used).
	- ELSEIF(MWID(KC).NE.0) THEN
	- IBEG=IP
	- IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
	- IBEG=IP+1
	- 170 IBEG=IBEG-1
	- IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
	- IF(K(IBEG,1).NE.2) IBEG=IBEG+1
	- IEND=IP-1
	- 180 IEND=IEND+1
	- IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
	- IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
	- NJOIN=0
	- DO 190 I=IBEG,IEND
	- IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
	- NJOIN=NJOIN+1
	- IJOIN(NJOIN)=I
	- ENDIF
	- 190 CONTINUE
	- ENDIF
	- CALL PYRESD(IP)
	- CALL PYPREP(IBEG)
	- IF(MINT(51).NE.0) RETURN
	-
	-C...Particle decay if unstable and allowed. Save long-lived particle
	-C...decays until second pass after Bose-Einstein effects.
	- ELSEIF(KCHG(KC,2).EQ.0) THEN
	- IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
	- & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
	- & CALL PYDECY(IP)
	-
	-C...Decay products may develop a shower.
	- IF(MSTJ(92).GT.0) THEN
	- IP1=MSTJ(92)
	- QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
	- & 1))2-(P(IP1,2)+P(IP1+1,2))2-(P(IP1,3)+P(IP1+1,3))**2))
	- MINT(33)=0
	- CALL PYSHOW(IP1,IP1+1,QMAX)
	- CALL PYPREP(IP1)
	- IF(MINT(51).NE.0) RETURN
	- MSTJ(92)=0
	- ELSEIF(MSTJ(92).LT.0) THEN
	- IP1=-MSTJ(92)
	- MINT(33)=0
	- CALL PYSHOW(IP1,-3,P(IP,5))
	- CALL PYPREP(IP1)
	- IF(MINT(51).NE.0) RETURN
	- MSTJ(92)=0
	- ENDIF
	-
	-C...Jet fragmentation: string or independent fragmentation.
	- ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
	- MFRAG=MSTJ(1)
	- IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
	- IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
	- IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
	- & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
	- IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
	- ENDIF
	- ENDIF
	- IF(MFRAG.EQ.1) CALL PYSTRF(IP)
	- IF(MFRAG.EQ.2) CALL PYINDF(IP)
	- IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
	- IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
	- ENDIF
	-
	-C...Loop back if enough space left in PYJETS and no error abort.
	- IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
	- ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
	- GOTO 160
	- ELSEIF(IP.LT.N) THEN
	- CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
	- ENDIF
	-
	-C...Include simple Bose-Einstein effect parametrization if desired.
	- IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
	- CALL PYBOEI(NSAV)
	- GOTO 150
	- ENDIF
	-
	-C...Check that momentum, energy and charge were conserved.
	- DO 210 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
	- DO 200 J=1,4
	- PS(2,J)=PS(2,J)+P(I,J)
	- 200 CONTINUE
	- PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
	- 210 CONTINUE
	- PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
	- &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
	- IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
	- &'(PYEXEC:) four-momentum was not conserved')
	- IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
	- &'(PYEXEC:) charge was not conserved')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYPREP
	-C...Rearranges partons along strings.
	-C...Special considerations for systems with junctions, with
	-C...possibility of junction-antijunction annihilation.
	-C...Allows small systems to collapse into one or two particles.
	-C...Checks flavours and colour singlet invariant masses.
	-
	- SUBROUTINE PYPREP(IP)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYINT1/MINT(400),VINT(400)
	-C...The common block of colour tags.
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
	- &/PYPARS/
	- DATA NERRPR/0/
	- SAVE NERRPR
	-C...Local arrays.
	- DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
	- &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
	- &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
	- &IJCP(0:6),TJUOLD(5)
	- CHARACTER CHTMP*6
	-
	-C...Function to give four-product.
	- FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	-
	-C...Rearrange parton shower product listing along strings: begin loop.
	- MSTU(24)=0
	- NOLD=N
	- I1=N
	- NJUNC=0
	- NPIECE=0
	- NJJSTR=0
	- MSTU32=MSTU(32)+1
	- DO 100 I=MAX(1,IP),N
	-C...First store junction positions.
	- IF(K(I,1).EQ.42) THEN
	- NJUNC=NJUNC+1
	- IJUNC(NJUNC,0)=I
	- IJUNC(NJUNC,4)=0
	- ENDIF
	- 100 CONTINUE
	-
	- DO 250 MQGST=1,3
	- DO 240 I=MAX(1,IP),N
	-C...Special treatment for junctions
	- IF (K(I,1).LE.0) GOTO 240
	- IF(K(I,1).EQ.42) THEN
	-C...MQGST=2: Look for junction-junction strings (not detected in the
	-C...main search below).
	- IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
	- IF (NJJSTR.EQ.0) THEN
	- NJJSTR = (3*NJUNC-NPIECE)/2
	- ENDIF
	-C...Check how many already identified strings end on this junction
	- ILC=0
	- DO 110 J=1,NPIECE
	- IF (IPIECE(J,4).EQ.I) ILC=ILC+1
	- 110 CONTINUE
	-C...If less than 3, remaining must be to another junction
	- IF (ILC.LT.3) THEN
	- IF (ILC.NE.2) THEN
	-C...Multiple j-j connections not handled yet.
	- CALL PYERRM(2,
	- & '(PYPREP:) Too many junction-junction strings.')
	- MINT(51)=1
	- RETURN
	- ENDIF
	-C...The colour information in the junction is unreadable for the
	-C...colour space search further down in this routine, so we must
	-C...start on the colour mother of this junction and then "artificially"
	-C...prevent the colour mother from connecting here again.
	- ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
	- KCS=4
	- IF (MOD(ITJUNC,2).EQ.0) KCS=5
	-C...Switch colour if the junction-junction leg is presumably a
	-C...junction mother leg rather than a junction daughter leg.
	- IF (ITJUNC.GE.3) KCS=9-KCS
	- IF (MINT(33).EQ.0) THEN
	-C...Find the unconnected leg and reorder junction daughter pointers so
	-C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
	-C...piece.
	- IA=MOD(K(I,4),MSTU(5))
	- IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
	- ITMP=MOD(K(I,5),MSTU(5))
	- IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
	- ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
	- K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
	- ELSE
	- K(I,5)=K(I,5)+(IA-ITMP)
	- ENDIF
	- K(I,4)=K(I,4)+(ITMP-IA)
	- IA=ITMP
	- ENDIF
	- IF (ITJUNC.LE.2) THEN
	-C...Beam baryon junction
	- K(IA,KCS) = K(IA,KCS) + 2MSTU(5)*2
	- K(I,KCS) = K(I,KCS) + 1MSTU(5)*2
	-C...Else 1 -> 2 decay junction
	- ELSE
	- K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
	- K(I,KCS) = K(I,KCS) + 2MSTU(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.2MSTU(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)+2MSTU(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)+2MSTU(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 - JDIJS)
	- 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=4D0FOUR(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=8D0FOUR(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+ISGNTJJ(1,IX)P(IJCP(2)-1,IX)
	- T1P2=T1P2+ISGNTJJ(1,IX)P(IJCP(3)-1,IX)
	- T2P3=T2P3+ISGNTJJ(2,IX)P(IJCP(4)+1,IX)
	- T2P4=T2P4+ISGNTJJ(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+ISGNTJJ(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+ISGNTJJ(1,IX)P(IJCP(3)+1,IX)
	- T2G2=T2G2+ISGNTJJ(2,IX)P(IJCP(4)-1,IX)
	- ENDIF
	- 580 CONTINUE
	- DELMJJ=16D0T1P1T1P2T2P3T2P4
	- IF (JJGLUE.EQ.0) THEN
	- DELMJJ=DELMJJ(T1T2+SQRT(T1T2*2-1))
	- ELSE
	- DELMJJ=DELMJJ4D0T1G1*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+IFCISW+3)+1,IJCP(IST+IFCISW+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=2INT(PYR(0)+3D0PARJ(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=2INT(PYR(0)+3D0PARJ(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((PECM2-(P(N+2,5)+P(N+3,5))2)(PECM*2-
	- &(P(N+2,5)-P(N+3,5))*2))/(2D0PECM)
	- 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/(2D0MAX(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,(PECM2-PR1-PR2)2-4D0PR1PR2))
	- PREVCF=PARJ(42)
	- IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
	- PREV=1D0/(1D0+EXP(MIN(50D0,PREVCFALAMBDPARJ(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(PA2+P(N+2,5)2)
	- P(N+3,4)=SQRT(PA2+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-alphae3)*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)=ALPHAP(I1,J)+BETAP(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(PCLPG2+(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-DELTAALPHA)P(I1,4).LT.P(I1,5).OR.
	- & (1D0-DELTABETA)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-DELTAALPHA)P(I1,J)
	- P(I2,J)=(1D0-DELTABETA)P(I2,J)
	- 1070 CONTINUE
	- P(I1,5)=(1D0-DELTAALPHA)P(I1,5)
	- P(I2,5)=(1D0-DELTABETA)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=2D0HCR+PECM2-P(N+2,5)2-2D0P(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(HBSQRT(MAX(0D0,((HB+HC)*2-4D0(HB+HD)P(N+2,5)*2)/
	- & (HA*2-(PECMP(IR,5))**2)))-(HB+HC))/(HB+HD)
	- HK1=(0.5D0(P(N+2,5)2-PECM2)+HDHK2)/HB
	- DO 1110 J=1,4
	- P(N+2,J)=(1D0+HK1)DPC(J)-HK2P(IR,J)
	- P(IR,J)=(1D0+HK2)P(IR,J)-HK1DPC(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.9D0PARJ(32)+DPS(5))*2) CALL PYERRM(3,
	- & '(PYPREP:) too small mass in jet system')
	- NP=0
	- KFN=0
	- KQS=0
	- NJU=0
	- DO 1170 J=1,5
	- DPS(J)=0D0
	- 1170 CONTINUE
	- ENDIF
	- 1180 CONTINUE
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYSTRF
	-C...Handles the fragmentation of an arbitrary colour singlet
	-C...jet system according to the Lund string fragmentation model.
	-
	- SUBROUTINE PYSTRF(IP)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local arrays. All MOPS variables ends with MO
	- DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
	- &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
	- &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
	- &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
	- &PBST(3,5),TJUOLD(5)
	-
	-C...Function: four-product of two vectors.
	- FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	- DFOUR(I,J)=DP(I,4)DP(J,4)-DP(I,1)DP(J,1)-DP(I,2)*DP(J,2)-
	- &DP(I,3)*DP(J,3)
	-
	-C...Reset counters.
	- MSTJ(91)=0
	- NSAV=N
	- MSTU90=MSTU(90)
	- NP=0
	- KQSUM=0
	- DO 100 J=1,5
	- DPS(J)=0D0
	- 100 CONTINUE
	- MJU(1)=0
	- MJU(2)=0
	- NTRYFN=0
	- IJUORI(1)=0
	- IJUORI(2)=0
	-
	-C...Identify parton system.
	- I=IP-1
	- 110 I=I+1
	- IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
	- CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0) GOTO 110
	- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
	- IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
	- IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
	- CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	-
	-C...Take copy of partons to be considered. Check flavour sum.
	- NP=NP+1
	- DO 120 J=1,5
	- K(N+NP,J)=K(I,J)
	- P(N+NP,J)=P(I,J)
	- IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
	- 120 CONTINUE
	- DPS(4)=DPS(4)+SQRT(P(I,1)2+P(I,2)2+P(I,3)2+P(I,5)2)
	- K(N+NP,3)=I
	- IF(KQ.NE.2) KQSUM=KQSUM+KQ
	- IF(K(I,1).EQ.41) THEN
	- IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
	- MJU(1)=N+NP
	- IJUORI(1)=I
	- ELSE
	- MJU(2)=N+NP
	- IJUORI(2)=I
	- ENDIF
	- ENDIF
	- IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
	- IF(MOD(KQSUM,3).NE.0) THEN
	- CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
	-
	-C...Boost copied system to CM frame (for better numerical precision).
	- IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
	- MBST=0
	- MSTU(33)=1
	- CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
	- & -DPS(3)/DPS(4))
	- ELSE
	- MBST=1
	- HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
	- DO 130 I=N+1,N+NP
	- HHPMT=P(I,1)2+P(I,2)2+P(I,5)**2
	- IF(P(I,3).GT.0D0) THEN
	- HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
	- P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
	- P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
	- ELSE
	- HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
	- P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
	- P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
	- ENDIF
	- 130 CONTINUE
	- ENDIF
	-
	-C...Search for very nearby partons that may be recombined.
	- NTRYR=0
	- NTRYWR=0
	- PARU12=PARU(12)
	- PARU13=PARU(13)
	- MJU(3)=MJU(1)
	- MJU(4)=MJU(2)
	- NR=NP
	- NRMIN=2
	- IF(MJU(1).GT.0) NRMIN=NRMIN+2
	- IF(MJU(2).GT.0) NRMIN=NRMIN+2
	- 140 IF(NR.GT.NRMIN) THEN
	- PDRMIN=2D0*PARU12
	- DO 150 I=N+1,N+NR
	- IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
	- I1=I+1
	- IF(I.EQ.N+NR) I1=N+1
	- IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
	- IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
	- & GOTO 150
	- IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
	- & GOTO 150
	- PAP=SQRT((P(I,1)2+P(I,2)2+P(I,3)*2)(P(I1,1)**2+
	- & P(I1,2)2+P(I1,3)2))
	- PVP=P(I,1)P(I1,1)+P(I,2)P(I1,2)+P(I,3)*P(I1,3)
	- PDR=4D0(PAP-PVP)2/MAX(1D-6,PARU132PAP+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).EQ.2) MSTU(90)=0
	- 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
	- MSTU(90)=MSTU90
	- 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)+2D0PBST(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)-DHK2DP(2,J)
	- P(IN1+1,J)=(1D0+DHK2)DP(2,J)-DHK1DP(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).EQ.2) MSTU(90)=0
	- 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+2D0DHCX1DHCX2*DHC12)
	- DHCY1=DFOUR(4,1)/DHC12
	- DHCY2=DFOUR(4,2)/DHC12
	- DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	- DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	- DO 420 J=1,4
	- DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	- P(IN(6),J)=DP(3,J)
	- P(IN(6)+1,J)=DHCYY(DP(4,J)-DHCY2DP(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.ZP(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+4NS.OR.IN(2).GT.N+NR+4NS.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+2D0DHCX1DHCX2*DHC12)
	- DHCY1=DFOUR(4,1)/DHC12
	- DHCY2=DFOUR(4,2)/DHC12
	- DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	- DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	- DO 500 J=1,4
	- DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	- P(IN(3),J)=DP(3,J)
	- P(IN(3)+1,J)=DHCYY(DP(4,J)-DHCY2DP(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(PXP2+PYP2-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,DHS22-4D0DHS1*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-2JQ)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
	- IF(MSTU(90+MSTU(90)).EQ.I+1) MSTU(90)=MSTU(90)-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=2INT(PYR(0)+3D0PARJ(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.5D0FOUR(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)-DHK2DP(2,J)
	- P(IN1+1,J)=(1D0+DHK2)DP(2,J)-DHK1DP(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).EQ.2) MSTU(90)=0
	- 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(3JT+1)=N+NR+1+4(JT/2)*(NS-1)
	- IN(3JT+2)=IN(3JT+1)+1
	- IN(3JT+3)=N+NR+4NS+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.1D0P(N+NR+1,5)*2)
	- 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
	- ZR=PR3/(ZP(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+2D0DHCX1DHCX2*DHC12)
	- DHCY1=DFOUR(4,1)/DHC12
	- DHCY2=DFOUR(4,2)/DHC12
	- DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	- DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	- DO 820 J=1,4
	- DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	- P(IN3,J)=DP(3,J)
	- P(IN3+1,J)=DHCYY(DP(4,J)-DHCY2DP(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.5D0PARJ(36)PMQ(3)
	- WREM2=FOUR(N+NRS,N+NRS)
	- IF(WREM2.LT.0.10D0) GOTO 710
	- IF(WREM2.LT.MAX(WMIN(1D0+(2D0PYR(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-4D0PR(1)*PR(2)))
	- Z=(WREM2+PR(JT)-PR(JR)+PW12(2D0Z-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=GBMOXTMO3/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.ZP(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(JSIN(JR).GT.JSIN(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(JSIN(1).GT.JSIN(3JR+1).OR.JSIN(2).GT.JSIN(3JR+2).OR.
	- &IN(1).GT.IN(2)) GOTO 710
	- IF(IN(1).NE.IN(3JT+1).OR.IN(2).NE.IN(3JT+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+2D0DHCX1DHCX2*DHC12)
	- DHCY1=DFOUR(4,1)/DHC12
	- DHCY2=DFOUR(4,2)/DHC12
	- DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	- DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	- DO 980 J=1,4
	- DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	- P(IN(3),J)=DP(3,J)
	- P(IN(3)+1,J)=DHCYY(DP(4,J)-DHCY2DP(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(3JT+3),IN(3))+PY(3)*
	- & FOUR(IN(3*JT+3)+1,IN(3)))
	- PYP=-(PX(3)FOUR(IN(3JT+3),IN(3)+1)+PY(3)*
	- & FOUR(IN(3*JT+3)+1,IN(3)+1))
	- IF(ABS(PXP2+PYP2-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(3JT+3),J)+PY(JT)P(IN(3JT+3)+1,J)+
	- & PX(3)P(IN(3),J)+PY(3)P(IN(3)+1,J)
	- DO 990 IN1=IN(3JT+1),IN(1)-4JS,4*JS
	- P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
	- 990 CONTINUE
	- DO 1000 IN2=IN(3JT+2),IN(2)-4JS,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)-JSP(IN2+2,JT)DHC
	- IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JSP(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,DHS22-4D0DHS1*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(JSIN(JR).GT.JSIN(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-2JQ)*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(3JQ+1),IN(3JQ+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)+(2JQ-3)JS*
	- & PX(3))*2+(PY(3-JQ)+(2JQ-3)JSPY(3))**2
	- ENDIF
	-
	-C...Solve kinematics for final two hadrons, if possible.
	- WREM2=2D0DHR1DHR2*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-4D0WREM2*PR(JT)))
	- PREVCF=PARJ(42)
	- IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
	- PREV=1D0/(1D0+EXP(MIN(50D0,PREVCFFBPARJ(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-
	- &4D0WREM2PR(JT))),DBLE(JS))
	- DO 1090 J=1,4
	- P(I-1,J)=(PX(JT)+PX(3))P(IN(3JQ+3),J)+(PY(JT)+PY(3))*
	- & P(IN(3JQ+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-10P(I-1,4)2.OR.DM2F2.GT.1D-10P(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)*2A(J,J).LT.A(I,J)*2A(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(2D0AIKAIJ/(3D0*AJK))
	- PEJ=SQRT(2D0AJKAIJ/(3D0*AIK))
	- PEK=SQRT(2D0AIKAJK/(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=PEJMINPEKMIN+0.5D0PAJMIN*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.25D0PAIMAX**2
	- PAJMAX=(PEIMAXSQRT(MAX(0D0,AIJ2-PMJ2HI))-
	- & 0.5D0PAIMAXAIJ)/HI
	- PAKMAX=(PEIMAXSQRT(MAX(0D0,AIK2-PMK2HI))-
	- & 0.5D0PAIMAXAIK)/HI
	- PEJMAX=SQRT(PAJMAX**2+PMJ2)
	- PEKMAX=SQRT(PAKMAX**2+PMK2)
	- FMAX=PEJMAXPEKMAX+0.5D0PAJMAX*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.25D0PAI**2
	- PAJ=(PEISQRT(MAX(0D0,AIJ2-PMJ2HI))-0.5D0PAIAIJ)/HI
	- PEJ=SQRT(PAJ**2+PMJ2)
	- PAK=(PEISQRT(MAX(0D0,AIK2-PMK2HI))-0.5D0PAIAIK)/HI
	- PEK=SQRT(PAK**2+PMK2)
	- FNOW=PEJPEK+0.5D0PAJ*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+VXCM2+VYCM2+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=(PCM5SPCM(4,4)-PCM45PCM(5,4))/(PCM4SPCM5S-PCM45*2)
	- C5=(PCM4SPCM(5,4)-PCM45PCM(4,4))/(PCM4SPCM5S-PCM45*2)
	- VXJU=C4PCM(4,1)+C5PCM(5,1)
	- VYJU=C4PCM(4,2)+C5PCM(5,2)
	- VZJU=C4PCM(4,3)+C5PCM(5,3)
	- GAMJU=SQRT(1D0+VXJU2+VYJU2+VZJU**2)
	-
	-C...Add two boosts, giving final result.
	- FCM=(VXJUVXCM+VYJUVYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
	- VJU(1)=VXJU+FCM*VXCM
	- VJU(2)=VYJU+FCM*VYCM
	- VJU(3)=VZJU+FCM*VZCM
	- VJU(4)=SQRT(1D0+VJU(1)2+VJU(2)2+VJU(3)**2)
	- VJU(5)=1D0
	-
	-C...In case of error in reconstruction: revert to CM frame of system.
	- CTH12=(PCM(1,1)PCM(2,1)+PCM(1,2)PCM(2,2)+PCM(1,3)*PCM(2,3))/
	- &(PCM(1,5)*PCM(2,5))
	- CTH13=(PCM(1,1)PCM(3,1)+PCM(1,2)PCM(3,2)+PCM(1,3)*PCM(3,3))/
	- &(PCM(1,5)*PCM(3,5))
	- CTH23=(PCM(2,1)PCM(3,1)+PCM(2,2)PCM(3,2)+PCM(2,3)*PCM(3,3))/
	- &(PCM(2,5)*PCM(3,5))
	- ERRCCM=(CTH12+0.5D0)2+(CTH13+0.5D0)2+(CTH23+0.5D0)**2
	- ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
	- DO 170 I=1,3
	- FAC1=PJU(I,1)VJU(1)+PJU(I,2)VJU(2)+PJU(I,3)*VJU(3)
	- FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
	- PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
	- PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
	- PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
	- PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
	- PCM(I,5)=SQRT(PCM(I,1)2+PCM(I,2)2+PCM(I,3)**2)
	- 170 CONTINUE
	- CTH12=(PCM(1,1)PCM(2,1)+PCM(1,2)PCM(2,2)+PCM(1,3)*PCM(2,3))/
	- &(PCM(1,5)*PCM(2,5))
	- CTH13=(PCM(1,1)PCM(3,1)+PCM(1,2)PCM(3,2)+PCM(1,3)*PCM(3,3))/
	- &(PCM(1,5)*PCM(3,5))
	- CTH23=(PCM(2,1)PCM(3,1)+PCM(2,2)PCM(3,2)+PCM(2,3)*PCM(3,3))/
	- &(PCM(2,5)*PCM(3,5))
	- ERRCJU=(CTH12+0.5D0)2+(CTH13+0.5D0)2+(CTH23+0.5D0)**2
	- ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
	- IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
	- VJU(1)=VXCM
	- VJU(2)=VYCM
	- VJU(3)=VZCM
	- VJU(4)=GAMCM
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYINDF
	-C...Handles the fragmentation of a jet system (or a single
	-C...jet) according to independent fragmentation models.
	-
	- SUBROUTINE PYINDF(IP)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local arrays.
	- DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
	- &KFLO(2),PXO(2),PYO(2),WO(2)
	-
	-C.. MOPS error message
	- IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
	- &' are not treated as expected in independent fragmentation')
	-
	-C...Reset counters. Identify parton system and take copy. Check flavour.
	- NSAV=N
	- MSTU90=MSTU(90)
	- NJET=0
	- KQSUM=0
	- DO 100 J=1,5
	- DPS(J)=0D0
	- 100 CONTINUE
	- I=IP-1
	- 110 I=I+1
	- IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
	- CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0) GOTO 110
	- KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
	- IF(KQ.EQ.0) GOTO 110
	- NJET=NJET+1
	- IF(KQ.NE.2) KQSUM=KQSUM+KQ
	- DO 120 J=1,5
	- K(NSAV+NJET,J)=K(I,J)
	- P(NSAV+NJET,J)=P(I,J)
	- DPS(J)=DPS(J)+P(I,J)
	- 120 CONTINUE
	- K(NSAV+NJET,3)=I
	- IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
	- &K(I+1,1).EQ.2)) GOTO 110
	- IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
	- CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	-
	-C...Boost copied system to CM frame. Find CM energy and sum flavours.
	- IF(NJET.NE.1) THEN
	- MSTU(33)=1
	- CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
	- & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
	- ENDIF
	- PECM=0D0
	- DO 130 J=1,3
	- NFI(J)=0
	- 130 CONTINUE
	- DO 140 I=NSAV+1,NSAV+NJET
	- PECM=PECM+P(I,4)
	- KFA=IABS(K(I,2))
	- IF(KFA.LE.3) THEN
	- NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
	- ELSEIF(KFA.GT.1000) THEN
	- KFLA=MOD(KFA/1000,10)
	- KFLB=MOD(KFA/100,10)
	- IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
	- IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
	- ENDIF
	- 140 CONTINUE
	-
	-C...Loop over attempts made. Reset counters.
	- NTRY=0
	- 150 NTRY=NTRY+1
	- IF(NTRY.GT.200) THEN
	- CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- N=NSAV+NJET
	- MSTU(90)=MSTU90
	- DO 160 J=1,3
	- NFL(J)=NFI(J)
	- IFET(J)=0
	- KFLF(J)=0
	- 160 CONTINUE
	-
	-C...Loop over jets to be fragmented.
	- DO 230 IP1=NSAV+1,NSAV+NJET
	- MSTJ(91)=0
	- NSAV1=N
	- MSTU91=MSTU(90)
	-
	-C...Initial flavour and momentum values. Jet along +z axis.
	- KFLH=IABS(K(IP1,2))
	- IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
	- KFLO(2)=0
	- WF=P(IP1,4)+SQRT(P(IP1,1)2+P(IP1,2)2+P(IP1,3)**2)
	-
	-C...Initial values for quark or diquark jet.
	- 170 IF(IABS(K(IP1,2)).NE.21) THEN
	- NSTR=1
	- KFLO(1)=K(IP1,2)
	- CALL PYPTDI(0,PXO(1),PYO(1))
	- WO(1)=WF
	-
	-C...Initial values for gluon treated like random quark jet.
	- ELSEIF(MSTJ(2).LE.2) THEN
	- NSTR=1
	- IF(MSTJ(2).EQ.2) MSTJ(91)=1
	- KFLO(1)=INT(1D0+(2D0+PARJ(2))PYR(0))(-1)**INT(PYR(0)+0.5D0)
	- CALL PYPTDI(0,PXO(1),PYO(1))
	- WO(1)=WF
	-
	-C...Initial values for gluon treated like quark-antiquark jet pair,
	-C...sharing energy according to Altarelli-Parisi splitting function.
	- ELSE
	- NSTR=2
	- IF(MSTJ(2).EQ.4) MSTJ(91)=1
	- KFLO(1)=INT(1D0+(2D0+PARJ(2))PYR(0))(-1)**INT(PYR(0)+0.5D0)
	- KFLO(2)=-KFLO(1)
	- CALL PYPTDI(0,PXO(1),PYO(1))
	- PXO(2)=-PXO(1)
	- PYO(2)=-PYO(1)
	- WO(1)=WFPYR(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(ZW-PR/MAX(1D-4,Z*W))
	- P(I,4)=0.5D0(ZW+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+3D0PARJ(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.8D0P(I,5)+0.2D0))
	- 420 CONTINUE
	- DO 440 I=NSAV+NJET+1,N
	- IR1=K(I,3)
	- IR2=N+IR1-NSAV
	- PLS=(P(I,1)P(IR1,1)+P(I,2)P(IR1,2)+P(I,3)*P(IR1,3))/
	- & (P(IR1,1)2+P(IR1,2)2+P(IR1,3)**2)
	- DO 430 J=1,3
	- P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)PSS)-1D0)
	- & PLS*P(IR1,J)
	- 430 CONTINUE
	- P(I,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)2+P(I,5)2)
	- 440 CONTINUE
	- ENDIF
	-
	-C...Scale momenta for energy conservation.
	- IF(MOD(MSTJ(3),5).NE.0) THEN
	- PMS=0D0
	- PES=0D0
	- PQS=0D0
	- DO 450 I=NSAV+NJET+1,N
	- PMS=PMS+P(I,5)
	- PES=PES+P(I,4)
	- PQS=PQS+P(I,5)**2/P(I,4)
	- 450 CONTINUE
	- IF(PMS.GE.PECM) GOTO 150
	- NECO=0
	- 460 NECO=NECO+1
	- PFAC=(PECM-PQS)/(PES-PQS)
	- PES=0D0
	- PQS=0D0
	- DO 480 I=NSAV+NJET+1,N
	- DO 470 J=1,3
	- P(I,J)=PFAC*P(I,J)
	- 470 CONTINUE
	- P(I,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)2+P(I,5)2)
	- PES=PES+P(I,4)
	- PQS=PQS+P(I,5)**2/P(I,4)
	- 480 CONTINUE
	- IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
	- ENDIF
	-
	-C...Origin of produced particles and parton daughter pointers.
	- 490 DO 500 I=NSAV+NJET+1,N
	- IF(MSTU(16).NE.2) K(I,3)=NSAV+1
	- IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
	- 500 CONTINUE
	- DO 510 I=NSAV+1,NSAV+NJET
	- I1=K(I,3)
	- K(I1,1)=K(I1,1)+10
	- IF(MSTU(16).NE.2) THEN
	- K(I1,4)=NSAV+1
	- K(I1,5)=NSAV+1
	- ELSE
	- K(I1,4)=K(I1,4)-NJET+1
	- K(I1,5)=K(I1,5)-NJET+1
	- IF(K(I1,5).LT.K(I1,4)) THEN
	- K(I1,4)=0
	- K(I1,5)=0
	- ENDIF
	- ENDIF
	- 510 CONTINUE
	-
	-C...Document independent fragmentation system. Remove copy of jets.
	- NSAV=NSAV+1
	- K(NSAV,1)=11
	- K(NSAV,2)=93
	- K(NSAV,3)=IP
	- K(NSAV,4)=NSAV+1
	- K(NSAV,5)=N-NJET+1
	- DO 520 J=1,4
	- P(NSAV,J)=DPS(J)
	- V(NSAV,J)=V(IP,J)
	- 520 CONTINUE
	- P(NSAV,5)=SQRT(MAX(0D0,DPS(4)2-DPS(1)2-DPS(2)2-DPS(3)2))
	- V(NSAV,5)=0D0
	- DO 540 I=NSAV+NJET,N
	- DO 530 J=1,5
	- K(I-NJET+1,J)=K(I,J)
	- P(I-NJET+1,J)=P(I,J)
	- V(I-NJET+1,J)=V(I,J)
	- 530 CONTINUE
	- 540 CONTINUE
	- N=N-NJET+1
	- DO 550 IZ=MSTU90+1,MSTU(90)
	- MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
	- 550 CONTINUE
	-
	-C...Boost back particle system. Set production vertices.
	- IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
	- &DPS(2)/DPS(4),DPS(3)/DPS(4))
	- DO 570 I=NSAV+1,N
	- DO 560 J=1,4
	- V(I,J)=V(IP,J)
	- 560 CONTINUE
	- 570 CONTINUE
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYDECY
	-C...Handles the decay of unstable particles.
	-
	- SUBROUTINE PYDECY(IP)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
	-C...Local arrays.
	- DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
	- &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
	- CHARACTER CIDC*4
	- DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
	- logical :: first, second
	- integer :: idx
	-
	-C...Functions: momentum in two-particle decays and four-product.
	- PAWT(A,B,C)=SQRT((A2-(B+C)2)(A2-(B-C)2))/(2D0A)
	- 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) == K(ITAU,2)) THEN
	-C...If tau -> tau + gamma then add gamma energy and loop.
	-!!! BCN: Catching invalid access to K(0,2)
	- idx = K(IMTAU,4)
	- IF(idx > 0) THEN
	- first = K(idx,2) == 22
	- ELSE
	- first = .false.
	- END IF
	- idx = K(IMTAU,5)
	- IF(idx > 0) THEN
	- second = K(idx,2) == 22
	- ELSE
	- second = .false.
	- END IF
	- IF(first) THEN
	- DO 130 J=1,4
	- PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
	- 130 CONTINUE
	- ELSEIF(second) 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 .AND.
	- & IABS(K(IMTAU,2)).LT.1000000) 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)
	-C DO 200 II=NSAV+1,NSAV+NDECAY
	-C K(II,1)=1
	-C K(II,3)=IP
	-C K(II,4)=0
	-C K(II,5)=0
	-C 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... call pylist (2)
	-
	-C... If Parent is Higgs (IORIG=25,35,36), another tau is boosted and rotate.
	-C... Only Higgs to tau pair decay
	-C... Fix Akiya Miyamoto for transversely polarized taus.
	-C IF(KFORIG.EQ.25.OR.KFORIG.EQ.35.OR.KFORIG.EQ.36) THEN
	-C ITFOUND=0
	-C IF (.NOT.(K(IORIG,4).EQ.0.OR.K(IORIG,5).EQ.0)) THEN
	-C DO 60210 J=K(IORIG,4), K(IORIG,5)
	-C IF( ABS(K(J,2)).EQ.15 ) THEN
	-C ITFOUND=ITFOUND+1
	-C IF( ITFOUND.GT.3 ) THEN
	-C PRINT *,'%%Fatal error in PYDCAY after PYTAUD,'
	-C PRINT *,'call: Higgs has >2 tau daughters.'
	-C STOP
	-C ENDIF
	-C CALL PYROBO(J,J,THETAU,PHITAU,0D0,0D0,0D0)
	-C CALL PYROBO(J,J,0D0,0D0,DBETAU(1),
	-C & DBETAU(2),DBETAU(3))
	-C ENDIF
	-C60210 CONTINUE
	-C ENDIF
	-C ... In the case of single tau decay, copy momentum before PYTAUD
	-C ELSE
	- DO 211 J=1,4
	- P(ITAU,J)=PTAU(J)
	- 211 CONTINUE
	-C ENDIF
	-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.5D0XBBMIXV(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(100MOD(KFA/10,100)+3)
	- ELSEIF(KPA.EQ.81) THEN
	- KFP=KFS(1000MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
	- ELSEIF(KP.EQ.82) THEN
	- CALL PYDCYK(-KFSINT(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(-2D0CNDELOG(MAX(1D-10,PYR(0))))*
	- & SIN(PARU(2)*PYR(0))
	- ND=0.5D0+0.5D0NP+0.25D0NQ+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
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- IF(NQ.EQ.4) THEN
	- IF(PYR(0).LT.PARJ(66)) JT=4
	- ENDIF
	- 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=4D0PMAS(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.5D0PMES/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(PA2+P(N+IL,5)2)
	- PV(IL+1,4)=SQRT(PA2+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(GABEP/(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
	- & +2D0FOUR(N+1,N+2)FOUR(N+1,N+3)*FOUR(N+2,N+3)
	- IF(MAX(WTWTCOR(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.5D0PMES)(FOUR122+FOUR132)+
	- & PMES(FOUR12FOUR13+FOUR122+FOUR132)
	- IF(WT.LT.PYR(0)0.25D0PMST(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=(FOUR10FOUR12-PMS1FOUR02)**2
	- IF(KFAS.EQ.22) HNUM=PMS1(2D0FOUR10FOUR12FOUR02-
	- & PMS1FOUR022-PMS0FOUR12*2-PMS2FOUR10*2+PMS1PMS0*PMS2)
	- HNUM=MAX(1D-6PMS12PMS0*PMS2,HNUM)
	- HDEN=(FOUR10*2-PMS1PMS0)(FOUR122-PMS1PMS2)
	- 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=2D0FOUR(IP,N+1)/P(IP,5)*2
	- HX2=2D0FOUR(IP,N+2)/P(IP,5)*2
	- HX3=2D0FOUR(IP,N+3)/P(IP,5)*2
	- WT=((1D0-HX1)/(HX2HX3))2+((1D0-HX2)/(HX1HX3))**2+
	- & ((1D0-HX3)/(HX1HX2))*2
	- IF(WT.LT.2D0*PYR(0)) GOTO 390
	- IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)P(IP,5)2.LT.4D0PARJ(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=2D0FOUR(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-2D0HX1).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-2D0HD(P(N+1,4)2+P(N+2,4)2)+HD*2
	- HF=HDHC-HB*2
	- HG=HDHC-HAHB
	- HH=(SQRT(HG*2+HEHF)-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(GABEP/(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)+2KFL1B+(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)+2KFL2B+(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
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- IF(MSTU(121).NE.-1) THEN
	- IF((1D0+PARJ(1))*PYR(0).GT.1D0)THEN
	- MBARY=1
	- CALL PYNMES(0)
	- ENDIF
	- ELSE
	- 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=SQWTPARF(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=33+3MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
	- ENDIF
	- ELSE
	- IF(MSTU(121).EQ.0)THEN
	- IPOS=35+5MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
	- ELSE
	- IPOS=35+54+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=900MAX(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=(100KFLA+10KFLB+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=(100KFLA+10KFLB+KFLS)KFS(-1)**KFLA
	- ELSE
	- RMIX=PYR(0)
	- IMIX=2KFLA+10KMUL
	- 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=SU6OCT4SU6S/(3*SU6S+1)
	- IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)4/(3SU6S+1)
	- ELSE
	- IF(KBARY.EQ.6) SU6OCT=SU6OCT(3+SU6S)/(3SU6S+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(3SU6S/(3SU6S+KFLDS**2)+PYR(0))
	- ENDIF
	- KF=ISIGN(1000KFLD+100KFLE+10*KFLF+KFLS,KFL1)
	- IF(KSIG.EQ.0) KF=ISIGN(1000KFLD+100KFLF+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+80KTAB1+25KTS+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+80KTAB1+25KTS+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(2KTAB1-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=1000KFL3A+100KFL3B+1
	- IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A(KFL3A-2)+2KFL3B) KFL3=
	- & KFL3+2
	- KFL3=ISIGN(KFL3,KFL1(13-2KTAB1))
	- 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+80KTAB1+25KTABS)+PARF(144+80KTAB1+
	- & 25KTABS)+PARF(145+80KTAB1+25*KTABS))
	- KF=110+2*KTABS+1
	- IF(RFL.GT.PARF(143+80KTAB1+25KTABS)) KF=220+2*KTABS+1
	- IF(RFL.GT.PARF(143+80KTAB1+25KTABS)+PARF(144+80*KTAB1+
	- & 25KTABS)) KF=330+2KTABS+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=(100KFLA+10KFLB+2KTABS+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=(100KFLA+10KFLB+2KTABS+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(1000KFLD+100KFLF+10*KFLE+2,KFL1)
	- IF(KTABS.GE.1) KF=ISIGN(1000KFLD+100KFLE+10KFLF+2KTABS,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)=3D0PARJ(18)/(2D0PARJ(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)4PARF(146)/(3*PARF(146)+1)
	- 100 CONTINUE
	- SU6(8)=SU6(2)4/(3PARF(146)+1)
	- SU6(6)=SU6(6)(3+PARF(146))/(3PARF(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=(2D0SU6(1)+PARJ(2)SU6(8))
	- DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
	- DMB(IUS0)=DMB(ISU0)
	- DMB(ISS1)=(2D0SU6(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)=(2D0SU6(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)=PAR2MPARJ(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)6D0QBB(ISS1)
	- QBM(IUU1)=6D0*QBB(IUU1)
	- QBM(ISU1)=3D0*QBB(ISU1)
	- QBM(IUS1)=PARJ(2)3D0QBB(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)=6D0PARJ(2)EXP(-PARJ(10)PMSS1)DMB(7+ISU0)
	- DMB(7+IUU1)=6D0EXP(-PARJ(10)PMUD1)
	- DMB(7+ISU1)=3D0EXP(-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)=WQWSQBM(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=2KFQOLD+10KMUL
	- 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=100KFLA+10KFLB+KFJ
	- PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
	- PARF(IPOS+IMES)=QWTSWTEXP(-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+5KMUL+ID)=QWTSWTDWTEXP(-PARF(193)*PMM)
	- IF(KMUL.EQ.0.AND.ID.GT.3) THEN
	- WTFAIL=WTFAIL+QWTSWTDWT*(1D0-PARJ(21+ID))
	- PARF(IPOS+5*KMUL+ID)=
	- & PARF(IPOS+5KMUL+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+FREDFBBPARF(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+4D0FA*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(ZMAX0.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=FCLOG(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 zc.
	- 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(-4D0FCZ(1D0-Z)2.LT.PYR(0)((1D0-Z)*2-FCZ)**2)
	- & GOTO 110
	- ELSE
	- IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
	- IF(FC.LT.0D0) Z=Z**(-1D0/FC)
	- ENDIF
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYSHOW
	-C...Generates timelike parton showers from given partons.
	-
	- SUBROUTINE PYSHOW(IP1,IP2,QMAX)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
	-C...Local arrays.
	- DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
	- &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
	- &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
	- &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
	- &IREF(1000)
	-
	-C...Check that QMAX not too low.
	- IF(MSTJ(41).LE.0) THEN
	- RETURN
	- ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
	- IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
	- ELSE
	- IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
	- & RETURN
	- ENDIF
	-
	-C...Store positions of shower initiating partons.
	- MPSPD=0
	- IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
	- NPA=1
	- IPA(1)=IP1
	- ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
	- & MSTU(32))) THEN
	- NPA=2
	- IPA(1)=IP1
	- IPA(2)=IP2
	- ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
	- & .AND.IP2.GE.-80) THEN
	- NPA=IABS(IP2)
	- DO 100 I=1,NPA
	- IPA(I)=IP1+I-1
	- 100 CONTINUE
	- ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
	- &IP2.EQ.-100) THEN
	- MPSPD=1
	- NPA=2
	- IPA(1)=IP1+6
	- IPA(2)=IP1+7
	- ELSE
	- CALL PYERRM(12,
	- & '(PYSHOW:) failed to reconstruct showering system')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	-
	-C...Send off to PYPTFS for pT-ordered evolution if requested,
	-C...if at least 2 partons, and without predefined shower branchings.
	- IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
	- &MPSPD.EQ.0) THEN
	- NPART=NPA
	- DO 110 II=1,NPART
	- IPART(II)=IPA(II)
	- PTPART(II)=0.5D0*QMAX
	- 110 CONTINUE
	- CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
	- RETURN
	- ENDIF
	-
	-C...Initialization of cutoff masses etc.
	- DO 120 IFL=0,40
	- ISCOL(IFL)=0
	- ISCHG(IFL)=0
	- KSH(IFL)=0
	- 120 CONTINUE
	- ISCOL(21)=1
	- KSH(21)=1
	- PMTH(1,21)=PYMASS(21)
	- PMTH(2,21)=SQRT(PMTH(1,21)*2+0.25D0PARJ(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.25D0PARJ(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.25D0PMQTH1**2)
	- PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
	- PMTH(4,IFL)=SQRT(PMTH(1,IFL)*2+0.25D0PARJ(82)**2)+PMTH(2,21)
	- PMTH(5,IFL)=SQRT(PMTH(1,IFL)*2+0.25D0PARJ(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.25D0PARJ(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.5D0PARJ(82),1.1D0PARJ(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.25D0PMQTH1**2)
	- PMTH(3,IR)=PMTH(2,IR)+PMQTH2
	- PMTH(4,IR)=SQRT(PMTH(1,IR)*2+0.25D0PARJ(82)**2)+PMTH(2,21)
	- PMTH(5,IR)=SQRT(PMTH(1,IR)*2+0.25D0PARJ(83)**2)+PMTH(2,22)
	- ELSEIF(ISCOL(IR).EQ.1) THEN
	- PMTH(2,IR)=SQRT(PMTH(1,IR)*2+0.25D0PARJ(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.25D0PARJ(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-4D0EIPARU(102)
	- EF=KCHG(KFLA(1),1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFPARU(102)
	- XWC=1D0/(16D0PARU(102)(1D0-PARU(102)))
	- SH=PS(5)**2
	- SQMZ=PMAS(23,1)**2
	- SQWZ=PS(5)*PMAS(23,2)
	- SBWZ=1D0/((SH-SQMZ)2+SQWZ2)
	- VECT=EI*2EF*2+2D0EIVIEFVFXWCSH(SH-SQMZ)*SBWZ+
	- & (VI2+AI2)VF2XWC*2SH*2SBWZ
	- AXIV=(VI2+AI2)AF2XWC*2SH*2SBWZ
	- 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-(2D0PMTH(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-(2D0PMTMPE/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=6D0LOG((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=6D0MSTJ(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)*22D0*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.4D0PMTH(2,IFF)2) B0=(33D0-2D0IFF)/6D0
	- 430 CONTINUE
	-C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
	- PMSC=MAX(0.5D0PARJ(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=PMSCEXP(MAX(-50D0,LOG(PYR(0))PARU(2)/(PARU(111)*FBR)))
	- ELSEIF(MSTJ(44).EQ.1) THEN
	- PMSQCD=4D0ALAMS(0.25D0PMSC/ALAMS)(PYR(0)*(B0/FBR))
	- ELSE
	- PMSQCD=PMSCEXP(MAX(-50D0,ALFMB0*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.5D0PARJ(83),PMS-PMTH(1,IR)*2)
	- IF(FBRE.LT.1D-3) THEN
	- PMSQED=0D0
	- ELSE
	- PMSQED=PMSEEXP(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-
	- & 4D0PMSGD1PMSGD2))
	- 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.2D0PYR(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.
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- IF(M3JC.EQ.0) THEN
	- IF(1D0+Z*2.LT.2D0PYR(0)) GOTO 410
	- ENDIF
	- 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(Z2+(1D0-Z)2.LT.PYR(0)) GOTO 410
	- KFLB=1+INT(MSTJ(45)*PYR(0))
	- PMQ=4D0PMTH(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=4D0PMTH(2,21)*2/V(IEP(1),5)
	- IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0PMQ)SQRT(1D0-PMQ)
	- & .LT.PYR(0)(1D0+0.5D0PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
	- ELSE
	- IF((1D0+0.5D0PMQ)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-2D0ZC)PYR(0)
	- K(IEP(1),5)=21
	- ELSE
	- Z=ZC+(1D0-2D0ZC)PYR(0)
	- KFLB=1+INT(MSTJ(45)*PYR(0))
	- PMQ=4D0PMTH(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+PMQTH32)/V(IEP(1),5)
	- PMQ2=(PMTH(1,IRGD2)2+PMQTH32)/V(IEP(1),5)
	- ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED*2)((1D0-PMQ1-PMQ2)**2-
	- & 4D0PMQ1PMQ2)))
	- 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.5D0PS(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(X12+X22)
	- 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,PEDME2-PS1ME+PM2ME2))
	- 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-PM2ME2)2-
	- & 4D0PS1MEPM2ME**2))
	- PEDME=PEM(0.5D0(V(IM,5)-PMLME+PS1ME-PM2ME*2)+PMLMEZMME)/
	- & V(IM,5)
	- ECMME=PEDME+SQRT(MAX(0D0,PEDME2-PS1ME+PM2ME2))
	- 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,PEDME2-PS1ME+PM2ME2))
	- M3JCC=66
	- ENDIF
	-C...Construct ME variables.
	- R1ME=PM1ME/ECMME
	- R2ME=PM2ME/ECMME
	- X1=(1D0+PS1ME/ECMME2-R2ME2)(Z+(1D0-Z)PM1ME**2/PS1ME)
	- X2=1D0+R2ME2-PS1ME/ECMME2
	-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=WMEMAX(1D-10,1D0+R1ME2-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+R2ME2-R1ME2-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=4D0X3((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)-4D0PMDAO**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)*2THE2ID.LT.1D0) GOTO 410
	- ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
	- THE2ID=Z(1D0-Z)(0.5D0P(IM,4))*2/V(IEP(1),5)
	- IF(PARJ(85)*2THE2ID.LT.1D0) GOTO 410
	- ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
	- THE2ID=Z(1D0-Z)(0.5D0P(IM,4))*2/V(IEP(1),5)
	- IF(PARJ(86)*2THE2ID.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.5D0P(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-
	- & 4D0V(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+PMQTH32)/V(I1,5)
	- PMQ2=(PMTH(1,IRGD2)2+PMQTH32)/V(I1,5)
	- ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED*2)((1D0-PMQ1-PMQ2)**2-
	- & 4D0PMQ1PMQ2)))
	- 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-
	- & 4D0PMQ1PMQ2)))
	- 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-4D0V(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=PMLSZM(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)-
	- & ZMV(N+2,5))-0.25D0PMLS)/PZM**2
	- ELSE
	- PTS=PMLS(ZM(1D0-ZM)PEM2/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=2D0ZAU/(1D0+ZAU*2)
	- ELSE
	- HAZIP=(ZAU/(1D0-ZAU(1D0-ZAU)))*2
	- ENDIF
	- IF(K(N+1,2).NE.21) THEN
	- HAZIP=HAZIP(-2D0ZM(1D0-ZM))/(1D0-2D0ZM*(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)/(ZSZGM))
	- 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))+
	- & PZMSQRT(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))+
	- & PEMSQRT(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)+
	- & 2D0PEMP(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)=(PEMP(N+1,4)-PZMP(N+1,3))/P(IM,5)
	- V(N+2,2)=(PEMP(N+2,4)-PZMP(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(BEXP(IM,1)+BEYP(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)+GABEPBEX)2+(P(IM,2)+GABEPBEY)**2)
	- THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
	- IF(PTIMB.GT.1D-4) THEN
	- PHI=PYANGL(P(IM,1)+GABEPBEX,P(IM,2)+GABEPBEY)
	- 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=BEXDP(1)+BEYDP(2)+BEZ*DP(3)
	- DGABP=GA(GADBP/(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(2D0CAD*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-HAZICCAD)/(1D0+HAZIC*2-2D0HAZIC*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-HAZIICAD)/(1D0+HAZII*2-2D0HAZII*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
	-C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	- IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21)) THEN
	- IF(PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
	- ENDIF
	- 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(BEXP(IPA(1),1)+BEYP(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)
	- & +GABEPBEX)2+(P(IPA(1),2)+GABEPBEY)**2))
	- PHI=PYANGL(P(IPA(1),1)+GABEPBEX,P(IPA(1),2)+GABEPBEY)
	- MSTU(33)=1
	- CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
	- ELSE
	- CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
	- & PS(3)/PS(4))
	- MSTU(33)=1
	- CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
	- ENDIF
	-
	-C...Decay vertex of shower.
	- DO 630 I=NS+1,N
	- DO 620 J=1,5
	- V(I,J)=V(IP1,J)
	- 620 CONTINUE
	- 630 CONTINUE
	-
	-C...Delete trivial shower, else connect initiators.
	- IF(N.LE.NS+NPA+IIM) THEN
	- N=NS
	- ELSE
	- DO 640 IP=1,NPA
	- K(IPA(IP),1)=14
	- K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
	- K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
	- K(NS+IIM+IP,3)=IPA(IP)
	- IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
	- IF(K(NS+IIM+IP,1).NE.1) THEN
	- K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
	- K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
	- ENDIF
	- 640 CONTINUE
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYPTFS
	-C...Generates pT-ordered timelike final-state parton showers.
	-
	-C...MODE defines how to find radiators and recoilers.
	-C... = 0 : based on colour flow between undecayed partons.
	-C... = 1 : for IPART <= NPARTD only consider primary partons,
	-C... whether decayed or not; else as above.
	-C... = 2 : based on common history, whether decayed or not.
	-C... = 3 : use (or create) MCT color information to shower partons
	-
	- SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Parameter statement for maximum size of showers.
	- PARAMETER (MAXNUR=1000)
	-C...Commonblocks.
	- COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
	- &/PYINT1/
	-C...Local arrays.
	- DIMENSION IPOS(2MAXNUR),IREC(2MAXNUR),IFLG(2*MAXNUR),
	- &ISCOL(2MAXNUR),ISCHG(2MAXNUR),PTSCA(2MAXNUR),IMESAV(2MAXNUR),
	- &PT2SAV(2MAXNUR),ZSAV(2MAXNUR),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.1D0ALAM3)*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-4D0EIPARU(102)
	- EF=KCHG(KFLA1,1)/3D0
	- AF=SIGN(1D0,EF+0.1D0)
	- VF=AF-4D0EFPARU(102)
	- XWC=1D0/(16D0PARU(102)(1D0-PARU(102)))
	- SH=PSUM(5)**2
	- SQMZ=PMAS(23,1)**2
	- SQWZ=PSUM(5)*PMAS(23,2)
	- SBWZ=1D0/((SH-SQMZ)2+SQWZ2)
	- VECT=EI*2EF*2+2D0EIVIEFVFXWCSH(SH-SQMZ)*SBWZ+
	- & (VI2+AI2)VF2XWC*2SH*2SBWZ
	- AXIV=(VI2+AI2)AF2XWC*2SH*2SBWZ
	- 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.25D0SHTCOR,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.5D00.5D0NFLAV
	-
	-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=WTPSGLCOLFACLOG(1D0/ZMNCUT-1D0)/B0
	- EVCOEF=EVEMGL
	- IF(MOCT.EQ.1) THEN
	- EVEMQQ=WTPSQQ(1D0-2D0ZMNCUT)/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-2D0ZMNCUT)
	- 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.PM2SHT/(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.WTPSGLPYR(0)) GOTO 350
	-
	-C...Weighting of g->gg branching.
	- ELSEIF(IFLAG.EQ.1) THEN
	- IF(1D0+Z*3.LT.WTPSGLPYR(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-4D0PMQ*2/PM2))
	- WTME=ROOTQQ(Z2+(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=AEM2PICHG2WTPSGA*LOG(1D0/ZMNCUT-1D0)
	-
	-C...Pick pT2 (in overestimated z range).
	- 370 PT2=PT2PYR(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.PM2SHT/(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.WTPSGAPYR(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-4D0PMQ*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=-ASYPOL2D0Z(1D0-Z)/(1D0-2D0Z*(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.5D0SQRT(MAX(0D0,(SHT-PM2-PM2R)2-4D0PM2*PM2R)/SHT)
	- PT2COR=PM2(PEM2Z(1D0-Z)-0.25D0PM2)/PZM**2
	- PTCOR=SQRT(MAX(0D0,PT2COR))
	- PZN=(PEM*2Z-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(PTCOR2+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(PTCOR2+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(2D0CAD*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=WMEMAX(1D-10,1D0+R1ME2-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+R2ME2-R1ME2-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(X12+X22)
	- WPS=2D0(CHG12(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+R1ME2-R2ME2-X1)/MAX(1D-10,2D0-X1-X2)
	- WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
	- & MAX(1D-10,1D0+R2ME2-R1ME2-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...(X12+X22)/((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.2D0R1.OR.X1.GE.1D0+R12-R2*2) RETURN
	- IF(X2.LE.2D0R2.OR.X2.GE.1D0+R22-R1*2) RETURN
	- IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
	- IF((2D0-2D0X1-2D0X2+X1X2+2D0R1*2+2D0R22)2.GE.
	- &(X1*2-4D0R1*2)(X2*2-4D0R2**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=PS2D0((X1+X2-1D0+ANUM-R12-R22)/
	- & ((1D0+R12-R22-X1)(1D0+R22-R1*2-X2))-
	- & R12/(1D0+R22-R12-X2)2-
	- & R22/(1D0+R12-R22-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-R12-R14+6R1R2-R22+2R1*2R22-R24)/2.D0
	- RFO1=-1.D0(3+6R12+R14-6R1R2+6R13R2-2R2*2
	- & -6R12R2*2+6R1R23+R24-3X1+6R1R2*X1
	- & +2R22X1+X1*2-2R1*2X1*2+3R1*2(2-X1-X2)
	- & +6R1R2(2-X1-X2)-R22(2-X1-X2)-2X1(2-X1-X2)
	- & -5R12X1(2-X1-X2)+R22X1(2-X1-X2)+X12(2-X1-X2)
	- & -3(2-X1-X2)2-3R1*2(2-X1-X2)2+R22(2-X1-X2)*2
	- & +2X1(2-X1-X2)2+(2-X1-X2)3-X2)/
	- & (-1+R12-R22+X2)**2
	- RFO1=RFO1-2(-3+R12-6R1R2+6R1*3R2+3R22-4R1*2R2**2
	- & +6R1R2*3+2X1+3R12X1+R2*2X1-X12-R12X1*2
	- & -R2*2X1*2+4(2-X1-X2)+2R12(2-X1-X2)+3R1R2*(2-X1
	- & -X2)-R2*2(2-X1-X2)-3X1(2-X1-X2)-2R12X1*(2-X1-X2)
	- & +X1*2(2-X1-X2)-(2-X1-X2)2-R12(2-X1-X2)2+R1R2*(2
	- & -X1-X2)*2+X1(2-X1-X2)**2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- RFO1=RFO1-1.D0(-1+2R12+R14+6R1R2+6R13R2-2R2*2
	- & -6R12R2*2+6R1R23+R24-X1-2R1*2X1-6R1R2*X1
	- & +8R22X1+X1*2-2R2*2X12-R12(2-X1-X2)+R22(2
	- & -X1-X2)-R1*2X1(2-X1-X2)+R22X1(2-X1-X2)+X12
	- & (2-X1-X2)+X2)/(-1-R12+R22+X1)**2
	- RFO1=RFO1/2.D0
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(2-R12-R14-6R1R2-R22+2R1*2R22-R24)/2.D0
	- RFO2=-1(3+6R12+R14+6R1R2-6R13R2-2R2*2
	- & -6R12R2*2-6R1R23+R24-3X1-6R1R2X1+2R2*2X1
	- & +X1*2-2R1*2X1*2+3R1*2(2-X1-X2)-6R1R2*(2-X1-X2)
	- & -R2*2(2-X1-X2)-2X1(2-X1-X2)-5R12X1*(2-X1-X2)
	- & +R2*2X1(2-X1-X2)+X12(2-X1-X2)-3(2-X1-X2)*2
	- & -3R12(2-X1-X2)2+R22(2-X1-X2)2+2X1(2-X1-X2)*2
	- & +(2-X1-X2)3-X2)/(-1+R12-R22+X2)2
	- RFO2=RFO2-2(-3+R12+6R1R2-6R1*3R2+3R22-4R1*2R2**2
	- & -6R1R2*3+2X1+3R12X1+R2*2X1-X12-R12X1*2
	- & -R2*2X1*2+4(2-X1-X2)+2R12(2-X1-X2)-3R1R2*(2-X1
	- & -X2)-R2*2(2-X1-X2)-3X1(2-X1-X2)-2R12X1*(2-X1-X2)
	- & +X1*2(2-X1-X2)-(2-X1-X2)2-R12(2-X1-X2)2-R1R2*(2
	- & -X1-X2)*2+X1(2-X1-X2)**2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- RFO2=RFO2-1(-1+2R12+R14-6R1R2-6R13R2-2R2*2
	- & -6R12R2*2-6R1R23+R24-X1-2R1*2X1+6R1R2*X1
	- & +8R22X1+X1*2-2R2*2X12-R12(2-X1-X2)+R22(2-X1
	- & -X2)-R1*2X1(2-X1-X2)+R22X1(2-X1-X2)+X12(2-X1-X2)
	- & +X2)/(-1-R12+R22+X1)**2
	- RFO2=RFO2/2.D0
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(2D0-R12-R14-R22+2D0R1*2R22-R24)/2D0
	- RFO4=(1-R1*4+6R1*2R22-R24+X1+3R12X1-9R22X1
	- & -3X12-R12X1*2+3R2*2X12+X13-X2-R1*2X2
	- & +R2*2X2-R1*2X1X2+R22X1X2+X12X2)/
	- & (-1-R12+R22+X1)**2
	- RFO4=RFO4
	- & -2(1+R12+R22-4R1*2R22+R12X1+2R2*2X1-X1**2
	- & -R2*2X1*2+2R1*2X2+R2*2X2-3X1X2+X1*2X2-X2**2
	- & -R1*2X2*2+X1X2**2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- RFO4=RFO4+(1-R1*4+6R1*2R22-R24-X1+R1*2X1-R2*2X1+X2
	- & -9R12X2+3R22X2+R1*2X1X2-R22X1X2-3X2**2
	- & +3R12X22-R22X22+X1X22+X23)/
	- & (-1+R12-R22+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-2D0R12+R14+R2*2-6D0R1R2*2
	- & +R1*2R2*2-2D0R2**4)
	- RFO1=2(-1+R1-2R1*2+2R13-R14+R15-R22+R1R2*2
	- & -5R12R22+R13R22-2R1R24+2X1-2R1X1
	- & +2R12X1-2R13X1+2R22X1+5R1R2*2X1
	- & +R1*2R2*2X1+2R24X1-X1*2+R1X12-R22X12+3X2
	- & +4R12X2+R1*4X2+2R22X2+2R12R2*2X2-4X1X2
	- & -2R12X1X2-R22X1X2+X12X2-2X2*2
	- & -2R12X2*2+X1X22)/(1-R12+R2**2-X2)/(-2+X1+X2)
	- RFO1=RFO1+(2R22+6R1R22-6R1*2R2*2+6R1*3R2**2
	- & +2R24+6R1R24-R22X1+R1*2R2*2X1-R2*4X1+X2
	- & -R1*4X2-3R22X2-6R1R2*2X2+9R12R2*2X2
	- & -2R24X2-X1X2+R12X1X2-X22-3R1*2X2**2
	- & +2R22X2*2+X1X22)/(-1+R12-R22+X2)2
	- RFO1=RFO1+(-4-8R12-4R1*4+4R2*2-4R1*2R2*2+8R2**4
	- & +9X1+10R1*2X1+R1*4X1-3R22X1+6R1R2*2X1
	- & +R1*2R2*2X1-2R24X1-6X12-2R1*2X12+X13
	- & +7X2+8R1*2X2+R1*4X2-7R22X2+6R1R2*2X2
	- & +R1*2R2*2X2-2R24X2-9X1X2-3R12X1*X2
	- & +2R22X1X2+2X1*2X2-3X22-R12X2**2
	- & +2R22X2*2+X1X22)/(-2+X1+X2)2
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0-2D0R12+R14+R2*2+6D0R1R2*2
	- & +R1*2R2*2-2D0R2**4)
	- RFO2=2(1+R1+2R1*2+2R13+R14+R15+R22+R1R2*2
	- & +5R12R22+R13R22-2R1R24-2X1-2R1X1
	- & -2R12X1-2R13X1-2R22X1+5R1R2*2X1
	- & -R1*2R2*2X1-2R24X1+X1*2+R1X12+R22X12-3X2
	- & -4R12X2-R1*4X2-2R22X2-2R12R2*2X2+4X1X2
	- & +2R12X1X2+R22X1X2-X12X2+2X22+2R1*2X2**2
	- & -X1X22)/(-1+R12-R2*2+X2)/(-2+X1+X2)
	- RFO2=RFO2+(2R22-6R1R22-6R1*2R2*2-6R1*3R2**2
	- & +2R24-6R1R24-R22X1+R1*2R2*2X1-R2*4X1+X2
	- & -R1*4X2-3R22X2+6R1R2*2X2+9R12R2*2X2
	- & -2R24X2-X1X2+R12X1X2-X22-3R1*2X2**2
	- & +2R22X2*2+X1X22)/(-1+R12-R22+X2)2
	- RFO2=RFO2+(-4-8R12-4R1*4+4R2*2-4R1*2R2*2+8R2*4+9X1
	- & +10R12X1+R1*4X1-3R22X1-6R1R2*2X1
	- & +R1*2R2*2X1-2R24X1-6X12-2R1*2X12+X13
	- & +7X2+8R1*2X2+R1*4X2-7R22X2-6R1R2*2X2
	- & +R1*2R2*2X2-2R24X2-9X1X2-3R12X1*X2
	- & +2R22X1X2+2X1*2X2-3X22-R12X2*2+2R2*2X2**2
	- & +X1X22)/(-2+X1+X2)*2
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1.D0-2.D0R12+R14+R22+R12R22-2.D0R2**4)
	- RFO4=2(1+2R12+R14+R2*2+5R1*2R2*2-2X1-2R12X1
	- & -2R22X1-R1*2R2*2X1-2R24X1+X12+R22X1*2
	- & -3X2-4R1*2X2-R1*4X2-2R22X2-2R12R2*2X2
	- & +4X1X2+2R12X1X2+R22X1X2-X12X2+2X2*2
	- & +2R12X2*2-X1X22)/(-1+R12-R2**2+X2)/(-2+X1+X2)
	- RFO4=RFO4+(2R22-6R1*2R2*2+2R24-R22X1+R12R2*2X1
	- & -R2*4X1+X2-R1*4X2-3R22X2+9R12R2*2X2
	- & -2R24X2-X1X2+R12X1X2-X22-3R1*2X2**2
	- & +2R22X2*2+X1X22)/(-1+R12-R22+X2)2
	- RFO4=RFO4+(-4-8R12-4R1*4+4R2*2-4R1*2R2*2+8R2*4+9X1
	- & +10R12X1+R1*4X1-3R22X1+R1*2R2*2X1-2R24X1
	- & -6X12-2R1*2X12+X13+7X2+8R1*2X2+R1*4X2
	- & -7R22X2+R1*2R2*2X2-2R24X2-9X1X2-3R12X1*X2
	- & +2R22X1X2+2X1*2X2-3X22-R12X2*2+2R2*2X2**2
	- & +X1X22)/(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-R12-R22-2D0R1*R2)
	- RFO1=-(-1+R1*4-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	- & +R24+X1-R12X1+2R1R2X1+3R22X1+X2+R1*2X2
	- & -R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	- & -2(R12+R14-2R1*3R2+R2*2-6R1*2R2*2-2R1R2*3
	- & +R24-R12X1+R1R2X1+2R2*2X1+2R12X2+R1R2X2
	- & -R2*2X2-X1X2)/(-1-R12+R22+X1)/(-1+R12-R2*2+X2)
	- & -(-1+R1*4-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	- & +R24+X1-R12X1+R22X1+X2+3R12X2+2R1R2*X2
	- & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0-R12-R22+2D0R1*R2)
	- RFO2=-(-1+R1*4+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	- & +R24+X1-R12X1-2R1R2X1+3R22X1+X2+R1*2X2
	- & -R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	- & -(-1+R1*4+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	- & +R24+X1-R12X1+R22X1+X2+3R12X2-2R1R2*X2
	- & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	- & +2(-R12-R14-2R1*3R2-R2*2+6R1*2R2**2
	- & -2R1R23-R24+R1*2X1+R1R2X1-2R22X1
	- & -2R12X2+R1R2X2+R2*2X2+X1*X2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1D0-R12-R2*2)
	- RFO4=-(-1+R1*4-6R1*2R22+R24+X1-R1*2X1+3R22X1+X2
	- & +R1*2X2-R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	- & -2(R12+R14+R22-6R1*2R22+R24-R1*2X1
	- & +2R22X1+2R12X2-R2*2X2-X1*X2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- & -(-1+R1*4-6R1*2R22+R24+X1-R1*2X1+R2*2X1
	- & +X2+3R12X2-R2*2X2-X1X2)/(-1+R12-R22+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+R12-R22+2D0R1)
	- RFO1=(4-4R12+4R2*2-3X1-2R1X1+R1*2X1-R2*2X1-5*X2
	- & -2R1X2+R1*2X2-R2*2X2+X1X2+X22)/(-2+X1+X2)*2
	- & +2(3-R1-5R12-R13+3R22+R1R2*2-2X1-R1*X1
	- & +R1*2X1-4X2+2R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (1-R12+R22-X2)/(-2+X1+X2)
	- & +(2-2R1-6R1*2-2R1*3+2R2*2-2R1R22-X1+R12X1
	- & -R2*2X1-3X2+2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (-1+R12-R22+X2)**2
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0+R12-R22-2D0R1)
	- RFO2=(4-4R12+4R2*2-3X1+2R1X1+R1*2X1-R2*2X1-5*X2
	- & +2R1X2+R1*2X2-R2*2X2+X1X2+X22)/(-2+X1+X2)*2
	- & +2(3+R1-5R12+R13+3R22-R1R2*2-2X1+R1*X1
	- & +R1*2X1-4X2+2R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (1-R12+R22-X2)/(-2+X1+X2)
	- & +(2+2R1-6R1*2+2R1*3+2R2*2+2R1R22-X1+R12X1
	- & -R2*2X1-3X2-2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (-1+R12-R22+X2)**2
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1D0+R12-R2*2)
	- RFO4=(4-4R12+4R2*2-3X1+R1*2X1-R2*2X1-5X2+R12X2
	- & -R2*2X2+X1X2+X22)/(-2+X1+X2)*2
	- & +2(3-5R1*2+3R2*2-2X1+R1*2X1-4X2+2R1*2X2
	- & -R2*2X2+X1X2+X22)/(1-R12+R2*2-X2)/(-2+X1+X2)
	- & +(2-6R12+2R22-X1+R12X1-R22X1-3X2+3R1*2X2
	- & -R2*2X2+X1X2+X22)/(-1+R12-R22+X2)*2
	- ISSET4=1
	- ENDIF
	-
	-C...V -> ~q ~qbar (~q = squark).
	- ELSEIF(ICLASS.EQ.6) THEN
	- RLO1=PS(1D0-2D0R12+R14-2D0R22-2D0R1*2R22+R24)
	- RFO1=2D03D0+(1+R12+R22-X1)(4R12-X1*2)/
	- & (-1-R12+R22+X1)**2
	- & -2D0(-1-3R12-R22+X1+X1*2/2+X2-X1X2/2)/
	- & (-1-R12+R22+X1)
	- & +(1+R12+R22-X2)(4R22-X22)
	- & /(-1+R12-R22+X2)**2
	- & -2D0(-1-R12-3R2*2+X1+X2-X1X2/2+X2**2/2)/
	- & (-1+R12-R22+X2)
	- & -(-4R12-4R1*4-4R2*2-8R1*2R2*2-4R2*4+2X1
	- & +6R12X1+6R22X1-2X12+2X2+6R12X2+6R22X2
	- & -4X1X2-2R12X1X2-2R2*2X1X2+X12X2-2X2*2
	- & +X1X22)/(-1-R12+R22+X1)/(-1+R12-R2*2+X2)
	- ISSET1=1
	-
	-C...~q -> ~q V.
	- ELSEIF(ICLASS.EQ.7) THEN
	- RLO1=PS(1D0-2D0R12+R14-2D0R22-2D0R1*2R22+R24)
	- RFO1=16R22+8(4R22+2R2*2X1+X2+R1*2X2+R2*2X2-X1*X2
	- & -2X22)/(3(-1+R12-R22+X2))+8(1+R12+R22-X2)
	- & (4R22-X22)/(3(-1+R12-R22+X2)*2)+8(X1+X2)*
	- & (-1-2R12-R14-2R2*2+2R1*2R22-R24+2*X1
	- & +2R12X1+2R22X1-X1*2+2X2+2R12X2+2R22X2
	- & -2X1X2-X2*2)/(3(-2+X1+X2)*2)+8(-1-R12+R22-X1)*
	- & (2R22X1+X2+R1*2X2+R2*2X2-X1X2-X2*2)/
	- & (3(-1+R12-R22+X2)(-2+X1+X2))+8(1+2R12+R14
	- & +2R22-2R1*2R22+R24-2X1-2R1*2X1-4R22X1
	- & +X1*2-3X2-3R12X2-3R22X2+3X1X2+2X2*2)/
	- & (3*(-2+X1+X2))
	- RFO1=3D0*RFO1/8D0
	- ISSET1=1
	-
	-C...S -> ~q ~qbar.
	- ELSEIF(ICLASS.EQ.8) THEN
	- RLO1=PS
	- RFO1=(-1-2R12-R14-2R2*2+2R1*2R22-R24+2*X1
	- & +2R12X1+2R22X1-X12-R22X12+2X2+2R12X2
	- & +2R22X2-3X1X2-R1*2X1X2-R22X1X2+X12X2-X2**2
	- & -R1*2X2*2+X1X2**2)/
	- & (1+R12-R22-X1)2/(-1+R12-R22+X2)2
	- RFO1=2D0*RFO1
	- ISSET1=1
	-
	-C...~q -> ~q S.
	- ELSEIF(ICLASS.EQ.9) THEN
	- RLO1=PS
	- RFO1=(-1-R12-R22+X2)/(-1+R12-R22+X2)**2
	- & +(1+R12-R22+X1)/(-1+R12-R22+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+R12-R22+2D0R1)
	- RFO1=(2R1+X1)(-1-R12-R22+X1)/(-1-R12+R22+X1)**2
	- & +2(-1-R12-2R13-R22-2R1R2*2+3X1/2+R1*X1
	- & -R1*2X1/2-R2*2X1/2+X2+R1X2+R12X2-X1*X2/2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- & +(2-2R1-6R1*2-2R1*3+2R2*2-2R1R22-X1+R12X1
	- & -R2*2X1-3X2+2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (-1+R12-R22+X2)**2
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0-2D0R1+R12-R22)
	- RFO2=(2R1-X1)(1+R12+R22-X1)/(-1-R12+R22+X1)**2
	- & +2(-1-R12+2R13-R22+2R1R2*2+3X1/2-R1*X1
	- & -R1*2X1/2-R2*2X1/2+X2-R1X2+R12X2-X1*X2/2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- & +(2+2R1-6R1*2+2R1*3+2R2*2+2R1R22-X1+R12X1
	- & -R2*2X1-3X2-2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (-1+R12-R22+X2)**2
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1+R12-R2*2)
	- RFO4=X1(-1-R12-R22+X1)/(-1-R12+R22+X1)*2
	- & +2D0(-1-R12-R22+3X1/2-R1*2X1/2-R2*2X1/2
	- & +X2+R1*2X2-X1*X2/2)/
	- & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	- & +(2-6R12+2R22-X1+R12X1-R22X1-3X2+3R1*2X2
	- & -R2*2X2+X1X2+X22)/(-1+R12-R22+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+2R1R2+R22-X1-X2)(X1+X2)/(-2+X1+X2)**2
	- & -(-1+R1*4-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	- & +R24+X1-R12X1+R22X1+X2+3R12X2+2R1R2*X2
	- & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	- & +(-1-2R12-R14-2R1R2-2R1*3R2+2R1R23+R24
	- & +X1+R1*2X1-2R1R2X1-3R2*2X1+2R12X2-2R22X2
	- & +X1X2+X22)/(-1+R12-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-2R1R2+R22-X1-X2)(X1+X2)/
	- & (-2+X1+X2)**2
	- & -(-1+R1*4+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	- & +R24+X1-R12X1+R22X1+X2+3R12X2-2R1R2*X2
	- & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	- & +(-1-2R12-R14+2R1R2+2R1*3R2-2R1R23+R24
	- & +X1+R1*2X1+2R1R2X1-3R2*2X1+2R12X2-2R22X2
	- & +X1X2+X22)/(-1+R12-R2*2+X2)/(-2+X1+X2)
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1D0-R12-R2*2)
	- RFO4=(1+R12+R22-X1-X2)(X1+X2)/(-2+X1+X2)*2
	- & -(-1+R1*4-6R1*2R22+R24+X1-R1*2X1+R2*2X1+X2
	- & +3R12X2-R2*2X2-X1*X2)/
	- & (-1+R12-R22+X2)**2
	- & -(-1-2R12-R14+R24+X1+R12X1-3R22X1
	- & +2R12X2-2R22X2+X1X2+X2*2)/
	- & (2-X1-X2)/(-1+R12-R22+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-R12+R22+2D0R2)
	- RFO1=(2R2+X2)(-1-R12-R22+X2)/(-1+R12-R22+X2)**2
	- & +(4+4R12-4R2*2-5X1-R1*2X1-2R2X1+R2*2X1+X1**2
	- & -3X2-R12X2-2R2X2+R2*2X2+X1*X2)/
	- & (-2+X1+X2)*2-2(-1-R12+R2+R12R2-R22-R2*3+X1
	- & +R2X1+R22X1+2X2+R12X2-X1X2/2-X2*2/2)/
	- & (2-X1-X2)/(-1+R12-R22+X2)
	- ISSET1=1
	- END IF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0-R12+R22-2D0R2)
	- RFO2=(2R2-X2)(1+R12+R22-X2)/(-1+R12-R22+X2)**2
	- & +(4+4R12-4R2*2-5X1-R1*2X1+2R2X1+R2*2X1+X1**2
	- & -3X2-R12X2+2R2X2+R2*2X2+X1*X2)/
	- & (-2+X1+X2)*2-2(-1-R12-R2-R12R2-R22+R2*3+X1
	- & -R2X1+R22X1+2X2+R12X2-X1X2/2-X2*2/2)/
	- & (2-X1-X2)/(-1+R12-R22+X2)
	- ISSET2=1
	- END IF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1D0-R12+R2*2)
	- RFO4=X2(-1-R12-R22+X2)/(-1+R12-R22+X2)*2
	- & +(4+4R12-4R2*2-5X1-R1*2X1+R2*2X1+X1**2
	- & -3X2-R12X2+R2*2X2+X1*X2)/
	- & (-2+X1+X2)*2-2(-1-R12-R22+X1+R2*2X1+2*X2
	- & +R1*2X2-X1X2/2-X2*2/2)/
	- & (2-X1-X2)/(-1+R12-R22+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+R12-R22+2D0R1)
	- RFO1=4(2R1+X1)(-1-R12-R22+X1)/(3(-1-R12+R22+X1)**2)
	- & -(-1-R1*2-2R13-R22-2R1R2*2+3X1/2+R1X1-R12X1/2
	- & -R2*2X1/2+X2+R1X2+R12X2-X1X2/2)/(3(-1-R12+R22
	- & +X1)(-1+R12-R22+X2))-3(-1+R1-R12-R13-R2**2
	- & +R1R22+2X1+R2*2X1-X1*2/2+X2+R1X2+R1*2X2-X1*X2/2)/
	- & ((-1-R12+R22+X1)(2-X1-X2))+3(4-4R12+4R2*2-3X1
	- & -2R1X1+R1*2X1-R2*2X1-5X2-2R1X2+R12X2-R2*2X2
	- & +X1X2+X22)/(-2+X1+X2)2+3(3-R1-5R12-R13+3R2**2
	- & +R1R22-2X1-R1X1+R12X1-4X2+2R1*2X2-R2*2X2
	- & +X1X2+X22)/((1-R12+R22-X2)(-2+X1+X2))+4(2-2R1
	- & -6R12-2R1*3+2R2*2-2R1R22-X1+R12X1-R2*2X1
	- & -3X2+2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (3(-1+R12-R22+X2)*2)
	- RFO1=3D0*RFO1/4D0
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0+R12-R22-2D0R1)
	- RFO2=4(2R1-X1)(1+R12+R22-X1)/(3(-1-R12+R22+X1)**2)
	- & -3(-1-R1-R12+R13-R22-R1R2*2+2X1+R2*2X1-X1**2/2
	- & +X2-R1X2+R12X2-X1X2/2)/((-1-R12+R22+X1)(2-X1-X2))
	- & +(2+2R12-4R1*3+2R2*2-4R1R22-3X1+2R1X1
	- & +R1*2X1+R2*2X1-2X2+2R1X2-2R1*2X2+X1*X2)/
	- & (6(-1-R12+R22+X1)(-1+R12-R22+X2))+3(4-4R1**2
	- & +4R22-3X1+2R1X1+R1*2X1-R2*2X1-5X2+2R1*X2
	- & +R1*2X2-R2*2X2+X1X2+X22)/(-2+X1+X2)2+3(3+R1
	- & -5R12+R13+3R2*2-R1R2*2-2X1+R1X1+R12X1-4*X2
	- & +2R12X2-R2*2X2+X1X2+X2*2)/
	- & ((1-R12+R22-X2)(-2+X1+X2))+4(2+2R1-6R1*2+2R1**3
	- & +2R22+2R1R22-X1+R12X1-R2*2X1-3X2-2R1*X2
	- & +3R12X2-R2*2X2+X1X2+X2*2)/
	- & (3(-1+R12-R22+X2)*2)
	- RFO2=3D0*RFO2/4D0
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1D0+R12-R2*2)
	- RFO4=8X1(-1-R12-R22+X1)/(3(-1-R12+R22+X1)2)-6(-1
	- & -R12-R22+2X1+R22X1-X12/2+X2+R12X2-X1X2/2)/
	- & ((-1-R12+R22+X1)(2-X1-X2))+(2+2R1*2+2R2*2-3X1
	- & +R1*2X1+R2*2X1-2X2-2R1*2X2+X1X2)/(3(-1-R1**2
	- & +R2*2+X1)(-1+R12-R22+X2))+6(4-4R1*2+4R2*2-3X1
	- & +R1*2X1-R2*2X1-5X2+R12X2-R2*2X2+X1X2+X2*2)/
	- & (-2+X1+X2)*2+6(3-5R12+3R2*2-2X1+R1*2X1-4*X2
	- & +2R12X2-R2*2X2+X1X2+X2*2)/
	- & ((1-R12+R22-X2)(-2+X1+X2))+8(2-6R12+2R2**2-X1
	- & +R1*2X1-R2*2X1-3X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	- & (3(-1+R12-R22+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-R12-R22-2D0R1*R2)
	- RFO1=64(1+R12+2R1R2+R22-X1-X2)(X1+X2)/(9(-2+X1+X2)*2)
	- & -16(-1+R14-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	- & +R24+X1-R12X1+2R1R2X1+3R22X1+X2+R1*2X2
	- & -R2*2X2-X1X2)/(-1-R12+R22+X1)2-16(R12+R14
	- & -2R13R2+R2*2-6R1*2R2*2-2R1R23+R2*4
	- & -R1*2X1+R1R2X1+2R22X1+2R12X2+R1R2X2-R2*2X2
	- & -X1X2)/((-1-R12+R22+X1)(-1+R12-R22+X2))
	- & -64(-1+R14-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	- & +R24+X1-R12X1+R22X1+X2+3R12X2+2R1R2*X2
	- & -R2*2X2-X1X2)/(9(-1+R12-R22+X2)**2)
	- & +8(-1+R14-2R1R2+2R1*3R2-2R22-2R1R23-R2*4
	- & -2R12X1+2R22X1+X1*2+X2-3R1*2X2-2R1R2*X2
	- & +R2*2X2+X1X2)/((-1-R12+R22+X1)(-2+X1+X2))
	- RFO1=RFO1
	- & +8(-1-2R12-R14-2R1R2-2R13R2+2R1R23+R24
	- & +X1+R1*2X1-2R1R2X1-3R2*2X1+2R12X2-2R22X2
	- & +X1X2+X22)/(9(2-X1-X2)(-1+R12-R2*2+X2))
	- RFO1=9D0*RFO1/64D0
	- ISSET1=1
	- ENDIF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1-R12-R22+2D0R1*R2)
	- RFO2=64(1+R12-2R1R2+R22-X1-X2)(X1+X2)/(9(-2+X1+X2)*2)
	- & -16(-1+R14+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	- & +R24+X1-R12X1-2R1R2X1+3R22X1+X2+R1*2X2
	- & -R2*2X2-X1X2)/(-1-R12+R22+X1)2-64(-1+R1**4
	- & +2R1R2+2R13R2-6R12R2*2+2R1R23+R2*4+X1
	- & -R1*2X1+R2*2X1+X2+3R12X2-2R1R2X2-R22X2
	- & -X1X2)/(9(-1+R12-R22+X2)*2)+16(-R12-R14
	- & -2R13R2-R2*2+6R1*2R2*2-2R1R23-R24+R12X1
	- & +R1R2X1-2R22X1-2R12X2+R1R2X2+R2*2X2+X1*X2)/
	- & ((-1-R12+R22+X1)(-1+R12-R2*2+X2))
	- RFO2=RFO2
	- & +8(-1+R14+2R1R2-2R1*3R2-2R22+2R1R23-R2*4
	- & -2R12X1+2R22X1+X1*2+X2-3R1*2X2+2R1R2*X2
	- & +R2*2X2+X1X2)/((-1-R12+R22+X1)(-2+X1+X2))
	- & +8(-1-2R12-R14+2R1R2+2R13R2-2R1R2**3
	- & +R24+X1+R12X1+2R1R2X1-3R22X1+2R12X2
	- & -2R22X2+X1X2+X22)/(9(2-X1-X2)(-1+R12-R2*2+X2))
	- RFO2=9D0*RFO2/64D0
	- ISSET2=1
	- ENDIF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1-R12-R2*2)
	- RFO4=128(1+R12+R22-X1-X2)(X1+X2)/(9(-2+X1+X2)2)-32(-1
	- & +R1*4-6R1*2R22+R24+X1-R1*2X1+3R22X1+X2
	- & +R1*2X2-R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	- & -32(R12+R14+R22-6R1*2R22+R24-R1*2X1
	- & +2R22X1+2R12X2-R2*2X2-X1*X2)/
	- & ((-1-R12+R22+X1)(-1+R12-R22+X2))-128(-1+R1**4
	- & -6R12R22+R24+X1-R1*2X1+R2*2X1+X2+3R12X2
	- & -R2*2X2-X1X2)/(9(-1+R12-R22+X2)**2)
	- & +16(-1+R14-2R22-R24-2R12X1+2R22X1+X1**2
	- & +X2-3R12X2+R2*2X2+X1*X2)/
	- & ((-1-R12+R22+X1)*(-2+X1+ X2))
	- RFO4=RFO4+16(-1-2R12-R14+R24+X1+R12X1-3R2*2X1
	- & +2R12X2-2R22X2+X1X2+X2*2)/
	- & (9(1-R12+R22-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-R12+R22+2D0R2)
	- RFO1=32(2R2+X2)(-1-R12-R22+X2)/(9(-1+R12-R22+X2)**2)
	- & +8(-1-R12-2R1*2R2-R2*2-2R2*3+X1+R2X1+R2*2X1
	- & +3X2/2-R12X2/2+R2X2-R22X2/2-X1*X2/2)/
	- & ((-1-R12+R22+X1)(-1+R12-R22+X2))+8(2+2R12-2R2
	- & -2R12R2-6R22-2R2*3-3X1-R1*2X1+2R2X1
	- & +3R22X1+X12-X2-R12X2+R22X2+X1*X2)/
	- & (-1-R12+R22+X1)*2+32(4+4R12-4R2*2-5X1
	- & -R1*2X1-2R2X1+R2*2X1+X1*2-3X2-R1*2X2-2R2X2
	- & +R2*2X2+X1X2)/(9(-2+X1+X2)**2)
	- RFO1=RFO1+8(3+3R12-R2+R12R2-5R22-R23-4X1-R12X1
	- & +2R22X1+X1*2-2X2-R2X2+R22X2+X1*X2)/
	- & ((-1-R12+R22+X1)(2-X1-X2))+8(-1-R12+R2+R12*R2
	- & -R22-R23+X1+R2X1+R22X1+2X2+R12X2-X1*X2/2
	- & -X2*2/2)/(9(2-X1-X2)(-1+R12-R2*2+X2))
	- RFO1=9D0*RFO1/32D0
	- ISSET1=1
	- END IF
	- IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	- RLO2=PS(1D0-R12+R22-2D0R2)
	- RFO2=32(2R2-X2)(1+R12+R22-X2)/(9(-1+R12-R22+X2)**2)
	- & +8(-1-R12+2R1*2R2-R2*2+2R2*3+X1-R2X1+R2*2X1
	- & +3X2/2-R12X2/2-R2X2-R22X2/2-X1*X2/2)/
	- & ((-1-R12+R22+X1)(-1+R12-R22+X2))+8(2+2R12+2R2
	- & +2R12R2-6R22+2R2*3-3X1-R1*2X1-2R2X1
	- & +3R22X1+X12-X2-R12X2+R22X2+X1*X2)/
	- & (-1-R12+R22+X1)*2+8(3+3R12+R2-R12R2-5R2*2
	- & +R2*3-4X1-R1*2X1+2R22X1+X1*2-2X2+R2X2+R22X2
	- & +X1X2)/((-1-R12+R22+X1)(2-X1-X2))
	- RFO2=RFO2+32(4+4R1*2-4R2*2-5X1-R1*2X1+2R2X1+R2*2X1
	- & +X1*2-3X2-R1*2X2+2R2X2+R2*2X2+X1*X2)/
	- & (9(-2+X1+X2)2)+8(-1-R12-R2-R12R2-R22+R2*3+X1
	- & -R2X1+R22X1+2X2+R12X2-X1X2/2-X2*2/2)/
	- & (9(2-X1-X2)(-1+R12-R22+X2))
	- RFO2=9D0*RFO2/32D0
	- ISSET2=1
	- END IF
	- IF(ICOMBI.EQ.4) THEN
	- RLO4=PS(1D0-R12+R2*2)
	- RFO4=64X2(-1-R12-R22+X2)/(9(-1+R12-R22+X2)*2)
	- & +16(-1-R12-R22+X1+R22X1+3X2/2-R12X2/2
	- & -R2*2X2/2-X1*X2/2)/
	- & ((-1-R12+R22+X1)(-1+R12-R22+X2))+16(3+3R1*2
	- & -5R22-4X1-R1*2X1+2R22X1+X1*2-2X2+R2*2X2
	- & +X1X2)/((-1-R12+R22+X1)(2-X1-X2))
	- & +64(4+4R1*2-4R2*2-5X1-R1*2X1+R2*2X1+X1*2-3X2
	- & -R1*2X2+R2*2X2+X1X2)/(9(-2+X1+X2)**2)
	- RFO4=RFO4+16(2+2R1*2-6R2*2-3X1-R1*2X1+3R22X1+X1**2
	- & -X2-R1*2X2+R2*2X2+X1X2)/(-1-R12+R22+X1)*2
	- & +16(-1-R12-R22+X1+R22X1+2X2+R12X2-X1*X2/2
	- & -X2*2/2)/(9(2-X1-X2)(-1+R12-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=PS2D0((X1+X2-1D0+ANUM-R12-R22)/
	- & ((1D0+R12-R22-X1)(1D0+R22-R1*2-X2))-
	- & R12/(1D0+R22-R12-X2)2-
	- & R22/(1D0+R12-R22-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=ALPCORRLO1+(1D0-ALPCOR)RLO2
	- RFO=ALPCORRFO1+(1D0-ALPCOR)RFO2
	- ELSEIF(ISSET4.EQ.1) THEN
	- RLO=RLO4
	- RFO=RFO4
	- ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
	- RLO=0.5D0*(RLO1+RLO2)
	- RFO=0.5D0*(RFO1+RFO2)
	- ELSEIF(ISSET1.EQ.1) THEN
	- RLO=RLO1
	- RFO=RFO1
	- ELSE
	- CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
	- RLO=1D0
	- RFO=0D0
	- ENDIF
	-
	-C...Output.
	- PYMAEL=RFO/RLO
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYBOEI
	-C...Modifies an event so as to approximately take into account
	-C...Bose-Einstein effects according to a simple phenomenological
	-C...parametrization.
	-
	- SUBROUTINE PYBOEI(NSAV)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
	-C...Local arrays and data.
	- DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
	- &BEIW(100),BEI3W(100)
	- DATA KFBE/211,-211,111,321,-321,130,310,221,331/
	-C...Statement function: squared invariant mass.
	- SDIP(I,J)=((P(I,4)+P(J,4))2-(P(I,3)+P(J,3))2-
	- &(P(I,2)+P(J,2))2-(P(I,1)+P(J,1))2)
	-
	-C...Boost event to overall CM frame. Calculate CM energy.
	- IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
	- DO 100 J=1,4
	- DPS(J)=0D0
	- 100 CONTINUE
	- DO 120 I=1,N
	- KFA=IABS(K(I,2))
	- IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
	- & .AND.K(I,3).GT.0) THEN
	- KFMA=IABS(K(K(I,3),2))
	- IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
	- ENDIF
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
	- DO 110 J=1,4
	- DPS(J)=DPS(J)+P(I,J)
	- 110 CONTINUE
	- 120 CONTINUE
	- CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
	- &-DPS(3)/DPS(4))
	- PECM=0D0
	- DO 130 I=1,N
	- IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
	- 130 CONTINUE
	-
	-C...Check if we have separated strings
	-
	-C...Reserve copy of particles by species at end of record.
	- IWP=0
	- IWN=0
	- NBE(0)=N+MSTU(3)
	- NMAX=NBE(0)
	- SMMIN=PECM
	- DO 190 IBE=1,MIN(10,MSTJ(52)+1)
	- NBE(IBE)=NBE(IBE-1)
	- DO 180 I=NSAV+1,N
	- IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
	- DO 140 IIBE=1,IBE-1
	- IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
	- 140 CONTINUE
	- ELSE
	- IF(K(I,2).NE.KFBE(IBE)) GOTO 180
	- ENDIF
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
	- IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
	- CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
	- RETURN
	- ENDIF
	- NBE(IBE)=NBE(IBE)+1
	- NMAX=NBE(IBE)
	- K(NBE(IBE),1)=I
	- K(NBE(IBE),2)=0
	- K(NBE(IBE),3)=0
	- K(NBE(IBE),4)=0
	- K(NBE(IBE),5)=0
	- P(NBE(IBE),1)=0.0D0
	- P(NBE(IBE),2)=0.0D0
	- P(NBE(IBE),3)=0.0D0
	- P(NBE(IBE),4)=0.0D0
	- P(NBE(IBE),5)=0.0D0
	- SMMIN=MIN(SMMIN,P(I,5))
	-C...Check if particles comes from different W's or Z's
	- IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
	- IM=I
	- 150 IF(K(IM,3).GT.0) THEN
	- IM=K(IM,3)
	- IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
	- K(NBE(IBE),5)=IM
	- IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
	- IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
	- IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
	- IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
	- ENDIF
	- ENDIF
	-C...Check if particles comes from different strings.
	- IF(PARJ(94).GT.0.0D0) THEN
	- IM=I
	- 160 IF(K(IM,3).GT.0) THEN
	- IM=K(IM,3)
	- IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
	- K(NBE(IBE),5)=IM
	- ENDIF
	- ENDIF
	- DO 170 J=1,3
	- P(NBE(IBE),J)=0D0
	- V(NBE(IBE),J)=0D0
	- 170 CONTINUE
	- P(NBE(IBE),5)=-1.0D0
	- 180 CONTINUE
	- 190 CONTINUE
	- IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
	-
	-C...Calculate separation between W+ and W- or between two Z0's.
	-C...No separation if there has been re-connections.
	- SIGW=PARJ(93)
	- IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
	- IF(K(IWP,2).EQ.23) THEN
	- DMW=PMAS(23,1)
	- DGW=PMAS(23,2)
	- ELSE
	- DMW=PMAS(24,1)
	- DGW=PMAS(24,2)
	- ENDIF
	- DMP=P(IWP,5)
	- DMN=P(IWN,5)
	- TAUPD=DMP/SQRT((DMP2-DMW2)*2+(DGW(DMP2)/DMW)2)
	- TAUND=DMN/SQRT((DMN2-DMW2)*2+(DGW(DMN2)/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.1D0MIN(PMHQ,PARJ(93)3.0D0)
	- QDELW=0.1D0*MIN(PMHQ,SIGW)
	- QDEL3W=0.1D0MIN(PMHQ,SIGW3.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.5D0QDEL3/(3.0D0PARJ(93)))
	- BEEXW=EXP(0.5D0*QDELW/SIGW)
	- BEEX3W=EXP(0.5D0QDEL3W/(3.0D0SIGW))
	- 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(QBIN2+QDEL2/12D0)/SQRT(QBIN2+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(QBIN2+QDEL32/12D0)/SQRT(QBIN2+PMHQ*2)
	- IF(MSTJ(51).EQ.1) THEN
	- BEEX3=BEEX3*BERT3
	- BEI3(IBIN)=BEI3(IBIN)*BEEX3
	- ELSE
	- BEI3(IBIN)=BEI3(IBIN)EXP(-(QBIN/(3.0D0PARJ(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(QBIN2+QDELW2/12D0)/SQRT(QBIN2+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(QBIN2+QDEL3W*2/12D0)/
	- & SQRT(QBIN2+PMHQ2)
	- IF(MSTJ(51).EQ.1) THEN
	- BEEX3W=BEEX3W*BERT3W
	- BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
	- ELSE
	- BEI3W(IBIN)=BEI3W(IBIN)EXP(-(QBIN/(3.0D0SIGW))**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=(RBIN3-IBIN3)/(3IBIN(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+3D0PARJ(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=(RBIN33-IBIN33)/(3IBIN3(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+3D0PARJ(92)QMOV3))*(2D0/3D0)
	- RSCALE=1.0D0
	- IF(MSTJ(54).EQ.2)
	- & RSCALE=1.0D0-EXP(-(QOLD/(2D0PARJ(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=(RBINW3-IBINW3)/(3IBINW(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+3D0PARJ(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=(RBIN3W3-IBIN3W3)/(3IBIN3W(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+3D0PARJ(92)QMOV3W))*(2D0/3D0)
	- IF(MSTJ(54).EQ.2)
	- & RSCALE=1.0D0-EXP(-(QOLD/(2D0SIGW))*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(S12SM3,S13MIN(SM1,SM3),
	- & S23MIN(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 (WMAXWI.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=S12MIN(MIN(S23,S24),MIN(S13,S14))S34
	- W=MIN(W,S13MIN(MIN(S23,S34),S12)S24)
	- W=MIN(W,S14MIN(MIN(S24,S34),S12)S23)
	- W=MIN(W,MIN(S23,S24)S13S14)
	- 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,ENEW2-P2-(P(I3,5)+P(I4,5))2)
	- Q2OLDP=MAX(0.0D0,EOLD2-P2-(P(I3,5)+P(I4,5))2)
	- CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
	- DO 370 J=1,3
	- V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
	- V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
	- 370 CONTINUE
	- ENDIF
	- 380 CONTINUE
	- 390 CONTINUE
	- 400 CONTINUE
	-
	-C...Shift momenta and recalculate energies.
	- ESUMP=0.0D0
	- ESUM=0.0D0
	- PROD=0.0D0
	- DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
	- I=K(IM,1)
	- ESUMP=ESUMP+P(I,4)
	- DO 410 J=1,3
	- P(I,J)=P(I,J)+P(IM,J)
	- 410 CONTINUE
	- P(I,4)=SQRT(P(I,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	- ESUM=ESUM+P(I,4)
	- DO 420 J=1,3
	- PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
	- 420 CONTINUE
	- 430 CONTINUE
	-
	- PARJ(96)=0.0D0
	- IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
	- 440 ALPHA=(ESUMP-ESUM)/PROD
	- PARJ(96)=PARJ(96)+ALPHA
	- PROD=0.0D0
	- ESUM=0.0D0
	- DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
	- I=K(IM,1)
	- DO 450 J=1,3
	- P(I,J)=P(I,J)+ALPHA*V(IM,J)
	- 450 CONTINUE
	- P(I,4)=SQRT(P(I,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	- ESUM=ESUM+P(I,4)
	- DO 460 J=1,3
	- PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
	- 460 CONTINUE
	- 470 CONTINUE
	- IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
	- & GOTO 440
	- ENDIF
	-
	-C...Rescale all momenta for energy conservation.
	- PES=0D0
	- PQS=0D0
	- DO 480 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
	- PES=PES+P(I,4)
	- PQS=PQS+P(I,5)**2/P(I,4)
	- 480 CONTINUE
	- PARJ(95)=PES-PECM
	- FAC=(PECM-PQS)/(PES-PQS)
	- DO 500 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
	- DO 490 J=1,3
	- P(I,J)=FAC*P(I,J)
	- 490 CONTINUE
	- P(I,4)=SQRT(P(I,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	- 500 CONTINUE
	-
	-C...Boost back to correct reference frame.
	- 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
	- DO 520 I=1,N
	- IF(K(I,1).LT.0) K(I,1)=-K(I,1)
	- 520 CONTINUE
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYBESQ
	-C...Calculates the momentum shift in a system of two particles assuming
	-C...the relative momentum squared should be shifted to Q2NEW. NI is the
	-C...last position occupied in /PYJETS/.
	-
	- SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYJETS/,/PYDAT1/
	-C...Local arrays and data.
	- DIMENSION DP(5)
	- SAVE HC1
	-
	- IF(MSTJ(55).EQ.0) THEN
	- DQ2=Q2NEW-Q2OLD
	- DP2=(P(I1,1)-P(I2,1))2+(P(I1,2)-P(I2,2))2+
	- & (P(I1,3)-P(I2,3))**2
	- DP12=P(I1,1)2+P(I1,2)2+P(I1,3)**2
	- & -P(I2,1)2-P(I2,2)2-P(I2,3)**2
	- SE=P(I1,4)+P(I2,4)
	- DE=P(I1,4)-P(I2,4)
	- DQ2SE=DQ2+SE**2
	- DA=SEDEDP12-DP2*DQ2SE
	- DB=DP2DQ2SE-DP12*2
	- HA=(DA+SQRT(MAX(DA*2+DQ2(DQ2+SE2-DE2)DB,0D0)))/(2D0DB)
	- 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.5D0SQRT(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(PZ2+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(PZ2+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.5D0PMAS(KC,2)TAN((2D0PYR(0)-1D0)
	- & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
	- ELSE
	- PM0=PYMASS
	- PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))2-PM02)/
	- & (PM0*PMAS(KC,2)))
	- PMUPP=ATAN(((PM0+PMAS(KC,3))2-PM02)/(PM0*PMAS(KC,2)))
	- PYMASS=SQRT(MAX(0D0,PM0*2+PM0PMAS(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)*2PARF(90+KFA)2/PARU(117)2))/
	- & LOG(MAX(4D0,Q2/PARU(117)2)))(12D0/(33D0-2D0*MSTU(118)))
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYNAME
	-C...Gives the particle/parton name as a character string.
	-
	- SUBROUTINE PYNAME(KF,CHAU)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT4/CHAF(500,2)
	- CHARACTER CHAF*16
	- SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
	-C...Local character variable.
	- CHARACTER CHAU*16
	-
	-C...Read out code with distinction particle/antiparticle.
	- CHAU=' '
	- KC=PYCOMP(KF)
	- IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
	-
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYCHGE
	-C...Gives three times the charge for a particle/parton.
	-
	- FUNCTION PYCHGE(KF)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYDAT2/
	-
	-C...Read out charge and change sign for antiparticle.
	- PYCHGE=0
	- KC=PYCOMP(KF)
	- IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYCOMP
	-C...Compress the standard KF codes for use in mass and decay arrays;
	-C...also checks whether a given code actually is defined.
	-
	- FUNCTION PYCOMP(KF)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYDAT1/,/PYDAT2/
	-C...Local arrays and saved data.
	- DIMENSION KFORD(100:500),KCORD(101:500)
	- SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
	-
	-C...Whenever necessary reorder codes for faster search.
	- IF(MSTU(20).EQ.0) THEN
	- NFORD=100
	- KFORD(100)=0
	- DO 120 I=101,500
	- KFA=KCHG(I,4)
	- IF(KFA.LE.100) GOTO 120
	- NFORD=NFORD+1
	- DO 100 I1=NFORD-1,0,-1
	- IF(KFA.GE.KFORD(I1)) GOTO 110
	- KFORD(I1+1)=KFORD(I1)
	- KCORD(I1+1)=KCORD(I1)
	- 100 CONTINUE
	- 110 KFORD(I1+1)=KFA
	- KCORD(I1+1)=I
	- 120 CONTINUE
	- MSTU(20)=1
	- KFLAST=0
	- KCLAST=0
	- ENDIF
	-
	-C...Fast action if same code as in latest call.
	- IF(KF.EQ.KFLAST) THEN
	- PYCOMP=KCLAST
	- RETURN
	- ENDIF
	-
	-C...Starting values. Remove internal diquark flags.
	- PYCOMP=0
	- KFA=IABS(KF)
	- IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
	- & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
	-
	-C...Simple cases: direct translation.
	- IF(KFA.GT.KFORD(NFORD)) THEN
	- ELSEIF(KFA.LE.100) THEN
	- PYCOMP=KFA
	-
	-C...Else binary search.
	- ELSE
	- IMIN=100
	- IMAX=NFORD+1
	- 130 IAVG=(IMIN+IMAX)/2
	- IF(KFORD(IAVG).GT.KFA) THEN
	- IMAX=IAVG
	- IF(IMAX.GT.IMIN+1) GOTO 130
	- ELSEIF(KFORD(IAVG).LT.KFA) THEN
	- IMIN=IAVG
	- IF(IMAX.GT.IMIN+1) GOTO 130
	- ELSE
	- PYCOMP=KCORD(IAVG)
	- ENDIF
	- ENDIF
	-
	-C...Check if antiparticle allowed.
	- IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
	- IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
	- ENDIF
	-
	-C...Save codes for possible future fast action.
	- KFLAST=KF
	- KCLAST=PYCOMP
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYERRM
	-C...Informs user of errors in program execution.
	-
	- SUBROUTINE PYERRM(MERR,CHMESS)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYJETS/,/PYDAT1/
	-C...Local character variable.
	- CHARACTER CHMESS()
	-
	-C...Write first few warnings, then be silent.
	- IF(MERR.LE.10) THEN
	- MSTU(27)=MSTU(27)+1
	- MSTU(28)=MERR
	- IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
	- & MERR,MSTU(31),CHMESS
	-
	-C...Write first few errors, then be silent or stop program.
	- ELSEIF(MERR.LE.20) THEN
	- IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
	- MSTU(30)=MSTU(30)+1
	- MSTU(24)=MERR-10
	- IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
	- & MERR-10,MSTU(31),CHMESS
	- IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
	- WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
	- WRITE(MSTU(11),5200)
	- IF(MERR.NE.17) CALL PYLIST(2)
	- CALL PYSTOP(3)
	- ENDIF
	-
	-C...Stop program in case of irreparable error.
	- ELSE
	- WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
	- CALL PYSTOP(3)
	- ENDIF
	-
	-C...Formats for output.
	- 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
	- &' PYEXEC calls:'/5X,A)
	- 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
	- &' PYEXEC calls:'/5X,A)
	- 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
	- &'event!')
	- 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
	- &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYALEM
	-C...Calculates the running alpha_electromagnetic.
	-
	- FUNCTION PYALEM(Q2)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYDAT1/
	-
	-C...Calculate real part of photon vacuum polarization.
	-C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
	-C...For hadrons use parametrization of H. Burkhardt et al.
	-C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
	- AEMPI=PARU(101)/(3D0*PARU(1))
	- IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
	- RPIGG=0D0
	- ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
	- RPIGG=0D0
	- ELSEIF(MSTU(101).EQ.2) THEN
	- RPIGG=1D0-PARU(101)/PARU(103)
	- ELSEIF(Q2.LT.0.09D0) THEN
	- RPIGG=AEMPI(13.4916D0+LOG(Q2))+0.00835D0LOG(1D0+Q2)
	- ELSEIF(Q2.LT.9D0) THEN
	- RPIGG=AEMPI(16.3200D0+2D0LOG(Q2))+
	- & 0.00238D0LOG(1D0+3.927D0Q2)
	- ELSEIF(Q2.LT.1D4) THEN
	- RPIGG=AEMPI(13.4955D0+3D0LOG(Q2))+0.00165D0+
	- & 0.00299D0*LOG(1D0+Q2)
	- ELSE
	- RPIGG=AEMPI(13.4955D0+3D0LOG(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,(2D0107D0/2025D0),(2D0963D0/14375D0),
	-c &(2D0*321D0/3703D0),0D0/
	-c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
	-c &(-2D0963D0/13225D0),(-2D0321D0/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(-6D0PARU(1)/
	- & ((33D0-2D0MSTU(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=ALAM2Q2RAT(2D0/(33D0-2D0NF))
	- IF(MSTU(111).EQ.2) ALAM2=ALAM2LOG(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=ALAM2Q2RAT(-2D0/(33D0-2D0NF))
	- IF(MSTU(111).EQ.2) ALAM2=ALAM2LOG(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)/(B0ALGQ)(1D0-B1*LOG(ALGQ)/
	- & (B0*2ALGQ)))
	- 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(X2+Y2)
	- 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(IJ,179)K,179)
	- I=J
	- J=K
	- K=M
	- L=MOD(53*L+1,169)
	- IF(MOD(L*M,64).GE.32) S=S+T
	- T=0.5D0*T
	- 100 CONTINUE
	- RRPY(II)=S
	- 110 CONTINUE
	- TWOM24=1D0
	- DO 120 I24=1,24
	- TWOM24=0.5D0*TWOM24
	- 120 CONTINUE
	- RRPY98=362436D0*TWOM24
	- RRPY99=7654321D0*TWOM24
	- RRPY00=16777213D0*TWOM24
	- MRPY2=1
	- MRPY3=0
	- MRPY4=97
	- MRPY5=33
	- ENDIF
	-
	-C...Generate next random number.
	- 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
	- IF(RUNI.LT.0D0) RUNI=RUNI+1D0
	- RRPY(MRPY4)=RUNI
	- MRPY4=MRPY4-1
	- IF(MRPY4.EQ.0) MRPY4=97
	- MRPY5=MRPY5-1
	- IF(MRPY5.EQ.0) MRPY5=97
	- RRPY98=RRPY98-RRPY99
	- IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
	- RUNI=RUNI-RRPY98
	- IF(RUNI.LT.0D0) RUNI=RUNI+1D0
	- IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
	-
	-C...Update counters. Random number to output.
	- MRPY3=MRPY3+1
	- IF(MRPY3.EQ.1000000000) THEN
	- MRPY2=MRPY2+1
	- MRPY3=0
	- ENDIF
	- PYR=RUNI
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYRGET
	-C...Dumps the state of the random number generator on a file
	-C...for subsequent startup from this state onwards.
	-
	- SUBROUTINE PYRGET(LFN,MOVE)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDATR/MRPY(6),RRPY(100)
	- SAVE /PYDATR/
	-C...Local character variable.
	- CHARACTER CHERR*8
	-
	-C...Backspace required number of records (or as many as there are).
	- IF(MOVE.LT.0) THEN
	- NBCK=MIN(MRPY(6),-MOVE)
	- DO 100 IBCK=1,NBCK
	- BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
	- 100 CONTINUE
	- MRPY(6)=MRPY(6)-NBCK
	- ENDIF
	-
	-C...Unformatted write on unit LFN.
	- WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
	- &(RRPY(I2),I2=1,100)
	- MRPY(6)=MRPY(6)+1
	- RETURN
	-
	-C...Write error.
	- 110 WRITE(CHERR,'(I8)') IERR
	- CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
	- &CHERR)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYRSET
	-C...Reads a state of the random number generator from a file
	-C...for subsequent generation from this state onwards.
	-
	- SUBROUTINE PYRSET(LFN,MOVE)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDATR/MRPY(6),RRPY(100)
	- SAVE /PYDATR/
	-C...Local character variable.
	- CHARACTER CHERR*8
	-
	-C...Backspace required number of records (or as many as there are).
	- IF(MOVE.LT.0) THEN
	- NBCK=MIN(MRPY(6),-MOVE)
	- DO 100 IBCK=1,NBCK
	- BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
	- 100 CONTINUE
	- MRPY(6)=MRPY(6)-NBCK
	- ENDIF
	-
	-C...Unformatted read from unit LFN.
	- NFOR=1+MAX(0,MOVE)
	- DO 110 IFOR=1,NFOR
	- READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
	- & (RRPY(I2),I2=1,100)
	- 110 CONTINUE
	- MRPY(6)=MRPY(6)+NFOR
	- RETURN
	-
	-C...Write error.
	- 120 WRITE(CHERR,'(I8)') IERR
	- CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
	- &CHERR)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYROBO
	-C...Performs rotations and boosts.
	-
	- SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- SAVE /PYJETS/,/PYDAT1/
	-C...Local arrays.
	- DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
	-
	-C...Find and check range of rotation/boost.
	- IMIN=IMI
	- IF(IMIN.LE.0) IMIN=1
	- IF(MSTU(1).GT.0) IMIN=MSTU(1)
	- IMAX=IMA
	- IF(IMAX.LE.0) IMAX=N
	- IF(MSTU(2).GT.0) IMAX=MSTU(2)
	- IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
	- CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
	- RETURN
	- ENDIF
	-
	-C...Optional resetting of V (when not set before.)
	- IF(MSTU(33).NE.0) THEN
	- DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
	- DO 100 J=1,5
	- V(I,J)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	- MSTU(33)=0
	- ENDIF
	-
	-C...Rotate, typically from z axis to direction (theta,phi).
	- IF(THE2+PHI2.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(BEX2+BEY2+BEZ**2.GT.1D-20) THEN
	- DBX=BEX
	- DBY=BEY
	- DBZ=BEZ
	- DB=SQRT(DBX2+DBY2+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=DBXDP(1)+DBYDP(2)+DBZ*DP(3)
	- DGABP=DGA(DGADBP/(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=DBXDV(1)+DBYDV(2)+DBZ*DV(3)
	- DGABV=DGA(DGADBV/(1D0+DGA)+DV(4))
	- V(I,1)=DV(1)+DGABV*DBX
	- V(I,2)=DV(2)+DGABV*DBY
	- V(I,3)=DV(3)+DGABV*DBZ
	- V(I,4)=DGA*(DV(4)+DBV)
	- 160 CONTINUE
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYEDIT
	-C...Performs global manipulations on the event record, in particular
	-C...to exclude unstable or undetectable partons/particles.
	-
	- SUBROUTINE PYEDIT(MEDIT)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
	-C...Local arrays.
	- DIMENSION NS(2),PTS(2),PLS(2)
	-
	-C...Remove unwanted partons/particles.
	- IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
	- IMAX=N
	- IF(MSTU(2).GT.0) IMAX=MSTU(2)
	- I1=MAX(1,MSTU(1))-1
	- DO 110 I=MAX(1,MSTU(1)),IMAX
	- IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
	- IF(MEDIT.EQ.1) THEN
	- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
	- ELSEIF(MEDIT.EQ.2) THEN
	- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 110
	- ELSEIF(MEDIT.EQ.3) THEN
	- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0) GOTO 110
	- IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
	- ELSEIF(MEDIT.EQ.5) THEN
	- IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0) GOTO 110
	- IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
	- & KCHG(KC,2).EQ.0) GOTO 110
	- ENDIF
	-
	-C...Pack remaining partons/particles. Origin no longer known.
	- I1=I1+1
	- DO 100 J=1,5
	- K(I1,J)=K(I,J)
	- P(I1,J)=P(I,J)
	- V(I1,J)=V(I,J)
	- 100 CONTINUE
	- K(I1,3)=0
	- 110 CONTINUE
	- IF(I1.LT.N) MSTU(3)=0
	- IF(I1.LT.N) MSTU(70)=0
	- N=I1
	-
	-C...Selective removal of class of entries. New position of retained.
	- ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
	- I1=0
	- DO 120 I=1,N
	- K(I,3)=MOD(K(I,3),MSTU(5))
	- IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
	- IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
	- IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
	- & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
	- IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
	- & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
	- IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
	- I1=I1+1
	- K(I,3)=K(I,3)+MSTU(5)*I1
	- 120 CONTINUE
	-
	-C...Find new event history information and replace old.
	- DO 140 I=1,N
	- IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
	- & K(I,3)/MSTU(5).EQ.0) GOTO 140
	- ID=I
	- 130 IM=MOD(K(ID,3),MSTU(5))
	- IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
	- IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
	- & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
	- ID=IM
	- GOTO 130
	- ENDIF
	- ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
	- IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
	- & K(IM,2).EQ.94) THEN
	- ID=IM
	- GOTO 130
	- ENDIF
	- ENDIF
	- K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
	- IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
	- IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
	- & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
	- IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
	- & K(K(I,4),3)/MSTU(5)
	- IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
	- & K(K(I,5),3)/MSTU(5)
	- ELSE
	- KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
	- IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
	- & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
	- KCD=MOD(K(I,4),MSTU(5))
	- IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
	- K(I,4)=MSTU(5)*2(K(I,4)/MSTU(5)*2)+MSTU(5)KCM+KCD
	- KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
	- IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
	- KCD=MOD(K(I,5),MSTU(5))
	- IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
	- K(I,5)=MSTU(5)*2(K(I,5)/MSTU(5)*2)+MSTU(5)KCM+KCD
	- ENDIF
	- 140 CONTINUE
	-
	-C...Pack remaining entries.
	- I1=0
	- MSTU90=MSTU(90)
	- MSTU(90)=0
	- DO 170 I=1,N
	- IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
	- I1=I1+1
	- DO 150 J=1,5
	- K(I1,J)=K(I,J)
	- P(I1,J)=P(I,J)
	- V(I1,J)=V(I,J)
	- 150 CONTINUE
	-C...Also update LHA1 colour tags
	- MCT(I1,1)=MCT(I,1)
	- MCT(I1,2)=MCT(I,2)
	- K(I1,3)=MOD(K(I1,3),MSTU(5))
	- DO 160 IZ=1,MSTU90
	- IF(I.EQ.MSTU(90+IZ)) THEN
	- MSTU(90)=MSTU(90)+1
	- MSTU(90+MSTU(90))=I1
	- PARU(90+MSTU(90))=PARU(90+IZ)
	- ENDIF
	- 160 CONTINUE
	- 170 CONTINUE
	- IF(I1.LT.N) MSTU(3)=0
	- IF(I1.LT.N) MSTU(70)=0
	- N=I1
	-
	-C...Fill in some missing daughter pointers (lost in colour flow).
	- ELSEIF(MEDIT.EQ.16) THEN
	- DO 220 I=1,N
	- IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
	- IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
	-C...Find daughters who point to mother.
	- DO 180 I1=I+1,N
	- IF(K(I1,3).NE.I) THEN
	- ELSEIF(K(I,4).EQ.0) THEN
	- K(I,4)=I1
	- ELSE
	- K(I,5)=I1
	- ENDIF
	- 180 CONTINUE
	- IF(K(I,5).EQ.0) K(I,5)=K(I,4)
	- IF(K(I,4).NE.0) GOTO 220
	-C...Find daughters who point to documentation version of mother.
	- IM=K(I,3)
	- IF(IM.LE.0.OR.IM.GE.I) GOTO 220
	- IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
	- IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
	- DO 190 I1=I+1,N
	- IF(K(I1,3).NE.IM) THEN
	- ELSEIF(K(I,4).EQ.0) THEN
	- K(I,4)=I1
	- ELSE
	- K(I,5)=I1
	- ENDIF
	- 190 CONTINUE
	- IF(K(I,5).EQ.0) K(I,5)=K(I,4)
	- IF(K(I,4).NE.0) GOTO 220
	-C...Find daughters who point to documentation daughters who,
	-C...in their turn, point to documentation mother.
	- ID1=IM
	- ID2=IM
	- DO 200 I1=IM+1,I-1
	- IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
	- ID2=I1
	- IF(ID1.EQ.IM) ID1=I1
	- ENDIF
	- 200 CONTINUE
	- DO 210 I1=I+1,N
	- IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
	- ELSEIF(K(I,4).EQ.0) THEN
	- K(I,4)=I1
	- ELSE
	- K(I,5)=I1
	- ENDIF
	- 210 CONTINUE
	- IF(K(I,5).EQ.0) K(I,5)=K(I,4)
	- 220 CONTINUE
	-
	-C...Save top entries at bottom of PYJETS commonblock.
	- ELSEIF(MEDIT.EQ.21) THEN
	- IF(2*N.GE.MSTU(4)) THEN
	- CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
	- RETURN
	- ENDIF
	- DO 240 I=1,N
	- DO 230 J=1,5
	- K(MSTU(4)-I,J)=K(I,J)
	- P(MSTU(4)-I,J)=P(I,J)
	- V(MSTU(4)-I,J)=V(I,J)
	- 230 CONTINUE
	- 240 CONTINUE
	- MSTU(32)=N
	-
	-C...Restore bottom entries of commonblock PYJETS to top.
	- ELSEIF(MEDIT.EQ.22) THEN
	- DO 260 I=1,MSTU(32)
	- DO 250 J=1,5
	- K(I,J)=K(MSTU(4)-I,J)
	- P(I,J)=P(MSTU(4)-I,J)
	- V(I,J)=V(MSTU(4)-I,J)
	- 250 CONTINUE
	- 260 CONTINUE
	- N=MSTU(32)
	-
	-C...Mark primary entries at top of commonblock PYJETS as untreated.
	- ELSEIF(MEDIT.EQ.23) THEN
	- I1=0
	- DO 270 I=1,N
	- KH=K(I,3)
	- IF(KH.GE.1) THEN
	- IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
	- ENDIF
	- IF(KH.NE.0) GOTO 280
	- I1=I1+1
	- IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
	- IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
	- 270 CONTINUE
	- 280 N=I1
	-
	-C...Place largest axis along z axis and second largest in xy plane.
	- ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
	- CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
	- & P(MSTU(61),2)),0D0,0D0,0D0)
	- CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
	- & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
	- CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
	- & P(MSTU(61)+1,2)),0D0,0D0,0D0)
	- IF(MEDIT.EQ.31) RETURN
	-
	-C...Rotate to put slim jet along +z axis.
	- DO 290 IS=1,2
	- NS(IS)=0
	- PTS(IS)=0D0
	- PLS(IS)=0D0
	- 290 CONTINUE
	- DO 300 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
	- IF(MSTU(41).GE.2) THEN
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 300
	- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
	- & .EQ.0) GOTO 300
	- ENDIF
	- IS=2D0-SIGN(0.5D0,P(I,3))
	- NS(IS)=NS(IS)+1
	- PTS(IS)=PTS(IS)+SQRT(P(I,1)2+P(I,2)2)
	- 300 CONTINUE
	- IF(NS(1)PTS(2)2.LT.NS(2)PTS(1)**2)
	- & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
	-
	-C...Rotate to put second largest jet into -z,+x quadrant.
	- DO 310 I=1,N
	- IF(P(I,3).GE.0D0) GOTO 310
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
	- IF(MSTU(41).GE.2) THEN
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 310
	- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
	- & .EQ.0) GOTO 310
	- ENDIF
	- IS=2D0-SIGN(0.5D0,P(I,1))
	- PLS(IS)=PLS(IS)-P(I,3)
	- 310 CONTINUE
	- IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
	- & 0D0,0D0,0D0)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYLIST
	-C...Gives program heading, or lists an event, or particle
	-C...data, or current parameter values.
	-
	- SUBROUTINE PYLIST(MLIST)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-
	-C...HEPEVT commonblock.
	- PARAMETER (NMXHEP=4000)
	- COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- DOUBLE PRECISION PHEP,VHEP
	- SAVE /HEPEVT/
	-
	-C...User process event common block.
	- INTEGER MAXNUP
	- PARAMETER (MAXNUP=500)
	- INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	- DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	- COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	- &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	- &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	- SAVE /HEPEUP/
	-
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- COMMON/PYCTAG/NCT,MCT(4000,2)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
	-C...Local arrays, character variables and data.
	- CHARACTER CHAP16,CHAC16,CHAN16,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=1000KFLA+100KFLB+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=10000KFLR+100KFLB+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=10000KFLR+110KFLB+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=1000KFLA+100KFLC+10*KFLB+KFLS
	- IF(KFLSP.GE.2) KF=1000KFLA+100KFLB+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(2IREFER)36, LINE*79,
	- &VERS1, SUBV3, DATE2, YEAR4, HOUR2, MINU2, 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
	-
	-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 CHINL120,CHKF9,CHVAR(22)9,CHLIN72,
	- &CHBLK(20)72,CHOLD16,CHTMP16,CHNEW16,CHCOM*24
	- DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
	- &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
	- &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
	- &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
	- &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
	-
	-C...Write header if not yet done.
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	-
	-C...Write information on file for editing.
	- IF(MUPDA.EQ.1) THEN
	- DO 110 KC=1,500
	- WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
	- & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
	- & MWID(KC),MDCY(KC,1)
	- DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
	- WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
	- & (KFDP(IDC,J),J=1,5)
	- 100 CONTINUE
	- 110 CONTINUE
	-
	-C...Read complete set of information from edited file or
	-C...read partial set of new or updated information from edited file.
	- ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
	-
	-C...Reset counters.
	- KCC=100
	- NDC=0
	- CHKF=' '
	- IF(MUPDA.EQ.2) THEN
	- DO 120 I=1,MSTU(6)
	- KCHG(I,4)=0
	- 120 CONTINUE
	- ELSE
	- DO 130 KC=1,MSTU(6)
	- IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
	- NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
	- 130 CONTINUE
	- ENDIF
	-
	-C...Begin of loop: read new line; unknown whether particle or
	-C...decay data.
	- 140 READ(LFN,5200,END=190) CHINL
	-
	-C...Identify particle code and whether already defined (for MUPDA=3).
	- IF(CHINL(2:10).NE.' ') THEN
	- CHKF=CHINL(2:10)
	- READ(CHKF,5300) KF
	- IF(MUPDA.EQ.2) THEN
	- IF(KF.LE.100) THEN
	- KC=KF
	- ELSE
	- KCC=KCC+1
	- KC=KCC
	- ENDIF
	- ELSE
	- KCREP=0
	- IF(KF.LE.100) THEN
	- KCREP=KF
	- ELSE
	- DO 150 KCR=101,KCC
	- IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
	- 150 CONTINUE
	- ENDIF
	-C...Remove duplicate old decay data.
	- IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
	- IDCREP=MDCY(KCREP,2)
	- NDCREP=MDCY(KCREP,3)
	- DO 160 I=1,KCC
	- IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
	- 160 CONTINUE
	- DO 180 I=IDCREP,NDC-NDCREP
	- MDME(I,1)=MDME(I+NDCREP,1)
	- MDME(I,2)=MDME(I+NDCREP,2)
	- BRAT(I)=BRAT(I+NDCREP)
	- DO 170 J=1,5
	- KFDP(I,J)=KFDP(I+NDCREP,J)
	- 170 CONTINUE
	- 180 CONTINUE
	- NDC=NDC-NDCREP
	- KC=KCREP
	- ELSEIF(KCREP.NE.0) THEN
	- KC=KCREP
	- ELSE
	- KCC=KCC+1
	- KC=KCC
	- ENDIF
	- ENDIF
	-
	-C...Study line with particle data.
	- IF(KC.GT.MSTU(6)) CALL PYERRM(27,
	- & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
	- READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
	- & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
	- & MWID(KC),MDCY(KC,1)
	- MDCY(KC,2)=0
	- MDCY(KC,3)=0
	-
	-C...Study line with decay data.
	- ELSE
	- NDC=NDC+1
	- IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
	- & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
	- IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
	- MDCY(KC,3)=MDCY(KC,3)+1
	- READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
	- & (KFDP(NDC,J),J=1,5)
	- ENDIF
	-
	-C...End of loop; ensure that PYCOMP tables are updated.
	- GOTO 140
	- 190 CONTINUE
	- MSTU(20)=0
	-
	-C...Perform possible tests that new information is consistent.
	- DO 220 KC=1,MSTU(6)
	- KF=KCHG(KC,4)
	- IF(KF.EQ.0) GOTO 220
	- WRITE(CHKF,5300) KF
	- IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
	- & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
	- & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
	- BRSUM=0D0
	- DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
	- IF(MDME(IDC,2).GT.80) GOTO 210
	- KQ=KCHG(KC,1)
	- PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
	- MERR=0
	- DO 200 J=1,5
	- KP=KFDP(IDC,J)
	- IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
	- IF(KP.EQ.81) KQ=0
	- ELSEIF(PYCOMP(KP).EQ.0) THEN
	- MERR=3
	- ELSE
	- KQ=KQ-PYCHGE(KP)
	- KPC=PYCOMP(KP)
	- PMS=PMS-PMAS(KPC,1)
	- IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
	- & PMAS(KPC,3))
	- ENDIF
	- 200 CONTINUE
	- IF(KQ.NE.0) MERR=MAX(2,MERR)
	- IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
	- & MERR=MAX(1,MERR)
	- IF(MERR.EQ.3) CALL PYERRM(17,
	- & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
	- IF(MERR.EQ.2) CALL PYERRM(17,
	- & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
	- IF(MERR.EQ.1) CALL PYERRM(7,
	- & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
	- BRSUM=BRSUM+BRAT(IDC)
	- 210 CONTINUE
	- WRITE(CHTMP,5500) BRSUM
	- IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
	- & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
	- & CHTMP(9:16)//' for KF ='//CHKF)
	- 220 CONTINUE
	-
	-C...Write DATA statements for inclusion in program.
	- ELSEIF(MUPDA.EQ.4) THEN
	-
	-C...Find out how many codes and decay channels are actually used.
	- KCC=0
	- NDC=0
	- DO 230 I=1,MSTU(6)
	- IF(KCHG(I,4).NE.0) THEN
	- KCC=I
	- NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
	- ENDIF
	- 230 CONTINUE
	-
	-C...Initialize writing of DATA statements for inclusion in program.
	- DO 300 IVAR=1,22
	- NDIM=MSTU(6)
	- IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
	- NLIN=1
	- CHLIN=' '
	- CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
	- LLIN=35
	- CHOLD='START'
	-
	-C...Loop through variables for conversion to characters.
	- DO 280 IDIM=1,NDIM
	- IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
	- IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
	- IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
	- IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
	- IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
	- IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
	- IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
	- IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
	- IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
	- IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
	- IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
	- IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
	- IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
	- IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
	- IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
	- IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
	- IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
	- IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
	- IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
	- IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
	- IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
	- IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
	-
	-C...Replace variables beyond what is properly defined.
	- IF(IVAR.LE.4) THEN
	- IF(IDIM.GT.KCC) CHTMP=' 0'
	- ELSEIF(IVAR.LE.8) THEN
	- IF(IDIM.GT.KCC) CHTMP=' 0.0'
	- ELSEIF(IVAR.LE.11) THEN
	- IF(IDIM.GT.KCC) CHTMP=' 0'
	- ELSEIF(IVAR.LE.13) THEN
	- IF(IDIM.GT.NDC) CHTMP=' 0'
	- ELSEIF(IVAR.LE.14) THEN
	- IF(IDIM.GT.NDC) CHTMP=' 0.0'
	- ELSEIF(IVAR.LE.19) THEN
	- IF(IDIM.GT.NDC) CHTMP=' 0'
	- ELSEIF(IVAR.LE.21) THEN
	- IF(IDIM.GT.KCC) CHTMP=' '
	- ELSE
	- IF(IDIM.GT.KCC) CHTMP=' 0'
	- ENDIF
	-
	-C...Length of variable, trailing decimal zeros, quotation marks.
	- LLOW=1
	- LHIG=1
	- DO 240 LL=1,16
	- IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
	- IF(CHTMP(LL:LL).NE.' ') LHIG=LL
	- 240 CONTINUE
	- CHNEW=CHTMP(LLOW:LHIG)//' '
	- LNEW=1+LHIG-LLOW
	- IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
	- LNEW=LNEW+1
	- 250 LNEW=LNEW-1
	- IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
	- IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
	- IF(LNEW.EQ.0) THEN
	- CHNEW(1:3)='0D0'
	- LNEW=3
	- ELSE
	- CHNEW(LNEW+1:LNEW+2)='D0'
	- LNEW=LNEW+2
	- ENDIF
	- ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
	- DO 260 LL=LNEW,1,-1
	- IF(CHNEW(LL:LL).EQ.'''') THEN
	- CHTMP=CHNEW
	- CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
	- LNEW=LNEW+1
	- ENDIF
	- 260 CONTINUE
	- LNEW=MIN(14,LNEW)
	- CHTMP=CHNEW
	- CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
	- LNEW=LNEW+2
	- ENDIF
	-
	-C...Form composite character string, often including repetition counter.
	- IF(CHNEW.NE.CHOLD) THEN
	- NRPT=1
	- CHOLD=CHNEW
	- CHCOM=CHNEW
	- LCOM=LNEW
	- ELSE
	- LRPT=LNEW+1
	- IF(NRPT.GE.2) LRPT=LNEW+3
	- IF(NRPT.GE.10) LRPT=LNEW+4
	- IF(NRPT.GE.100) LRPT=LNEW+5
	- IF(NRPT.GE.1000) LRPT=LNEW+6
	- LLIN=LLIN-LRPT
	- NRPT=NRPT+1
	- WRITE(CHTMP,5400) NRPT
	- LRPT=1
	- IF(NRPT.GE.10) LRPT=2
	- IF(NRPT.GE.100) LRPT=3
	- IF(NRPT.GE.1000) LRPT=4
	- CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
	- LCOM=LRPT+1+LNEW
	- ENDIF
	-
	-C...Add characters to end of line, to new line (after storing old line),
	-C...or to new block of lines (after writing old block).
	- IF(LLIN+LCOM.LE.70) THEN
	- CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
	- LLIN=LLIN+LCOM+1
	- ELSEIF(NLIN.LE.19) THEN
	- CHLIN(LLIN+1:72)=' '
	- CHBLK(NLIN)=CHLIN
	- NLIN=NLIN+1
	- CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
	- LLIN=6+LCOM+1
	- ELSE
	- CHLIN(LLIN:72)='/'//' '
	- CHBLK(NLIN)=CHLIN
	- WRITE(CHTMP,5400) IDIM-NRPT
	- CHBLK(1)(30:33)=CHTMP(13:16)
	- DO 270 ILIN=1,NLIN
	- WRITE(LFN,5700) CHBLK(ILIN)
	- 270 CONTINUE
	- NLIN=1
	- CHLIN=' '
	- CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
	- & ',I= , )/'//CHCOM(1:LCOM)//','
	- WRITE(CHTMP,5400) IDIM-NRPT+1
	- CHLIN(25:28)=CHTMP(13:16)
	- LLIN=35+LCOM+1
	- ENDIF
	- 280 CONTINUE
	-
	-C...Write final block of lines.
	- CHLIN(LLIN:72)='/'//' '
	- CHBLK(NLIN)=CHLIN
	- WRITE(CHTMP,5400) NDIM
	- CHBLK(1)(30:33)=CHTMP(13:16)
	- DO 290 ILIN=1,NLIN
	- WRITE(LFN,5700) CHBLK(ILIN)
	- 290 CONTINUE
	- 300 CONTINUE
	- ENDIF
	-
	-C...Formats for reading and writing particle data.
	- 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
	- 5100 FORMAT(10X,2I5,F12.6,5I10)
	- 5200 FORMAT(A120)
	- 5300 FORMAT(I9)
	- 5400 FORMAT(I16)
	- 5500 FORMAT(F16.5)
	- 5600 FORMAT(F16.6)
	- 5700 FORMAT(A72)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYK
	-C...Provides various integer-valued event related data.
	-
	- FUNCTION PYK(I,J)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Default value. For I=0 number of entries, number of stable entries
	-C...or 3 times total charge.
	- PYK=0
	- IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
	- ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
	- PYK=N
	- ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
	- DO 100 I1=1,N
	- IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
	- IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
	- & PYCHGE(K(I1,2))
	- 100 CONTINUE
	- ELSEIF(I.EQ.0) THEN
	-
	-C...For I > 0 direct readout of K matrix or charge.
	- ELSEIF(J.LE.5) THEN
	- PYK=K(I,J)
	- ELSEIF(J.EQ.6) THEN
	- PYK=PYCHGE(K(I,2))
	-
	-C...Status (existing/fragmented/decayed), parton/hadron separation.
	- ELSEIF(J.LE.8) THEN
	- IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
	- IF(J.EQ.8) PYK=PYK*K(I,2)
	- ELSEIF(J.LE.12) THEN
	- KFA=IABS(K(I,2))
	- KC=PYCOMP(KFA)
	- KQ=0
	- IF(KC.NE.0) KQ=KCHG(KC,2)
	- IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
	- IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
	- IF(J.EQ.11) PYK=KC
	- IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
	-
	-C...Heaviest flavour in hadron/diquark.
	- ELSEIF(J.EQ.13) THEN
	- KFA=IABS(K(I,2))
	- PYK=MOD(KFA/100,10)(-1)*MOD(KFA/100,10)
	- IF(KFA.LT.10) PYK=KFA
	- IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
	- PYK=PYK*ISIGN(1,K(I,2))
	-
	-C...Particle history: generation, ancestor, rank.
	- ELSEIF(J.LE.15) THEN
	- I2=I
	- I1=I
	- 110 PYK=PYK+1
	- I2=I1
	- I1=K(I1,3)
	- IF(I1.GT.0) THEN
	- IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
	- ENDIF
	- IF(J.EQ.15) PYK=I2
	- ELSEIF(J.EQ.16) THEN
	- KFA=IABS(K(I,2))
	- IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
	- & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
	- I1=I
	- 120 I2=I1
	- I1=K(I1,3)
	- IF(I1.GT.0) THEN
	- KFAM=IABS(K(I1,2))
	- ILP=1
	- IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
	- IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
	- & ILP=0
	- IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
	- IF(ILP.EQ.1) GOTO 120
	- ENDIF
	- IF(K(I1,1).EQ.12) THEN
	- DO 130 I3=I1+1,I2
	- IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
	- & .AND.K(I3,2).NE.93) PYK=PYK+1
	- 130 CONTINUE
	- ELSE
	- I3=I2
	- 140 PYK=PYK+1
	- I3=I3+1
	- IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
	- ENDIF
	- ENDIF
	-
	-C...Particle coming from collapsing jet system or not.
	- ELSEIF(J.EQ.17) THEN
	- I1=I
	- 150 PYK=PYK+1
	- I3=I1
	- I1=K(I1,3)
	- I0=MAX(1,I1)
	- KC=PYCOMP(K(I0,2))
	- IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
	- IF(PYK.EQ.1) PYK=-1
	- IF(PYK.GT.1) PYK=0
	- RETURN
	- ENDIF
	- IF(KCHG(KC,2).EQ.0) GOTO 150
	- IF(K(I1,1).NE.12) PYK=0
	- IF(K(I1,1).NE.12) RETURN
	- I2=I1
	- 160 I2=I2+1
	- IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
	- K3M=K(I3-1,3)
	- IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
	- K3P=K(I3+1,3)
	- IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
	-
	-C...Number of decay products. Colour flow.
	- ELSEIF(J.EQ.18) THEN
	- IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
	- IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
	- ELSEIF(J.LE.22) THEN
	- IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
	- IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
	- IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
	- IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
	- IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
	- ELSE
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYP
	-C...Provides various real-valued event related data.
	-
	- FUNCTION PYP(I,J)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local array.
	- DIMENSION PSUM(4)
	-
	-C...Set default value. For I = 0 sum of momenta or charges,
	-C...or invariant mass of system.
	- PYP=0D0
	- IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
	- ELSEIF(I.EQ.0.AND.J.LE.4) THEN
	- DO 100 I1=1,N
	- IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
	- 100 CONTINUE
	- ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
	- DO 120 J1=1,4
	- PSUM(J1)=0D0
	- DO 110 I1=1,N
	- IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
	- & P(I1,J1)
	- 110 CONTINUE
	- 120 CONTINUE
	- PYP=SQRT(MAX(0D0,PSUM(4)2-PSUM(1)2-PSUM(2)2-PSUM(3)2))
	- ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
	- DO 130 I1=1,N
	- IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
	- 130 CONTINUE
	- ELSEIF(I.EQ.0) THEN
	-
	-C...Direct readout of P matrix.
	- ELSEIF(J.LE.5) THEN
	- PYP=P(I,J)
	-
	-C...Charge, total momentum, transverse momentum, transverse mass.
	- ELSEIF(J.LE.12) THEN
	- IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
	- IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)2+P(I,2)2+P(I,3)**2
	- IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)2+P(I,2)2
	- IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)2+P(I,1)2+P(I,2)**2
	- IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
	-
	-C...Theta and phi angle in radians or degrees.
	- ELSEIF(J.LE.16) THEN
	- IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)2+P(I,2)2))
	- IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
	- IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
	-
	-C...True rapidity, rapidity with pion mass, pseudorapidity.
	- ELSEIF(J.LE.19) THEN
	- PMR=0D0
	- IF(J.EQ.17) PMR=P(I,5)
	- IF(J.EQ.18) PMR=PYMASS(211)
	- PR=MAX(1D-20,PMR2+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=2D0SQRT(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=2D0SQRT(P(I,1)2+P(I,2)*2)/PARU(21)
	- IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
	- IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
	- IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
	- ENDIF
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYSPHE
	-C...Performs sphericity tensor analysis to give sphericity,
	-C...aplanarity and the related event axes.
	-
	- SUBROUTINE PYSPHE(SPH,APL)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local arrays.
	- DIMENSION SM(3,3),SV(3,3)
	-
	-C...Calculate matrix to be diagonalized.
	- NP=0
	- DO 110 J1=1,3
	- DO 100 J2=J1,3
	- SM(J1,J2)=0D0
	- 100 CONTINUE
	- 110 CONTINUE
	- PS=0D0
	- DO 140 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
	- IF(MSTU(41).GE.2) THEN
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 140
	- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	- & GOTO 140
	- ENDIF
	- NP=NP+1
	- PA=SQRT(P(I,1)2+P(I,2)2+P(I,3)**2)
	- PWT=1D0
	- IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
	- & MAX(1D-10,PA)**(PARU(41)-2D0)
	- DO 130 J1=1,3
	- DO 120 J2=J1,3
	- SM(J1,J2)=SM(J1,J2)+PWTP(I,J1)P(I,J2)
	- 120 CONTINUE
	- 130 CONTINUE
	- PS=PS+PWTPA*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(2D0SP,SQRT(3D0(1D0-SP*2))-SP)
	- P(N+3,4)=1D0/3D0+SQRT(-SQ)MIN(2D0SP,-SQRT(3D0(1D0-SP*2))-SP)
	- P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
	- IF(P(N+2,4).LT.1D-5) THEN
	- CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
	- SPH=-1D0
	- APL=-1D0
	- RETURN
	- ENDIF
	-
	-C...Find first and last eigenvector by solving equation system.
	- DO 240 I=1,3,2
	- DO 180 J1=1,3
	- SV(J1,J1)=SM(J1,J1)-P(N+I,4)
	- DO 170 J2=J1+1,3
	- SV(J1,J2)=SM(J1,J2)
	- SV(J2,J1)=SM(J1,J2)
	- 170 CONTINUE
	- 180 CONTINUE
	- SMAX=0D0
	- DO 200 J1=1,3
	- DO 190 J2=1,3
	- IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
	- JA=J1
	- JB=J2
	- SMAX=ABS(SV(J1,J2))
	- 190 CONTINUE
	- 200 CONTINUE
	- SMAX=0D0
	- DO 220 J3=JA+1,JA+2
	- J1=J3-3*((J3-1)/3)
	- RL=SV(J1,JB)/SV(JA,JB)
	- DO 210 J2=1,3
	- SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
	- IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
	- JC=J1
	- SMAX=ABS(SV(J1,J2))
	- 210 CONTINUE
	- 220 CONTINUE
	- JB1=JB+1-3*(JB/3)
	- JB2=JB+2-3*((JB+1)/3)
	- P(N+I,JB1)=-SV(JC,JB2)
	- P(N+I,JB2)=SV(JC,JB1)
	- P(N+I,JB)=-(SV(JA,JB1)P(N+I,JB1)+SV(JA,JB2)P(N+I,JB2))/
	- & SV(JA,JB)
	- PA=SQRT(P(N+I,1)2+P(N+I,2)2+P(N+I,3)**2)
	- SGN=(-1D0)**INT(PYR(0)+0.5D0)
	- DO 230 J=1,3
	- P(N+I,J)=SGN*P(N+I,J)/PA
	- 230 CONTINUE
	- 240 CONTINUE
	-
	-C...Middle axis orthogonal to other two. Fill other codes.
	- SGN=(-1D0)**INT(PYR(0)+0.5D0)
	- P(N+2,1)=SGN(P(N+1,2)P(N+3,3)-P(N+1,3)*P(N+3,2))
	- P(N+2,2)=SGN(P(N+1,3)P(N+3,1)-P(N+1,1)*P(N+3,3))
	- P(N+2,3)=SGN(P(N+1,1)P(N+3,2)-P(N+1,2)*P(N+3,1))
	- DO 260 I=1,3
	- K(N+I,1)=31
	- K(N+I,2)=95
	- K(N+I,3)=I
	- K(N+I,4)=0
	- K(N+I,5)=0
	- P(N+I,5)=0D0
	- DO 250 J=1,5
	- V(I,J)=0D0
	- 250 CONTINUE
	- 260 CONTINUE
	-
	-C...Calculate sphericity and aplanarity. Select storing option.
	- SPH=1.5D0*(P(N+2,4)+P(N+3,4))
	- APL=1.5D0*P(N+3,4)
	- MSTU(61)=N+1
	- MSTU(62)=NP
	- IF(MSTU(43).LE.1) MSTU(3)=3
	- IF(MSTU(43).GE.2) N=N+3
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYTHRU
	-C...Performs thrust analysis to give thrust, oblateness
	-C...and the related event axes.
	-
	- SUBROUTINE PYTHRU(THR,OBL)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local arrays.
	- DIMENSION TDI(3),TPR(3)
	-
	-C...Take copy of particles that are to be considered in thrust analysis.
	- NP=0
	- PS=0D0
	- DO 100 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	- IF(MSTU(41).GE.2) THEN
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 100
	- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	- & GOTO 100
	- ENDIF
	- IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
	- CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
	- THR=-2D0
	- OBL=-2D0
	- RETURN
	- ENDIF
	- NP=NP+1
	- K(N+NP,1)=23
	- P(N+NP,1)=P(I,1)
	- P(N+NP,2)=P(I,2)
	- P(N+NP,3)=P(I,3)
	- P(N+NP,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)**2)
	- P(N+NP,5)=1D0
	- IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
	- & P(N+NP,4)**(PARU(42)-1D0)
	- PS=PS+P(N+NP,4)*P(N+NP,5)
	- 100 CONTINUE
	-
	-C...Very low multiplicities (0 or 1) not considered.
	- IF(NP.LE.1) THEN
	- CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
	- THR=-1D0
	- OBL=-1D0
	- RETURN
	- ENDIF
	-
	-C...Loop over thrust and major. T axis along z direction in latter case.
	- DO 320 ILD=1,2
	- IF(ILD.EQ.2) THEN
	- K(N+NP+1,1)=31
	- PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
	- MSTU(33)=1
	- CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
	- THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
	- CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
	- ENDIF
	-
	-C...Find and order particles with highest p (pT for major).
	- DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
	- P(ILF,4)=0D0
	- 110 CONTINUE
	- DO 160 I=N+1,N+NP
	- IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)2+P(I,2)2)
	- DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
	- IF(P(I,4).LE.P(ILF,4)) GOTO 140
	- DO 120 J=1,5
	- P(ILF+1,J)=P(ILF,J)
	- 120 CONTINUE
	- 130 CONTINUE
	- ILF=N+NP+3
	- 140 DO 150 J=1,5
	- P(ILF+1,J)=P(I,J)
	- 150 CONTINUE
	- 160 CONTINUE
	-
	-C...Find and order initial axes with highest thrust (major).
	- DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
	- P(ILG,4)=0D0
	- 170 CONTINUE
	- NC=2**(MIN(MSTU(44),NP)-1)
	- DO 250 ILC=1,NC
	- DO 180 J=1,3
	- TDI(J)=0D0
	- 180 CONTINUE
	- DO 200 ILF=1,MIN(MSTU(44),NP)
	- SGN=P(N+NP+ILF+3,5)
	- IF(2*ILF((ILC+2(ILF-1)-1)/2ILF).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)=SGNTPR(J)/(PSTHP)
	- 310 CONTINUE
	- P(N+NP+ILD,4)=THP
	- P(N+NP+ILD,5)=0D0
	- ENDIF
	- IAGR=IAGR+1
	- IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
	- 320 CONTINUE
	-
	-C...Find minor axis and value by orthogonality.
	- SGN=(-1D0)**INT(PYR(0)+0.5D0)
	- P(N+NP+3,1)=-SGN*P(N+NP+2,2)
	- P(N+NP+3,2)=SGN*P(N+NP+2,1)
	- P(N+NP+3,3)=0D0
	- THP=0D0
	- DO 330 I=N+1,N+NP
	- THP=THP+P(I,5)ABS(P(N+NP+3,1)P(I,1)+P(N+NP+3,2)*P(I,2))
	- 330 CONTINUE
	- P(N+NP+3,4)=THP/PS
	- P(N+NP+3,5)=0D0
	-
	-C...Fill axis information. Rotate back to original coordinate system.
	- DO 350 ILD=1,3
	- K(N+ILD,1)=31
	- K(N+ILD,2)=96
	- K(N+ILD,3)=ILD
	- K(N+ILD,4)=0
	- K(N+ILD,5)=0
	- DO 340 J=1,5
	- P(N+ILD,J)=P(N+NP+ILD,J)
	- V(N+ILD,J)=0D0
	- 340 CONTINUE
	- 350 CONTINUE
	- CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
	-
	-C...Calculate thrust and oblateness. Select storing option.
	- THR=P(N+1,4)
	- OBL=P(N+2,4)-P(N+3,4)
	- MSTU(61)=N+1
	- MSTU(62)=NP
	- IF(MSTU(43).LE.1) MSTU(3)=3
	- IF(MSTU(43).GE.2) N=N+3
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYCLUS
	-C...Subdivides the particle content of an event into jets/clusters.
	-
	- SUBROUTINE PYCLUS(NJET)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local arrays and saved variables.
	- DIMENSION PS(5)
	- SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
	-
	-C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
	- R2T(I1,I2)=(P(I1,5)P(I2,5)-P(I1,1)P(I2,1)-P(I1,2)*P(I2,2)-
	- &P(I1,3)P(I2,3))2D0P(I1,5)P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
	- R2M(I1,I2)=2D0P(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)=2D0MIN(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=2D0MAX(R2ACC,PS(5)*2)
	- DO 400 ITRY1=N+1,N+NJET-1
	- DO 390 ITRY2=ITRY1+1,N+NJET
	- IF(MSTU(46).LE.2) THEN
	- R2=R2T(ITRY1,ITRY2)
	- ELSEIF(MSTU(46).LE.4) THEN
	- R2=R2M(ITRY1,ITRY2)
	- ELSE
	- R2=R2D(ITRY1,ITRY2)
	- ENDIF
	- IF(R2.GE.R2MIN) GOTO 390
	- IMIN1=ITRY1
	- IMIN2=ITRY2
	- R2MIN=R2
	- 390 CONTINUE
	- 400 CONTINUE
	-
	-C...If allowed, join two closest jets and start over.
	- IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
	- IREC=MIN(IMIN1,IMIN2)
	- IDEL=MAX(IMIN1,IMIN2)
	- DO 410 J=1,4
	- P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
	- 410 CONTINUE
	- P(IREC,5)=SQRT(P(IREC,1)2+P(IREC,2)2+P(IREC,3)**2)
	- DO 430 I=IDEL+1,N+NJET
	- DO 420 J=1,5
	- P(I-1,J)=P(I,J)
	- 420 CONTINUE
	- 430 CONTINUE
	- IF(MSTU(46).GE.2) THEN
	- DO 440 I=N+NP+1,N+2*NP
	- IORI=N+K(I,4)
	- IF(IORI.EQ.IDEL) K(I,4)=IREC-N
	- IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
	- 440 CONTINUE
	- ENDIF
	- NJET=NJET-1
	- GOTO 300
	-
	-C...Divide up broad jet if empty cluster in list of final ones.
	- ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
	- DO 450 I=N+1,N+NJET
	- K(I,5)=0
	- 450 CONTINUE
	- DO 460 I=N+NP+1,N+2*NP
	- K(N+K(I,4),5)=K(N+K(I,4),5)+1
	- 460 CONTINUE
	- IEMP=0
	- DO 470 I=N+1,N+NJET
	- IF(K(I,5).EQ.0) IEMP=I
	- 470 CONTINUE
	- IF(IEMP.NE.0) THEN
	- NLOOP=NLOOP+1
	- ISPL=0
	- R2MAX=0D0
	- DO 480 I=N+NP+1,N+2*NP
	- IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
	- IJET=N+K(I,4)
	- R2=R2T(I,IJET)
	- IF(R2.LE.R2MAX) GOTO 480
	- ISPL=I
	- R2MAX=R2
	- 480 CONTINUE
	- IF(ISPL.NE.0) THEN
	- IJET=N+K(ISPL,4)
	- DO 490 J=1,4
	- P(IEMP,J)=P(ISPL,J)
	- P(IJET,J)=P(IJET,J)-P(ISPL,J)
	- 490 CONTINUE
	- P(IEMP,5)=P(ISPL,5)
	- P(IJET,5)=SQRT(P(IJET,1)2+P(IJET,2)2+P(IJET,3)**2)
	- IF(NLOOP.LE.2) GOTO 300
	- ENDIF
	- ENDIF
	- ENDIF
	-
	-C...If generalized thrust has not yet converged, continue iteration.
	- IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
	- &THEN
	- TSAV=PSJT/PSS
	- GOTO 310
	- ENDIF
	-
	-C...Reorder jets according to energy.
	- DO 510 I=N+1,N+NJET
	- DO 500 J=1,5
	- V(I,J)=P(I,J)
	- 500 CONTINUE
	- 510 CONTINUE
	- DO 540 INEW=N+1,N+NJET
	- PEMAX=0D0
	- DO 520 ITRY=N+1,N+NJET
	- IF(V(ITRY,4).LE.PEMAX) GOTO 520
	- IMAX=ITRY
	- PEMAX=V(ITRY,4)
	- 520 CONTINUE
	- K(INEW,1)=31
	- K(INEW,2)=97
	- K(INEW,3)=INEW-N
	- K(INEW,4)=0
	- DO 530 J=1,5
	- P(INEW,J)=V(IMAX,J)
	- 530 CONTINUE
	- V(IMAX,4)=-1D0
	- K(IMAX,5)=INEW
	- 540 CONTINUE
	-
	-C...Clean up particle-jet assignments and jet information.
	- DO 550 I=N+NP+1,N+2*NP
	- IORI=K(N+K(I,4),5)
	- K(I,4)=IORI-N
	- IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
	- K(IORI,4)=K(IORI,4)+1
	- 550 CONTINUE
	- IEMP=0
	- PSJT=0D0
	- DO 570 I=N+1,N+NJET
	- K(I,5)=0
	- PSJT=PSJT+P(I,5)
	- P(I,5)=SQRT(MAX(P(I,4)2-P(I,5)2,0D0))
	- DO 560 J=1,5
	- V(I,J)=0D0
	- 560 CONTINUE
	- IF(K(I,4).EQ.0) IEMP=I
	- 570 CONTINUE
	-
	-C...Select storing option. Output variables. Check for failure.
	- MSTU(61)=N+1
	- MSTU(62)=NP
	- MSTU(63)=NPRE
	- PARU(61)=PS(5)
	- PARU(62)=PSJT/PSS
	- PARU(63)=SQRT(R2MIN)
	- IF(NJET.LE.1) PARU(63)=0D0
	- IF(IEMP.NE.0) THEN
	- CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
	- NJET=-1
	- RETURN
	- ENDIF
	- IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
	- IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
	- NSAV=NJET
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYCELL
	-C...Provides a simple way of jet finding in eta-phi-ET coordinates,
	-C...as used for calorimeters at hadron colliders.
	-
	- SUBROUTINE PYCELL(NJET)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Loop over all particles. Find cell that was hit by given particle.
	- PTLRAT=1D0/SINH(PARU(51))**2
	- NP=0
	- NC=N
	- DO 110 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
	- IF(P(I,1)2+P(I,2)2.LE.PTLRATP(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(PT2+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))(2IETA-1-MSTU(51))
	- P(NC,2)=(PARU(1)/MSTU(52))(2IPHI-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(-2D0LOG(MAX(1D-10,PYR(0)))PEI)
	- & COS(PARU(2)*PYR(0))
	- IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
	- P(IC,5)=PEF
	- IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
	- 130 CONTINUE
	- ENDIF
	-
	-C...Remove cells below threshold.
	- IF(PARU(58).GT.0D0) THEN
	- NCC=NC
	- NC=N
	- DO 140 IC=N+1,NCC
	- IF(P(IC,5).GT.PARU(58)) THEN
	- NC=NC+1
	- K(NC,3)=K(IC,3)
	- K(NC,4)=K(IC,4)
	- K(NC,5)=K(IC,5)
	- P(NC,1)=P(IC,1)
	- P(NC,2)=P(IC,2)
	- P(NC,5)=P(IC,5)
	- ENDIF
	- 140 CONTINUE
	- ENDIF
	-
	-C...Find initiator cell: the one with highest pT of not yet used ones.
	- NJ=NC
	- 150 ETMAX=0D0
	- DO 160 IC=N+1,NC
	- IF(K(IC,5).NE.2) GOTO 160
	- IF(P(IC,5).LE.ETMAX) GOTO 160
	- ICMAX=IC
	- ETA=P(IC,1)
	- PHI=P(IC,2)
	- ETMAX=P(IC,5)
	- 160 CONTINUE
	- IF(ETMAX.LT.PARU(52)) GOTO 220
	- IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
	- CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
	- NJET=-2
	- RETURN
	- ENDIF
	- K(ICMAX,5)=1
	- NJ=NJ+1
	- K(NJ,4)=0
	- K(NJ,5)=1
	- P(NJ,1)=ETA
	- P(NJ,2)=PHI
	- P(NJ,3)=0D0
	- P(NJ,4)=0D0
	- P(NJ,5)=0D0
	-
	-C...Sum up unused cells within required distance of initiator.
	- DO 170 IC=N+1,NC
	- IF(K(IC,5).EQ.0) GOTO 170
	- IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
	- DPHIA=ABS(P(IC,2)-PHI)
	- IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
	- PHIC=P(IC,2)
	- IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
	- IF((P(IC,1)-ETA)2+(PHIC-PHI)2.GT.PARU(54)**2) GOTO 170
	- K(IC,5)=-K(IC,5)
	- K(NJ,4)=K(NJ,4)+K(IC,4)
	- P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
	- P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
	- P(NJ,5)=P(NJ,5)+P(IC,5)
	- 170 CONTINUE
	-
	-C...Reject cluster below minimum ET, else accept.
	- IF(P(NJ,5).LT.PARU(53)) THEN
	- NJ=NJ-1
	- DO 180 IC=N+1,NC
	- IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
	- 180 CONTINUE
	- ELSEIF(MSTU(54).LE.2) THEN
	- P(NJ,3)=P(NJ,3)/P(NJ,5)
	- P(NJ,4)=P(NJ,4)/P(NJ,5)
	- IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
	- & P(NJ,4))
	- DO 190 IC=N+1,NC
	- IF(K(IC,5).LT.0) K(IC,5)=0
	- 190 CONTINUE
	- ELSE
	- DO 200 J=1,4
	- P(NJ,J)=0D0
	- 200 CONTINUE
	- DO 210 IC=N+1,NC
	- IF(K(IC,5).GE.0) GOTO 210
	- P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
	- P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
	- P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
	- P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
	- K(IC,5)=0
	- 210 CONTINUE
	- ENDIF
	- GOTO 150
	-
	-C...Arrange clusters in falling ET sequence.
	- 220 DO 250 I=1,NJ-NC
	- ETMAX=0D0
	- DO 230 IJ=NC+1,NJ
	- IF(K(IJ,5).EQ.0) GOTO 230
	- IF(P(IJ,5).LT.ETMAX) GOTO 230
	- IJMAX=IJ
	- ETMAX=P(IJ,5)
	- 230 CONTINUE
	- K(IJMAX,5)=0
	- K(N+I,1)=31
	- K(N+I,2)=98
	- K(N+I,3)=I
	- K(N+I,4)=K(IJMAX,4)
	- K(N+I,5)=0
	- DO 240 J=1,5
	- P(N+I,J)=P(IJMAX,J)
	- V(N+I,J)=0D0
	- 240 CONTINUE
	- 250 CONTINUE
	- NJET=NJ-NC
	-
	-C...Convert to massless or massive four-vectors.
	- IF(MSTU(54).EQ.2) THEN
	- DO 260 I=N+1,N+NJET
	- ETA=P(I,3)
	- P(I,1)=P(I,5)*COS(P(I,4))
	- P(I,2)=P(I,5)*SIN(P(I,4))
	- P(I,3)=P(I,5)*SINH(ETA)
	- P(I,4)=P(I,5)*COSH(ETA)
	- P(I,5)=0D0
	- 260 CONTINUE
	- ELSEIF(MSTU(54).GE.3) THEN
	- DO 270 I=N+1,N+NJET
	- P(I,5)=SQRT(MAX(0D0,P(I,4)2-P(I,1)2-P(I,2)2-P(I,3)2))
	- 270 CONTINUE
	- ENDIF
	-
	-C...Information about storage.
	- MSTU(61)=N+1
	- MSTU(62)=NP
	- MSTU(63)=NC-N
	- IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
	- IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYJMAS
	-C...Determines, approximately, the two jet masses that minimize
	-C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
	-
	- SUBROUTINE PYJMAS(PMH,PML)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-C...Local arrays.
	- DIMENSION SM(3,3),SAX(3),PS(3,5)
	-
	-C...Reset.
	- NP=0
	- DO 120 J1=1,3
	- DO 100 J2=J1,3
	- SM(J1,J2)=0D0
	- 100 CONTINUE
	- DO 110 J2=1,4
	- PS(J1,J2)=0D0
	- 110 CONTINUE
	- 120 CONTINUE
	- PSS=0D0
	- PIMASS=PMAS(PYCOMP(211),1)
	-
	-C...Take copy of particles that are to be considered in mass analysis.
	- DO 170 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
	- IF(MSTU(41).GE.2) THEN
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 170
	- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	- & GOTO 170
	- ENDIF
	- IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
	- CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
	- PMH=-2D0
	- PML=-2D0
	- RETURN
	- ENDIF
	- NP=NP+1
	- DO 130 J=1,5
	- P(N+NP,J)=P(I,J)
	- 130 CONTINUE
	- IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
	- IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
	- P(N+NP,4)=SQRT(P(N+NP,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	-
	-C...Fill information in sphericity tensor and total momentum vector.
	- DO 150 J1=1,3
	- DO 140 J2=J1,3
	- SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
	- 140 CONTINUE
	- 150 CONTINUE
	- PSS=PSS+(P(I,1)2+P(I,2)2+P(I,3)**2)
	- DO 160 J=1,4
	- PS(3,J)=PS(3,J)+P(N+NP,J)
	- 160 CONTINUE
	- 170 CONTINUE
	-
	-C...Very low multiplicities (0 or 1) not considered.
	- IF(NP.LE.1) THEN
	- CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
	- PMH=-1D0
	- PML=-1D0
	- RETURN
	- ENDIF
	- PARU(61)=SQRT(MAX(0D0,PS(3,4)2-PS(3,1)2-PS(3,2)**2-
	- &PS(3,3)**2))
	-
	-C...Find largest eigenvalue to matrix (third degree equation).
	- DO 190 J1=1,3
	- DO 180 J2=J1,3
	- SM(J1,J2)=SM(J1,J2)/PSS
	- 180 CONTINUE
	- 190 CONTINUE
	- SQ=(SM(1,1)SM(2,2)+SM(1,1)SM(3,3)+SM(2,2)*SM(3,3)-
	- &SM(1,2)2-SM(1,3)2-SM(2,3)**2)/3D0-1D0/9D0
	- SR=-0.5D0(SQ+1D0/9D0+SM(1,1)SM(2,3)*2+SM(2,2)SM(1,3)**2+
	- &SM(3,3)SM(1,2)2-SM(1,1)SM(2,2)*SM(3,3))+
	- &SM(1,2)SM(1,3)SM(2,3)+1D0/27D0
	- SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
	- SMA=1D0/3D0+SQRT(-SQ)MAX(2D0SP,SQRT(3D0(1D0-SP*2))-SP)
	-
	-C...Find largest eigenvector by solving equation system.
	- DO 210 J1=1,3
	- SM(J1,J1)=SM(J1,J1)-SMA
	- DO 200 J2=J1+1,3
	- SM(J2,J1)=SM(J1,J2)
	- 200 CONTINUE
	- 210 CONTINUE
	- SMAX=0D0
	- DO 230 J1=1,3
	- DO 220 J2=1,3
	- IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
	- JA=J1
	- JB=J2
	- SMAX=ABS(SM(J1,J2))
	- 220 CONTINUE
	- 230 CONTINUE
	- SMAX=0D0
	- DO 250 J3=JA+1,JA+2
	- J1=J3-3*((J3-1)/3)
	- RL=SM(J1,JB)/SM(JA,JB)
	- DO 240 J2=1,3
	- SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
	- IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
	- JC=J1
	- SMAX=ABS(SM(J1,J2))
	- 240 CONTINUE
	- 250 CONTINUE
	- JB1=JB+1-3*(JB/3)
	- JB2=JB+2-3*((JB+1)/3)
	- SAX(JB1)=-SM(JC,JB2)
	- SAX(JB2)=SM(JC,JB1)
	- SAX(JB)=-(SM(JA,JB1)SAX(JB1)+SM(JA,JB2)SAX(JB2))/SM(JA,JB)
	-
	-C...Divide particles into two initial clusters by hemisphere.
	- DO 270 I=N+1,N+NP
	- PSAX=P(I,1)SAX(1)+P(I,2)SAX(2)+P(I,3)*SAX(3)
	- IS=1
	- IF(PSAX.LT.0D0) IS=2
	- K(I,3)=IS
	- DO 260 J=1,4
	- PS(IS,J)=PS(IS,J)+P(I,J)
	- 260 CONTINUE
	- 270 CONTINUE
	- PMS=MAX(1D-10,PS(1,4)2-PS(1,1)2-PS(1,2)2-PS(1,3)2)+
	- &MAX(1D-10,PS(2,4)2-PS(2,1)2-PS(2,2)2-PS(2,3)2)
	-
	-C...Reassign one particle at a time; find maximum decrease of m^2 sum.
	- 280 PMD=0D0
	- IM=0
	- DO 290 J=1,4
	- PS(3,J)=PS(1,J)-PS(2,J)
	- 290 CONTINUE
	- DO 300 I=N+1,N+NP
	- PPS=P(I,4)PS(3,4)-P(I,1)PS(3,1)-P(I,2)PS(3,2)-P(I,3)PS(3,3)
	- IF(K(I,3).EQ.1) PMDI=2D0(P(I,5)*2-PPS)
	- IF(K(I,3).EQ.2) PMDI=2D0(P(I,5)*2+PPS)
	- IF(PMDI.LT.PMD) THEN
	- PMD=PMDI
	- IM=I
	- ENDIF
	- 300 CONTINUE
	-
	-C...Loop back if significant reduction in sum of m^2.
	- IF(PMD.LT.-PARU(48)*PMS) THEN
	- PMS=PMS+PMD
	- IS=K(IM,3)
	- DO 310 J=1,4
	- PS(IS,J)=PS(IS,J)-P(IM,J)
	- PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
	- 310 CONTINUE
	- K(IM,3)=3-IS
	- GOTO 280
	- ENDIF
	-
	-C...Final masses and output.
	- MSTU(61)=N+1
	- MSTU(62)=NP
	- PS(1,5)=SQRT(MAX(0D0,PS(1,4)2-PS(1,1)2-PS(1,2)2-PS(1,3)2))
	- PS(2,5)=SQRT(MAX(0D0,PS(2,4)2-PS(2,1)2-PS(2,2)2-PS(2,3)2))
	- PMH=MAX(PS(1,5),PS(2,5))
	- PML=MIN(PS(1,5),PS(2,5))
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYFOWO
	-C...Calculates the first few Fox-Wolfram moments.
	-
	- SUBROUTINE PYFOWO(H10,H20,H30,H40)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Copy momenta for particles and calculate H0.
	- NP=0
	- H0=0D0
	- HD=0D0
	- DO 110 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
	- IF(MSTU(41).GE.2) THEN
	- KC=PYCOMP(K(I,2))
	- IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	- & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	- & K(I,2).EQ.KSUSY1+39) GOTO 110
	- IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	- & GOTO 110
	- ENDIF
	- IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
	- CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
	- H10=-1D0
	- H20=-1D0
	- H30=-1D0
	- H40=-1D0
	- RETURN
	- ENDIF
	- NP=NP+1
	- DO 100 J=1,3
	- P(N+NP,J)=P(I,J)
	- 100 CONTINUE
	- P(N+NP,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)**2)
	- H0=H0+P(N+NP,4)
	- HD=HD+P(N+NP,4)**2
	- 110 CONTINUE
	- H0=H0**2
	-
	-C...Very low multiplicities (0 or 1) not considered.
	- IF(NP.LE.1) THEN
	- CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
	- H10=-1D0
	- H20=-1D0
	- H30=-1D0
	- H40=-1D0
	- RETURN
	- ENDIF
	-
	-C...Calculate H1 - H4.
	- H10=0D0
	- H20=0D0
	- H30=0D0
	- H40=0D0
	- DO 130 I1=N+1,N+NP
	- DO 120 I2=I1+1,N+NP
	- CTHE=(P(I1,1)P(I2,1)+P(I1,2)P(I2,2)+P(I1,3)*P(I2,3))/
	- & (P(I1,4)*P(I2,4))
	- H10=H10+P(I1,4)P(I2,4)CTHE
	- H20=H20+P(I1,4)P(I2,4)(1.5D0CTHE*2-0.5D0)
	- H30=H30+P(I1,4)P(I2,4)(2.5D0CTHE3-1.5D0CTHE)
	- H40=H40+P(I1,4)P(I2,4)(4.375D0CTHE4-3.75D0CTHE**2+
	- & 0.375D0)
	- 120 CONTINUE
	- 130 CONTINUE
	-
	-C...Calculate H1/H0 - H4/H0. Output.
	- MSTU(61)=N+1
	- MSTU(62)=NP
	- H10=(HD+2D0*H10)/H0
	- H20=(HD+2D0*H20)/H0
	- H30=(HD+2D0*H30)/H0
	- H40=(HD+2D0*H40)/H0
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYTABU
	-C...Evaluates various properties of an event, with statistics
	-C...accumulated during the course of the run and
	-C...printed at the end.
	-
	- SUBROUTINE PYTABU(MTABU)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Parameter statement to help give large particle numbers.
	- PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	- &KEXCIT=4000000,KDIMEN=5000000)
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
	-C...Local arrays, character variables, saved variables and data.
	- DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
	- &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
	- &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
	- &KFDM(8),KFDC(200,0:8),NPDC(200)
	- SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
	- &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
	- &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
	- CHARACTER CHAU16,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/1200D0/,FM2FM/1200D0/,
	- &NEVEE/0/,FE1EC/500D0/,FE2EC/500D0/,FE1EA/250D0/,FE2EA/250D0/,
	- &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,FACNPRFS,FACNFIFS,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,PMR2+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))/(2D0PARU(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(2MOD(IYETA/2IB,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=FACNMUFM/DBLE(2*(IB-1))
	- IF(IM.EQ.3) BNAVE=FACNMUFM/DBLE(4*(IB-1))
	- DO 490 IP=1,4
	- FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
	- FMOMS(IP)=SQRT(MAX(0D0,FAC(FACFM2FM(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(FACFM2FM(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(PMR2+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)+FACP(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(FACFE2EC(J)-FEEC1**2)))
	- FEEC2=FAC*FE1EC(51-J)
	- FEES2=SQRT(MAX(0D0,FAC(FACFE2EC(51-J)-FEEC2**2)))
	- FEECA=FAC*FE1EA(J)
	- FEESA=SQRT(MAX(0D0,FAC(FACFE2EA(J)-FEECA**2)))
	- WRITE(MSTU(11),5800) 3.6D0(J-1),3.6D0J,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(FACFE2EC(I)-P(I,1)**2)))
	- P(I,2)=FAC*FE1EC(51-I)
	- V(I,2)=SQRT(MAX(0D0,FAC(FACFE2EC(51-I)-P(I,2)**2)))
	- P(I,3)=FAC*FE1EA(I)
	- V(I,3)=SQRT(MAX(0D0,FAC(FACFE2EA(I)-P(I,3)**2)))
	- P(I,4)=PARU(1)*(I-1)/50D0
	- P(I,5)=PARU(1)*I/50D0
	- V(I,4)=3.6D0*(I-1)
	- V(I,5)=3.6D0*I
	- 630 CONTINUE
	- N=25
	- DO 640 J=1,5
	- K(N+1,J)=0
	- P(N+1,J)=0D0
	- V(N+1,J)=0D0
	- 640 CONTINUE
	- K(N+1,1)=32
	- K(N+1,2)=99
	- K(N+1,5)=NEVEE
	- MSTU(3)=1
	-
	-C...Reset statistics on decay channels.
	- ELSEIF(MTABU.EQ.50) THEN
	- NEVDC=0
	- NKFDC=0
	- NREDC=0
	-
	-C...Identify and order flavour content of final state.
	- ELSEIF(MTABU.EQ.51) THEN
	- NEVDC=NEVDC+1
	- NDS=0
	- DO 670 I=1,N
	- IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
	- NDS=NDS+1
	- IF(NDS.GT.8) THEN
	- NREDC=NREDC+1
	- RETURN
	- ENDIF
	- KFM=2*IABS(K(I,2))
	- IF(K(I,2).LT.0) KFM=KFM-1
	- DO 650 IDS=NDS-1,1,-1
	- IIN=IDS+1
	- IF(KFM.LT.KFDM(IDS)) GOTO 660
	- KFDM(IDS+1)=KFDM(IDS)
	- 650 CONTINUE
	- IIN=1
	- 660 KFDM(IIN)=KFM
	- 670 CONTINUE
	-
	-C...Find whether old or new final state.
	- DO 690 IDC=1,NKFDC
	- IF(NDS.LT.KFDC(IDC,0)) THEN
	- IKFDC=IDC
	- GOTO 700
	- ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
	- DO 680 I=1,NDS
	- IF(KFDM(I).LT.KFDC(IDC,I)) THEN
	- IKFDC=IDC
	- GOTO 700
	- ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
	- GOTO 690
	- ENDIF
	- 680 CONTINUE
	- IKFDC=-IDC
	- GOTO 700
	- ENDIF
	- 690 CONTINUE
	- IKFDC=NKFDC+1
	- 700 IF(IKFDC.LT.0) THEN
	- IKFDC=-IKFDC
	- ELSEIF(NKFDC.GE.200) THEN
	- NREDC=NREDC+1
	- RETURN
	- ELSE
	- DO 720 IDC=NKFDC,IKFDC,-1
	- NPDC(IDC+1)=NPDC(IDC)
	- DO 710 I=0,8
	- KFDC(IDC+1,I)=KFDC(IDC,I)
	- 710 CONTINUE
	- 720 CONTINUE
	- NKFDC=NKFDC+1
	- KFDC(IKFDC,0)=NDS
	- DO 730 I=1,NDS
	- KFDC(IKFDC,I)=KFDM(I)
	- 730 CONTINUE
	- NPDC(IKFDC)=0
	- ENDIF
	- NPDC(IKFDC)=NPDC(IKFDC)+1
	-
	-C...Write statistics on decay channels.
	- ELSEIF(MTABU.EQ.52) THEN
	- FAC=1D0/MAX(1,NEVDC)
	- WRITE(MSTU(11),5900) NEVDC
	- DO 750 IDC=1,NKFDC
	- DO 740 I=1,KFDC(IDC,0)
	- KFM=KFDC(IDC,I)
	- KF=(KFM+1)/2
	- IF(2*KF.NE.KFM) KF=-KF
	- CALL PYNAME(KF,CHAU)
	- CHDC(I)=CHAU(1:12)
	- IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
	- 740 CONTINUE
	- WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
	- 750 CONTINUE
	- IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
	-
	-C...Copy statistics on decay channels into /PYJETS/.
	- ELSEIF(MTABU.EQ.53) THEN
	- FAC=1D0/MAX(1,NEVDC)
	- DO 780 IDC=1,NKFDC
	- K(IDC,1)=32
	- K(IDC,2)=99
	- K(IDC,3)=0
	- K(IDC,4)=0
	- K(IDC,5)=KFDC(IDC,0)
	- DO 760 J=1,5
	- P(IDC,J)=0D0
	- V(IDC,J)=0D0
	- 760 CONTINUE
	- DO 770 I=1,KFDC(IDC,0)
	- KFM=KFDC(IDC,I)
	- KF=(KFM+1)/2
	- IF(2*KF.NE.KFM) KF=-KF
	- IF(I.LE.5) P(IDC,I)=KF
	- IF(I.GE.6) V(IDC,I-5)=KF
	- 770 CONTINUE
	- V(IDC,5)=FAC*NPDC(IDC)
	- 780 CONTINUE
	- N=NKFDC
	- DO 790 J=1,5
	- K(N+1,J)=0
	- P(N+1,J)=0D0
	- V(N+1,J)=0D0
	- 790 CONTINUE
	- K(N+1,1)=32
	- K(N+1,2)=99
	- K(N+1,5)=NEVDC
	- V(N+1,5)=FAC*NREDC
	- MSTU(3)=1
	- ENDIF
	-
	-C...Format statements for output on unit MSTU(11) (default 6).
	- 5000 FORMAT(///20X,'Event statistics - initial state'/
	- &20X,'based on an analysis of ',I6,' events'//
	- &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
	- &'according to fragmenting system multiplicity'/
	- &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
	- &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
	- 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
	- 5200 FORMAT(///20X,'Event statistics - final state'/
	- &20X,'based on an analysis of ',I7,' events'//
	- &5X,'Mean primary multiplicity =',F10.4/
	- &5X,'Mean final multiplicity =',F10.4/
	- &5X,'Mean charged multiplicity =',F10.4//
	- &5X,'Number of particles produced per event (directly and via ',
	- &'decays/branchings)'/
	- &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
	- &8X,'Total'/35X,'prim seco prim seco'/)
	- 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
	- 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
	- &20X,'based on an analysis of ',I6,' events'//
	- &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
	- &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
	- 5500 FORMAT(10X)
	- 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
	- 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
	- &20X,'based on an analysis of ',I6,' events'//
	- &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
	- &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
	- 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
	- 5900 FORMAT(///20X,'Decay channel analysis - final state'/
	- &20X,'based on an analysis of ',I6,' events'//
	- &2X,'Probability',10X,'Complete final state'/)
	- 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
	- 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
	- &'or table overflow)')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYEEVT
	-C...Handles the generation of an e+e- annihilation jet event.
	-
	- SUBROUTINE PYEEVT(KFL,ECM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Check input parameters.
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IF(KFL.LT.0.OR.KFL.GT.8) THEN
	- CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
	- IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
	- IF(ECM.LT.ECMMIN) THEN
	- CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	-
	-C...Check consistency of MSTJ options set.
	- IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
	- CALL PYERRM(6,
	- & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
	- MSTJ(110)=1
	- ENDIF
	- IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
	- CALL PYERRM(6,
	- & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
	- MSTJ(111)=0
	- ENDIF
	-
	-C...Initialize alpha_strong and total cross-section.
	- MSTU(111)=MSTJ(108)
	- IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
	- &MSTU(111)=1
	- PARU(112)=PARJ(121)
	- IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
	- IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
	- &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
	- &XTOT)
	- IF(MSTJ(116).GE.3) MSTJ(116)=1
	- PARJ(171)=0D0
	-
	-C...Add initial e+e- to event record (documentation only).
	- NTRY=0
	- 100 NTRY=NTRY+1
	- IF(NTRY.GT.100) THEN
	- CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
	- RETURN
	- ENDIF
	- MSTU(24)=0
	- NC=0
	- IF(MSTJ(115).GE.2) THEN
	- NC=NC+2
	- CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
	- K(NC-1,1)=21
	- CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
	- K(NC,1)=21
	- ENDIF
	-
	-C...Radiative photon (in initial state).
	- MK=0
	- ECMC=ECM
	- IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
	- &THEK,PHIK,ALPK)
	- IF(MK.EQ.1) ECMC=SQRT(ECM(ECM-2D0PAK))
	- 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,DBEKSIN(THEK),0D0,DBEKCOS(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-2D0MSTU(112))PARU(111)))))
	- Q2R=PARJ(168)ECM*2
	- ELSE
	- PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
	- & (2D0PARU(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.115D0MSTU(118))ALSPI**2
	- IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0MSTU(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.519D0MSTU(118))ALSPI*2
	- ENDIF
	-
	-C...Calculate Z0 width if default value not acceptable.
	- IF(MSTJ(102).GE.3) THEN
	- RVA=3D0(3D0+(4D0PARU(102)-1D0)*2)+6D0RQCD*(2D0+
	- & (1D0-8D0PARU(102)/3D0)2+(4D0PARU(102)/3D0-1D0)**2)
	- DO 100 KFLC=5,6
	- VQ=1D0
	- IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
	- & (2D0PYMASS(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+3D0RQCD(0.5D0VQ(3D0-VQ*2)VF2+VQ3)
	- 100 CONTINUE
	- PARJ(124)=PARU(101)PARJ(123)RVA/(48D0PARU(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/(16D0PARU(102)(1D0-PARU(102)))
	- SFW=ECM4/((ECM2-PARJ(123)2)2+(PARJ(123)PARJ(124))*2)
	- SFI=SFW(1D0-(PARJ(123)/ECM)*2)
	- VE=4D0*PARU(102)-1D0
	- SF1I=SFF(VEPOLL+PARJ(132)-PARJ(131))
	- SF1W=SFF*2((VE*2+1D0)POLL+2D0VE(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-(2D0PMQ/ECM)*2)
	-
	-C...Calculate R and sum of charges for QED or QFD case.
	- RQQ=RQQ+3D0QF2POLL
	- IF(MSTJ(102).LE.1) THEN
	- RTOT=RTOT+3D00.5D0VQ(3D0-VQ2)QF*2POLL
	- ELSE
	- VF=SIGN(1D0,QF)-4D0QFPARU(102)
	- RQV=RQV-6D0QFVF*SF1I
	- RVA=RVA+3D0(VF2+1D0)SF1W
	- RTOT=RTOT+3D0(0.5D0VQ(3D0-VQ2)(QF*2POLL-
	- & 2D0QFVFHF1I+VF2HF1W)+VQ*3HF1W)
	- ENDIF
	- 110 CONTINUE
	- RSUM=RQQ
	- IF(MSTJ(102).GE.2) RSUM=RQQ+SFIRQV+SFWRVA
	-
	-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-(2D0PARJ(127)/ECM)*2)
	- ALE=2D0*LOG(ECM/PYMASS(11))-1D0
	- SIGV=ALE/3D0+2D0LOG(ECM2/(PYMASS(13)PYMASS(15)))/3D0-4D0/3D0+
	- &1.526D0LOG(ECM*2/0.932D0)
	-
	-C...Soft and hard radiative cross-section in QED case.
	- IF(MSTJ(102).LE.1) THEN
	- SIGV=1.5D0ALE-0.5D0+PARU(1)2/3D0+2D0SIGV
	- SIGS=ALE(2D0LOG(XKL)-LOG(1D0-XKL)-XKL)
	- SIGH=ALE(2D0LOG(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.5D0SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
	- PARJ(164)=(RQVSZW2(1D0-2D0SFW)+RVA(2D0SFI+SZW*2-
	- & 4D0+3D0SZM-SZM2))/(SZWRSUM)
	- SIGV=1.5D0ALE-0.5D0+PARU(1)2/3D0+((2D0RQQ+SFI*RQV)/
	- & RSUM)SIGV+(SZWSFWRQV/RSUM)PARU(1)*20D0/9D0
	- SIGS=ALE(2D0LOG(XKL)+PARJ(161)LOG(1D0-XKL)+PARJ(162)XKL+
	- & PARJ(163)LOG(((XKL-SZM)2+SZW2)/(SZM2+SZW*2))+
	- & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
	- SIGH=ALE(2D0LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
	- & (1D0-XKL))+PARJ(162)(XKU-XKL)+PARJ(163)
	- & LOG(((XKU-SZM)2+SZW2)/((XKL-SZM)2+SZW2))+
	- & 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)=2D0LOG(XX)+PARJ(161)LOG(1D0-XX)+PARJ(162)*XX+
	- &PARJ(163)LOG((XX-SZM)2+SZW2)+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-(2D0PARJ(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.2D0PYR(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.5D0ECMXK
	-
	-C...Photon polar and azimuthal angle.
	- PME=2D0(PYMASS(11)/ECM)*2
	- 120 CTHM=PME(2D0/PME)*PYR(0)
	- IF(1D0-(XK*2CTHM(1D0-0.5D0CTHM)+2D0(1D0-XK)PME/MAX(PME,
	- &CTHM(1D0-0.5D0CTHM)))/(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+(XKCTHE)*2).GT.
	- &PYR(0)) SGN=-1D0
	- ALPK=ASIN(SGNSTHE(XK-SGN(2D0SQRT(1D0-XK)-2D0+XK)*CTHE)/
	- &(2D0-XK(1D0-SGNCTHE)))
	-
	- 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/(16D0PARU(102)(1D0-PARU(102)))
	- SFW=ECMC4/((ECMC2-PARJ(123)2)2+(PARJ(123)PARJ(124))*2)
	- SFI=SFW(1D0-(PARJ(123)/ECMC)*2)
	- VE=4D0*PARU(102)-1D0
	- HF1I=SFISFF(VE*POLL+PARJ(132)-PARJ(131))
	- HF1W=SFWSFF2((VE*2+1D0)POLL+2D0VE(PARJ(132)-PARJ(131)))
	- RFMAX=MAX(4D0/9D0POLL-4D0/3D0(1D0-8D0PARU(102)/3D0)HF1I+
	- & ((1D0-8D0PARU(102)/3D0)2+1D0)HF1W,1D0/9D0POLL+2D0/3D0
	- & (-1D0+4D0PARU(102)/3D0)HF1I+((-1D0+4D0PARU(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-(2D0PMQ/ECMC)*2))
	-
	-C...Calculate weight in QED or QFD case.
	- IF(MSTJ(102).LE.1) THEN
	- RF=QF**2
	- RFV=0.5D0VQ(3D0-VQ*2)QF**2
	- ELSE
	- VF=SIGN(1D0,QF)-4D0QFPARU(102)
	- RF=QF*2POLL-2D0QFVFHF1I+(VF2+1D0)HF1W
	- RFV=0.5D0VQ(3D0-VQ*2)(QF*2POLL-2D0QFVFHF1I+VF2HF1W)+
	- & VQ*3HF1W
	- IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ*3HF1W/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.2D0PMQ+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-2D0MSTU(112))PARU(111)))))
	- Q2R=PARJ(168)ECM*2
	- ELSE
	- PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0PARU(112)/ECM)*2))
	- Q2=PARJ(169)ECM*2
	- PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
	- & (2D0PARU(112)/ECM)*2))
	- Q2R=PARJ(168)ECM*2
	- ENDIF
	-
	-C...alpha_strong for R and R itself.
	- ALSPI=(3D0/4D0)CFPYALPS(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.115D0MSTU(118))ALSPI**2
	- IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
	- & (33D0-2D0MSTU(112))/12D0LOG(PARJ(168))ALSPI*2)
	- ELSE
	- RQCD=1D0+ALSPI-(3D0/32D0+0.519D0MSTU(118))(4D0ALSPI/3D0)*2
	- ENDIF
	-
	-C...alpha_strong for jet rate. Initial value for y cut.
	- ALSPI=(3D0/4D0)CFPYALPS(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)=(2D0ALSPI/3D0)((3D0-6D0CUT+2D0LOG(CUT))*
	- & LOG(CUT/(1D0-2D0CUT))+(2.5D0+1.5D0CUT-6.571D0)*
	- & (1D0-3D0CUT)+5.833D0(1D0-3D0CUT)2-3.894D0
	- & (1D0-3D0CUT)3+1.342D0(1D0-3D0CUT)*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*2CT*2(2.419D0+0.5989D0CT+0.6782D0CT**2-
	- & 0.2661D0CT3+0.01159D0CT**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)+(100D0CUT-IZ)(ZHUT(IZ+1)-ZHUT(IZ))
	- ENDIF
	- PARJ(153)=ALSPIPARJ(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-2D0MSTU(112))/12D0LOG(PARJ(169))ALSPIPARJ(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.330D0CT+0.8304D0CT**2
	- IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)*2(3.035D0-2.091D0*CT+
	- & 0.4059D0CT*2)
	- XQQQQ=1.25D0(-0.1080D0+0.01486D0CT+0.009364D0CT*2)
	- IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
	- ELSE
	- XQQGG=-0.09773D0+0.2959D0CT-0.2764D0CT*2+0.08832D0CT**3
	- IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)*2(-0.04079D0+
	- & 0.1340D0CT-0.1326D0CT*2+0.04365D0CT**3)
	- XQQQQ=1.25D0(0.003661D0-0.004888D0CT-0.001081D0CT*2+
	- & 0.002093D0CT*3)
	- IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
	- ENDIF
	- PARJ(154)=ALSPI*2CT*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)CFPYALPS(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)CFPYALPS(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(4D0CUT)**(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-2D0CUT)*
	- & LOG((1D0-2D0CUT)/CUT)+0.5D0(9D0CUT*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+X2/4D0+X3/9D0+X4/16D0+X5/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=(2D0PMQ/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+80D0CUT)
	- 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-2D0MSTU(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(Y132+Y232+2D0Y12.LE.2D0PYR(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=(Y132+Y232+2D0Y12)/(Y13Y23)
	- WT2=CF(-2D0(CUTL-Y12L)*2-3D0CUTL-1D0+3.289868D0+
	- & 2D0(2D0CUTL-Y12L)*CUT/Y12)+
	- & CN((CUTL-Y12L)2-(CUTL-Y13L)2-(CUTL-Y23L)*2-
	- & 11D0CUTL/6D0+67D0/18D0+1.644934D0-(2D0CUTL-Y12L)*CUT/Y12+
	- & (2D0CUTL-Y13L)CUT/Y13+(2D0CUTL-Y23L)CUT/Y23)+
	- & TR(2D0CUTL/3D0-10D0/9D0)+
	- & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
	- & Y13L(4D0Y12*2+2D0Y12Y13+4D0Y12Y23+Y13Y23)/
	- & (Y12+Y23)*2+Y23L(4D0Y122+2D0Y12Y23+4D0Y12*Y13+
	- & Y13Y23)/(Y12+Y13)*2)/WT1+
	- & CN(Y13LY13/(Y12+Y23)+Y23LY23/(Y12+Y13))/WT1+(CN-2D0CF)*
	- & ((Y122+(Y12+Y13)2)(Y12LY23L-Y12LY12M-Y23L
	- & Y23M+1.644934D0-Y12I-Y23I)/(Y13Y23)+(Y122+(Y12+Y23)2)
	- & (Y12LY13L-Y12LY12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
	- & (Y13Y23)+(Y132+Y232)/(Y13Y23*(Y13+Y23))-
	- & 2D0Y12LY122/(Y13+Y23)2-4D0Y12LY12/(Y13+Y23))/WT1-
	- & CN(Y13LY23L-Y13LY13M-Y23LY23M+1.644934D0-Y13I-Y23I)
	- IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
	- IF(1D0+WTOPT+ALS2PIWT2.LE.WTMAXPYR(0)) GOTO 110
	- PARJ(156)=(WTOPT+ALS2PIWT2)/(1D0+WTOPT+ALS2PIWT2)
	-
	- 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)ZY3+ZHUP(IZ,10)/(ZX-ZY2)+
	- & 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)ZY3+ZHUP(IZ,10)/(ZX-ZY2)+
	- & 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)ZY3+ZHUP(IZ,10)/(ZX-ZY2)+
	- & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
	- WT2=WTL+(WTU-WTL)(100D0CUT+1D0-IZ)
	- ENDIF
	- IF(1D0+WTOPT+2D0ALS2PIWT2.LE.0D0) MSTJ(121)=1
	- IF(1D0+WTOPT+2D0ALS2PIWT2.LE.WTMAX*PYR(0)) GOTO 110
	- PARJ(156)=(WTOPT+2D0ALS2PIWT2)/(1D0+WTOPT+2D0ALS2PIWT2)
	- ENDIF
	-
	-C...Impose mass cuts (gives two jets). For fixed jet number new try.
	- X1=1D0-Y23
	- X2=1D0-Y13
	- X3=1D0-Y12
	- IF(4D0Y23Y13Y12/X3*2.LE.QME) NJET=2
	- IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
	- & 0.5D0QME2+(0.5D0QME+0.25D0QME2)((1D0-X2)/(1D0-X1)+
	- & (1D0-X1)/(1D0-X2)).GT.(X12+X22)*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(4D0CUT2+PYR(0)((1D0-CUT)*2-4D0CUT**2))
	- IF(LOG((X3-CUT)/CUT).LE.PYR(0)LOG((1D0-2D0CUT)/CUT)) GOTO 140
	- YD=SIGN(2D0CUT((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*2PYR(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=(2D0PMQ/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.1125D0CFTR/CUT**2
	- ID=1
	-
	-C...Sample the five kinematical variables (for qqgg preweighted in y34).
	- 110 Y134=3D0CUT+(1D0-6D0CUT)*PYR(0)
	- Y234=3D0CUT+(1D0-6D0CUT)*PYR(0)
	- IF(IT.EQ.1) Y34=(1D0-5D0CUT)EXP(-CT*PYR(0))
	- IF(IT.EQ.2) Y34=CUT+(1D0-6D0CUT)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-4D0SQRT(MAX(0D0,VT(1D0-VT)*
	- &VB(1D0-VB)))CP-(1D0-2D0VT)(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)=(Y12Y342-Y13Y24Y34+Y14Y23Y34+3D0Y12Y23Y34+
	- & 3D0Y12Y14Y34+4D0Y12*2Y34-Y13Y23Y24+2D0Y12Y23*Y24-
	- & Y13Y14Y24-2D0Y12Y13Y24+2D0Y12*2Y24+Y14Y232+2D0Y12*
	- & Y232+Y142Y23+4D0Y12Y14Y23+4D0Y122Y23+2D0Y12Y14**2+
	- & 2D0Y12Y13Y14+4D0Y12*2Y14+2D0Y122Y13+2D0Y12*3)/
	- & (2D0Y13Y134Y234Y24)+(Y24Y34+Y12Y34+Y13*Y24-
	- & Y14Y23+Y12Y13)/(Y13Y1342)+2D0Y23*(1D0-Y13)/
	- & (Y13Y134Y24)+Y34/(2D0Y13Y24)
	- WTB(IC)=(Y12Y24Y34+Y12Y14Y34-Y13Y242+Y13Y14Y24+2D0Y12*
	- & Y14Y24)/(Y13Y134Y23Y14)+Y12(1D0+Y34)Y124/(Y134Y234Y14*
	- & Y24)-(2D0Y13Y24+Y14*2+Y13Y23+2D0Y12Y13)/(Y13Y134Y14)+
	- & Y12Y123Y124/(2D0Y13Y14Y23Y24)
	- WTC(IC)=-(5D0Y12Y34*2+2D0Y12Y24Y34+2D0Y12Y23*Y34+
	- & 2D0Y12Y14Y34+2D0Y12Y13Y34+4D0Y122Y34-Y13Y24*2+
	- & Y14Y23Y24+Y13Y23Y24+Y13Y14Y24-Y12Y14Y24-Y13*2Y24-
	- & 3D0Y12Y13Y24-Y14Y232-Y142Y23+Y13Y14*Y23-
	- & 3D0Y12Y14Y23-Y12Y13Y23)/(4D0Y134Y234Y34**2)+
	- & (3D0Y12Y34*2-3D0Y13Y24Y34+3D0Y12Y24*Y34+
	- & 3D0Y14Y23Y34-Y13Y24*2-Y12Y23Y34+6D0Y12Y14Y34+
	- & 2D0Y12Y13Y34-2D0Y12*2Y34+Y14Y23Y24-3D0Y13Y23*Y24-
	- & 2D0Y13Y14Y24+4D0Y12Y14Y24+2D0Y12Y13*Y24+
	- & 3D0Y14Y23*2+2D0Y14*2Y23+2D0Y142Y12+
	- & 2D0Y122Y14+6D0Y12Y14Y23-2D0Y12Y13*2-
	- & 2D0Y122Y13)/(4D0Y13Y134Y234Y34)
	- WTC(IC)=WTC(IC)+(2D0Y12Y34*2-2D0Y13Y24Y34+Y12Y24Y34+
	- & 4D0Y13Y23Y34+4D0Y12Y14Y34+2D0Y12Y13Y34+2D0Y12*2Y34-
	- & Y13Y242+3D0Y14Y23Y24+4D0Y13Y23Y24-2D0Y13Y14Y24+
	- & 4D0Y12Y14Y24+2D0Y12Y13Y24+2D0Y14Y23*2+4D0Y13Y23*2+
	- & 2D0Y13Y14Y23+2D0Y12Y14Y23+4D0Y12Y13Y23+2D0Y12Y14*2+
	- & 4D0Y122Y13+4D0Y12Y13Y14+2D0Y12*2Y14)/
	- & (4D0Y13Y134Y24Y34)-(Y12Y342-2D0Y14Y24Y34-
	- & 2D0Y13Y24Y34-Y14Y23Y34+Y13Y23Y34+Y12Y14*Y34+
	- & 2D0Y12Y13Y34-2D0Y14*2Y24-4D0Y13Y14*Y24-
	- & 4D0Y132Y24-Y14*2Y23-Y13*2Y23+Y12Y13Y14-
	- & Y12Y132)/(2D0Y13Y34Y134*2)+(Y12Y34**2-
	- & 4D0Y14Y24Y34-2D0Y13Y24Y34-2D0Y14Y23*Y34-
	- & 4D0Y13Y23Y34-4D0Y12Y14Y34-4D0Y12Y13*Y34-
	- & 2D0Y13Y14Y24+2D0Y13*2Y24+2D0Y142Y23-
	- & 2D0Y13Y14Y23-Y12Y14*2-6D0Y12Y13Y14-
	- & Y12Y132)/(4D0Y34*2Y134**2)
	- WTTOT=WTTOT+Y34CF(CFWTA(IC)+(CF-0.5D0CN)*WTB(IC)+
	- & CN*WTC(IC))/8D0
	- ELSE
	- WTD(IC)=(Y13Y23Y34+Y12Y23Y34-Y12*2Y34+Y13Y23Y24+2D0Y12
	- & Y23Y24-Y14Y23*2+Y12Y13Y24+Y12Y14Y23+Y12Y13Y14)/(Y132
	- & Y123*2)-(Y12Y34*2-Y13Y24Y34+Y12Y24Y34-Y14Y23Y34-Y12
	- & Y23Y34-Y13Y24*2+Y14Y23Y24-Y13Y23Y24-Y132Y24+Y14*
	- & Y232)/(Y132Y123Y134)+(Y13Y14Y12+Y34Y14Y12-Y34*2Y12+
	- & Y13Y14Y24+2D0Y34Y14Y24-Y23Y14*2+Y34Y13Y24+Y34Y23*Y14+
	- & Y34Y13Y23)/(Y13*2Y134*2)-(Y34Y12*2-Y13Y24Y12+Y34Y24*
	- & Y12-Y23Y14Y12-Y34Y14Y12-Y13Y242+Y23Y14Y24-Y13Y14*Y24-
	- & Y13*2Y24+Y23Y142)/(Y132Y134*Y123)
	- WTE(IC)=(Y12Y34(Y23-Y24+Y14+Y13)+Y13Y242-Y14Y23Y24+Y13
	- & Y23Y24+Y13Y14Y24+Y132Y24-Y14Y23(Y14+Y23+Y13))/(Y13Y23
	- & Y123Y134)-Y12(Y12Y34-Y23Y24-Y13Y24-Y14Y23-Y14Y13)/(Y13
	- & Y23Y1232)-(Y14+Y13)(Y24+Y23)Y34/(Y13Y23Y134Y234)+
	- & (Y12Y34(Y14-Y24+Y23+Y13)+Y13Y242-Y23Y14Y24+Y13Y14*Y24+
	- & Y13Y23Y24+Y13*2Y24-Y23Y14(Y14+Y23+Y13))/(Y13Y14Y134*
	- & Y123)-Y34(Y34Y12-Y14Y24-Y13Y24-Y23Y14-Y23Y13)/(Y13Y14
	- & Y134*2)-(Y23+Y13)(Y24+Y14)Y12/(Y13Y14Y123Y124)
	- WTTOT=WTTOT+CF(TRWTD(IC)+(CF-0.5D0CN)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))/(8D0WTTOT)
	- 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.5D0Y34(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-Q12Y134
	- X4=1D0-(1D0-Q12)Y134-Q12Y234
	- X2=1D0-Y124
	- X12=(1D0-Q12)Y13+Q12Y23
	- X14=Y12-0.5D0*QME
	- IF(Y134Y234/((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)=CFTR(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=(2D0PMQN/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-Q24Y134
	- X4=1D0-(1D0-Q24)Y134-Q24Y123
	- X2=1D0-(1D0-Q13)Y234-Q13Y124
	- X12=(1D0-Q24)((1D0-Q13)Y14+Q13Y34)+Q24((1D0-Q13)*Y12+
	- & Q13*Y23)
	- X14=Y24-0.5D0*QME
	- X34=(1D0-Q24)((1D0-Q13)Y23+Q13Y12)+Q24((1D0-Q13)*Y34+
	- & Q13*Y14)
	- IF(PMQ2+PMQN2+MIN(X12,X34)ECM*2.LE.
	- & (PARJ(127)+PMQ+PMQN)**2) NJET=2
	- IF(Y123Y134/((1D0-X1)(1D0-X4)).LE.PYR(0)) NJET=2
	- ENDIF
	- 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYXDIF
	-C...Gives the angular orientation of events.
	-
	- SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Charge. Factors depending on polarization for QED case.
	- QF=KCHG(KFL,1)/3D0
	- POLL=1D0-PARJ(131)*PARJ(132)
	- POLD=PARJ(132)-PARJ(131)
	- IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
	- HF1=POLL
	- HF2=0D0
	- HF3=PARJ(133)**2
	- HF4=0D0
	-
	-C...Factors depending on flavour, energy and polarization for QFD case.
	- ELSE
	- SFF=1D0/(16D0PARU(102)(1D0-PARU(102)))
	- SFW=ECM4/((ECM2-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-4D0QFPARU(102)
	- HF1=QF*2POLL-2D0QFVFSFISFF(VEPOLL-AE*POLD)+
	- & (VF2+AF2)SFWSFF*2((VE2+AE2)POLL-2D0VEAEPOLD)
	- HF2=-2D0QFAFSFISFF(AEPOLL-VEPOLD)+2D0VFAFSFWSFF2
	- & (2D0VEAEPOLL-(VE2+AE2)POLD)
	- HF3=PARJ(133)*2(QF*2-2D0QFVFSFISFFVE+(VF2+AF2)*
	- & SFWSFF2(VE2-AE2))
	- HF4=-PARJ(133)*22D0QFVFSFW(PARJ(123)PARJ(124)/ECM2)
	- & 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=(2D0PYMASS(KFL)/ECM)*2
	- IF(NJET.EQ.2) THEN
	- SIGU=4D0*SQRT(1D0-QME)
	- SIGL=2D0QMESQRT(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=(X1X2-2D0X1-2D0X2+2D0+QME)/SQRT((X12-QME)(X2**2-QME))
	- ST12=SQRT(1D0-CT12**2)
	- IF(MSTJ(109).NE.1) THEN
	- SIGU=2D0X12+X22(1D0+CT12*2)-QME(3D0+CT12**2-X1-X2)-
	- & QMEX1/XQ+0.5D0QME((X22-QME)ST12*2-2D0X2)*XQ
	- SIGL=(X2ST12)2-QME(3D0-CT12*2-2.5D0(X1+X2)+X1*X2+QME)+
	- & 0.5D0QME(X1*2-X1-QME)/XQ+0.5D0QME((X22-QME)CT12**2-
	- & X2)*XQ
	- SIGT=0.5D0(X22-QME-0.5D0QME(X22-QME)/XQ)ST12**2
	- SIGI=((1D0-0.5D0QMEXQ)(X22-QME)ST12*CT12+
	- & QME(1D0-X1-X2+0.5D0X1X2+0.5D0QME)*ST12/CT12)/SQ2
	- SIGA=X2*2ST12/SQ2
	- SIGP=2D0(X12-X22CT12)
	-
	-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))(X32-0.5D0XT**2)+
	- & PARJ(171)(X32-0.5D0XT*2-4D0(1D0-X1)(1D0-X2)*2/X1)
	- SIGL=(1D0-PARJ(171))0.5D0XT**2+
	- & PARJ(171)0.5D0(1D0-X1)*2XT**2
	- SIGT=(1D0-PARJ(171))0.25D0XT**2+
	- & PARJ(171)0.25D0XT*2(1D0-2D0*X1)
	- SIGI=-(0.5D0/SQ2)((1D0-PARJ(171))XTX3CT13+
	- & PARJ(171)XT((1D0-2D0X1)X3CT13-X1(X1-X2)))
	- SIGA=(0.25D0/SQ2)XT(2D0(1D0-X1)-X1X3)
	- 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=(2D0HF1A+HF3A+HF4A)ABS(SIGU)+2D0(HF1A+HF3A+HF4A)
	- &ABS(SIGL)+2D0(HF1A+2D0HF3A+2D0HF4A)ABS(SIGT)+2D0SQ2
	- &(HF1A+2D0HF3A+2D0HF4A)ABS(SIGI)+4D0SQ2HF2AABS(SIGA)+
	- &2D0HF2AABS(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(C2PHIHF3-S2PHIHF4))*SIGU+
	- &2D0(STHE2HF1-STHE*2(C2PHIHF3-S2PHIHF4))*SIGL+
	- &2D0(STHE2C2CHIHF1+((1D0+CTHE2)C2CHIC2PHI-2D0CTHES2CHI
	- &S2PHI)HF3-((1D0+CTHE2)C2CHIS2PHI+2D0CTHES2CHIC2PHI)HF4)
	- &SIGT-2D0SQ2(2D0STHECTHECCHIHF1-2D0STHE(CTHECCHIC2PHI-
	- &SCHIS2PHI)HF3+2D0STHE(CTHECCHIS2PHI+SCHIC2PHI)HF4)*SIGI+
	- &4D0SQ2STHECCHIHF2SIGA+2D0CTHEHF2SIGP
	- IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYONIA
	-C...Generates Upsilon and toponium decays into three gluons
	-C...or two gluons and a photon.
	-
	- SUBROUTINE PYONIA(KFL,ECM)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	- SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	-
	-C...Printout. Check input parameters.
	- IF(MSTU(12).NE.12345) CALL PYLIST(0)
	- IF(KFL.LT.0.OR.KFL.GT.8) THEN
	- CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	- IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
	- CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
	- IF(MSTU(21).GE.1) RETURN
	- ENDIF
	-
	-C...Initial e+e- and onium state (optional).
	- NC=0
	- IF(MSTJ(115).GE.2) THEN
	- NC=NC+2
	- CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
	- K(NC-1,1)=21
	- CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
	- K(NC,1)=21
	- ENDIF
	- KFLC=IABS(KFL)
	- IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
	- NC=NC+1
	- KF=110*KFLC+3
	- MSTU10=MSTU(10)
	- MSTU(10)=1
	- P(NC,5)=ECM
	- CALL PY1ENT(NC,KF,ECM,0D0,0D0)
	- K(NC,1)=21
	- K(NC,3)=1
	- MSTU(10)=MSTU10
	- ENDIF
	-
	-C...Choose x1 and x2 according to matrix element.
	- NTRY=0
	- 100 X1=PYR(0)
	- X2=PYR(0)
	- X3=2D0-X1-X2
	- IF(X3.GE.1D0.OR.((1D0-X1)/(X2X3))2+((1D0-X2)/(X1X3))**2+
	- &((1D0-X3)/(X1X2))2.LE.2D0PYR(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.2D0QF2PARU(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=(X1X3-2D0X1-2D0X3+2D0)/(X1X3)
	- ST13=SQRT(1D0-CT13**2)
	- SIGL=0.5D0X32((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=(SIGLCT13/ST13+0.5D0X1X3(1D0-X2)*2ST13)/SQ2
	- SIGMAX=(2D0HF1+HF3)ABS(SIGU)+2D0(HF1+HF3)ABS(SIGL)+2D0*(HF1+
	- & 2D0HF3)ABS(SIGT)+2D0SQ2(HF1+2D0HF3)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*2C2PHIHF3)SIGU+2D0(STHE2HF1-
	- & STHE*2C2PHIHF3)SIGL+2D0(STHE2C2CHIHF1+((1D0+CTHE2)
	- & C2CHIC2PHI-2D0CTHES2CHIS2PHI)HF3)SIGT-
	- & 2D0SQ2(2D0STHECTHECCHIHF1-2D0STHE
	- & (CTHECCHIC2PHI-SCHIS2PHI)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*2ICHAR(TITFX(3IT-2:3IT-2))+
	- & 256ICHAR(TITFX(3IT-1:3IT-1))+ICHAR(TITFX(3IT: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)=F1BIN(IS1+IX)+F2BIN(IS2+IX)
	- 100 CONTINUE
	- ELSEIF(OPER.EQ.'-') THEN
	- DO 110 IX=6,8+NX
	- BIN(IS3+IX)=F1BIN(IS1+IX)-F2BIN(IS2+IX)
	- 110 CONTINUE
	- ELSEIF(OPER.EQ.'*') THEN
	- DO 120 IX=6,8+NX
	- BIN(IS3+IX)=F1BIN(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 TITLE60, OUT100, 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(3IT-2:3IT)=CHAR(IEQ/2562)//CHAR(MOD(IEQ,2562)/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.LINDYAC(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.LINDYAC(1)10D0**IPOT) IPOT=IPOT-1
	- IF(YMAX-YMIN.GT.LINDYAC(10)10D0**IPOT) IPOT=IPOT+1
	- DELY=DYAC(1)
	- DO 120 IDEL=1,9
	- IF(YMAX-YMIN.GE.LINDYAC(IDEL)10D0**IPOT) DELY=DYAC(IDEL+1)
	- 120 CONTINUE
	- DY=DELY10D0*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),10IR)/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),10IR)/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+CTAX*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 TITLE60,FORMAT13
	-
	-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(3IT-2:3IT)=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-4D0RM3*RM4))
	- RPTS=4D0VINT(71)*2/SHAT
	- BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)*2-4D0RM3*RM4-RPTS))
	- RM34=2D0RM3RM4
	- RSQM=1D0+RM34
	- RTHM=(4D0RM3RM4+RPTS)/(1D0-RM3-RM4+BE34L)
	- THAT=-0.5D0SHATMAX(RTHM,1D0-RM3-RM4-BE34*CTH)
	- UHAT=-0.5D0SHATMAX(RTHM,1D0-RM3-RM4+BE34*CTH)
	- PT2=MAX(VINT(71)*2,0.25D0SHATBE342(1D0-CTH**2))
	-
	-C...Decisions by user to be put here.
	-
	-C...Stop program if this routine is ever called.
	-C...You should not copy these lines to your own routine.
	- WRITE(MSTU(11),5000)
	- CALL PYSTOP(6)
	-
	-C...Format for error printout.
	- 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
	- &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
	- &1X,'Execution stopped!')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...PYEVWT
	-C...Dummy routine, which the user can replace in order to multiply the
	-C...standard PYTHIA differential cross-section by a process- and
	-C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
	-C...to generation of weighted events, with weight 1/WTXS, while for
	-C...MSTP(142)=2 it corresponds to a modification of the underlying
	-C...physics.
	-
	- SUBROUTINE PYEVWT(WTXS)
	-
	-C...Double precision and integer declarations.
	- IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	- IMPLICIT INTEGER(I-N)
	- INTEGER PYK,PYCHGE,PYCOMP
	-C...Commonblocks.
	- COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	- COMMON/PYINT1/MINT(400),VINT(400)
	- COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	- SAVE /PYDAT1/,/PYINT1/,/PYINT2/
	-
	-C...Set default weight for WTXS.
	- WTXS=1D0
	-
	-C...Read out subprocess number.
	- ISUB=MINT(1)
	- ISTSB=ISET(ISUB)
	-
	-C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
	- TAU=VINT(21)
	- YST=VINT(22)
	- CTH=0D0
	- IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
	- TAUP=0D0
	- IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
	-
	-C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
	- X1=VINT(41)
	- X2=VINT(42)
	- XF=X1-X2
	- SHAT=VINT(44)
	- THAT=VINT(45)
	- UHAT=VINT(46)
	- PT2=VINT(48)
	-
	-C...Modifications by user to be put here.
	-
	-C...Stop program if this routine is ever called.
	-C...You should not copy these lines to your own routine.
	- WRITE(MSTU(11),5000)
	- CALL PYSTOP(4)
	-
	-C...Format for error printout.
	- 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
	- &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
	- &1X,'Execution stopped!')
	-
	- RETURN
	- END
	-
	-C*********************************************************************
	-
	-C...UPINIT
	-C...Dummy routine, to be replaced by a user implementing external
	-C...processes. Is supposed to fill the HEPRUP commonblock with info
	-C...on incoming beams and allowed processes.
	-
	-C...New example: handles a standard Les Houches Events File.
	-
	-c$$$ SUBROUTINE UPINIT
	-c$$$
	-c$$$C...Double precision and integer declarations.
	-c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-c$$$ IMPLICIT INTEGER(I-N)
	-c$$$
	-c$$$C...PYTHIA commonblock: only used to provide read unit MSTP(161).
	-c$$$ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	-c$$$ SAVE /PYPARS/
	-c$$$
	-c$$$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$$$
	-c$$$C...Lines to read in assumed never longer than 200 characters.
	-c$$$ PARAMETER (MAXLEN=200)
	-c$$$ CHARACTER*(MAXLEN) STRING
	-c$$$
	-c$$$C...Format for reading lines.
	-c$$$ CHARACTER*6 STRFMT
	-c$$$ STRFMT='(A000)'
	-c$$$ WRITE(STRFMT(3:5),'(I3)') MAXLEN
	-c$$$
	-c$$$C...Loop until finds line beginning with "<init>" or "<init ".
	-c$$$ 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
	-c$$$ IBEG=0
	-c$$$ 110 IBEG=IBEG+1
	-c$$$C...Allow indentation.
	-c$$$ IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
	-c$$$ IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
	-c$$$ &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
	-c$$$
	-c$$$C...Read first line of initialization info.
	-c$$$ READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
	-c$$$ &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	-c$$$
	-c$$$C...Read NPRUP subsequent lines with information on each process.
	-c$$$ DO 120 IPR=1,NPRUP
	-c$$$ READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
	-c$$$ & XMAXUP(IPR),LPRUP(IPR)
	-c$$$ 120 CONTINUE
	-c$$$ RETURN
	-c$$$
	-c$$$C...Error exit: give up if initalization does not work.
	-c$$$ 130 WRITE(,) ' Failed to read LHEF initialization information.'
	-c$$$ WRITE(,) ' Event generation will be stopped.'
	-c$$$ CALL PYSTOP(12)
	-c$$$
	-c$$$ RETURN
	-c$$$ 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.
	-
	-c$$$ SUBROUTINE UPEVNT
	-c$$$
	-c$$$C...Double precision and integer declarations.
	-c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-c$$$ IMPLICIT INTEGER(I-N)
	-c$$$
	-c$$$C...PYTHIA commonblock: only used to provide read unit MSTP(162).
	-c$$$ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	-c$$$ SAVE /PYPARS/
	-c$$$
	-c$$$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$$$
	-c$$$C...Lines to read in assumed never longer than 200 characters.
	-c$$$ PARAMETER (MAXLEN=200)
	-c$$$ CHARACTER*(MAXLEN) STRING
	-c$$$
	-c$$$C...Format for reading lines.
	-c$$$ CHARACTER*6 STRFMT
	-c$$$ STRFMT='(A000)'
	-c$$$ WRITE(STRFMT(3:5),'(I3)') MAXLEN
	-c$$$
	-c$$$C...Loop until finds line beginning with "<event>" or "<event ".
	-c$$$ 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
	-c$$$ IBEG=0
	-c$$$ 110 IBEG=IBEG+1
	-c$$$C...Allow indentation.
	-c$$$ IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
	-c$$$ IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
	-c$$$ &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
	-c$$$
	-c$$$C...Read first line of event info.
	-c$$$ READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
	-c$$$ &AQEDUP,AQCDUP
	-c$$$
	-c$$$C...Read NUP subsequent lines with information on each particle.
	-c$$$ DO 120 I=1,NUP
	-c$$$ READ(MSTP(162),*,END=130,ERR=130) 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$$$ 120 CONTINUE
	-c$$$ RETURN
	-c$$$
	-c$$$C...Error exit, typically when no more events.
	-c$$$ 130 WRITE(,) ' Failed to read LHEF event information.'
	-c$$$ WRITE(,) ' Will assume end of file has been reached.'
	-c$$$ NUP=0
	-c$$$ MSTI(51)=1
	-c$$$
	-c$$$ RETURN
	-c$$$ 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.
	-
	-c$$$ SUBROUTINE UPVETO(IVETO)
	-c$$$
	-c$$$C...HEPEVT commonblock.
	-c$$$ PARAMETER (NMXHEP=4000)
	-c$$$ COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	-c$$$ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	-c$$$ DOUBLE PRECISION PHEP,VHEP
	-c$$$ SAVE /HEPEVT/
	-c$$$
	-c$$$C...Next few lines allow you to see what info PYVETO extracted from
	-c$$$C...the full event record for the first two events.
	-c$$$C...Delete if you don't want it.
	-c$$$ DATA NLIST/0/
	-c$$$ SAVE NLIST
	-c$$$ IF(NLIST.LE.2) THEN
	-c$$$ WRITE(,) ' Full event record at time of UPVETO call:'
	-c$$$ CALL PYLIST(1)
	-c$$$ WRITE(,) ' Part of event record made available to UPVETO:'
	-c$$$ CALL PYLIST(5)
	-c$$$ NLIST=NLIST+1
	-c$$$ ENDIF
	-c$$$
	-c$$$C...Make decision here.
	-c$$$ IVETO = 0
	-c$$$
	-c$$$ RETURN
	-c$$$ END
	-
	-C*********************************************************************
	-
	-c$$$C...PDFSET
	-c$$$C...Dummy routine, to be removed when PDFLIB is to be linked.
	-c$$$
	-c$$$ SUBROUTINE PDFSET(PARM,VALUE)
	-c$$$
	-c$$$C...Double precision and integer declarations.
	-c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-c$$$ IMPLICIT INTEGER(I-N)
	-c$$$ INTEGER PYK,PYCHGE,PYCOMP
	-c$$$C...Commonblocks.
	-c$$$ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	-c$$$ SAVE /PYDAT1/
	-c$$$C...Local arrays and character variables.
	-c$$$ CHARACTER*20 PARM(20)
	-c$$$ DOUBLE PRECISION VALUE(20)
	-c$$$
	-c$$$C...Stop program if this routine is ever called.
	-c$$$ WRITE(MSTU(11),5000)
	-c$$$ CALL PYSTOP(5)
	-c$$$ PARM(20)=PARM(1)
	-c$$$ VALUE(20)=VALUE(1)
	-c$$$
	-c$$$C...Format for error printout.
	-c$$$ 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
	-c$$$ &1X,'Dummy routine PDFSET in PYTHIA file called instead.'/
	-c$$$ &1X,'Execution stopped!')
	-c$$$
	-c$$$ RETURN
	-c$$$ END
	-c$$$
	-c$$$C*********************************************************************
	-c$$$
	-c$$$C...STRUCTM
	-c$$$C...Dummy routine, to be removed when PDFLIB is to be linked.
	-c$$$
	-c$$$ SUBROUTINE STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
	-c$$$
	-c$$$C...Double precision and integer declarations.
	-c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-c$$$ IMPLICIT INTEGER(I-N)
	-c$$$ INTEGER PYK,PYCHGE,PYCOMP
	-c$$$C...Commonblocks.
	-c$$$ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	-c$$$ SAVE /PYDAT1/
	-c$$$C...Local variables
	-c$$$ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
	-c$$$
	-c$$$C...Stop program if this routine is ever called.
	-c$$$ WRITE(MSTU(11),5000)
	-c$$$ CALL PYSTOP(5)
	-c$$$ UPV=XX+QQ
	-c$$$ DNV=XX+2D0*QQ
	-c$$$ USEA=XX+3D0*QQ
	-c$$$ DSEA=XX+4D0*QQ
	-c$$$ STR=XX+5D0*QQ
	-c$$$ CHM=XX+6D0*QQ
	-c$$$ BOT=XX+7D0*QQ
	-c$$$ TOP=XX+8D0*QQ
	-c$$$ GLU=XX+9D0*QQ
	-c$$$
	-c$$$C...Format for error printout.
	-c$$$ 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
	-c$$$ &1X,'Dummy routine STRUCTM in PYTHIA file called instead.'/
	-c$$$ &1X,'Execution stopped!')
	-c$$$
	-c$$$ RETURN
	-c$$$ END
	-c$$$
	-c$$$C*********************************************************************
	-c$$$
	-c$$$C...STRUCTP
	-c$$$C...Dummy routine, to be removed when PDFLIB is to be linked.
	-c$$$
	-c$$$ SUBROUTINE STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
	-c$$$ &BOT,TOP,GLU)
	-c$$$
	-c$$$C...Double precision and integer declarations.
	-c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-c$$$ IMPLICIT INTEGER(I-N)
	-c$$$ INTEGER PYK,PYCHGE,PYCOMP
	-c$$$C...Commonblocks.
	-c$$$ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	-c$$$ SAVE /PYDAT1/
	-c$$$C...Local variables
	-c$$$ DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
	-c$$$ &TOP,GLU
	-c$$$
	-c$$$C...Stop program if this routine is ever called.
	-c$$$ WRITE(MSTU(11),5000)
	-c$$$ CALL PYSTOP(5)
	-c$$$ UPV=XX+QQ2
	-c$$$ DNV=XX+2D0*QQ2
	-c$$$ USEA=XX+3D0*QQ2
	-c$$$ DSEA=XX+4D0*QQ2
	-c$$$ STR=XX+5D0*QQ2
	-c$$$ CHM=XX+6D0*QQ2
	-c$$$ BOT=XX+7D0*QQ2
	-c$$$ TOP=XX+8D0*QQ2
	-c$$$ GLU=XX+9D0*QQ2
	-c$$$
	-c$$$C...Format for error printout.
	-c$$$ 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
	-c$$$ &1X,'Dummy routine STRUCTP in PYTHIA file called instead.'/
	-c$$$ &1X,'Execution stopped!')
	-c$$$
	-c$$$ RETURN
	-c$$$ 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.
	-
	-CAM SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
	-CAM
	-CAMC...Double precision and integer declarations.
	-CAM IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	-CAM IMPLICIT INTEGER(I-N)
	-CAM INTEGER PYK,PYCHGE,PYCOMP
	-CAMC...Commonblocks.
	-CAM COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	-CAM COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	-CAM SAVE /PYJETS/,/PYDAT1/
	-CAM
	-CAMC...Stop program if this routine is ever called.
	-CAMC...You should not copy these lines to your own routine.
	-CAM NDECAY=ITAU+IORIG+KFORIG
	-CAM WRITE(MSTU(11),5000)
	-CAM CALL PYSTOP(10)
	-CAM
	-CAMC...Format for error printout.
	-CAM 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
	-CAM &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
	-CAM &1X,'Execution stopped!')
	-CAM
	-CAM RETURN
	-CAM 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
	Index: trunk/stdhep/heprup.h
	===================================================================
	--- trunk/stdhep/heprup.h (revision 8888)
	+++ trunk/stdhep/heprup.h (revision 8889)
	@@ -1,17 +0,0 @@
	-/*
	-C...User process initialization commonblock.
	-*/
	-
	-#define MAXPUP 100
	-extern struct heprup {
	- int idbmup[2];
	- double ebmup[2];
	- int pdfgup[2];
	- int pdfsup[2];
	- int idwtup;
	- int nprup;
	- double xsecup[MAXPUP];
	- double xerrup[MAXPUP];
	- double xmaxup[MAXPUP];
	- int lprup[MAXPUP];
	-} heprup_;
	Index: trunk/stdhep/stdxrd.f
	===================================================================
	--- trunk/stdhep/stdxrd.f (revision 8888)
	+++ trunk/stdhep/stdxrd.f (revision 8889)
	@@ -1,144 +0,0 @@
	- subroutine stdxrd(ilbl,istream,lok)
	-
	-C...Purpose: to read a buffer or an event from the standard common block.
	-C
	-C returns ilbl & lok
	-C
	-C ilbl = 1 - standard HEPEVT common block
	-C ilbl = 2 - standard HEPEVT common block and HEPEV2
	-C ilbl = 3 - stdevent struct
	-C ilbl = 4 - standard HEPEVT common block with Les Houches
	-C ilbl = 5 - standard HEPEVT common block with Les Houches
	-C and multiple collisions
	-C ilbl = 11 - HEPEUP common block
	-C ilbl = 12 - HEPRUP common block
	-C ilbl = 100 - STDHEP begin run record
	-C ilbl = 200 - STDHEP end run record
	-C
	-C lok = 0 if no problems were encountered
	-C
	-
	- include "stdcnt.inc"
	- include "stdlun.inc"
	- include "stdhd.inc"
	- include "mcfio.inc"
	-
	- integer ilbl,lok,istream
	- integer i
	- integer xdr_stdhep, xdr_stdhep_multi, xdr_stdhep_cm1
	- external xdr_stdhep, xdr_stdhep_multi, xdr_stdhep_cm1
	- integer xdr_stdhep_cxx, xdr_stdhep_4, xdr_stdhep_4_multi
	- external xdr_stdhep_cxx, xdr_stdhep_4, xdr_stdhep_4_multi
	- integer xdr_hepeup, xdr_heprup
	- external xdr_hepeup, xdr_heprup
	-
	- logical lfirst
	- data lfirst/.TRUE./
	- save lfirst
	-
	-C...print version number if this is the first call
	- if(lfirst)then
	- call stdversn
	- nstdrd = 0
	- nlhrd = 0
	- lfirst=.FALSE.
	- endif
	-
	- lok = 0
	-c...get the next xdr event
	- if(mcfio_NextEvent(istream) .ne. MCFIO_RUNNING)then
	- call mcfio_InfoStreamInt(istream,MCFIO_STATUS,istat)
	- if(istat .eq. MCFIO_EOF) go to 800
	- if(istat .eq. MCFIO_RUNNING) go to 700
	- go to 900
	- endif
	-c...what blocks are in this event?
	- call mcfio_InfoEventInt(istream,MCFIO_NUMBLOCKS,numblocks)
	- do i=1,numblocks
	- call mcfio_InfoEventInt(istream,MCFIO_BLOCKIDS,blkids(i))
	- if(blkids(i).eq.MCFIO_STDHEP)then
	-c...zero stdhep common
	- call stdzero
	-c...fill stdhep common
	- if(mcfio_block(istream,MCFIO_STDHEP,xdr_stdhep) .eq. -1)
	- 1 go to 700
	- ilbl = 1
	- call stdtcopy(2,istream,lok)
	- if(lok.eq.0) nstdrd = nstdrd + 1
	- elseif(blkids(i).eq.MCFIO_STDHEPM)then
	-c...zero stdhep common
	- call stdzero
	-c...fill stdhep common
	- if(mcfio_block(istream,MCFIO_STDHEPM,xdr_stdhep_multi)
	- 1 .eq. -1) go to 700
	- ilbl = 2
	- nstdrd = nstdrd + 1
	- elseif(blkids(i).eq.MCFIO_STDHEP4)then
	-c...zero stdhep common
	- call stdzero
	-c...fill stdhep common
	- if(mcfio_block(istream,MCFIO_STDHEP4,xdr_stdhep_4) .eq. -1)
	- 1 go to 700
	- ilbl = 4
	- call stdtcopy(2,istream,lok)
	- if(lok.eq.0) nstdrd = nstdrd + 1
	- elseif(blkids(i).eq.MCFIO_STDHEP4M)then
	-c...zero stdhep common
	- call stdzero
	-c...fill stdhep common
	- if(mcfio_block(istream,MCFIO_STDHEP4M,xdr_stdhep_4_multi)
	- 1 .eq. -1) go to 700
	- ilbl = 5
	- nstdrd = nstdrd + 1
	- elseif(blkids(i).eq.MCFIO_STDHEPCXX)then
	-c...zero stdhep common
	- call stdzero
	-c...fill stdevent struct
	-c if(mcfio_block(istream,MCFIO_STDHEPCXX,xdr_stdhep_cxx)
	-c 1 .eq. -1) go to 700
	- ilbl = 3
	- write (lnhout,703)
	-c...fix stdhep common from stdevent
	-c call copy_stdevent
	-c nstdrd = nstdrd + 1
	- elseif(blkids(i).eq.MCFIO_HEPEUP)then
	-c...Les Houches event - fill hepeup common
	- if(mcfio_block(istream,MCFIO_HEPEUP,xdr_hepeup)
	- 1 .eq. -1) go to 700
	- ilbl = 11
	- nlhrd = nlhrd + 1
	- elseif(blkids(i).eq.MCFIO_HEPRUP)then
	-c...Les Houches event - fill heprup common
	- if(mcfio_block(istream,MCFIO_HEPRUP,xdr_heprup)
	- 1 .eq. -1) go to 700
	- ilbl = 12
	- nlhrd = nlhrd + 1
	- elseif(blkids(i).eq.MCFIO_STDHEPBEG)then
	-c...begin run event - fill stdcm1 common
	- if(mcfio_block(istream,MCFIO_STDHEPBEG,xdr_stdhep_cm1)
	- 1 .eq. -1) go to 700
	- ilbl = 100
	- elseif(blkids(i).eq.MCFIO_STDHEPEND)then
	-c...end run event - fill stdcm1 common
	- if(mcfio_block(istream,MCFIO_STDHEPEND,xdr_stdhep_cm1)
	- 1 .eq. -1) go to 700
	- ilbl = 200
	- endif
	- enddo
	- return
	-
	- 700 write (lnhout,701)
	- lok=1
	- return
	- 800 write (lnhout,801)
	- lok=1
	- return
	- 900 write (lnhout,901)
	- lok=2
	- stop
	- 701 format(/5X,'STDXRD: unable to read xdr block')
	- 703 format(/5X,'STDXRD: stdevent struct cannot be processed')
	- 801 format(/5X,'STDXRD: end of file found')
	- 901 format(/5X,'STDXRD: unrecognized status - stop')
	- end
	-
	Index: trunk/stdhep/stdhd.h
	===================================================================
	--- trunk/stdhep/stdhd.h (revision 8888)
	+++ trunk/stdhep/stdhd.h (revision 8889)
	@@ -1,19 +0,0 @@
	-/*
	-----------------------------------------------------------------
	- This header collects the mcfio initial information
	-----------------------------------------------------------------
	-*/
	-
	-extern struct stdhd1 {
	-char date[255]; /* MCFIO_CREATIONDATE: creation date */
	-char title[255]; /* MCFIO_TITLE: title */
	-char comment[255]; /* MCFIO_COMMENT: comment */
	-} stdhd1_;
	-
	-extern struct stdhd2 {
	-int dlen; /* actual lenght of date */
	-int tlen; /* actual lenght of title */
	-int clen; /* actual lenght of comment */
	-int numblocks; /* MCFIO_NUMBLOCKS: number of blocks per event */
	-int blkids[50]; /* MCFIO_BLOCKIDS: list of block types */
	-} stdhd2_;
	Index: trunk/stdhep/stdtcopy.f
	===================================================================
	--- trunk/stdhep/stdtcopy.f (revision 8888)
	+++ trunk/stdhep/stdtcopy.f (revision 8889)
	@@ -1,117 +0,0 @@
	- subroutine stdtcopy(idir,istr,lok)
	-
	-C...Purpose: to copy an event to/from the standard common block.
	-C
	- implicit none
	-
	- include "stdhep.inc"
	- include "hepev4.inc"
	- include "stdtmp.inc"
	- include "stdlun.inc"
	-
	- integer idir,lok,i,k,istr
	-
	- lok=0
	- if(idir.eq.1)then
	-c... copy from hepevt to stdtmp
	- nhept = nhep
	- nevhept = nevhep
	- idrupt = idruplh
	- eventweightt = eventweightlh
	- alphaqedt = alphaqedlh
	- alphaqcdt = alphaqcdlh
	- do i=1,10
	- scalet(i) = scalelh(i)
	- enddo
	- do i=1,nhep
	- isthept(i) = isthep(i)
	- idhept(i) = idhep(i)
	- do k=1,2
	- jmohept(k,i) = jmohep(k,i)
	- jdahept(k,i) = jdahep(k,i)
	- icolorflowt(k,i) = icolorflowlh(k,i)
	- enddo
	- do k=1,5
	- phept(k,i) = phep(k,i)
	- enddo
	- do k=1,4
	- vhept(k,i) = vhep(k,i)
	- enddo
	- do k=1,3
	- spint(k,i) = spinlh(k,i)
	- enddo
	- enddo
	- elseif(idir.eq.2)then
	-c... copy from stdtmp to hepevt
	-c... allow for multiple interactions
	- if((nhep+nhept) .gt. NMXHEP) go to 900
	- nevhep = nevhept
	-c... no multiple interaction option for hepev4 information
	- idruplh = idrupt
	- eventweightlh = eventweightt
	- alphaqedlh = alphaqedt
	- alphaqcdlh = alphaqcdt
	- do i=1,10
	- scalelh(i) = scalet(i)
	- enddo
	- do i=1,nhept
	- isthep(i+nhep) = isthept(i)
	- idhep(i+nhep) = idhept(i)
	- do k=1,2
	- jmohep(k,i+nhep) = jmohept(k,i)
	- jdahep(k,i+nhep) = jdahept(k,i)
	- icolorflowlh(k,i+nhep) = icolorflowt(k,i)
	- enddo
	- do k=1,5
	- phep(k,i+nhep) = phept(k,i)
	- enddo
	- do k=1,4
	- vhep(k,i+nhep) = vhept(k,i)
	- enddo
	- do k=1,3
	- spinlh(k,i+nhep) = spint(k,i)
	- enddo
	- enddo
	- nmulti = nmulti + 1
	- if(nmulti.le.NMXMLT) then
	- nevmulti(nmulti) = nevhept
	- itrkmulti(nmulti) = nhep + 1
	- mltstr(nmulti) = istr
	- idrupmulti(nmulti) = idrupt
	- eventweightmulti(nmulti) = eventweightt
	- alphaqedmulti(nmulti) = alphaqedt
	- alphaqcdmulti(nmulti) = alphaqcdt
	- do i=1,10
	- scalemulti(i,nmulti) = scalet(i)
	- enddo
	- else
	- write(lnhout,902) nmulti,NMXMLT
	- endif
	-C... adjust pointers for "multiple interaction" events
	- do i=1,nhept
	- jmulti(nhep+i) = nmulti
	- do k=1,2
	-c... make sure 0 pointers remain 0
	- if(jmohep(k,i+nhep).ne.0)
	- 1 jmohep(k,i+nhep) = jmohep(k,i+nhep) + nhep
	- if(jdahep(k,i+nhep).ne.0)
	- 1 jdahep(k,i+nhep) = jdahep(k,i+nhep) + nhep
	- if(icolorflowlh(k,i+nhep).ne.0)
	- 1 icolorflowlh(k,i+nhep) = icolorflowlh(k,i+nhep) + nhep
	- enddo
	- enddo
	- nhep = nhep + nhept
	- else
	- write (lnhout,801)
	- endif
	- return
	- 900 continue
	- write (lnhout,901) nevhept
	- lok = 5
	- return
	- 801 format(/5X,'STDTCOPY: improper calling flag')
	- 901 format(/5X,'STDTCOPY: event would overflow HEPEVT array size'/
	- 1 5X,'STDTCOPY: event ',i8,' has been lost')
	- 902 format(/5X,'STDTCOPY: ',i2,' multiple interactions in this event'/
	- 1 5X,'STDTCOPY: only ',i2,'multiple interactions are allowed')
	- end
	Index: trunk/stdhep/hepeup.inc
	===================================================================
	--- trunk/stdhep/hepeup.inc (revision 8888)
	+++ trunk/stdhep/hepeup.inc (revision 8889)
	@@ -1,33 +0,0 @@
	-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)
	-
	-C
	-C Les Houches accord 2001
	-C
	-C NUP - number of particle entries in this event
	-C IDPRUP - ID of the process for this event
	-C (ID's are generator-specific)
	-C XWGTUP - event weight
	-C SCALUP - scale of the event in GeV, as used to calculate PDFs
	-C AQEDUP - QED coupling used for this event
	-C AQCDUP - QCD coupling used for this event
	-C IDUP - particle ID according to PDG convention
	-C ISTUP - status code:
	-C -1 incoming particle
	-C +1 outgoing final state particle
	-C -2 intermediate space like propagator
	-C +2 intermediate resonance, mass should be preserved
	-C +3 intermediate resonance for documentation only
	-C -9 incoming beam particles (generally not needed)
	-C MOTHUP - index of first and last mother
	-C ICOLUP - tag for color flow lines
	-C PUP - lab frame 4 momentum and mass in GeV
	-C VTIMUP - invariant lifetime
	-C SPINUP - cos of angle between spin-vector of particle and 3 momentum of decaying particle
	-C
	Index: trunk/stdhep/stdxwrt.f
	===================================================================
	--- trunk/stdhep/stdxwrt.f (revision 8888)
	+++ trunk/stdhep/stdxwrt.f (revision 8889)
	@@ -1,58 +0,0 @@
	- subroutine stdxwrt(ilbl,istream,lok)
	-
	-C...Purpose: to write a buffer or an event from the standard common block.
	-C
	-C if ilbl = 1 write HEPEVT common block
	-C ilbl = 2 write HEPEVT, HEPEV2, and HEPEV3 common blocks
	-C ilbl = 4 write HEPEVT and HEPEV4 common blocks
	-C ilbl = 5 write HEPEVT, HEPEV2, HEPEV3, and HEPEV4 common blocks
	-C ilbl = 11 write HEPEUP common block
	-C ilbl = 12 write HEPRUP common block
	-C ilbl = 100 write STDHEP begin run record
	-C ilbl = 200 write STDHEP end run record
	-C otherwise, don't do anything
	-C
	-C lok = 0 if no problems were encountered
	-
	- include "stdcnt.inc"
	- include "stdlun.inc"
	-
	- integer ilbl,lok,istream
	- logical lfirst
	- data lfirst/.TRUE./
	- save lfirst
	-
	-C...print version number if this is the first call
	- if(lfirst)then
	- call stdversn
	- nstdwrt = 0
	- nlhwrt = 0
	- lfirst=.FALSE.
	- endif
	-
	- lok=0
	- if(ilbl.eq.1 .or. ilbl.eq.2)then
	-C... the stdhep common block and maybe the multiple interaction common
	- call stdxwevt(ilbl,istream,lok)
	- elseif(ilbl.eq.4 .or. ilbl.eq.5)then
	-C... the stdhep common block and maybe the multiple interaction common
	-C... include HEPEV4
	- call stdxwevtlh(ilbl,istream,lok)
	- elseif(ilbl.eq.11 .or. ilbl.eq.12)then
	-C... the Les Houches common blocks
	- call stdxwevtup(ilbl,istream,lok)
	- elseif(ilbl.eq.100)then
	- call stdxwcm1(ilbl,istream,lok)
	- elseif(ilbl.eq.200)then
	- call stdxwcm1(ilbl,istream,lok)
	- else
	- write(lnhout,902) ilbl
	- endif
	- return
	- 900 write (lnhout,901)
	- lok=1
	- return
	- 101 format(/5X,'STDXWRT: the output buffer is empty')
	- 901 format(/5X,'STDXWRT: write error')
	- 902 format(/5X,'STDXWRT: do not know what to do with record type',i5)
	- end
	Index: trunk/stdhep/mcfio.inc
	===================================================================
	--- trunk/stdhep/mcfio.inc (revision 8888)
	+++ trunk/stdhep/mcfio.inc (revision 8889)
	@@ -1,154 +0,0 @@
	-c
	-c Include file for mcfast i/o layer.
	-c
	-c Paul Lebrun, October 1994.
	-c
	- integer MCFIO_VERSION
	- integer MCFIO_STATUS
	- integer MCFIO_RUNNING
	- integer MCFIO_BOF
	- integer MCFIO_EOF
	- integer MCFIO_NUMBLOCKS
	- integer MCFIO_READORWRITE
	- integer MCFIO_READ
	- integer MCFIO_WRITE
	- integer MCFIO_DIRECTORSEQUENTIAL
	- integer MCFIO_DIRECT
	- integer MCFIO_SEQUENTIAL
	- integer MCFIO_BLOCKIDS
	- integer MCFIO_NUMWORDS
	- integer MCFIO_EFFICIENCY
	- integer MCFIO_NUMEVTS
	- integer MCFIO_FILENUMBER
	- integer MCFIO_MAXREC
	- integer MCFIO_MINREC
	- integer MCFIO_NUMRECORDS
	- integer MCFIO_RECORDLENGTHS
	- integer MCFIO_TITLE
	- integer MCFIO_COMMENT
	- integer MCFIO_CREATIONDATE
	- integer MCFIO_CLOSINGDATE
	- integer MCFIO_FILENAME
	- integer MCFIO_DEVICENAME
	- integer MCFIO_EVENTNUMBER
	- integer MCFIO_STORENUMBER
	- integer MCFIO_RUNNUMBER
	- integer MCFIO_TRIGGERMASK
	- integer MCFIO_NUMNTUPLES
	- integer MCFIO_NTUPLESLIST
	- PARAMETER (MCFIO_VERSION = 100)
	- PARAMETER (MCFIO_STATUS = 101)
	- PARAMETER (MCFIO_RUNNING = 102)
	- PARAMETER (MCFIO_BOF = 103)
	- PARAMETER (MCFIO_EOF = 104)
	- PARAMETER (MCFIO_NUMBLOCKS = 501)
	- PARAMETER (MCFIO_READORWRITE = 502)
	- PARAMETER (MCFIO_READ = 1)
	- PARAMETER (MCFIO_WRITE = 2)
	- PARAMETER (MCFIO_DIRECTORSEQUENTIAL = 503)
	- PARAMETER (MCFIO_DIRECT = 1)
	- PARAMETER (MCFIO_SEQUENTIAL = 2)
	- PARAMETER (MCFIO_BLOCKIDS = 504)
	- PARAMETER (MCFIO_NUMWORDS = 505)
	- PARAMETER (MCFIO_EFFICIENCY = 506)
	- PARAMETER (MCFIO_NUMEVTS = 507)
	- PARAMETER (MCFIO_FILENUMBER = 508)
	- PARAMETER (MCFIO_MAXREC = 509)
	- PARAMETER (MCFIO_MINREC = 510)
	- PARAMETER (MCFIO_NUMRECORDS = 511)
	- PARAMETER (MCFIO_RECORDLENGTHS = 512)
	- PARAMETER (MCFIO_TITLE = 1001)
	- PARAMETER (MCFIO_COMMENT = 1002)
	- PARAMETER (MCFIO_CREATIONDATE = 1003)
	- PARAMETER (MCFIO_CLOSINGDATE = 1013)
	- PARAMETER (MCFIO_FILENAME = 1004)
	- PARAMETER (MCFIO_DEVICENAME = 1005)
	- PARAMETER (MCFIO_EVENTNUMBER = 2001)
	- PARAMETER (MCFIO_STORENUMBER = 2002)
	- PARAMETER (MCFIO_RUNNUMBER = 2003)
	- PARAMETER (MCFIO_TRIGGERMASK = 2004)
	- PARAMETER (MCFIO_NUMNTUPLES = 4001)
	- PARAMETER (MCFIO_NTUPLESLIST = 4002)
	-
	- integer mcfio_OpenReadDirect
	- integer mcfio_OpenReadMapped
	- integer mcfio_OpenWriteDirect
	- integer mcfio_OpenReadSequential
	- integer mcfio_OpenWriteSequential
	- integer mcfio_NextEvent
	- integer mcfio_SpecificEvent
	- integer mcfio_NextSpecificEvent
	- integer mcfio_Block
	- integer mcfio_InfoNumStream
	- integer mcfio_DeclareNtuple
	- integer mcfio_EndDeclNtuples
	- integer mcfio_Ntuple
	- integer mcfio_NtupleMult
	- integer mcfio_NtupleVar
	- integer mcfio_NtupleSubVar
	- integer mcfio_NtupleSubStruct
	- integer mcfio_GetNtupleIds
	- integer mcfio_GetNTupleUID
	- integer mcfio_GetNTupleCategory
	- integer mcfio_GetNTupleTitle
	- integer mcfio_GetNTupleName
	-
	- external mcfio_OpenReadDirect
	- external mcfio_OpenReadMapped
	- external mcfio_OpenWriteDirect
	- external mcfio_OpenReadSequential
	- external mcfio_OpenWriteSequential
	- external mcfio_NextEvent
	- external mcfio_SpecificEvent
	- external mcfio_NextSpecificEvent
	- external mcfio_Block
	- external mcfio_InfoNumStream
	- external mcfio_DeclareNtuple
	- external mcfio_EndDeclNtuples
	- external mcfio_Ntuple
	- external mcfio_GetNtupleIds
	- external mcfio_GetNTupleUID
	- external mcfio_GetNTupleCategory
	- external mcfio_GetNTupleTitle
	- external mcfio_GetNTupleName
	- external mcfio_NtupleMult
	- external mcfio_NtupleVar
	- external mcfio_NtupleSubVar
	- external mcfio_NtupleSubStruct
	-C
	-C Block definition now. Start counting at 101 See also mcfioC_GetBlockNames
	-C
	- integer MCFIO_STDHEP
	- integer MCFIO_STDHEPM
	- integer MCFIO_STDHEP4
	- integer MCFIO_STDHEP4M
	- integer MCFIO_STDHEPBEG
	- integer MCFIO_STDHEPEND
	- integer MCFIO_STDHEPCXX
	- integer MCFIO_OFFTRACKARRAYS
	- integer MCFIO_OFFTRACKSTRUCT
	- integer MCFIO_TRACEARRAYS
	- integer MCFIO_HEPEUP
	- integer MCFIO_HEPRUP
	- parameter ( MCFIO_STDHEP = 101 )
	- parameter ( MCFIO_OFFTRACKARRAYS = 102 )
	- parameter ( MCFIO_OFFTRACKSTRUCT = 103 )
	- parameter ( MCFIO_TRACEARRAYS = 104 )
	- parameter ( MCFIO_STDHEPM = 105 )
	- parameter ( MCFIO_STDHEPBEG = 106 )
	- parameter ( MCFIO_STDHEPEND = 107 )
	- parameter ( MCFIO_STDHEPCXX = 108 )
	- parameter ( MCFIO_STDHEP4 = 201 )
	- parameter ( MCFIO_STDHEP4M = 202 )
	- parameter ( MCFIO_HEPEUP = 203 )
	- parameter ( MCFIO_HEPRUP = 204 )
	-c
	-c Some of these statements should be in the user code,
	-c uncommented.
	-c
	-c integer xdr_mcfast_track_offline
	-c external xdr_mcfast_track_offline
	-c integer xdr_mcfast_track_offlslow
	-c external xdr_mcfast_track_offlslow
	-c
	-c
	Index: trunk/stdhep/stdcnt.inc
	===================================================================
	--- trunk/stdhep/stdcnt.inc (revision 8888)
	+++ trunk/stdhep/stdcnt.inc (revision 8889)
	@@ -1,6 +0,0 @@
	-C -------------------------------------------------------------
	-C
	- integer nstdwrt,nstdrd,nlhwrt,nlhrd
	- common /stdcnt/ nstdwrt,nstdrd,nlhwrt,nlhrd
	- save /stdcnt/
	-C -------------------------------------------------------------
	Index: trunk/stdhep/Makefile.am
	===================================================================
	--- trunk/stdhep/Makefile.am (revision 8888)
	+++ trunk/stdhep/Makefile.am (revision 8889)
	@@ -1,109 +0,0 @@
	-## Makefile.am -- Makefile for WHIZARD
	-##
	-## Process this file with automake to produce Makefile.in
	-##
	-########################################################################
	-#
	-# Copyright (C) 1999-2023 by
	-# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	-# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	-# Juergen Reuter <juergen.reuter@desy.de>
	-# with contributions from
	-# cf. main AUTHORS file
	-#
	-# WHIZARD is free software; you can redistribute it and/or modify it
	-# under the terms of the GNU General Public License as published by
	-# the Free Software Foundation; either version 2, or (at your option)
	-# any later version.
	-#
	-# WHIZARD is distributed in the hope that it will be useful, but
	-# WITHOUT ANY WARRANTY; without even the implied warranty of
	-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	-# GNU General Public License for more details.
	-#
	-# You should have received a copy of the GNU General Public License
	-# along with this program; if not, write to the Free Software
	-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	-#
	-########################################################################
	-
	-## The files in this directory end up in an auxiliary libtool library.
	-
	-noinst_LTLIBRARIES = libwo_stdhep.la
	-
	-libwo_stdhep_la_SOURCES = \
	- mcf_hepev4_xdr.c \
	- mcf_hepup_xdr.c \
	- mcf_stdcm1_xdr.c \
	- mcf_Stdhep_xdr.c \
	- stdhep_mcfio.c \
	- stdhep_internal_utils.c \
	- stdtcopy.f \
	- stdversn.f \
	- stdxend.f \
	- stdxrd.f \
	- stdxrinit.f \
	- stdxropen.f \
	- stdxwcm1.f \
	- stdxwevt.f \
	- stdxwevtlh.f \
	- stdxwevtup.f \
	- stdxwinit.f \
	- stdxwopen.f \
	- stdxwrt.f \
	- stdzero.f \
	- hepev4.h \
	- hepeup.h \
	- heprup.h \
	- stdcm1.h \
	- stdcnt.h \
	- stdhd.h \
	- stdhep.h \
	- stdhep_mcfio.h \
	- stdlun.h \
	- stdtmp.h \
	- stdver.h \
	- hepev4.inc \
	- hepeup.inc \
	- heprup.inc \
	- mcfio.inc \
	- stdcm1.inc \
	- stdcnt.inc \
	- stdhd.inc \
	- stdhep.inc \
	- stdlun.inc \
	- stdtmp.inc \
	- stdver.inc
	-
	-## The include files are not automatically found (by certain Fortran compilers)
	-## RPC flags need to be included if SunRPC is absent
	-AM_FCFLAGS = -I$(top_srcdir)/stdhep
	-AM_FFLAGS = -I$(top_srcdir)/stdhep
	-AM_CFLAGS = $(RPC_CFLAGS) -I$(top_srcdir)/mcfio
	-
	-########################################################################
	-## Default Fortran compiler options
	-
	-## Profiling
	-if FC_USE_PROFILING
	-AM_FCFLAGS += $(FCFLAGS_PROFILING)
	-endif
	-
	-## OpenMP
	-if FC_USE_OPENMP
	-AM_FCFLAGS += $(FCFLAGS_OPENMP)
	-endif
	-
	-########################################################################
	-## Non-standard cleanup tasks
	-
	-## Remove F90 module files
	-clean-local:
	- -rm -f *.$(FC_MODULE_EXT)
	-if FC_SUBMODULES
	- -rm -f *.smod
	-endif
	-
	-## Remove backup files
	-maintainer-clean-local:
	- -rm -f *~
	Index: trunk/stdhep/stdxropen.f
	===================================================================
	--- trunk/stdhep/stdxropen.f (revision 8888)
	+++ trunk/stdhep/stdxropen.f (revision 8889)
	@@ -1,50 +0,0 @@
	- subroutine stdxropen(filename,ntries,istream,lok)
	-c
	-c initialize xdr reading
	-c
	- implicit none
	- include "mcfio.inc"
	- include "stdlun.inc"
	- include "stdhd.inc"
	- integer istream,lok,ntries,i
	- character() filename
	-
	- logical lfirst
	- data lfirst/.TRUE./
	- save lfirst
	-c
	-c Initialization phase.
	-c
	-C...print version number if this is the first call
	- if(lfirst)then
	- call stdversn
	- lfirst=.FALSE.
	- endif
	- lok = 0
	- istream = mcfio_OpenReadDirect(filename)
	- if (istream .eq. -1) go to 900
	- call mcfio_InfoStreamChar(istream,MCFIO_CREATIONDATE,date,dlen)
	- call mcfio_InfoStreamChar(istream,MCFIO_TITLE,title,tlen)
	- call mcfio_InfoStreamChar(istream,MCFIO_COMMENT,comment,clen)
	- call mcfio_InfoStreamInt(istream,MCFIO_NUMEVTS,ntries)
	- call mcfio_InfoStreamInt(istream,MCFIO_NUMBLOCKS,numblocks)
	- do i=1,numblocks
	- call mcfio_InfoStreamInt(istream,MCFIO_BLOCKIDS,blkids(i))
	- enddo
	- write(lnhout,1001) istream,title(1:tlen),date(1:dlen),
	- 1 comment(1:clen),ntries,numblocks
	- return
	-
	- 900 continue
	- write(lnhout,1002)
	- lok = -1
	- stop
	-
	-1001 format(/' STDXROPEN: successfully opened input stream ',i5/
	- 1 10x,'title: ',a60/
	- 2 10x,'date: ',a60/
	- 3 10x,a70/
	- 4 20x,i10,' events'/
	- 5 20x,i10,' blocks per event'/)
	-1002 format(' STDXROPEN: Cannot open input file, give up ')
	- end
	Index: trunk/stdhep/heprup.inc
	===================================================================
	--- trunk/stdhep/heprup.inc (revision 8888)
	+++ trunk/stdhep/heprup.inc (revision 8889)
	@@ -1,40 +0,0 @@
	-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)
	-
	-C
	-C Les Houches accord 2001
	-C
	-C MAXPUP - max. number of different processes to be interfaced at one time
	-C IDBMUP - ID of beam particles 1 and 2 according to the PDG convention
	-C EBMUP - energy in GeV of beam particles 1 and 2
	-C PDFGUP - author group for beam particles 1 and 2 according to PDFlib specifications
	-C PDFSUP - PDF set ID for beam particles 1 and 2 according to PDFlib specifications
	-C
	-C For e+e- or when the SHG defaults are to be used,
	-C set PDFGUP=-1 and PDFSUP=-1
	-C
	-C IDWTUP - master switch dictating how the event weights are interpreted
	-C NPRUP - number of different user subprocesses
	-C XSECUP - cross section for process in pb
	-C XERRUP - statistical error associated with XSECUP
	-C XMAXUP - maximum XWGTUP (in common block HEPEUP) for this process
	-C LPRUP - user process ID's for this run
	-C
	-C event control of
	-C IDWTUP selection mixing or XWGTUP output
	-C criteria unweighting input
	-C +1 XMAXUP SHG +weighted +1
	-C -1 XMAXUP SHG +/-weighted +/-1
	-C +2 XSECUP SHG +weighted +1
	-C -2 XSECUP SHG +/-weighted +/-1
	-C +3 user interface +1 +1
	-C -3 user interface +/-1 +/-1
	-C +4 user interface +weighted +weighted
	-C 14 user interface +/-weighted +/-weighted
	-C
	Index: trunk/stdhep/stdxrinit.f
	===================================================================
	--- trunk/stdhep/stdxrinit.f (revision 8888)
	+++ trunk/stdhep/stdxrinit.f (revision 8889)
	@@ -1,26 +0,0 @@
	- subroutine stdxrinit(filename,ntries,istream,lok)
	-c
	-c initialize xdr reading
	-c
	- implicit none
	- include "mcfio.inc"
	- include "stdlun.inc"
	- integer istream,lok,ntries
	- character() filename
	-
	- logical lfirst
	- data lfirst/.TRUE./
	- save lfirst
	-c
	-c Initialization phase.
	-c
	-C...print version number if this is the first call
	- if(lfirst)then
	- call stdversn
	- lfirst=.FALSE.
	- endif
	- lok = 0
	- call mcfio_init()
	- call stdxropen(filename,ntries,istream,lok)
	- return
	- end
	Index: trunk/stdhep/stdxwevt.f
	===================================================================
	--- trunk/stdhep/stdxwevt.f (revision 8888)
	+++ trunk/stdhep/stdxwevt.f (revision 8889)
	@@ -1,48 +0,0 @@
	- subroutine stdxwevt(ilbl,istream,lok)
	-
	-C...Purpose: to write an event from the standard common block.
	-C
	-C lok = 0 if no problems were encountered
	-
	- include "stdhep.inc"
	- include "stdcnt.inc"
	- include "stdlun.inc"
	- include "mcfio.inc"
	-
	- integer ilbl,lok,istream
	- integer xdr_stdhep, xdr_stdhep_multi
	- external xdr_stdhep, xdr_stdhep_multi
	-
	- lok=0
	- if(NHEP.LE.0)then
	- write(lnhout,101) NEVHEP
	- elseif(ilbl.eq.1)then
	- call stdtcopy(1,istream,lok)
	- if(lok.ne.0) go to 700
	- if(mcfio_block(istream, MCFIO_STDHEP, xdr_stdhep)
	- 1 .eq. -1) go to 800
	- call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- nstdwrt = nstdwrt + 1
	- elseif(ilbl.eq.2)then
	- if(mcfio_block(istream, MCFIO_STDHEPM, xdr_stdhep_multi)
	- 1 .eq. -1) go to 800
	- call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- nstdwrt = nstdwrt + 1
	- endif
	- return
	- 700 write (lnhout,701) NEVHEP
	- lok = 4
	- stop
	- 800 write (lnhout,801) NEVHEP
	- lok=2
	- stop
	- 900 write (lnhout,901) NEVHEP
	- lok=1
	- stop
	- 101 format(/5X,'STDXWEVT: no particles to write in event',I8)
	- 701 format(/5X,'STDXWEVT: error copying stdhep block for event ',I8)
	- 801 format(/5X,'STDXWEVT: error filling stdhep block for event ',I8)
	- 901 format(/5X,'STDXWEVT: error writing event ',I8)
	- end
	Index: trunk/stdhep/stdhep.h
	===================================================================
	--- trunk/stdhep/stdhep.h (revision 8888)
	+++ trunk/stdhep/stdhep.h (revision 8889)
	@@ -1,49 +0,0 @@
	-/*
	-** Basic COMMON block from STDHEP: the HEPEVT COMMON block
	-** See product StDhep
	-*/
	-/* note that to avoid alignment problems, structures and common blocks
	- should be in the order: double precision, real, integer.
	-*/
	-#define NMXHEP 4000
	-#define NMXMLT 16
	-extern struct hepevt {
	-int nevhep; /* The event number */
	-int nhep; /* The number of entries in this event */
	-int isthep[NMXHEP]; /* The Particle id */
	-int idhep[NMXHEP]; /* The particle id */
	-int jmohep[NMXHEP][2]; /* The position of the mother particle */
	-int jdahep[NMXHEP][2]; /* Position of the first daughter... */
	-double phep[NMXHEP][5]; /* 4-Momentum, mass */
	-double vhep[NMXHEP][4]; /* Vertex information */
	-} hepevt_;
	-extern struct hepev2 {
	-int nmulti; /* number of interactions in the list */
	-int jmulti[NMXHEP]; /* multiple interaction number */
	-} hepev2_;
	-extern struct hepev3 {
	-int nevmulti[NMXMLT]; /* event number of original interaction */
	-int itrkmulti[NMXMLT]; /* first particle in the original interaction */
	-int mltstr[NMXMLT]; /* stream this event is from */
	-} hepev3_;
	-
	-/* prototypes */
	-#if defined(c_plusplus) \|\| defined(__cplusplus)
	-extern "C" {
	-#endif
	-
	-void hepnam_(int particleID, char name, int length_of_name);
	-int hepchg_(int *particleID);
	-float stdchg_(int *particleID);
	-void stdspin_(int index, int jspin);
	-void stdcquarks_(int index, int quark1, int quark2, int quark3,
	- int ang_mom, int jspin, int radial, int kqx);
	-void stdquarks_(int index, int quark1, int quark2, int quark3,
	- int ang_mom, int jspin, int radial, int kqx);
	-
	-#if defined(c_plusplus) \|\| defined(__cplusplus)
	-}
	-#endif
	-
	-void StdHepZero();
	-int StdHepTempCopy(int idir, int istr);
	Index: trunk/stdhep/stdhd.inc
	===================================================================
	--- trunk/stdhep/stdhd.inc (revision 8888)
	+++ trunk/stdhep/stdhd.inc (revision 8889)
	@@ -1,23 +0,0 @@
	-c -------------------------------------------------------------
	-c This header collects the mcfio initial information
	-c
	-c date - MCFIO_CREATIONDATE: creation date
	-c title - MCFIO_TITLE: title
	-c comment - MCFIO_COMMENT: comment
	-c dlen - actual lenght of date
	-c tlen - actual lenght of title
	-c clen - actual lenght of comment
	-c numblocks - MCFIO_NUMBLOCKS: number of blocks per event
	-c blkids - MCFIO_BLOCKIDS: list of block types
	-c
	-c use: write(*,1001) title(1:tlen),date(1:dlen),comment(1:clen)
	-c 1001 format(10x,'title: ',a60/10x,'date: ',a60/10x,a70)
	-c
	- character*255 date, title, comment
	- integer dlen, tlen, clen, numblocks, blkids
	- common /stdhd1/ date, title, comment
	- common /stdhd2/ dlen, tlen, clen, numblocks, blkids(50)
	- save /stdhd1/
	- save /stdhd2/
	-c
	-c -------------------------------------------------------------
	Index: trunk/stdhep/mcf_hepev4_xdr.c
	===================================================================
	--- trunk/stdhep/mcf_hepev4_xdr.c (revision 8888)
	+++ trunk/stdhep/mcf_hepev4_xdr.c (revision 8889)
	@@ -1,271 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_hepev4_xdr.c -- XDR Utility routines for the Block Stdhep filters *
	-* hepevt and hepev4 (and optionally hepev2 and hepev3) *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun, Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include <stdlib.h>
	-#include <time.h>
	-#include "mcfio_Dict.h"
	-#include "mcf_xdr.h"
	-#include "stdhep.h"
	-#include "hepev4.h"
	-#include "stdtmp.h"
	-#include "stdver.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-bool_t xdr_stdhep_4_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the HEPEVT temporary COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version. */
	-
	- unsigned int nn, nn2, nn3, nn4, nn5, nnw, nnw2, nnw3, nnw4, nnw5;
	- int *idat;
	- double *dat;
	- unsigned int n5 = 5; /* for scale */
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (*blockid != MCFIO_STDHEP4) {
	- fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	-
	- nn = (unsigned int) stdtmp_.nhept; /* Number of elements in isthep or idhep */
	- nn2 = 2(unsigned int) stdtmp_.nhept; / Number of elements in jmohep or jdahep */
	- nn3 = 3(unsigned int) stdtmp_.nhept; / Number of elements in spinlh */
	- nn4 = 4(unsigned int) stdtmp_.nhept; / Number of elements in vhep */
	- nn5 = 5(unsigned int) stdtmp_.nhept; / Number of elements in phep */
	- nnw = (unsigned int) stdtmp_.nhept;
	- nnw2 = 2 * nnw;
	- nnw3 = 3 * nnw;
	- nnw4 = 4 * nnw;
	- nnw5 = 5 * nnw;
	-
	- /* Total length in bytes include blockid, ntot, version, nevhept and nhept as well
	- as the arrays remembering doubles are longer than ints. */
	- ntot = 5sizeof(int) + sizeof(int)(2nn + 2*nn2)
	- + sizeof(double)*(nn4 + nn5)
	- + (8 + nn3)sizeof(double) + (1 + nn2)sizeof(int);
	-
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	- xdr_int(xdrs, &(stdtmp_.nevhept)) &&
	- xdr_int(xdrs, &(stdtmp_.nhept))) == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEP4) ) {
	- fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- idat = stdtmp_.isthept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int),
	- (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = stdtmp_.idhept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int),
	- (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) stdtmp_.jmohept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int),
	- (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) stdtmp_.jdahept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int),
	- (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) stdtmp_.phept;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw5, 5*NMXHEP, sizeof(double),
	- (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) stdtmp_.vhept;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- /* valid for stdhep 5.01 and later */
	- if ( xdr_double(xdrs, &(tmpev4_.eventweightt) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(tmpev4_.alphaqedt) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(tmpev4_.alphaqcdt) ) == FALSE) return FALSE;
	- dat = (double *) tmpev4_.scalet;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &n5, 10, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) tmpev4_.spint;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw3, 3*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- idat = (int *) tmpev4_.icolorflowt;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- if ( xdr_int(xdrs, &(tmpev4_.idrupt) ) == FALSE) return FALSE;
	- return TRUE;
	-}
	-
	-bool_t xdr_stdhep_4_multi_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the HEPEVT COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version.
	- Also translate the HEPEV2 COMMON block from the STDHEP package to/from
	- an XDR stream. HEPEV2 contains multiple interaction information */
	-
	- unsigned int nn, nn2, nn3, nn4, nn5, nnw, nnw2, nnw3, nnw4, nnw5;
	- unsigned int nmlt, nnmlt, nmltd, nnmlt5;
	- int i;
	- int *idat;
	- char *vers;
	- double *dat;
	- unsigned int n5 = 10; /* for scale */
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (*blockid != MCFIO_STDHEP4M) {
	- fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- nn = sizeof(int) * hepevt_.nhep;
	- nn2 = 2 * sizeof(int) * hepevt_.nhep;
	- nn3 = 3 * sizeof(double) * hepevt_.nhep;
	- nn4 = 4 * sizeof(double) * hepevt_.nhep;
	- nn5 = 10 * sizeof(double) * hepevt_.nhep;
	- nmlt = sizeof(int) * hepev2_.nmulti;
	- nmltd = sizeof(double) * hepev2_.nmulti;
	- nnw = (unsigned int) hepevt_.nhep;
	- nnw2 = 2 * nnw;
	- nnw3 = 3 * nnw;
	- nnw4 = 4 * nnw;
	- nnw5 = 5 * nnw;
	- nnmlt = (unsigned int) hepev2_.nmulti;
	- nnmlt5 = 5 * nnmlt;
	- ntot = 6 sizeof(int) + 3 * nn + 2 * nn2 + nn4 + nn5 + 3 * nmlt
	- + nn3 + 8 * sizeof(double) + nn2 + sizeof(int)
	- + 8 * nmltd + nmlt;
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	- xdr_int(xdrs, &(hepevt_.nevhep)) &&
	- xdr_int(xdrs, &(hepevt_.nhep))) == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEP4M) ) {
	- fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- idat = hepevt_.isthep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepevt_.idhep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) hepevt_.jmohep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) hepevt_.jdahep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) hepevt_.phep;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw5, 5*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepevt_.vhep;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- /*
	- ** V2.02 Upgrade : adding Multiple interactions.
	- */
	- if ( xdr_int(xdrs, &(hepev2_.nmulti)) == FALSE) return FALSE;
	- idat = hepev2_.jmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- /*
	- ** V4.04 Upgrade : adding more Multiple interaction information
	- */
	- idat = hepev3_.nevmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepev3_.itrkmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepev3_.mltstr;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- /* valid for stdhep 5.01 and later */
	- if ( xdr_double(xdrs, &(hepev4_.eventweightlh) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(hepev4_.alphaqedlh) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(hepev4_.alphaqcdlh) ) == FALSE) return FALSE;
	- dat = (double *) hepev4_.scalelh;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &n5, 10, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepev4_.spinlh;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw3, 3*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- idat = (int *) hepev4_.icolorflowlh;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- if ( xdr_int(xdrs, &(hepev4_.idruplh) ) == FALSE) return FALSE;
	- dat = (double *) hepev5_.eventweightmulti;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnmlt, NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepev5_.alphaqedmulti;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnmlt, NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepev5_.alphaqcdmulti;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnmlt, NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepev5_.scalemulti;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnmlt5, 10*NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- idat = hepev5_.idrupmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- return TRUE;
	-}
	-
	-
	Index: trunk/stdhep/mcf_stdcm1_xdr.c
	===================================================================
	--- trunk/stdhep/mcf_stdcm1_xdr.c (revision 8888)
	+++ trunk/stdhep/mcf_stdcm1_xdr.c (revision 8889)
	@@ -1,148 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_stdcm1_xdr.c -- XDR Utility routines for the Block stdcm1 filters *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun, Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include <stdlib.h>
	-#include <time.h>
	-#include "mcfio_Dict.h"
	-#include "mcf_xdr.h"
	-#include "stdcm1.h"
	-#include "stdver.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-struct stdcm1 stdcm1_;
	-struct stdcm2 stdcm2_;
	-
	-bool_t xdr_stdhep_cm1_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the STDCM1 COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version. */
	-
	- unsigned int nn, nn1, nn2;
	- int *idat;
	- double *dat;
	- char *vers;
	- char *cdat;
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (( blockid != MCFIO_STDHEPEND)&&( blockid != MCFIO_STDHEPBEG)) {
	- fprintf (stderr, "mcf_Stdhep_cm1_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- nn = sizeof(int) * stdcm1_.nevtreq;
	- nn1 = sizeof(float) * stdcm1_.nevtreq;
	- nn2 = sizeof(double) * stdcm1_.nevtreq;
	- ntot = 3 sizeof(int) + 3 * nn + 2 * nn1 + 2 * nn2
	- + 2 * sizeof(char) * ( MCF_XDR_STDCM2_LENGTH + 1 );
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) )
	- == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) &&
	- (( blockid != MCFIO_STDHEPEND)&&( blockid != MCFIO_STDHEPBEG))) {
	- fprintf (stderr, "mcf_Stdhep_cm1_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- if ( xdr_int(xdrs, &(stdcm1_.nevtreq) ) == FALSE) return FALSE;
	- if ( xdr_int(xdrs, &(stdcm1_.nevtgen) ) == FALSE) return FALSE;
	- if ( xdr_int(xdrs, &(stdcm1_.nevtwrt) ) == FALSE) return FALSE;
	- if ( xdr_float(xdrs, &(stdcm1_.stdecom) ) == FALSE) return FALSE;
	- if ( xdr_float(xdrs, &(stdcm1_.stdxsec) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(stdcm1_.stdseed1) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(stdcm1_.stdseed2) ) == FALSE) return FALSE;
	- /*
	- ** V5.01 Upgrade : adding stdcm2
	- */
	- vers = *version;
	- if (((strcmp(vers,"1.") == 0) \|\| (strcmp(vers,"2.") == 0) \|\|
	- (strcmp(vers,"3.") == 0) \|\| (strcmp(vers,"4.") == 0) \|\|
	- (strcmp(vers,"5.00") == 0) ) && (xdrs->x_op == XDR_DECODE)) {
	- strncpy(stdcm2_.generatorname, " ", MCF_XDR_STDCM2_LENGTH);
	- strncpy(stdcm2_.pdfname, " ", MCF_XDR_STDCM2_LENGTH);
	- return TRUE;
	- }
	-/*
	- allocate memory and deal with encoding and decoding separately
	-*/
	- cdat = malloc(MCF_XDR_STDCM2_LENGTH+1);
	- if( (xdrs->x_op == XDR_DECODE) ) {
	- strncpy(stdcm2_.generatorname, " ", MCF_XDR_STDCM2_LENGTH);
	- strncpy(stdcm2_.pdfname, " ", MCF_XDR_STDCM2_LENGTH);
	- cdat = NULL;
	- if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	- strncpy(stdcm2_.generatorname,cdat,MCF_XDR_STDCM2_LENGTH);
	- cdat = NULL;
	- if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	- strncpy(stdcm2_.pdfname,cdat,MCF_XDR_STDCM2_LENGTH);
	- } else {
	- strncpy(cdat, stdcm2_.generatorname, MCF_XDR_STDCM2_LENGTH);
	- /* some compilers do not properly append the null terminator */
	- cdat[MCF_XDR_STDCM2_LENGTH]='\0';
	- if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	- strncpy(cdat, stdcm2_.pdfname, MCF_XDR_STDCM2_LENGTH);
	- cdat[MCF_XDR_STDCM2_LENGTH]='\0';
	- if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	- }
	- free(cdat);
	-
	- /*
	- ** V5.02 Upgrade : add nevtlh to stdcm1
	- ** note that we cannot get here unless the version is 5.00 or greater
	- */
	- if (((strcmp(vers,"5.00") == 0) \|\| (strcmp(vers,"5.01") == 0))
	- && (xdrs->x_op == XDR_DECODE)) {
	- stdcm1_.nevtlh = 0;
	- return TRUE;
	- }
	- if ( xdr_int(xdrs, &(stdcm1_.nevtlh) ) == FALSE) return FALSE;
	-
	- return TRUE;
	-}
	-
	Index: trunk/stdhep/stdxwopen.f
	===================================================================
	--- trunk/stdhep/stdxwopen.f (revision 8888)
	+++ trunk/stdhep/stdxwopen.f (revision 8889)
	@@ -1,53 +0,0 @@
	- subroutine stdxwopen(filename,gtitle,ntries,istream,lok)
	-c
	-c initialize xdr tape writing
	-c WARNING: this routine cannot be used if you want to write anything
	-c besides stdhep records
	-c
	- implicit none
	- include "mcfio.inc"
	- include "stdlun.inc"
	- include "stdhd.inc"
	- integer istream,lok,ntries
	- character () filename
	- character () gtitle
	- character (10), target :: commnt = "No comment"
	- character (10), pointer :: comm => null()
	-
	- logical lfirst
	- data lfirst/.TRUE./
	- save lfirst
	-
	-C...print version number if this is the first call
	- if(lfirst)then
	- call stdversn
	- lfirst=.FALSE.
	- endif
	-c
	-c Initialization phase.
	-c
	- comm => commnt
	- lok = 0
	- title = gtitle
	- numblocks = 8
	- blkids(1) = MCFIO_STDHEP
	- blkids(2) = MCFIO_STDHEPM
	- blkids(3) = MCFIO_STDHEPBEG
	- blkids(4) = MCFIO_STDHEPEND
	- blkids(5) = MCFIO_STDHEP4
	- blkids(6) = MCFIO_STDHEP4M
	- blkids(7) = MCFIO_HEPEUP
	- blkids(8) = MCFIO_HEPRUP
	- istream = mcfio_OpenWriteDirect(filename, title, comm,
	- & ntries, blkids, numblocks)
	- if (istream .eq. -1) then
	- write(lnhout,1002)
	- lok = -1
	- stop
	- end if
	- write(lnhout,1001)
	-
	- return
	-1001 format(' STDXWOPEN WARNING: I/O is initialized for stdhep only')
	-1002 format(' STDXWOPEN: Cannot open output file, give up ')
	- end
	Index: trunk/stdhep/stdxwinit.f
	===================================================================
	--- trunk/stdhep/stdxwinit.f (revision 8888)
	+++ trunk/stdhep/stdxwinit.f (revision 8889)
	@@ -1,28 +0,0 @@
	- subroutine stdxwinit(filename,title,ntries,istream,lok)
	-c
	-c initialize xdr tape writing
	-c WARNING: this routine cannot be used if you want to write anything
	-c besides stdhep records
	-c
	- implicit none
	- include "mcfio.inc"
	- include "stdlun.inc"
	- integer istream,lok,ntries
	- character () filename
	- character () title
	-
	- logical lfirst
	- data lfirst/.TRUE./
	-
	-C...print version number if this is the first call
	- if(lfirst)then
	- call stdversn
	- lfirst=.FALSE.
	- endif
	-c
	-c Initialization phase.
	-c
	- call mcfio_init()
	- call stdxwopen(filename,title,ntries,istream,lok)
	- return
	- end
	Index: trunk/stdhep/hepev4.h
	===================================================================
	--- trunk/stdhep/hepev4.h (revision 8888)
	+++ trunk/stdhep/hepev4.h (revision 8889)
	@@ -1,21 +0,0 @@
	-/* Hepev4 holds Les Houches information */
	-/* note that to avoid alignment problems, structures and common blocks
	- should be in the order: double precision, real, integer.
	-*/
	-extern struct hepev4 {
	- double eventweightlh; /* event weight */
	- double alphaqedlh; /* QED coupling alpha_em */
	- double alphaqcdlh; /* QCD coupling alpha_s */
	- double scalelh[10]; /* Scale Q of the event */
	- double spinlh[NMXHEP][3]; /* spin information */
	- int icolorflowlh[NMXHEP][2]; /* (Anti-)Colour flow */
	- int idruplh; /* ID, as given by LPRUP codes */
	-} hepev4_;
	-
	-extern struct hepev5 {
	- double eventweightmulti[NMXMLT]; /* original event weight */
	- double alphaqedmulti[NMXMLT]; /* original QED coupling alpha_em */
	- double alphaqcdmulti[NMXMLT]; /* original QCD coupling alpha_s */
	- double scalemulti[NMXMLT][10]; /* original Scale Q of the event */
	- int idrupmulti[NMXMLT]; /* original ID, as given by LPRUP codes */
	-} hepev5_;
	Index: trunk/stdhep/stdcm1.h
	===================================================================
	--- trunk/stdhep/stdcm1.h (revision 8888)
	+++ trunk/stdhep/stdcm1.h (revision 8889)
	@@ -1,19 +0,0 @@
	-/*
	-** STDHEP begin/end run COMMON block
	-** See product StDhep
	-*/
	-extern struct stdcm1 {
	-float stdecom; /* STDECOM - center-of-mass energy */
	-float stdxsec; /* STDXSEC - cross-section */
	-double stdseed1; /* STDSEED1 - random number seed */
	-double stdseed2; /* STDSEED2 - random number seed */
	-int nevtreq; /* NEVTREQ - number of events to be generated */
	-int nevtgen; /* NEVTGEN - number of events actually generated */
	-int nevtwrt; /* NEVTWRT - number of events written to output file */
	-int nevtlh; /* NEVTLH - number of Les Houches events written to output file */
	-} stdcm1_;
	-
	-extern struct stdcm2 {
	-char generatorname[20]; /* name of Monte Carlo generator */
	-char pdfname[20]; /* name of PDF method used */
	-} stdcm2_;
	Index: trunk/stdhep/stdxwevtup.f
	===================================================================
	--- trunk/stdhep/stdxwevtup.f (revision 8888)
	+++ trunk/stdhep/stdxwevtup.f (revision 8889)
	@@ -1,54 +0,0 @@
	- subroutine stdxwevtup(ilbl,istream,lok)
	-
	-C...Purpose: to write an event from the standard common block.
	-C
	-C ilbl = 11 write HEPEUP common block
	-C ilbl = 12 write HEPRUP common block
	-C lok = 0 if no problems were encountered
	-
	- include "hepeup.inc"
	- include "heprup.inc"
	- include "stdcnt.inc"
	- include "stdlun.inc"
	- include "mcfio.inc"
	-
	- integer ilbl,lok,istream
	- integer xdr_hepeup, xdr_heprup
	- external xdr_hepeup, xdr_heprup
	-
	- lok=0
	-
	- if(ilbl.eq.11)then
	- if(nup.le.0)then
	- write(lnhout,101)
	-C... negative units seem to be a problem for nagfor
	-C write(lnhout,101) nup
	- else
	- if(mcfio_block(istream, MCFIO_HEPEUP, xdr_hepeup)
	- 1 .eq. -1) go to 700
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- nlhwrt = nlhwrt + 1
	- endif
	- elseif(ilbl.eq.12)then
	- if(mcfio_block(istream, MCFIO_HEPRUP, xdr_heprup)
	- 1 .eq. -1) go to 800
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- nlhwrt = nlhwrt + 1
	- endif
	-
	- return
	-
	- 700 write (lnhout,701)
	- lok=2
	- stop
	- 800 write (lnhout,801)
	- lok=2
	- stop
	- 900 write (lnhout,901)
	- lok=1
	- stop
	- 101 format(/5X,'stdxwevtup: no particles to write for HEPEUP block')
	- 701 format(/5X,'stdxwevtup: error filling Les Houches HEPEUP block ')
	- 801 format(/5X,'stdxwevtup: error filling Les Houches HEPRUP block ')
	- 901 format(/5X,'stdxwevtup: error writing Les Houches event ')
	- end
	Index: trunk/stdhep/stdhep_internal_utils.c
	===================================================================
	--- trunk/stdhep/stdhep_internal_utils.c (revision 8888)
	+++ trunk/stdhep/stdhep_internal_utils.c (revision 8889)
	@@ -1,208 +0,0 @@
	-/*******************************************************************************
	-* *
	-* stdhep_internal_utils.c -- C version of stdhep internal utility routines *
	-* *
	-* Copyright (c) 1995 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <stdlib.h>
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-/*
	-* StdHep definitions and include files
	-*/
	-#include "stdhep.h"
	-#include "hepev4.h"
	-#include "stdtmp.h"
	-#include "hepeup.h"
	-
	-struct stdtmp stdtmp_;
	-struct tmpev4 tmpev4_;
	-
	-/* Purpose: copy an event to/from the standard common block */
	-int StdHepTempCopy(int idir, int istr)
	-{
	- int nh, i, k;
	- if (idir == 1) { /* copy from hepevt to stdtmp */
	- stdtmp_.nevhept = hepevt_.nevhep;
	- stdtmp_.nhept = hepevt_.nhep;
	- tmpev4_.eventweightt = hepev4_.eventweightlh;
	- tmpev4_.alphaqedt = hepev4_.alphaqedlh;
	- tmpev4_.alphaqcdt = hepev4_.alphaqcdlh;
	- for (i = 0; i < 10; i++) {
	- tmpev4_.scalet[i] = hepev4_.scalelh[i];
	- }
	- tmpev4_.idrupt = hepev4_.idruplh;
	- for (i = 0; i < hepevt_.nhep; i++) {
	- stdtmp_.isthept[i] = hepevt_.isthep[i];
	- stdtmp_.idhept[i] = hepevt_.idhep[i];
	- for (k = 0; k < 2; k++) {
	- stdtmp_.jmohept[i][k] = hepevt_.jmohep[i][k];
	- stdtmp_.jdahept[i][k] = hepevt_.jdahep[i][k];
	- tmpev4_.icolorflowt[i][k] = hepev4_.icolorflowlh[i][k];
	- }
	- for (k = 0; k < 5; k++)
	- stdtmp_.phept[i][k] = hepevt_.phep[i][k];
	- for (k = 0; k < 4; k++)
	- stdtmp_.vhept[i][k] = hepevt_.vhep[i][k];
	- for (k = 0; k < 3; k++)
	- tmpev4_.spint[i][k] = hepev4_.spinlh[i][k];
	- }
	- } else if (idir == 2) { /* copy from stdtmp to hepevt */
	- if (hepevt_.nhep + stdtmp_.nhept > NMXHEP) {
	- fprintf(stderr,
	- " StdHepTempCopy: event would overflow HEPEVT array size\n");
	- fprintf(stderr," StdHepTempCopy: event %d has been lost\n",
	- stdtmp_.nevhept);
	- return 5;
	- }
	- hepevt_.nevhep = stdtmp_.nevhept;
	- nh = hepevt_.nhep;
	- hepev4_.eventweightlh = tmpev4_.eventweightt;
	- hepev4_.alphaqedlh = tmpev4_.alphaqedt;
	- hepev4_.alphaqcdlh = tmpev4_.alphaqcdt;
	- for (i = 0; i < 10; i++) {
	- hepev4_.scalelh[i] = tmpev4_.scalet[i];
	- }
	- hepev4_.idruplh = tmpev4_.idrupt;
	- for (i = 0; i < stdtmp_.nhept; i++) {
	- hepevt_.isthep[nh+i] = stdtmp_.isthept[i];
	- hepevt_.idhep[nh+i] = stdtmp_.idhept[i];
	- for (k = 0; k < 2; k++) {
	- hepevt_.jmohep[nh+i][k] = stdtmp_.jmohept[i][k];
	- hepevt_.jdahep[nh+i][k] = stdtmp_.jdahept[i][k];
	- hepev4_.icolorflowlh[nh+i][k] = tmpev4_.icolorflowt[i][k];
	- }
	- for (k = 0; k < 5; k++)
	- hepevt_.phep[nh+i][k] = stdtmp_.phept[i][k];
	- for (k = 0; k < 4; k++)
	- hepevt_.vhep[nh+i][k] = stdtmp_.vhept[i][k];
	- for (k = 0; k < 3; k++)
	- hepev4_.spinlh[nh+i][k] = tmpev4_.spint[i][k];
	- }
	- hepev2_.nmulti += 1;
	- if (hepev2_.nmulti <= NMXMLT ) {
	- hepev3_.nevmulti[hepev2_.nmulti] = stdtmp_.nevhept;
	- hepev3_.itrkmulti[hepev2_.nmulti] = stdtmp_.nhept + 1;
	- hepev3_.mltstr[hepev2_.nmulti] = istr;
	- hepev5_.eventweightmulti[i] = tmpev4_.eventweightt;
	- hepev5_.alphaqedmulti[i] = tmpev4_.alphaqedt;
	- hepev5_.alphaqcdmulti[i] = tmpev4_.alphaqcdt;
	- for( k = 0; k < 10; ++k) {
	- hepev5_.scalemulti[i][k] = tmpev4_.scalet[k];
	- }
	- hepev5_.idrupmulti[i] = tmpev4_.idrupt;
	- } else {
	- fprintf(stderr," StdHepTempCopy: %d multiple interactions in this event\n",
	- hepev2_.nmulti );
	- fprintf(stderr," StdHepTempCopy: only %d multiple interactions are allowed\n",
	- NMXMLT );
	- }
	- for (i = 0; i < stdtmp_.nhept; i++) {
	- hepev2_.jmulti[nh+i] = hepev2_.nmulti;
	- for (k = 0; k < 2; k++) {
	- if (hepevt_.jmohep[nh+i][k] != 0) {
	- hepevt_.jmohep[nh+i][k] += hepevt_.nhep;
	- }
	- if (hepevt_.jdahep[nh+i][k] != 0) {
	- hepevt_.jdahep[nh+i][k] += hepevt_.nhep;
	- }
	- if (hepev4_.icolorflowlh[nh+i][k] != 0) {
	- hepev4_.icolorflowlh[nh+i][k] += hepevt_.nhep;
	- }
	- }
	- }
	- hepevt_.nhep += stdtmp_.nhept;
	- } else {
	- fprintf(stderr," StdHepTempCopy: improper calling flag\n");
	- }
	- return 0;
	-}
	-
	-void StdHepZero(void)
	-{
	- int i, k;
	- hepevt_.nhep = 0;
	- hepev2_.nmulti = 0;
	- for (i = 0; i < NMXHEP; i++) {
	- hepevt_.isthep[i] = 0;
	- hepevt_.idhep[i] = 0;
	- hepev2_.jmulti[i] = 0;
	- for (k = 0; k < 2; k++) {
	- hepevt_.jmohep[i][k] = 0;
	- hepevt_.jdahep[i][k] = 0;
	- hepev4_.icolorflowlh[i][k] = 0;
	- }
	- for (k = 0; k < 5; k++)
	- hepevt_.phep[i][k] = 0.;
	- for (k = 0; k < 4; k++)
	- hepevt_.vhep[i][k] = 0.;
	- for (k = 0; k < 3; k++)
	- hepev4_.spinlh[i][k] = 0.;
	- }
	- for (i = 0; i < NMXMLT; i++) {
	- hepev3_.nevmulti[i] = 0;
	- hepev3_.itrkmulti[i] = 0;
	- hepev3_.mltstr[i] = 0;
	- hepev5_.eventweightmulti[i] = 0.;
	- hepev5_.alphaqedmulti[i] = 0.;
	- hepev5_.alphaqcdmulti[i] = 0.;
	- for( k = 0; k < 10; ++k) {
	- hepev5_.scalemulti[i][k] = 0.;
	- }
	- hepev5_.idrupmulti[i] = 0;
	- }
	- hepev4_.eventweightlh = 0.;
	- hepev4_.alphaqedlh = 0.;
	- hepev4_.alphaqcdlh = 0.;
	- for (i = 0; i < 10; i++) {
	- hepev4_.scalelh[i] = 0.;
	- }
	- hepev4_.idruplh = 0;
	-}
	-
	-void StdHepZeroHEPEUP(void)
	-{
	- int i, k;
	- hepeup_.nup;
	- hepeup_.idprup;
	- hepeup_.xwgtup;
	- hepeup_.scalup;
	- hepeup_.aqedup;
	- hepeup_.aqcdup;
	- for (i = 0; i < MAXNUP; ++i) {
	- hepeup_.idup[i];
	- hepeup_.istup[i];
	- for (k = 0; k < 2; ++k) {
	- hepeup_.mothup[i][k];
	- hepeup_.icolup[i][k];
	- }
	- for (k = 0; k < 5; ++k) {
	- hepeup_.pup[i][k];
	- }
	- hepeup_.vtimup[i];
	- hepeup_.spinup[i];
	- }
	-}
	Index: trunk/stdhep/stdhep_mcfio.c
	===================================================================
	--- trunk/stdhep/stdhep_mcfio.c (revision 8888)
	+++ trunk/stdhep/stdhep_mcfio.c (revision 8889)
	@@ -1,540 +0,0 @@
	-/*******************************************************************************
	-* *
	-* stdhep_mcfio.c -- C version of mcfio interface routines *
	-* *
	-* Copyright (c) 1995 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <stdlib.h>
	-#include <rpc/types.h>
	-#include <rpc/xdr.h>
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-/*
	-* mcfio/StdHep definitions and include files
	-*/
	-#include "mcf_xdr.h"
	-#include "mcfio_Dict.h"
	-#include "mcfio_Direct.h"
	-#include "mcfio_Util1.h"
	-#include "mcfio_Block.h"
	-#include "stdhep.h"
	-#include "hepev4.h"
	-#include "hepeup.h"
	-#include "heprup.h"
	-#include "stdhd.h"
	-#include "stdcnt.h"
	-#include "stdlun.h"
	-#include "stdhep_mcfio.h"
	-
	-struct hepevt hepevt_;
	-struct hepev2 hepev2_;
	-struct hepev3 hepev3_;
	-struct hepev4 hepev4_;
	-struct hepev5 hepev5_;
	-struct hepeup hepeup_;
	-struct heprup heprup_;
	-struct stdcnt stdcnt_;
	-struct heplun heplun_;
	-struct stdstr stdstr_;
	-struct stdhd1 stdhd1_;
	-struct stdhd2 stdhd2_;
	-
	-extern int xdr_stdhep_();
	-extern int xdr_stdhep_multi_();
	-extern int xdr_stdhep_4_();
	-extern int xdr_stdhep_4_multi_();
	-extern int xdr_stdhep_cm1_();
	-extern int xdr_hepeup_();
	-extern int xdr_heprup_();
	-
	-int StdHepXdrReadInit(char *filename, int ntries, int ist)
	-{
	- int ierr;
	-
	- mcfioC_Init();
	- ierr = StdHepXdrReadOpen(filename, ntries, ist);
	- return ierr;
	-}
	-int StdHepXdrReadOpen(char *filename, int ntries, int ist)
	-{
	- int istream, iblk;
	- int numblocks, blkids[50];
	-
	- istream = mcfioC_OpenReadDirect(filename);
	- stdstr_.ixdrstr[ist] = istream;
	- if (istream == -1) {
	- fprintf(stderr," StdHepXdrReadOpen: cannot open output file \n");
	- return -1;
	- }
	- mcfioC_InfoStreamChar(istream, MCFIO_CREATIONDATE, stdhd1_.date, &stdhd2_.dlen);
	- mcfioC_InfoStreamChar(istream, MCFIO_TITLE, stdhd1_.title, &stdhd2_.tlen);
	- mcfioC_InfoStreamChar(istream, MCFIO_COMMENT, stdhd1_.comment, &stdhd2_.clen);
	- mcfioC_InfoStreamInt(istream, MCFIO_NUMEVTS, &ntries);
	- mcfioC_InfoStreamInt(istream, MCFIO_NUMBLOCKS, &numblocks);
	- mcfioC_InfoStreamInt(istream, MCFIO_BLOCKIDS, blkids);
	-
	- stdhd2_.numblocks = numblocks;
	- for ( iblk=0; iblk < numblocks; ++iblk ) {
	- stdhd2_.blkids[iblk] = blkids[iblk];
	- }
	-
	- stdcnt_.nstdrd = 0;
	- stdcnt_.nlhrd = 0;
	- fprintf(stdout,
	- " StdHepXdrReadOpen: successfully opened input stream %d\n",istream);
	- fprintf(stdout," title: %s\n",stdhd1_.title);
	- fprintf(stdout," date: %s\n",stdhd1_.date);
	- fprintf(stdout," %d events\n",ntries);
	- fprintf(stdout," %d blocks per event\n",stdhd2_.numblocks);
	- return 0;
	-}
	-int StdHepXdrRead(int *ilbl, int ist)
	-{
	-/* Purpose: to read a buffer or an event from the standard common block.
	-C
	-C returns ilbl
	-C
	-C ilbl = 1 - standard HEPEVT common block
	-C ilbl = 2 - standard HEPEVT common block and HEPEV2
	-C ilbl = 3 - stdevent struct
	-C ilbl = 4 - standard HEPEVT common block with Les Houches
	-C ilbl = 5 - standard HEPEVT common block with Les Houches
	-C and multiple collisions
	-C ilbl = 11 - HEPEUP common block
	-C ilbl = 12 - HEPRUP common block
	-C ilbl = 100 - STDHEP begin run record
	-C ilbl = 200 - STDHEP end run record
	-C */
	-
	- int istat;
	- int i, numblocks, blkids[50];
	-
	- int istream = stdstr_.ixdrstr[ist];
	- if(mcfioC_NextEvent(istream) != MCFIO_RUNNING) {
	- mcfioC_InfoStreamInt(istream, MCFIO_STATUS, &istat);
	- if(istat == MCFIO_EOF) {
	- fprintf(stderr," StdHepXdrRead: end of file found\n");
	- return 1;
	- }
	- else {
	- fprintf(stderr," StdHepXdrRead: unrecognized status - stop\n");
	- return 2;
	- }
	- }
	- mcfioC_InfoStreamInt(istream, MCFIO_NUMBLOCKS, &numblocks);
	- mcfioC_InfoStreamInt(istream, MCFIO_BLOCKIDS, blkids);
	-
	- for (i = 0; i < numblocks; i++) {
	- if (blkids[i] == MCFIO_STDHEP) {
	- StdHepZero();
	- if (mcfioC_Block(istream,MCFIO_STDHEP,xdr_stdhep_) != -1) {
	- *ilbl = 1;
	- if (StdHepTempCopy(2,istream) == 0)
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_STDHEPM) {
	- StdHepZero();
	- if (mcfioC_Block(istream,MCFIO_STDHEPM,xdr_stdhep_multi_) != -1) {
	- *ilbl = 2;
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_STDHEP4) {
	- StdHepZero();
	- if (mcfioC_Block(istream,MCFIO_STDHEP4,xdr_stdhep_4_) != -1) {
	- *ilbl = 4;
	- if (StdHepTempCopy(2,istream) == 0)
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_STDHEP4M) {
	- StdHepZero();
	- if (mcfioC_Block(istream,MCFIO_STDHEP4M,xdr_stdhep_4_multi_) != -1) {
	- *ilbl = 5;
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_STDHEPBEG) {
	- if (mcfioC_Block(istream,MCFIO_STDHEPBEG,xdr_stdhep_cm1_) != -1) {
	- *ilbl = 100;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_STDHEPEND) {
	- if (mcfioC_Block(istream,MCFIO_STDHEPEND,xdr_stdhep_cm1_) != -1) {
	- *ilbl = 200;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_HEPEUP) {
	- if (mcfioC_Block(istream,MCFIO_HEPEUP,xdr_hepeup_) != -1) {
	- *ilbl = 11;
	- stdcnt_.nlhrd = stdcnt_.nlhrd + 1;
	- return 0;
	- }
	- }
	- else if (blkids[i] == MCFIO_HEPRUP) {
	- if (mcfioC_Block(istream,MCFIO_HEPRUP,xdr_heprup_) != -1) {
	- *ilbl = 12;
	- stdcnt_.nlhrd = stdcnt_.nlhrd + 1;
	- return 0;
	- }
	- }
	- }
	- return 1;
	-}
	-int StdHepXdrReadMulti(int *ilbl, int ist)
	-{
	-/* Purpose: to read a buffer or an event from the standard common block
	- this routine handles multiple input streams
	-C
	-C return ilbl
	-C
	-C ilbl = 1 - standard HEPEVT common block
	-C ilbl = 2 - standard HEPEVT common block and HEPEV2
	-C ilbl = 100 - STDHEP begin run record
	-C ilbl = 200 - STDHEP end run record
	-C */
	-
	- int istat;
	- int i, numblocks, blkids[50];
	-
	- int istream = stdstr_.ixdrstr[ist];
	- if(mcfioC_NextEvent(istream) != MCFIO_RUNNING) {
	- mcfioC_InfoStreamInt(istream, MCFIO_STATUS, &istat);
	- if(istat == MCFIO_EOF) {
	- fprintf(stderr," StdHepXdrReadMulti: end of file found\n");
	- return 1;
	- }
	- else {
	- fprintf(stderr,
	- " StdHepXdrReadMulti: unrecognized status - stop\n");
	- return 2;
	- }
	- }
	- mcfioC_InfoStreamInt(istream, MCFIO_NUMBLOCKS, &numblocks);
	- mcfioC_InfoStreamInt(istream, MCFIO_BLOCKIDS, blkids);
	- for (i = 0; i < numblocks; i++) {
	- if (blkids[i] == MCFIO_STDHEP) {
	- if (mcfioC_Block(istream,MCFIO_STDHEP,xdr_stdhep_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrReadMulti: unable to read xdr block\n");
	- return 1;
	- }
	- *ilbl = 1;
	- if (StdHepTempCopy(2,istream) == 0)
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- }
	- else if (blkids[i] == MCFIO_STDHEPM) {
	- fprintf(stderr,
	- " StdHepXdrRead: multiple interaction event - HEPEVT is zeroed\n");
	- StdHepZero();
	- if (mcfioC_Block(istream,MCFIO_STDHEPM,xdr_stdhep_multi_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrReadMulti: unable to read xdr block\n");
	- return 1;
	- }
	- *ilbl = 2;
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- }
	- else if (blkids[i] == MCFIO_STDHEP4) {
	- if (mcfioC_Block(istream,MCFIO_STDHEP4,xdr_stdhep_4_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrReadMulti: unable to read xdr block\n");
	- return 1;
	- }
	- *ilbl = 4;
	- if (StdHepTempCopy(2,istream) == 0)
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- }
	- else if (blkids[i] == MCFIO_STDHEP4M) {
	- fprintf(stderr,
	- " StdHepXdrRead: multiple interaction event - HEPEVT is zeroed\n");
	- StdHepZero();
	- if (mcfioC_Block(istream,MCFIO_STDHEP4M,xdr_stdhep_4_multi_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrReadMulti: unable to read xdr block\n");
	- return 1;
	- }
	- *ilbl = 5;
	- stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	- }
	- }
	- return 0;
	-}
	-int StdHepXdrWriteInit(char filename, char title, int ntries, int ist)
	-{
	- int ierr;
	-
	- mcfioC_Init();
	- ierr = StdHepXdrWriteOpen(filename, title, ntries, ist);
	- return ierr;
	-}
	-int StdHepXdrWriteOpen(char filename, char title, int ntries, int ist)
	-{
	- int istream, iblk;
	- int numblocks = 8;
	- int blkids[50];
	- char *comment = '\0';
	-
	- blkids[0] = MCFIO_STDHEP;
	- blkids[1] = MCFIO_STDHEPM;
	- blkids[2] = MCFIO_STDHEPBEG;
	- blkids[3] = MCFIO_STDHEPEND;
	- blkids[4] = MCFIO_STDHEP4;
	- blkids[5] = MCFIO_STDHEP4M;
	- blkids[6] = MCFIO_HEPEUP;
	- blkids[7] = MCFIO_HEPRUP;
	-
	- strncpy(stdhd1_.title,title,255);
	- stdhd2_.numblocks = numblocks;
	- for ( iblk=0; iblk < numblocks; ++iblk ) {
	- stdhd2_.blkids[iblk] = blkids[iblk];
	- }
	-
	- istream = mcfioC_OpenWriteDirect(filename, title, comment,
	- ntries, blkids, numblocks);
	- stdstr_.ixdrstr[ist] = istream;
	- if (istream == -1) {
	- fprintf(stderr," StdHepXdrWriteOpen: cannot open output file \n");
	- return -1;
	- }
	- fprintf(stdout," StdHepXdrWriteOpen: I/O initialized for StdHep only\n");
	- return 0;
	-}
	-int StdHepXdrWrite(int ilbl, int ist)
	-{
	- int iret = 0;
	-
	- if ((ilbl == 1) \|\| (ilbl == 2))
	- iret = StdHepXdrWriteEvent(ilbl, ist);
	- else if ((ilbl == 4) \|\| (ilbl == 5))
	- iret = StdHepXdrWriteEventLH(ilbl, ist);
	- else if (ilbl == 11)
	- iret = StdHepXdrWriteEventEUP(ilbl, ist);
	- else if (ilbl == 12)
	- iret = StdHepXdrWriteEventRUP(ilbl, ist);
	- else if ((ilbl == 100) \|\| (ilbl == 200))
	- iret = StdHepXdrWriteCM(ilbl, ist);
	- else
	- fprintf(stderr,
	- " StdHepXdrWrite: don't know what to do with record type %d\n", ilbl);
	- return iret;
	-}
	-int StdHepXdrWriteCM(int ilbl, int ist)
	-{
	- int istream = stdstr_.ixdrstr[ist];
	- if (ilbl == 100) {
	- if (mcfioC_Block(istream, MCFIO_STDHEPBEG, xdr_stdhep_cm1_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteCM: error filling stdhep cm1 common block\n");
	- return 2;
	- }
	- }
	- else if (ilbl == 200) {
	- if (mcfioC_Block(istream, MCFIO_STDHEPEND, xdr_stdhep_cm1_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteCM: error filling stdhep cm1 common block\n");
	- return 2;
	- }
	- }
	- else {
	- fprintf(stderr,
	- " StdHepXdrWriteCM: called with improper label %d\n",ilbl);
	- return 3;
	- }
	- if (mcfioC_NextEvent(istream) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteCM: error writing stdhep cm1 xdr block\n");
	- return 1;
	- }
	- return 0;
	-}
	-int StdHepXdrWriteEvent(int ilbl, int ist)
	-{
	- int istream = stdstr_.ixdrstr[ist];
	- if ((ilbl != 1) && (ilbl != 2)) {
	- fprintf(stderr,
	- " StdHepXdrWriteEvent: called with illegal label %d\n",
	- ilbl);
	- return 3;
	- }
	- else if (hepevt_.nhep <= 0) {
	- fprintf(stderr,
	- " StdHepXdrWriteEvent: event %d is empty\n", hepevt_.nevhep);
	- return 0;
	- }
	- else if (ilbl == 1) {
	- if (StdHepTempCopy(1,istream) != 0) {
	- fprintf(stderr,
	- " StdHepXdrWriteEvent: copy failed - event not written\n");
	- return 4;
	- }
	- if (mcfioC_Block(istream, MCFIO_STDHEP, xdr_stdhep_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteEvent: error filling stdhep block for event %d\n",
	- hepevt_.nevhep);
	- return 2;
	- }
	- mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	- }
	- else if (ilbl == 2) {
	- if (mcfioC_Block(istream, MCFIO_STDHEPM, xdr_stdhep_multi_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteEvent: error filling stdhep block for event %d\n",
	- hepevt_.nevhep);
	- return 2;
	- }
	- mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	- }
	- if (mcfioC_NextEvent(istream) == -1) {
	- fprintf(stderr," StdHepXdrWriteCM: error writing event %d\n",
	- hepevt_.nevhep);
	- return 1;
	- }
	- stdcnt_.nstdwrt = stdcnt_.nstdwrt + 1;
	- return 0;
	-}
	-int StdHepXdrWriteEventLH(int ilbl, int ist)
	-{
	- int istream = stdstr_.ixdrstr[ist];
	- if ((ilbl != 4) && (ilbl != 5)) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventLH: called with illegal label %d\n",
	- ilbl);
	- return 3;
	- }
	- else if (hepevt_.nhep <= 0) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventLH: event %d is empty\n", hepevt_.nevhep);
	- return 0;
	- }
	- else if (ilbl == 4) {
	- if (StdHepTempCopy(1,istream) != 0) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventLH: copy failed - event not written\n");
	- return 4;
	- }
	- if (mcfioC_Block(istream, MCFIO_STDHEP4, xdr_stdhep_4_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventLH: error filling stdhep block for event %d\n",
	- hepevt_.nevhep);
	- return 2;
	- }
	- mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	- }
	- else if (ilbl == 5) {
	- if (mcfioC_Block(istream, MCFIO_STDHEP4M, xdr_stdhep_4_multi_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventLH: error filling stdhep block for event %d\n",
	- hepevt_.nevhep);
	- return 2;
	- }
	- mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	- }
	- if (mcfioC_NextEvent(istream) == -1) {
	- fprintf(stderr," StdHepXdrWriteLH: error writing event %d\n",
	- hepevt_.nevhep);
	- return 1;
	- }
	- stdcnt_.nstdwrt = stdcnt_.nstdwrt + 1;
	- return 0;
	-}
	-int StdHepXdrWriteEventEUP(int ilbl, int ist)
	-{
	- int istream = stdstr_.ixdrstr[ist];
	- if ( ilbl != 11 ) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventEUP: called with illegal label %d\n",
	- ilbl);
	- return 3;
	- }
	- else if (hepeup_.nup <= 0) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventEUP: event is empty\n");
	- return 0;
	- }
	- else if (ilbl == 11) {
	- if (mcfioC_Block(istream, MCFIO_HEPEUP, xdr_hepeup_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventEUP: error filling stdhep block for event\n");
	- return 2;
	- }
	- }
	- if (mcfioC_NextEvent(istream) == -1) {
	- fprintf(stderr," StdHepXdrWriteEUP: error writing event\n");
	- return 1;
	- }
	- stdcnt_.nlhwrt = stdcnt_.nlhwrt + 1;
	- return 0;
	-}
	-int StdHepXdrWriteEventRUP(int ilbl, int ist)
	-{
	- int istream = stdstr_.ixdrstr[ist];
	- if ( ilbl != 12 ) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventRUP: called with illegal label %d\n",
	- ilbl);
	- return 3;
	- }
	- else if (ilbl == 12) {
	- if (mcfioC_Block(istream, MCFIO_HEPRUP, xdr_heprup_) == -1) {
	- fprintf(stderr,
	- " StdHepXdrWriteEventRUP: error filling stdhep block for event\n");
	- return 2;
	- }
	- }
	- if (mcfioC_NextEvent(istream) == -1) {
	- fprintf(stderr," StdHepXdrWriteRUP: error writing event\n");
	- return 1;
	- }
	- stdcnt_.nlhwrt = stdcnt_.nlhwrt + 1;
	- return 0;
	-}
	-void StdHepXdrEnd(int ist)
	-{
	- int inum, ieff;
	-
	- int istream = stdstr_.ixdrstr[ist];
	- mcfioC_InfoStreamInt(istream, MCFIO_NUMWORDS, &inum);
	- mcfioC_InfoStreamInt(istream, MCFIO_EFFICIENCY, &ieff);
	- mcfioC_Close(istream);
	- fprintf(stdout,
	- " StdHepXdrEnd: %d words i/o with %d efficiency\n",inum,ieff);
	-}
	-void StdHepPrintHeader( )
	-{
	- fprintf(stdout," StdHep MCFio header information:\n");
	- fprintf(stdout," title: %s\n",stdhd1_.title);
	- fprintf(stdout," date: %s\n",stdhd1_.date);
	- fprintf(stdout," %s\n",stdhd1_.comment);
	- fprintf(stdout," %d blocks per event\n",stdhd2_.numblocks);
	-}
	Index: trunk/stdhep/stdhep_mcfio.h
	===================================================================
	--- trunk/stdhep/stdhep_mcfio.h (revision 8888)
	+++ trunk/stdhep/stdhep_mcfio.h (revision 8889)
	@@ -1,53 +0,0 @@
	-#ifndef STDHEP_MCFIO_H
	-#define STDHEP_MCFIO_H
	-
	-/*******************************************************************************
	-* *
	-* stdhep_mcfio.h -- header for C version of mcfio interface routines *
	-* *
	-* Copyright (c) 1995 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-
	-/* prototypes */
	-#if defined(c_plusplus) \|\| defined(__cplusplus)
	-extern "C" {
	-#endif
	-
	-
	-int StdHepXdrReadInit(char *filename, int ntries, int ist);
	-int StdHepXdrReadOpen(char *filename, int ntries, int ist);
	-int StdHepXdrRead(int *ilbl, int ist);
	-int StdHepXdrReadMulti(int *ilbl, int ist);
	-int StdHepXdrWriteInit(char filename, char title, int ntries, int ist);
	-int StdHepXdrWriteOpen(char filename, char title, int ntries, int ist);
	-int StdHepXdrWrite(int ilbl, int ist);
	-int StdHepXdrWriteCM(int ilbl, int ist);
	-int StdHepXdrWriteEvent(int ilbl, int ist);
	-int StdHepXdrWriteEventLH(int ilbl, int ist);
	-int StdHepXdrWriteEventEUP(int ilbl, int ist);
	-int StdHepXdrWriteEventRUP(int ilbl, int ist);
	-void StdHepXdrEnd(int ist);
	-void StdHepPrintHeader( );
	-
	-#if defined(c_plusplus) \|\| defined(__cplusplus)
	-}
	-#endif
	-
	-#endif /* STDHEP_MCFIO_H */
	Index: trunk/stdhep/stdversn.f
	===================================================================
	--- trunk/stdhep/stdversn.f (revision 8888)
	+++ trunk/stdhep/stdversn.f (revision 8889)
	@@ -1,22 +0,0 @@
	- subroutine stdversn
	-C
	-C...print STDHEP version number
	-C
	- include "stdver.inc"
	- include "stdlun.inc"
	- logical lfirst
	- data lfirst/.TRUE./
	- save lfirst
	-
	- if(lfirst)then
	- lfirst = .FALSE.
	- stdhep_ver = '5.06.01'
	- stdhep_date = 'November 20, 2007'
	- write(lnhout,1001) stdhep_ver,stdhep_date
	- endif
	-1001 format(//
	- 1 10X,'********************************************************'/
	- 2 10X,'* STDHEP version ',a7,' - ',a20,' *'/
	- 3 10X,'********************************************************'//)
	- return
	- end
	Index: trunk/stdhep/stdxend.f
	===================================================================
	--- trunk/stdhep/stdxend.f (revision 8888)
	+++ trunk/stdhep/stdxend.f (revision 8889)
	@@ -1,16 +0,0 @@
	- subroutine stdxend(istream)
	-c
	-c end xdr tape writing
	-c
	- implicit none
	- include "mcfio.inc"
	- include "stdlun.inc"
	- integer istream,ieff,inum
	-c
	- call mcfio_InfoStreamInt(istream, MCFIO_NUMWORDS, inum)
	- call mcfio_InfoStreamInt(istream, MCFIO_EFFICIENCY, ieff)
	- call mcfio_close(istream)
	- write(lnhout,1001) inum,ieff
	- return
	-1001 format(/10x,'STDXEND: ',i10,' words i/o with ',i8,' efficiency ')
	- end
	Index: trunk/stdhep/stdver.h
	===================================================================
	--- trunk/stdhep/stdver.h (revision 8888)
	+++ trunk/stdhep/stdver.h (revision 8889)
	@@ -1,5 +0,0 @@
	-/* stdhep version common block */
	-extern struct stdver {
	-char stdhep_ver[10]; /* stdhep version numver */
	-char stdhep_date[20]; /* date of this stdhep version */
	-} stdver_;
	Index: trunk/stdhep/stdxwcm1.f
	===================================================================
	--- trunk/stdhep/stdxwcm1.f (revision 8888)
	+++ trunk/stdhep/stdxwcm1.f (revision 8889)
	@@ -1,46 +0,0 @@
	- subroutine stdxwcm1(ilbl,istream,lok)
	-
	-C...Purpose: to write begin/end run information in a standard format
	-C
	-C if ilbl = 100 write STDHEP begin run record
	-C if ilbl = 200 write STDHEP end run record
	-C
	-C lok = 0 if no problems were encountered
	-
	- include "stdcm1.inc"
	- include "stdcnt.inc"
	- include "stdlun.inc"
	- include "mcfio.inc"
	-
	- integer ilbl,lok
	- integer xdr_stdhep_cm1
	- external xdr_stdhep_cm1
	-
	- lok=0
	- if(nevtlh.eq.0) nevtlh = nlhwrt
	- if(ilbl.eq.100)then
	- if(mcfio_block(istream, MCFIO_STDHEPBEG, xdr_stdhep_cm1)
	- 1 .eq. -1) go to 800
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- elseif(ilbl.eq.200)then
	- if(mcfio_block(istream, MCFIO_STDHEPEND, xdr_stdhep_cm1)
	- 1 .eq. -1) go to 800
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- else
	- lok = 3
	- write (lnhout,701) ilbl
	- endif
	-
	- return
	- 800 write (lnhout,801) ilbl
	- lok=2
	- stop
	- 900 write (lnhout,901)
	- lok=1
	- stop
	- 701 format(/5X,'STDXWCM1: called with improper label ',i4)
	- 801 format(/5X,'STDXWCM1: error filling stdhep cm1 block for label '
	- 1 ,i4)
	- 901 format(/5X,'STDXWCM1: error writing stdhep cm1 block ')
	- end
	-
	Index: trunk/stdhep/stdlun.h
	===================================================================
	--- trunk/stdhep/stdlun.h (revision 8888)
	+++ trunk/stdhep/stdlun.h (revision 8889)
	@@ -1,16 +0,0 @@
	-/* StdHep I/O unit and stream information */
	-
	-#define LUN_ARRAY 16 /* I/O array size */
	-extern struct heplun {
	- int lnhwrt; /* event output unit number */
	- int lnhrd; /* event input unit number */
	- int lnhout; /* line printer output unit number */
	- int lnhdcy; /* decay file unit number */
	- int lnhpdf; /* PDF file unit number */
	- int lnhdmp; /* ascii dump file unit number */
	- int lnhrdm[LUN_ARRAY]; /* unit number array for multiple I/O files */
	-} heplun_;
	-
	-extern struct stdstr {
	- int ixdrstr[LUN_ARRAY]; /* array of xdr stream addresses */
	-} stdstr_;
	Index: trunk/stdhep/stdhep.inc
	===================================================================
	--- trunk/stdhep/stdhep.inc (revision 8888)
	+++ trunk/stdhep/stdhep.inc (revision 8889)
	@@ -1,46 +0,0 @@
	-C -------------------------------------------------------------
	-C
	- integer NMXHEP
	- parameter (NMXHEP=4000)
	- common/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- integer NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
	- double precision PHEP,VHEP
	- save /HEPEVT/
	-C... NEVHEP - event number
	-C... NHEP - number of entries in this event
	-C... ISTHEP(..) - status code
	-C... IDHEP(..) - particle ID, P.D.G. standard
	-C... JMOHEP(1,..) - position of mother particle in list
	-C... JMOHEP(2,..) - position of second mother particle in list
	-C... JDAHEP(1,..) - position of first daughter in list
	-C... JDAHEP(2,..) - position of last daughter in list
	-C... PHEP(1,..) - x momentum in GeV/c
	-C... PHEP(2,..) - y momentum in GeV/c
	-C... PHEP(3,..) - z momentum in GeV/c
	-C... PHEP(4,..) - energy in GeV
	-C... PHEP(5,..) - mass in GeV/c**2
	-C... VHEP(1,..) - x vertex position in mm
	-C... VHEP(2,..) - y vertex position in mm
	-C... VHEP(3,..) - z vertex position in mm
	-C... VHEP(4,..) - production time in mm/c
	-C
	-C -------------------------------------------------------------
	-C
	- common/hepev2/nmulti,jmulti(NMXHEP)
	- integer nmulti,jmulti
	- save /hepev2/
	-C... nmulti - number of interactions in the list
	-C... jmulti(..) - multiple interaction number
	-C
	-C -------------------------------------------------------------
	- integer NMXMLT
	- parameter (NMXMLT=16)
	- common/hepev3/nevmulti(NMXMLT),itrkmulti(NMXMLT),mltstr(NMXMLT)
	- integer nevmulti,itrkmulti,mltstr
	- save /hepev3/
	-C... nevmulti(i) - event number of original interaction
	-C... itrkmulti(i) - first particle in the original interaction
	-C... mltstr(i) - stream this event is from
	-C
	-C -------------------------------------------------------------
	Index: trunk/stdhep/stdxwevtlh.f
	===================================================================
	--- trunk/stdhep/stdxwevtlh.f (revision 8888)
	+++ trunk/stdhep/stdxwevtlh.f (revision 8889)
	@@ -1,50 +0,0 @@
	- subroutine stdxwevtlh(ilbl,istream,lok)
	-
	-C...Purpose: to write an event from the standard common block.
	-C
	-C ilbl = 4 write HEPEVT and HEPEV4 common blocks
	-C ilbl = 5 write HEPEVT, HEPEV2, HEPEV3, and HEPEV4 common blocks
	-C lok = 0 if no problems were encountered
	-
	- include "stdhep.inc"
	- include "stdcnt.inc"
	- include "stdlun.inc"
	- include "mcfio.inc"
	-
	- integer ilbl,lok,istream
	- integer xdr_stdhep_4, xdr_stdhep_4_multi
	- external xdr_stdhep_4, xdr_stdhep_4_multi
	-
	- lok=0
	- if(NHEP.LE.0)then
	- write(lnhout,101) NEVHEP
	- elseif(ilbl.eq.4)then
	- call stdtcopy(1,istream,lok)
	- if(lok.ne.0) go to 700
	- if(mcfio_block(istream, MCFIO_STDHEP4, xdr_stdhep_4)
	- 1 .eq. -1) go to 800
	- call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- nstdwrt = nstdwrt + 1
	- elseif(ilbl.eq.5)then
	- if(mcfio_block(istream, MCFIO_STDHEP4M, xdr_stdhep_4_multi)
	- 1 .eq. -1) go to 800
	- call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	- if(mcfio_NextEvent(istream) .eq. -1) go to 900
	- nstdwrt = nstdwrt + 1
	- endif
	- return
	- 700 write (lnhout,701) NEVHEP
	- lok = 4
	- stop
	- 800 write (lnhout,801) NEVHEP
	- lok=2
	- stop
	- 900 write (lnhout,901) NEVHEP
	- lok=1
	- stop
	- 101 format(/5X,'STDXWEVTLH: no particles to write in event',I8)
	- 701 format(/5X,'STDXWEVTLH: error copying stdhep block for event ',I8)
	- 801 format(/5X,'STDXWEVTLH: error filling stdhep block for event ',I8)
	- 901 format(/5X,'STDXWEVTLH: error writing event ',I8)
	- end
	Index: trunk/stdhep/stdtmp.h
	===================================================================
	--- trunk/stdhep/stdtmp.h (revision 8888)
	+++ trunk/stdhep/stdtmp.h (revision 8889)
	@@ -1,27 +0,0 @@
	-/*
	-** Basic COMMON block from STDHEP: the temporary COMMON block
	-** This is a copy of the HEPEVT COMMON block
	-*/
	-/* note that to avoid alignment problems, structures and common blocks
	- should be in the order: double precision, real, integer.
	-*/
	-extern struct stdtmp {
	-double phept[NMXHEP][5]; /* 4-Momentum, mass */
	-double vhept[NMXHEP][4]; /* Vertex information */
	-int nevhept; /* The event number */
	-int nhept; /* The number of entries in this event */
	-int isthept[NMXHEP]; /* The Particle id */
	-int idhept[NMXHEP]; /* The particle id */
	-int jmohept[NMXHEP][2]; /* The position of the mother particle */
	-int jdahept[NMXHEP][2]; /* Position of the first daughter... */
	-} stdtmp_;
	-
	-extern struct tmpev4 {
	- double eventweightt; /* event weight */
	- double alphaqedt; /* QED coupling alpha_em */
	- double alphaqcdt; /* QCD coupling alpha_s */
	- double scalet[10]; /* Scale Q of the event */
	- double spint[NMXHEP][3]; /* spin information */
	- int icolorflowt[NMXHEP][2]; /* (Anti-)Colour flow */
	- int idrupt; /* ID, as given by LPRUP codes */
	-} tmpev4_;
	Index: trunk/stdhep/hepev4.inc
	===================================================================
	--- trunk/stdhep/hepev4.inc (revision 8888)
	+++ trunk/stdhep/hepev4.inc (revision 8889)
	@@ -1,53 +0,0 @@
	-c -------------------------------------------------------------
	-c hepev4 holds generator level information
	-c
	- double precision eventweightlh, scalelh
	- double precision alphaqedlh, alphaqcdlh, spinlh
	- integer icolorflowlh, idruplh
	-c
	- common/hepev4/eventweightlh, alphaqedlh, alphaqcdlh, scalelh(10),
	- 1 spinlh(3,NMXHEP), icolorflowlh(2,NMXHEP), idruplh
	- save /hepev4/
	-
	-C idruplh : The identity of the current process,
	-C as given by the LPRUP codes.
	-C eventweightlh : The event weight:
	-C Equal to (total cross section)/(total generated)
	-C for the output of Pythia, Herwig, etc.
	-C alphaqedlh : QED coupling alpha_em.
	-C alphaqcdlh : QCD coupling alpha_s.
	-C scalelh(10) : Squared Scale Q of the event.
	-C......Defined for standard 2->1->2 or 2->2 process
	-C.......kinematics are p1 + p2 -> q1 + q2
	-C scalehl(1)= Q2 hard scale (used in PDF and couplings)
	-C scalehl(2)= Q2 scale of parton shower
	-C scalehl(3)= s-hat, invariant (p1+p2)**2
	-C scalehl(4)= t-hat, invariant (p1-q1)**2
	-C scalehl(5)= u-hat, invariant (p1-q2)**2
	-C scalehl(6)= squared transverse momentum of q1 (i.e., pt-hat**2)
	-C.......Additionally, for 2->3 processes, p1 + p2 -> q1 + q2 + q3
	-C scalehl(7)= squared transverse momentum of q2
	-C scalehl(8)= user defined, 0 by default
	-C scalehl(9)= user defined, 0 by default
	-C scalehl(10)= user defined, 0 by default
	-C spinlh(3,..) : spin information
	-C icolorflowlh(2,..) : (Anti-)Colour flow.
	-C
	-c -------------------------------------------------------------
	-
	- double precision eventweightmulti, scalemulti
	- double precision alphaqedmulti, alphaqcdmulti
	- integer idrupmulti
	-
	- common/hepev5/eventweightmulti(NMXMLT),alphaqedmulti(NMXMLT),
	- 1 alphaqcdmulti(NMXMLT),scalemulti(10,NMXMLT),
	- 2 idrupmulti(NMXMLT)
	- save /hepev5/
	-
	-C idrupmulti(i) : identity of the original interaction
	-C eventweightmulti(i) : event weight of the original interaction
	-C alphaqedmulti : QED coupling alpha_em of the original interaction
	-C alphaqcdmulti : QCD coupling alpha_s of the original interaction
	-C scalemulti(10,i) : Scales of the original interaction
	-C
	-C -------------------------------------------------------------
	Index: trunk/stdhep/stdcm1.inc
	===================================================================
	--- trunk/stdhep/stdcm1.inc (revision 8888)
	+++ trunk/stdhep/stdcm1.inc (revision 8889)
	@@ -1,25 +0,0 @@
	-c -------------------------------------------------------------
	-c
	-c stdecom - center-of-mass energy
	-c stdxsec - cross-section
	-c stdseed1 - random number seed
	-c stdseed2 - random number seed
	-c nevtreq - number of events to be generated
	-c nevtgen - number of events actually generated
	-c nevtwrt - number of events written to output file
	-c nevtlh - number of Les Houches events written to output file
	-c
	-c generatorname - name of Monte Carlo generator
	-c pdfname - name of PDF method used
	-c
	- real stdecom,stdxsec
	- double precision stdseed1,stdseed2
	- integer nevtreq,nevtgen,nevtwrt,nevtlh
	- character*20 generatorname, pdfname
	- common /stdcm1/ stdecom,stdxsec,stdseed1,stdseed2,
	- 1 nevtreq,nevtgen,nevtwrt,nevtlh
	- common /stdcm2/ generatorname, pdfname
	- save /stdcm1/
	- save /stdcm2/
	-c
	-c -------------------------------------------------------------
	Index: trunk/stdhep/mcf_hepup_xdr.c
	===================================================================
	--- trunk/stdhep/mcf_hepup_xdr.c (revision 8888)
	+++ trunk/stdhep/mcf_hepup_xdr.c (revision 8889)
	@@ -1,194 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_hepup_xdr.c -- XDR Utility routines for the Block Stdhep filters *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun, Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include <stdlib.h>
	-#include <time.h>
	-#include "mcfio_Dict.h"
	-#include "mcf_xdr.h"
	-#include "hepeup.h"
	-#include "heprup.h"
	-#include "stdver.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-bool_t xdr_hepeup_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the HEPEUP COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version. */
	-
	- unsigned int nn, nn2, nn5;
	- int *idat;
	- double *dat;
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (*blockid != MCFIO_HEPEUP) {
	- fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	-
	- nn = (unsigned int) hepeup_.nup; /* Number of elements in idup, istup, vtimup, spinup */
	- nn2 = 2(unsigned int) hepeup_.nup; / Number of elements in mothup, icolup */
	- nn5 = 5(unsigned int) hepeup_.nup; / Number of elements in pup */
	-
	- /* Total length in bytes include blockid, ntot, version, as well
	- as the common block entries */
	- ntot = sizeof(int)(5 + 2nn + 2nn2) + sizeof(double)(4 + 2nn + nn5);
	-
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	- xdr_int(xdrs, &(hepeup_.nup)) &&
	- xdr_int(xdrs, &(hepeup_.idprup))) == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_HEPEUP) ) {
	- fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	-
	- if ( xdr_double(xdrs, &(hepeup_.xwgtup) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(hepeup_.scalup) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(hepeup_.aqedup) ) == FALSE) return FALSE;
	- if ( xdr_double(xdrs, &(hepeup_.aqcdup) ) == FALSE) return FALSE;
	- idat = hepeup_.idup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nn, MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepeup_.istup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nn, MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) hepeup_.mothup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nn2, 2*MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) hepeup_.icolup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nn2, 2*MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) hepeup_.pup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nn5, 5*MAXNUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepeup_.vtimup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nn, MAXNUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepeup_.spinup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nn, MAXNUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- return TRUE;
	-}
	-
	-bool_t xdr_heprup_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the HEPRUP COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version. */
	-
	- unsigned int nn, n2;
	- int i;
	- int *idat;
	- char *vers;
	- double *dat;
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (*blockid != MCFIO_HEPRUP) {
	- fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	-
	- nn = (unsigned int) heprup_.nprup; /* Number of elements in xsecup, xerrup, xmaxup, lprup */
	- n2 = (unsigned int) 2; /* Number of elements in idbmup, ebmup, pdfgup, pdfsup */
	-
	- /* Total length in bytes include blockid, ntot, version, as well
	- as the common block entries */
	- ntot = sizeof(int)(5 + 3n2 + nn) + sizeof(double)(n2 + 3*nn);
	-
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	- xdr_int(xdrs, &(heprup_.idwtup)) &&
	- xdr_int(xdrs, &(heprup_.nprup))) == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_HEPRUP) ) {
	- fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- idat = heprup_.idbmup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &n2, 2, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) heprup_.ebmup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &n2, 2, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- idat = heprup_.pdfgup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &n2, 2, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = heprup_.pdfsup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &n2, 2, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) heprup_.xsecup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nn, MAXPUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) heprup_.xerrup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nn, MAXPUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) heprup_.xmaxup;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nn, MAXPUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- idat = heprup_.lprup;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nn, MAXPUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	-
	- return TRUE;
	-}
	-
	-
	Index: trunk/stdhep/mcf_Stdhep_xdr.c
	===================================================================
	--- trunk/stdhep/mcf_Stdhep_xdr.c (revision 8888)
	+++ trunk/stdhep/mcf_Stdhep_xdr.c (revision 8889)
	@@ -1,232 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_Stdhep_xdr.c -- XDR Utility routines for the Block Stdhep filters *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun, Lynn Garren *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include <stdlib.h>
	-#include <time.h>
	-#include "mcfio_Dict.h"
	-#include "mcf_xdr.h"
	-#include "stdhep.h"
	-#include "stdtmp.h"
	-#include "stdver.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-bool_t xdr_stdhep_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the HEPEVT temporary COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version. */
	-
	- unsigned int nn, nn2, nn4, nn5, nnw, nnw2, nnw4, nnw5;
	- int *idat;
	- double *dat;
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (*blockid != MCFIO_STDHEP) {
	- fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	-
	- nn = (unsigned int) stdtmp_.nhept; /* Number of elements in isthep or idhep */
	- nn2 = 2(unsigned int) stdtmp_.nhept; / Number of elements in jmohep or jdahep */
	- nn4 = 4(unsigned int) stdtmp_.nhept; / Number of elements in vhep */
	- nn5 = 5(unsigned int) stdtmp_.nhept; / Number of elements in phep */
	- nnw = (unsigned int) stdtmp_.nhept;
	- nnw2 = 2 * nnw;
	- nnw4 = 4 * nnw;
	- nnw5 = 5 * nnw;
	-
	- /* Total length in bytes include blockid, ntot, version, nevhept and nhept as well
	- as the arrays remembering doubles are longer than ints. */
	- ntot = 5sizeof(int) + sizeof(int)(2nn + 2nn2) + sizeof(double)(nn4 + nn5);
	-
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	- xdr_int(xdrs, &(stdtmp_.nevhept)) &&
	- xdr_int(xdrs, &(stdtmp_.nhept))) == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEP) ) {
	- fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- idat = stdtmp_.isthept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = stdtmp_.idhept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) stdtmp_.jmohept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) stdtmp_.jdahept;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) stdtmp_.phept;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw5, 5*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) stdtmp_.vhept;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- return TRUE;
	-}
	-
	-bool_t xdr_stdhep_multi_(XDR xdrs, int blockid,
	- int ntot, char* version)
	-
	-{
	-/* Translate the HEPEVT COMMON block from the STDHEP package to/from
	- an XDR stream. Note that we do not allocate memory, because we fill
	- directly the COMMON. Also, mcfio will allocate the space for the
	- string version.
	- Also translate the HEPEV2 COMMON block from the STDHEP package to/from
	- an XDR stream. HEPEV2 contains multiple interaction information */
	-
	- unsigned int nn, nn2, nn4, nn5, nnw, nnw2, nnw4, nnw5, nmlt, nnmlt;
	- int i;
	- int *idat;
	- char *vers;
	- double *dat;
	-
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- if (*blockid != MCFIO_STDHEPM) {
	- fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- nn = sizeof(int) * hepevt_.nhep;
	- nn2 = 2 * sizeof(int) * hepevt_.nhep;
	- nn4 = 4 * sizeof(double) * hepevt_.nhep;
	- nn5 = 5 * sizeof(double) * hepevt_.nhep;
	- nmlt = sizeof(int) * hepev2_.nmulti;
	- nnw = (unsigned int) hepevt_.nhep;
	- nnw2 = 2 * nnw;
	- nnw4 = 4 * nnw;
	- nnw5 = 5 * nnw;
	- nnmlt = (unsigned int) hepev2_.nmulti;
	- ntot = 6 sizeof(int) + 3 * nn + 2 * nn2 + nn4 + nn5 + 3 * nmlt;
	- if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	- strncpy(version[0],stdver_.stdhep_ver, 4);
	- }
	-
	- if ( (xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	- xdr_int(xdrs, &(hepevt_.nevhep)) &&
	- xdr_int(xdrs, &(hepevt_.nhep))) == FALSE) return FALSE;
	-
	- if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEPM) ) {
	- fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	- (*blockid));
	- return FALSE;
	- }
	- idat = hepevt_.isthep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepevt_.idhep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) hepevt_.jmohep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = (int *) hepevt_.jdahep;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- dat = (double *) hepevt_.phep;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw5, 5*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- dat = (double *) hepevt_.vhep;
	- if ( xdr_array(xdrs, (char **) &dat,
	- &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	- /*
	- ** V2.02 Upgrade : adding Multiple interactions.
	- */
	- vers = *version;
	- if ((strcmp(vers,"1.05") == 0) && (xdrs->x_op == XDR_DECODE)) {
	- hepev2_.nmulti = -1;
	- return TRUE;
	- }
	- if ( xdr_int(xdrs, &(hepev2_.nmulti)) == FALSE) return FALSE;
	- idat = hepev2_.jmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- /*
	- ** V4.04 Upgrade : adding more Multiple interaction information
	- */
	- if (((strcmp(vers,"2.") > 0) \|\| (strcmp(vers,"3.") > 0))
	- && (xdrs->x_op == XDR_DECODE)) {
	- for (i = 0; i < NMXMLT; i++) {
	- hepev3_.nevmulti[i] = 0;
	- hepev3_.itrkmulti[i] = 0;
	- hepev3_.mltstr[i] = 0;
	- }
	- return TRUE;
	- }
	- if (((strcmp(vers,"4.00") == 0) \|\| (strcmp(vers,"4.01") == 0) \|\|
	- (strcmp(vers,"4.02") == 0) \|\| (strcmp(vers,"4.03") == 0) )
	- && (xdrs->x_op == XDR_DECODE)) {
	- for (i = 0; i < NMXMLT; i++) {
	- hepev3_.nevmulti[i] = 0;
	- hepev3_.itrkmulti[i] = 0;
	- hepev3_.mltstr[i] = 0;
	- }
	- return TRUE;
	- }
	- idat = hepev3_.nevmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepev3_.itrkmulti;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- idat = hepev3_.mltstr;
	- if ( xdr_array(xdrs, (char **) &idat,
	- &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	- return TRUE;
	-}
	-
	-
	Index: trunk/stdhep/hepeup.h
	===================================================================
	--- trunk/stdhep/hepeup.h (revision 8888)
	+++ trunk/stdhep/hepeup.h (revision 8889)
	@@ -1,21 +0,0 @@
	-/*
	-C...User process event common block.
	-*/
	-
	-#define MAXNUP 500
	-extern struct hepeup {
	- int nup; /* number of particles */
	- int idprup;
	- double xwgtup;
	- double scalup;
	- double aqedup;
	- double aqcdup;
	- int idup[MAXNUP];
	- int istup[MAXNUP];
	- int mothup[MAXNUP][2];
	- int icolup[MAXNUP][2];
	- double pup[MAXNUP][5];
	- double vtimup[MAXNUP];
	- double spinup[MAXNUP];
	-} hepeup_;
	-
	Index: trunk/stdhep/stdzero.f
	===================================================================
	--- trunk/stdhep/stdzero.f (revision 8888)
	+++ trunk/stdhep/stdzero.f (revision 8889)
	@@ -1,50 +0,0 @@
	-
	- subroutine STDZERO
	-
	-C...Purpose: to zero the standard common block.
	-C
	- include "stdhep.inc"
	- include "hepev4.inc"
	-
	- integer J,K
	-
	-C...set everything to zero
	- NHEP = 0
	- nmulti = 0
	- do 120 J=1,NMXHEP
	- ISTHEP(J)=0
	- IDHEP(J)=0
	- jmulti(J)=0
	- do 100 K=1,2
	- JMOHEP(K,J)=0
	- JDAHEP(K,J)=0
	- 100 icolorflowlh(K,J)=0
	- do 105 K=1,5
	- 105 PHEP(K,J)=0.
	- do 110 K=1,4
	- 110 VHEP(K,J)=0.
	- do K=1,3
	- spinlh(K,J) = 0.
	- enddo
	- 120 CONTINUE
	- do j=1,NMXMLT
	- nevmulti(j)=0
	- itrkmulti(j)=0
	- mltstr(j)=0
	- eventweightmulti(j)=0.
	- alphaqedmulti(j)=0.
	- alphaqcdmulti(j)=0.
	- do k=1,5
	- scalemulti(k,j)=0.
	- enddo
	- idrupmulti(j)=0
	- enddo
	- eventweightlh = 0.
	- alphaqedlh = 0.
	- alphaqcdlh = 0.
	- do j=1,5
	- scalelh(j) = 0.
	- enddo
	- idruplh = 0
	- return
	- end
	Index: trunk/stdhep/stdver.inc
	===================================================================
	--- trunk/stdhep/stdver.inc (revision 8888)
	+++ trunk/stdhep/stdver.inc (revision 8889)
	@@ -1,10 +0,0 @@
	-C -------------------------------------------------------------
	-C
	- common/stdver/stdhep_ver,stdhep_date
	- character*10 stdhep_ver
	- character*20 stdhep_date
	- save /stdver/
	-C... stdhep_ver - stdhep version number
	-C... stdhep_date - date of this stdhep version
	-C
	-C -------------------------------------------------------------
	Index: trunk/stdhep/stdlun.inc
	===================================================================
	--- trunk/stdhep/stdlun.inc (revision 8888)
	+++ trunk/stdhep/stdlun.inc (revision 8889)
	@@ -1,10 +0,0 @@
	-C -------------------------------------------------------------
	-C
	- integer lnhwrt,lnhrd,lnhout,lnhdcy,lnhpdf,lnhdmp,lnhrdm,ixdrstr
	- character*80 qqufile ! use this to set the QQ user decay file
	- common/heplun/lnhwrt,lnhrd,lnhout,lnhdcy,lnhpdf,lnhdmp,lnhrdm(16)
	- common/stdstr/ixdrstr(16)
	- common/stdfnm/qqufile
	- save /heplun/,/stdstr/
	-C
	-C -------------------------------------------------------------
	Index: trunk/stdhep/stdtmp.inc
	===================================================================
	--- trunk/stdhep/stdtmp.inc (revision 8888)
	+++ trunk/stdhep/stdtmp.inc (revision 8889)
	@@ -1,54 +0,0 @@
	-C -------------------------------------------------------------
	-C
	-C This is the temporary common block used to get events to and
	-C from xdr. It enables reading multiple stdhep input streams.
	-C
	- common/stdtmp/ phept(5,NMXHEP),vhept(4,NMXHEP),
	- 1 nevhept,nhept,isthept(NMXHEP),idhept(NMXHEP),
	- & jmohept(2,NMXHEP),jdahept(2,NMXHEP)
	- integer nevhept,nhept,isthept,idhept,jmohept,jdahept
	- double precision phept,vhept
	- save /stdtmp/
	-C... nevhept - event number
	-C... nhept - number of entries in this event
	-C... isthept(..) - status code
	-C... idhept(..) - particle ID, P.D.G. standard
	-C... jmohept(1,..) - position of mother particle in list
	-C... jmohept(2,..) - position of second mother particle in list
	-C... jdahept(1,..) - position of first daughter in list
	-C... jdahept(2,..) - position of last daughter in list
	-C... phept(1,..) - x momentum in GeV/c
	-C... phept(2,..) - y momentum in GeV/c
	-C... phept(3,..) - z momentum in GeV/c
	-C... phept(4,..) - energy in GeV
	-C... phept(5,..) - mass in GeV/c**2
	-C... vhept(1,..) - x vertex position in mm
	-C... vhept(2,..) - y vertex position in mm
	-C... vhept(3,..) - z vertex position in mm
	-C... vhept(4,..) - production time in mm/c
	-C
	-C -------------------------------------------------------------
	-c -------------------------------------------------------------
	-c hepev4 holds Les Houches information
	-c
	- double precision eventweightt, scalet
	- double precision alphaqedt, alphaqcdt, spint
	- integer icolorflowt, idrupt
	-c
	- common/tmpev4/eventweightt, alphaqedt, alphaqcdt, scalet(10),
	- 1 spint(3,NMXHEP), icolorflowt(2,NMXHEP), idrupt
	- save /tmpev4/
	-
	-C idrupt : The identity of the current process,
	-C as given by the LPRUP codes.
	-C eventweightt : The event weight:
	-C Equal to (total cross section)/(total generated)
	-C for the output of Pythia, Herwig, etc.
	-C scalet : Scale Q of the event.
	-C (fact. scale for PDF and energy scale for ISR and FSR)
	-C alphaqedt : QED coupling alpha_em.
	-C alphaqcdt : QCD coupling alpha_s.
	-C spint(3,..) : spin information
	-C icolorflowt(2,..) : (Anti-)Colour flow.
	-C
	-c -------------------------------------------------------------
	Index: trunk/stdhep/stdcnt.h
	===================================================================
	--- trunk/stdhep/stdcnt.h (revision 8888)
	+++ trunk/stdhep/stdcnt.h (revision 8889)
	@@ -1,9 +0,0 @@
	-/*
	- StdHep counting common block
	-*/
	-extern struct stdcnt {
	- int nstdwrt; /* number of events written */
	- int nstdrd; /* number of events read */
	- int nlhwrt; /* number of Les Houches events written */
	- int nlhrd; /* number of Les Houches events read */
	-} stdcnt_;
	Index: trunk/mcfio/mcfio_UserDictionary.h
	===================================================================
	--- trunk/mcfio/mcfio_UserDictionary.h (revision 8888)
	+++ trunk/mcfio/mcfio_UserDictionary.h (revision 8889)
	@@ -1,25 +0,0 @@
	-/*
	-** A small container to hold a set of user block declaration
	-**
	-* Written by Paul Lebrun, Aug 2001
	-*/
	-
	-typedef struct _aUserBlockDecl {
	- int blkNum;
	- char *title;
	-} aUserBlockDecl;
	-
	-typedef struct _allMCFIO_UserBlockDecl {
	- int num;
	- int numPreAlloc;
	- aUserBlockDecl **decls;
	-}allMCFIO_UserBlockDecl ;
	-
	-extern allMCFIO_UserBlockDecl *AllMCFIO_UserBlockDecl;
	-
	-/*
	-** Internally used in mcfio. Return NULL if not on the list,
	-** otherwise return the point to the relevant title block.
	-*/
	-char *mcfioC_UserBlockDescript(int blkNum);
	-void mcfioC_DefineUserBlock(int blkN, char *descr);
	Index: trunk/mcfio/mcf_xdr.h
	===================================================================
	--- trunk/mcfio/mcf_xdr.h (revision 8888)
	+++ trunk/mcfio/mcf_xdr.h (revision 8889)
	@@ -1,185 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_xdr.h -- Include file for mcfast Xdr layer. Specifies the headers *
	-* ( Block, event, table and files) * *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warrenty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-*******************************************************************************/
	-#define MCF_XDR_F_TITLE_LENGTH 255
	-#define MCF_XDR_B_TITLE_LENGTH 80
	-#define MCF_XDR_MAXLREC 32000
	-#define MCF_XDR_MINLREC 512
	-#define MCF_XDR_VERSION "v0.0"
	-#define MCF_STREAM_NUM_MAX 20
	-#define MCF_DEFAULT_TABLE_SIZE 100
	-#define MCF_XDR_VERSION_LENGTH 4
	-#define MCF_XDR_STDCM2_LENGTH 20
	-#define XDR_MCFIOCODE 1025 /* Private code to be passed to the encoding
	- filter to estimate the length prior to encode
	- in memory */
	-
	-typedef enum _mcfxdrBlockType {
	- GENERIC, FILEHEADER, EVENTTABLE, SEQUENTIALHEADER,
	- EVENTHEADER, NOTHING
	-} mcfxdrBlockType;
	-
	-
	-typedef struct _mcfxdrGeneric{
	- int id; /* Identifier for this item = FILEHEADER */
	- int length; /* The length of data body, byte count, excluding
	- the id and version, and this word */
	- char version[MCF_XDR_VERSION_LENGTH+1];
	- /* The version of this particular block */
	- int data; / The data block */
	-} mcfxdrGeneric;
	-
	-typedef struct _mcfxdrFileHeader{
	- int id; /* Identifier for this item = FILEHEADER */
	- int length; /* The length of data body, byte count, excluding
	- the id and version, and this word */
	- char version[MCF_XDR_VERSION_LENGTH+1];
	- /* The version of this particular block */
	- char title[MCF_XDR_F_TITLE_LENGTH+1];
	- /* The title length */
	- char comment[MCF_XDR_F_TITLE_LENGTH+1]; /* The comment ..*/
	- char date[30];
	- char closingDate[30];
	- unsigned int numevts_expect; /* The number of event expected */
	- unsigned int numevts; /* The number of evts really written on tape */
	- unsigned int firstTable; /* The XDR locator for the first table */
	- unsigned int dimTable; /* The number of events listed in the fixed-sized
	- event table */
	- unsigned int nBlocks;
	- /* The maximum number of Block types in the file
	- ( excluding File headers and Event Tables) */
	- int blockIds; / The list of Block identifiers */
	-
	- char *blockNames; / The list of names ( Titles) for these blocks */
	- unsigned int nNTuples;
	- /* The maximum number of Ntuples defined for this
	- stream */
	-
	-} mcfxdrFileHeader;
	-
	-typedef struct _mcfxdrEventTable{
	- int id; /* Identifier for this item = EVENTTABLE */
	- int length; /* The length of data body, byte count, excluding
	- the id and version, and this word */
	- char version[MCF_XDR_VERSION_LENGTH+1];
	- /* The version of this particular block */
	- int nextLocator; /The Locator for the next Event Table. /
	- int previousnumevts; /* The size of the previous Table */
	- int numevts; /* The number of events in this chunk */
	- unsigned int dim; /* The dimension of the arrays listed below */
	- unsigned int ievt; /* The current index in the list */
	- int evtnums; / The List of event numbers, within a store */
	- int storenums; / The list of Store number within a Run */
	- int runnums; / The list of run numbers */
	- int trigMasks; / The list of user-defined Trigger masks */
	- unsigned int *ptrEvents;
	- /* The list of XDR pointers for these events */
	-} mcfxdrEventTable;
	-
	-typedef struct _mcfxdrSequentialHeader{
	- int id; /* Identifier for this item = SEQUENTIALHEADER */
	- int length; /* The length of data body, byte count, excluding
	- the id and version, and this word */
	- char version[MCF_XDR_VERSION_LENGTH+1];
	- /* The version of this particular block */
	- unsigned int nRecords; /* The number of records (including this one)
	- in the logical event */
	-} mcfxdrSequentialHeader;
	-
	-typedef struct _mcfxdrEventHeader{
	- int id; /* Identifier for this item = CHUNKHEADER */
	- int length; /* The length of data body, byte count, excluding
	- the id and version, and this word */
	- char version[MCF_XDR_VERSION_LENGTH+1];
	- /* The version of this particular block */
	- int previousevtnum; /* The previous event number */
	- int evtnum; /* The event numbers, within a store */
	- int storenum; /* The Store number within a Run */
	- int runnum; /* The Run numbers */
	- int trigMask; /* The Trigger masks */
	- unsigned int nBlocks; /* The number of Blocks */
	- unsigned int dimBlocks; /* The dimension of the two following arrays */
	- int blockIds; / The list of Block identifiers */
	- unsigned int *ptrBlocks;
	- /* The list of XDR pointers for these blocks */
	- unsigned int nNTuples;
	- /* The number of Ntuples defined for this event */
	-
	- unsigned int dimNTuples; /* The dimension of the two following arrays */
	- int nTupleIds; / The list of Ntuple identifiers, pointing to the
	- global list array */
	- unsigned int *ptrNTuples;
	- /* The list of XDR pointers for these NTuples */
	-
	-} mcfxdrEventHeader;
	-
	-typedef struct _mcfStream{
	- int id; /* Id of the Stream */
	- int row; /* Read or Write */
	- int dos; /* Direct, Memory Mapped I/O or Sequential */
	- int status; /* The Stream status, either at BOF, RUNNING, EOF
	- or simply declared, and needs to be opened
	- (NTuple usage) */
	- int numWordsC; /* The number of words read or written, Content */
	- int numWordsT; /* The number of words read or written, Total */
	- mcfxdrFileHeader fhead; / The File header */
	- mcfxdrEventHeader ehead; / The current Event Header */
	- unsigned int currentPos; /* The XDR current position */
	- unsigned int evtPos; /* The XDR position for the begingin of evt */
	- unsigned int tablePos; /* The XDR position for the table */
	- unsigned int firstPos; /* The XDR position just before file header */
	- XDR xdr; / The XDR stream */
	- char filename; / Filename */
	- FILE filePtr; / The file pointer */
	- int fileDescr; /* File descriptor if Memory Mapped */
	- char fileAddr; / Address in virtual memory if Memory Mapped */
	- size_t fileLen; /* The file length */
	- mcfxdrEventTable table; / The event table */
	- char device; / The device name, if any */
	- char vsn; / The Visual S. number, e.g., the tape label */
	- int filenumber; /* The sequential file number, if any */
	- int minlrec; /* The minimum record length for this stream */
	- int maxlrec; /* The maximum record length for this stream */
	- int bufferSize; /* The current size of the primary buffer */
	- mcfxdrSequentialHeader shead; / The Sequential header */
	- char buffer; / A pointer to a generic data buffer, to get the
	- data from tape and then decode it */
	- char buffer2; / A secondary buffer, to hold the event
	- as the event grows */
	-} mcfStream;
	-
	-extern mcfStream **McfStreamPtrList;
	-extern char **McfGenericVersion;
	-extern unsigned int McfNumOfStreamActive;
	-extern bool_t McfNTuPleSaveDecoding;
	-
	-bool_t xdr_mcfast_generic(XDR xdrs, int blockid,
	- int ntot, char* version, char** data);
	-bool_t xdr_mcfast_headerBlock(XDR xdrs, int blockid,
	- int ntot, char* version);
	-bool_t xdr_mcfast_fileheader(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrFileHeader **mcf,
	- int streamId);
	-bool_t xdr_mcfast_eventtable(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrEventTable **mcf);
	-bool_t xdr_mcfast_seqheader(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrSequentialHeader **mcf);
	-bool_t xdr_mcfast_eventheader(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrEventHeader **mcf);
	Index: trunk/mcfio/mcf_ntubld_db.h
	===================================================================
	--- trunk/mcfio/mcf_ntubld_db.h (revision 8888)
	+++ trunk/mcfio/mcf_ntubld_db.h (revision 8889)
	@@ -1,59 +0,0 @@
	-#ifndef _mcf_tmp_INC
	-#define _mcf_tmp_INC
	-
	-
	-/*** template line_title ***/
	-
	-typedef struct _line_title_s {
	- char line[80]; /* */
	-} line_title_s;
	-static const int n_el_line_title=1;
	-extern struct line_title_c {
	- int n_obj_line_title;
	- int idmline_title;
	- line_title_s line_title[500];
	-} line_title_c_;
	-static int *n_obj_line_title = &(line_title_c_.n_obj_line_title);
	-static line_title_s *line_title = &line_title_c_.line_title[0];
	-
	-/*** template header ***/
	-
	-typedef struct _header_s {
	- char title[80]; /* */
	- char version[80]; /* */
	- char namemaxindex[80]; /* */
	- int maxmult; /* */
	- int orgstyle; /* */
	- int nvar; /* */
	-} header_s;
	-static const int n_el_header=6;
	-extern struct header_c {
	- int n_obj_header;
	- int idmheader;
	- header_s header[1];
	-} header_c_;
	-static int *n_obj_header = &(header_c_.n_obj_header);
	-static header_s *header = &header_c_.header[0];
	-
	-/*** template variable ***/
	-
	-typedef struct _variable_s {
	- char name[80]; /* */
	- char description[80]; /* */
	- int type; /* */
	- char isfixedsize[80]; /* */
	- int numdim; /* */
	- int dimensions[5]; /* */
	-} variable_s;
	-static const int n_el_variable=10;
	-extern struct variable_c {
	- int n_obj_variable;
	- int idmvariable;
	- variable_s variable[100];
	-} variable_c_;
	-static int *n_obj_variable = &(variable_c_.n_obj_variable);
	-static variable_s *variable = &variable_c_.variable[0];
	-
	-#endif
	-
	-void mcf_ntubldInit();
	Index: trunk/mcfio/mcfio_Direct.c
	===================================================================
	--- trunk/mcfio/mcfio_Direct.c (revision 8888)
	+++ trunk/mcfio/mcfio_Direct.c (revision 8889)
	@@ -1,1029 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_Direct.c -- Utility routines for the McFast Monte-Carlo *
	-* Direct Access I/O core routines *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <sys/stat.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#include <stdlib.h>
	-#include <unistd.h>
	-#include <time.h>
	-#include <sys/mman.h>
	-#include <fcntl.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcfio_Dict.h"
	-#include "mcfio_Util1.h"
	-#include "mcfio_Direct.h"
	-#include "mcf_NTuIOFiles.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcfio_Sequential.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-#ifndef MAP_FILE
	-#define MAP_FILE 0
	-#endif
	-
	-extern nTuDDL **NTuDDLList;
	-extern int NumOfNTuples;
	-
	-
	-/* Static routine used in this module */
	-
	-static int mcfioC_gofornextevent(mcfStream *str);
	-static int mcfioC_nextspecevt(mcfStream *str, int inum, int istore,
	- int irun, int itrig);
	-static int openReadDirect(char*filename, int mode);
	-
	-
	-int mcfioC_OpenReadDirect(char *filename)
	-{
	-/*
	-** Routine to open and read the header file for a Direct access Stream,
	-** Standard Unix I/O
	-*/
	- return openReadDirect(filename, MCFIO_DIRECT);
	-}
	-
	-int mcfioC_OpenReadMapped(char *filename)
	-{
	-/*
	-** Routine to open and read the header file for a Direct access Stream,
	-** Standard Unix I/O
	-*/
	- return openReadDirect(filename, MCFIO_MEMMAPPED);
	-}
	-
	-static int openReadDirect(char *filename, int mode)
	-/*
	-** Routine to open and read the header file for a Direct access Stream.
	-*/
	-{
	- int i, j, jstr, idtmp, ntot, ll1, jdRef, oldNumOfNTuples;
	- int iff;
	- u_int p1, p2;
	- FILE *ff;
	- mcfStream *str;
	- nTuDDL ddl, ddlRef;
	- struct stat statbuf;
	- char *srcFile;
	-
	-
	- if (McfStreamPtrList == NULL) mcfioC_Init();
	-
	- if (McfNumOfStreamActive >= MCF_STREAM_NUM_MAX) {
	- fprintf(stderr,
	- " mcfio_OpenReadDirect: Too many streams opened simultaneously.\n");
	- return -1;
	- }
	- jstr = -1; i=0;
	- while ((jstr == -1) && (i<MCF_STREAM_NUM_MAX)) {
	- if (McfStreamPtrList[i] == NULL) jstr=i;
	- i++;
	- }
	- if(jstr == -1) {
	- fprintf(stderr,
	- " mcfio_OpenReadDirect: Internal error, please report \n");
	- return -1;
	- }
	- if ((filename == NULL) \|\| (strlen(filename) > 255)) {
	- fprintf(stderr,
	- " mcfio_OpenReadDirect: You must give a valid UNIX filename.\n");
	- return -1;
	- }
	- /*
	- ** Now we can try to open this file....
	- */
	- if (mode == MCFIO_DIRECT) {
	- ff = fopen(filename, "r");
	- if (ff == NULL) {
	- fprintf(stderr,
	- " mcfio_OpenReadDirect: Problem opening file %s, message \n", filename);
	- perror ("mcfio_OpenReadDirect");
	- return -1;
	- }
	- } else {
	- /*
	- ** Using memory mapped i/o
	- */
	- iff = open(filename, O_RDONLY);
	- if (iff < 0) {
	- fprintf(stderr,
	- " mcfio_OpenReadMapped: Problem opening file %s, message \n", filename);
	- perror ("mcfio_OpenReadMapped");
	- return -1;
	- }
	- }
	- McfStreamPtrList[jstr] = (mcfStream *) malloc(sizeof(mcfStream));
	- str = McfStreamPtrList[jstr];
	- str->xdr = (XDR *) malloc(sizeof(XDR));
	- str->id = jstr+1;
	- str->row = MCFIO_READ;
	- str->dos = mode;
	- str->numWordsC = 0;
	- str->numWordsT = 0;
	- ll1 = strlen(filename) + 1;
	- str->filename = (char ) malloc(sizeof(char) ll1);
	- strcpy(str->filename,filename);
	- if (mode == MCFIO_DIRECT) {
	- str->filePtr = ff;
	- xdrstdio_create(str->xdr, ff, XDR_DECODE);
	- str->fileDescr = 0;
	- str->fileAddr = NULL;
	- str->fileLen = 0;
	- } else {
	- /*
	- ** Use memory mapped I/O
	- */
	- if (fstat(iff, &statbuf) < 0) {
	- fprintf (stderr,
	- " mcfio_OpenReadMapped: Problem getting file length for %s \n", filename);
	- perror ("mcfio_OpenReadMapped");
	- return -1;
	- }
	- if ((srcFile =
	- mmap(0, statbuf.st_size, PROT_READ, MAP_FILE \| MAP_SHARED, iff, 0 ))
	- == (caddr_t) -1) {
	- fprintf (stderr,
	- " mcfio_OpenReadMapped: Problem with memory mapping for %s \n", filename);
	- perror ("mcfio_OpenReadMapped");
	- return -1;
	- }
	- str->filePtr = (FILE *) NULL;
	- str->fileDescr = iff;
	- str->fileAddr = srcFile;
	- str->fileLen = (size_t) statbuf.st_size;
	- xdrmem_create(str->xdr, srcFile, statbuf.st_size, XDR_DECODE);
	- }
	- str->device = NULL;
	- str->vsn = NULL;
	- str->filenumber = -1;
	- str->minlrec = -1;
	- str->maxlrec = -1;
	- str->shead = NULL;
	- str->ehead = NULL;
	- str->table = NULL;
	- str->buffer = NULL;
	- str->buffer2 = NULL;
	- p1 = xdr_getpos(str->xdr);
	- str->firstPos = p1;
	- str->status = MCFIO_BOF;
	- str->fhead = NULL;
	- oldNumOfNTuples = NumOfNTuples;
	- if (xdr_mcfast_fileheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->fhead), str->id) == FALSE) {
	- fprintf (stderr,
	- "mcfio_OpenReadDirect: Unable to decode fileheader \n");
	- mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	- mcfioC_Close(jstr+1);
	- return -1;
	- }
	- if (idtmp != FILEHEADER) {
	- fprintf (stderr,
	- "mcfio_OpenReadDirect: First Structure not the header \n");
	-
	- fprintf (stderr,
	- " : Further accesses probably suspicious \n");
	- mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	- mcfioC_Close(jstr+1);
	- return -1;
	- }
	- p2 = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- /*
	- ** Check if new these Ntuple template are not reference, if so,
	- ** set the reference pointer accordingly, conversely, recompute the
	- ** offsets and length if requested. We also fill the sequential
	- ** id number for the descriptors. Note: those are trivial for
	- ** input streams, but we still fill them for consitency.
	- */
	- for (i=0; i<str->fhead->nNTuples; i++) {
	- ddl = mcf_GetNTuByPtrID((oldNumOfNTuples+i+1));
	- if (ddl == NULL) continue;
	- ddl->streamId = (jstr+1);
	- ddl->seqNTuId = (i+1);
	- if (ddl->descrNtu == NULL) {
	- for (j=0, jdRef=1; j<i; j++, jdRef++) {
	- if (jdRef == ddl->referenceId) {
	- ddlRef = mcf_GetNTuByPtrID((oldNumOfNTuples+j+1));
	- /*
	- ** back up in the linked list if need be, until we
	- ** a fully documented descriptor.
	- */
	- while (ddlRef->descrNtu == NULL) ddlRef = ddlRef->reference;
	- ddl->reference = ddlRef;
	- break;
	- }
	- }
	- } else {
	- if (McfNTuPleSaveDecoding == TRUE) {
	- mcf_ComputeNTuOffsets(ddl);
	- mcf_ComputeNTuLengths(ddl);
	- }
	- }
	- }
	- str->currentPos = p2;
	- str->fhead->firstTable = p2;
	- /* presumably correct , assume standard direct acces file config. */
	- str->numWordsT += ((p2-p1)/4);
	- str->status = MCFIO_RUNNING;
	- str->table = (mcfxdrEventTable *) malloc(sizeof(mcfxdrEventTable));
	- str->table->nextLocator = -1;
	- str->table->dim = str->fhead->dimTable;
	- str->table->numevts = 0;
	- str->table->previousnumevts = 0;
	- str->table->evtnums = NULL;
	- str->table->storenums = NULL;
	- str->table->runnums = NULL;
	- str->table->trigMasks = NULL;
	- str->table->ptrEvents = NULL;
	- str->ehead = (mcfxdrEventHeader *) malloc(sizeof(mcfxdrEventHeader));
	- str->ehead->dimBlocks = str->fhead->nBlocks;
	- str->ehead->blockIds = NULL;
	- str->ehead->ptrBlocks = NULL;
	- str->ehead->dimNTuples = str->fhead->nNTuples;
	- str->ehead->nTupleIds = NULL;
	- str->ehead->ptrNTuples = NULL;
	- McfNumOfStreamActive++;
	- return (jstr+1);
	-}
	-
	-int mcfioC_OpenWriteDirect(char filename, char title, char *comment,
	- int numevts_pred, int *blkIds, u_int nBlocks)
	-
	-/*
	-** Routine to open and write the header file for a Direct access Stream.
	-*/
	-{
	- int i, jstr, idtmp, ntot;
	- u_int p1, p2;
	- FILE *ff;
	- mcfStream *str;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: We will first initialize by calling mcfio_Init.\n");
	- mcfioC_Init();
	- }
	- if (McfNumOfStreamActive >= MCF_STREAM_NUM_MAX) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: Too many streams opened simultaneously.\n");
	- return -1;
	- }
	- jstr = -1; i=0;
	- while ((jstr == -1) && (i<MCF_STREAM_NUM_MAX)) {
	- if (McfStreamPtrList[i] == NULL) jstr=i;
	- i++;
	- }
	- if(jstr == -1) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: Internal error, please report \n");
	- return -1;
	- }
	- if ((filename == NULL) \|\| (strlen(filename) > 255)) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: You must give a valid UNIX filename.\n");
	- return -1;
	- }
	- if ((title != NULL) && (strlen(title) > 255)) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: Title is too long\n");
	- return -1;
	- }
	-
	- if ((comment != NULL) && (strlen(comment) > 255)) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: comment is too long\n");
	- return -1;
	- }
	-
	- /*
	- ** Now we can try to open this file....
	- */
	- ff = fopen(filename, "w");
	- if (ff == NULL) {
	- fprintf(stderr,
	- " mcfio_OpenWriteDirect: Problem opening file %s, message \n", filename);
	- perror ("mcfio_OpenWriteDirect");
	- return -1;
	- }
	- McfStreamPtrList[jstr] = (mcfStream *) malloc(sizeof(mcfStream));
	- str = McfStreamPtrList[jstr];
	- str->xdr = (XDR *) malloc(sizeof(XDR));
	- str->id = jstr+1;
	- str->row = MCFIO_WRITE;
	- str->dos = MCFIO_DIRECT;
	- str->numWordsC = 0;
	- str->numWordsT = 0;
	- str->filename = (char ) malloc(sizeof(char) ( strlen(filename) +1) );
	- strcpy(str->filename,filename);
	- str->filePtr = ff;
	- str->device = NULL;
	- str->vsn = NULL;
	- str->filenumber = -1;
	- str->minlrec = -1;
	- str->maxlrec = -1;
	- str->shead = NULL;
	- str->ehead = NULL;
	- str->table = NULL;
	- str->buffer = NULL;
	- str->buffer2 = NULL;
	- xdrstdio_create(str->xdr, ff, XDR_ENCODE);
	- p1 = xdr_getpos(str->xdr);
	- str->firstPos = p1;
	- str->currentPos = p1;
	- str->status = MCFIO_BOF;
	- str->fhead = (mcfxdrFileHeader *) malloc(sizeof(mcfxdrFileHeader));
	- /*
	- ** Fill the file header, additional info will be written on tape
	- */
	- if (title == NULL) strcpy(str->fhead->title,"No Title given");
	- else strcpy(str->fhead->title,title);
	-
	- if (comment == NULL) strcpy(str->fhead->comment,"No comment");
	- else strcpy(str->fhead->comment, comment);
	- str->fhead->numevts_expect = numevts_pred;
	- str->fhead->numevts = 0;
	- /*
	- ** Futur expansion : make this a tunable parameter.
	- */
	- str->fhead->dimTable = MCF_DEFAULT_TABLE_SIZE;
	- str->fhead->firstTable = -1;
	- str->fhead->nBlocks = nBlocks;
	- if (nBlocks > 0) {
	- str->fhead->blockIds = (int ) malloc(sizeof(int) nBlocks);
	- str->fhead->blockNames = (char*) malloc(sizeof(char ) * nBlocks);
	- } else {
	- str->fhead->blockIds = NULL;
	- str->fhead->blockNames = NULL;
	- }
	- for (i=0; i<nBlocks; i++) {
	- str->fhead->blockIds[i] = blkIds[i];
	- str->fhead->blockNames[i] =
	- (char ) malloc(sizeof(char) (MCF_XDR_B_TITLE_LENGTH + 1));
	- mcfioC_GetBlockName(blkIds[i], str->fhead->blockNames[i]);
	- }
	- str->fhead->nNTuples = 0; /* Will be filled later */
	- if (mcfioC_Wrtfhead(str, INITIATE) == FALSE){
	- mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	- fclose(ff);
	- return -1;
	- }
	- str->table = (mcfxdrEventTable *) malloc(sizeof(mcfxdrEventTable));
	- str->table->numevts=-1;
	- str->table->nextLocator = -1;
	- str->table->evtnums = (int ) malloc(sizeof(int) str->fhead->dimTable);
	- str->table->storenums = (int ) malloc(sizeof(int) str->fhead->dimTable);
	- str->table->runnums = (int ) malloc(sizeof(int) str->fhead->dimTable);
	- str->table->trigMasks = (int ) malloc(sizeof(int) str->fhead->dimTable);
	- str->table->ptrEvents =
	- (u_int ) malloc(sizeof(int) str->fhead->dimTable);
	- /*
	- ** Write the first dummy table
	- */
	- if (mcfioC_Wrttable(str, INITIATE) == FALSE) return -1;
	- str->ehead = (mcfxdrEventHeader *) malloc(sizeof(mcfxdrEventHeader));
	- str->ehead->dimBlocks = str->fhead->nBlocks;
	- str->ehead->nBlocks = 0;
	- str->ehead->dimNTuples = 0;
	- str->ehead->nNTuples = 0;
	- str->ehead->evtnum = 0;
	- str->ehead->previousevtnum = 0;
	- str->ehead->storenum = 0;
	- str->ehead->runnum = 0;
	- str->ehead->trigMask = 0;
	- str->ehead->nTupleIds = NULL;
	- str->ehead->ptrNTuples = NULL;
	- if (nBlocks > 0) {
	- str->ehead->blockIds =
	- (int ) malloc(sizeof(int) str->fhead->nBlocks);
	- str->ehead->ptrBlocks =
	- (u_int ) malloc(sizeof(int) str->fhead->nBlocks);
	- } else {
	- str->ehead->blockIds = NULL;
	- str->ehead->ptrBlocks = NULL;
	- }
	- /*
	- ** Write the first dummy event header
	- */
	- if (mcfioC_WrtEvt(str, INITIATE) == FALSE) return -1;
	- str->ehead->evtnum = 0;
	- str->status = MCFIO_RUNNING;
	- McfNumOfStreamActive++;
	- return (jstr+1);
	-
	-}
	-
	-int mcfioC_NextEvent(int stream)
	-/*
	-** The Core routine for getting or setting the next event d.s. from/to
	-** a stream.
	-**
	-*/
	-{
	- int i, jstr, idtmp, ntot, nn1;
	- u_int p_evt, p1, p2, *p_ptr;
	- mcfStream *str;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_NextEvent: You must first initialize by calling mcfio_Init.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_NextEvent: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str->dos == MCFIO_SEQUENTIAL) return mcfioC_NextEventSequential(stream);
	- if (str->row == MCFIO_READ) {
	- /*
	- ** Read the next event, hunt for either an event or a table of event
	- ** if event table not available.
	- */
	- if ((str->table == NULL) \|\|
	- ((str->table != NULL)&& (str->table->evtnums == NULL))) {
	- idtmp = mcfioC_gofornextevent(str);
	- if (idtmp != EVENTTABLE) {
	- if (str->table !=NULL)
	- mcfioC_Free_EventTable(&(str->table));
	- if (idtmp == NOTHING) return -1;
	- p_evt = str->currentPos;
	- } else {
	- if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NextEvent: XDR Error decoding the EventTable \n");
	- return -1;
	- }
	- p2 = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((p2-str->currentPos)/4);
	- str->currentPos = p2;
	- str->table->ievt = 0;
	- /*
	- ** If table empty, cal this routine recursively to get
	- ** the next event
	- */
	- if (str->table->numevts <= 0) {
	- if (str->table->nextLocator == -1)
	- mcfioC_Free_EventTable(&(str->table));
	- return mcfioC_NextEvent(str->id);
	- }
	- p_evt = str->table->ptrEvents[0];
	- }
	- } else {
	- if (str->table->ievt < str->table->numevts) {
	- p_evt = str->table->ptrEvents[str->table->ievt];
	- } else {
	- /*
	- ** decode the next table, if valid. If not, scrap the
	- ** existing table and call next event recursively.
	- */
	- if (str->table->nextLocator == -2) {
	- /*
	- ** Stream is at EOF
	- */
	- str->status = MCFIO_EOF;
	- return MCFIO_EOF;
	- } else if (str->table->nextLocator == -1) {
	- fprintf(stderr,
	- " mcfio_NextEvent: Corrupted Event Table \n");
	- return -1;
	- }
	- if (xdr_setpos(str->xdr, str->table->nextLocator) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NextEvent: Error Repositioning stream \n");
	- return -1;
	- }
	- if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NextEvent: XDR Error decoding the EventTable \n");
	- return -1;
	- }
	- p2 = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((p2-str->currentPos)/4);
	- str->currentPos = p2;
	- str->table->ievt = 0;
	- p_evt = str->table->ptrEvents[0];
	- }
	- }
	- /*
	- ** we should be pointing to a good event header here.
	- */
	- if (xdr_setpos(str->xdr, p_evt) == FALSE) return -1;
	- if( xdr_mcfast_eventheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return -1;
	- str->currentPos = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((str->currentPos - p_evt)/4);
	- if (str->table != NULL) str->table->ievt ++;
	- return MCFIO_RUNNING;
	- } else {
	- /*
	- ** Writing Code here.
	- */
	- str->table->numevts++;
	- str->fhead->numevts++;
	- if (str->ehead->previousevtnum == str->ehead->evtnum) str->ehead->evtnum++;
	- /*
	- ** Write the current event header, normal case. First Flush the current
	- ** event, then initiate the next one event. Note that wrtevt will
	- ** reposition the stream after rewriting the event header, if FLUSH.
	- ** e.g. ready to initiate either a new table or a new event.
	- */
	- if (mcfioC_WrtEvt(str, FLUSH) == FALSE) return -1;
	- str->ehead->previousevtnum = str->ehead->evtnum;
	- if (str->table->numevts == (str->fhead->dimTable - 1)) {
	- /*
	- ** The Event table is now full. Flush it. Then initiate a new table.
	- */
	- str->table->nextLocator = xdr_getpos(str->xdr);
	- if (mcfioC_Wrttable(str, FLUSH) == FALSE) return -1;
	- if (mcfioC_Wrttable(str, INITIATE) == FALSE) return -1;
	- }
	- str->ehead->nBlocks = 0;
	- str->ehead->nNTuples = 0;
	- nn1 = str->ehead->evtnum;
	- if (mcfioC_WrtEvt(str, INITIATE) == FALSE) return -1;
	- str->ehead->evtnum = nn1;
	- return MCFIO_RUNNING;
	- }
	-}
	-
	-int mcfioC_SpecificEvent(int stream, int ievt,
	- int istore, int irun, int itrig)
	-{
	- int i, jstr, idtmp, ntot, ok, nn1;
	- u_int p_evt, p1, p2, *p_ptr;
	- mcfStream *str;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_SpecificEvent: You must first initialize by calling mcfio_Init.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_SpecificEvent: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	- str = McfStreamPtrList[jstr];
	- if ((str->row != MCFIO_READ) \|\| (str->dos == MCFIO_SEQUENTIAL)) {
	- fprintf(stderr,
	-" mcfio_SpecificEvent: Only valid for INPUT, DIRECT ACCESS \
	- or Memory Mapped \n");
	- return -1;
	- }
	- if (xdr_setpos(str->xdr, str->fhead->firstTable) == FALSE ) {
	- fprintf(stderr,
	- " mcfio_SpecificEvent: Could not reposition Direct Access Stream %d \n",
	- (jstr+1)) ;
	- return -1;
	- }
	- str->currentPos = str->fhead->firstTable;
	-
	- ok = mcfioC_nextspecevt(str, ievt, istore, irun, itrig);
	- if (ok == FALSE) {
	- mcfioC_RewindDirect(jstr);
	- if (xdr_setpos(str->xdr, str->fhead->firstTable) == FALSE ) {
	- fprintf(stderr,
	- " mcfio_SpecificEvent: Could not reposition Direct Access Stream %d \n",
	- (jstr+1)) ;
	- return -1;
	- }
	- str->currentPos = str->fhead->firstTable;
	- ok = mcfioC_nextspecevt(str, ievt, istore, irun, itrig);
	- }
	- if (ok == FALSE) return -1;
	- return ok;
	-
	-}
	-int mcfioC_NextSpecificEvent(int stream, int ievt,
	- int istore, int irun, int itrig)
	-{
	- int i, jstr, idtmp, ntot, ok, nn1;
	- u_int p_evt, p1, p2, *p_ptr;
	- mcfStream *str;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_NextSpecific: You must first initialize by calling mcfio_Init.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_NextSpecific: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	- str = McfStreamPtrList[jstr];
	- if ((str->row != MCFIO_READ) \|\| (str->dos == MCFIO_SEQUENTIAL)) {
	- fprintf(stderr,
	- " mcfio_NextSpecificEvent: Only valid for INPUT, DIRECT ACCESS\
	- or memory mapped I/O \n");
	- return -1;
	- }
	- ok = mcfioC_nextspecevt(str, ievt, istore, irun, itrig);
	- if (ok == FALSE) return -1;
	- return ok;
	-
	-}
	-
	-
	-void mcfioC_CloseDirect(int jstr)
	-/*
	-** Close a direct access stream, Standard I/O or Memory Mapped
	-**
	-*/
	-{
	- int i, idtmp, ntot;
	- u_int p1, p2, *p_ptr;
	- FILE *ff;
	- mcfStream *str;
	- nTuDDL *ddl;
	-
	- str = McfStreamPtrList[jstr];
	- if (str->row == MCFIO_WRITE) {
	- /*
	- ** Flush the event header, and the last table header.
	- */
	- if (str->status == MCFIO_RUNNING) {
	- str->table->numevts++;
	- str->ehead->evtnum++;
	- if (mcfioC_WrtEvt(str, FLUSH) == FALSE) return;
	- str->table->nextLocator = -2;
	- str->table->numevts--; /* Decrement, the table is incomplete at
	- this point */
	- if (mcfioC_Wrttable(str, FLUSH) == FALSE) return;
	- if (mcfioC_Wrtfhead(str, FLUSH) == FALSE) return;
	- }
	- }
	- xdr_destroy(str->xdr);
	- if (str->dos == MCFIO_DIRECT) {
	- fclose(str->filePtr);
	- } else {
	- /*
	- ** Memory mapped I/O, one has to unmapped..
	- */
	- munmap((caddr_t) str->fileAddr, str->fileLen);
	- close(str->fileDescr);
	- }
	- /*
	- ** One must declare the Ntuples obsolete for this stream.
	- ** Do not release the memory, just flag these Ntuple with an obsolete
	- ** stream
	- */
	- for (i=0; i<NumOfNTuples; i++) {
	- ddl = mcf_GetNTuByPtrID((i+1));
	- if ((ddl != NULL) && (ddl->streamId == (jstr+1)))
	- ddl->streamId = -1;
	- }
	-}
	-
	-void mcfioC_RewindDirect(int jstr)
	-/*
	-** Rewind a direct access stream, open for Read only
	-**
	-*/
	-{
	- mcfStream *str;
	-
	- str = McfStreamPtrList[jstr];
	- if (xdr_setpos(str->xdr, str->fhead->firstTable) == FALSE )
	- fprintf(stderr,
	- " mcfio_Rewind: Could not reposition Direct Access Stream %d \n",
	- (jstr+1)) ;
	- str->currentPos = str->fhead->firstTable;
	- if (str->table != NULL) {
	- str->table->nextLocator = str->fhead->firstTable;
	- str->table->numevts = 0;
	- str->table->previousnumevts = 0;
	- }
	- if (str->ehead != NULL) {
	- str->ehead->evtnum = 0;
	- str->ehead->previousevtnum = 0;
	- }
	- return;
	-}
	-
	-int mcfioC_Wrtfhead(mcfStream *str, int mode)
	-/*
	-** Write the file header.
	-** IF Mode = INITIATE, write the dummy information, at the current location.
	-** IF mode = Flush, rewite all the information, this time with the
	-** correct number of events.
	-**
	-*/
	-{
	- int idtmp, ntot;
	- u_int p1, p0;
	- int k;
	- time_t clock;
	-
	- idtmp = FILEHEADER;
	- if (mode == FLUSH) {
	- time(&clock);
	- strcpy(str->fhead->closingDate, ctime(&clock));
	- if(xdr_setpos(str->xdr,str->firstPos) == FALSE) return FALSE;
	- if (xdr_mcfast_fileheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->fhead), str->id) == FALSE) {
	- fprintf (stderr,
	- "mcfio_OpenCloseDirect: Unable to reencode file head \n");
	- return FALSE;
	- }
	- /*
	- ** The version of MCFIO is still at this point v2.0
	- */
	- } else if (mode == INITIATE) {
	- /* Put the current date/time in a string */
	- time(&clock);
	- strcpy(str->fhead->date, ctime(&clock));
	- /*
	- ** We obviously do not have the closing times stamp yet (Causality)
	- ** So we put ?, however, we have to put the right number of them,
	- ** the we do not screw up the XDR pointers..
	- */
	- for (k=0; k<strlen(ctime(&clock)); k++) str->fhead->closingDate[k] = '?';
	- str->fhead->closingDate[strlen(ctime(&clock))] = '\0';
	- p0 = str->currentPos;
	- if (xdr_mcfast_fileheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->fhead), str->id) == FALSE) {
	- fprintf (stderr,
	- "mcfio_OpenWriteDirect: Unable to encode fileheader \n");
	- return FALSE;
	- }
	- p1 = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((p1-p0)/4);
	- str->currentPos = p1;
	- return TRUE;
	- } else {
	- fprintf(stderr," mcfioC_Wrtfhead: Internal error, lost mode \n");
	- return FALSE;
	- }
	- return TRUE;
	-}
	-
	-
	-int mcfioC_WrtEvt(mcfStream *str, int mode)
	-/*
	-** Write an event header, and update the table. Presumably, we have room
	-** in this table to do so.
	-** IF Mode = INITIATE, write the dummy event header, at the current location.
	-** Do not fill the element table.
	-** If mode = FLUSH write the real event header and also
	-** fill the Table elements.
	-**
	-*/
	-{
	- int i, idtmp, ntot;
	- u_int p1, p0;
	-
	- idtmp = EVENTHEADER;
	- if (mode == FLUSH) {
	- str->table->evtnums[str->table->numevts] = str->ehead->evtnum;
	- str->table->storenums[str->table->numevts] = str->ehead->storenum;
	- str->table->runnums[str->table->numevts] = str->ehead->runnum;
	- str->table->trigMasks[str->table->numevts] = str->ehead->trigMask;
	- str->table->ptrEvents[str->table->numevts] = str->evtPos;
	- p0 = str->currentPos;
	- if(xdr_setpos(str->xdr,str->evtPos) == FALSE) return FALSE;
	- p1 = str->evtPos;
	- if(xdr_mcfast_eventheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return FALSE;
	- str->currentPos = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((str->currentPos-p1)/4);
	- if(xdr_setpos(str->xdr,p0) == FALSE) return FALSE;
	- str->currentPos = p0;
	- str->ehead->nBlocks = 0;
	- str->ehead->nNTuples = 0;
	- return TRUE;
	- } else if (mode == INITIATE) {
	- str->ehead->nBlocks = 0; /do not initialize nNTuples, already done /
	- str->ehead->evtnum = -1;
	- str->evtPos = xdr_getpos(str->xdr);
	-
	- if(xdr_mcfast_eventheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return FALSE;
	- str->currentPos = xdr_getpos(str->xdr);
	- return TRUE;
	- } else {
	- fprintf(stderr," mcfioC_WrtEvt: Internal error, lost mode \n");
	- return FALSE;
	- }
	-}
	-
	-int mcfioC_Wrttable(mcfStream *str, int mode)
	-/*
	-** Write an event table.
	-** IF Mode = INITIATE, write the dummy event table, at the current location.
	-** Do not fill the element table.
	-** If mode = FLUSH write the real event header and also
	-** fill the Table elements.
	-**
	-*/
	-{
	- int idtmp, ntot;
	- u_int p1, p0;
	-
	- idtmp = EVENTTABLE;
	- str->table->dim = str->fhead->dimTable;
	- if (mode == FLUSH) {
	- p0 = str->currentPos;
	- if(xdr_setpos(str->xdr,str->tablePos) == FALSE) return FALSE;
	- p1 = str->tablePos;
	- str->table->numevts++;
	- if(xdr_mcfast_eventtable(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->table)) == FALSE) return FALSE;
	- str->currentPos = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((str->currentPos-p1)/4);
	- if(xdr_setpos(str->xdr,p0) == FALSE) return FALSE;
	- str->currentPos = p0;
	- str->tablePos = -1;
	- str->table->nextLocator = -1;
	- str->table->numevts=-1;
	- return TRUE;
	- } else if (mode == INITIATE) {
	- str->tablePos = xdr_getpos(str->xdr);
	- str->table->nextLocator = -1;
	- if(xdr_mcfast_eventtable(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->table)) == FALSE) return FALSE;
	- str->currentPos = xdr_getpos(str->xdr);
	- return TRUE;
	- } else {
	- fprintf(stderr," mcfioC_Wrttable: Internal error, lost mode \n");
	- return FALSE;
	- }
	-}
	-
	-static int mcfioC_gofornextevent(mcfStream *str)
	-/*
	-** Move in the direct access file to the next event or event table,
	-** whatever comes first. The XDR current position is set to the beginning
	-** of the event header or event table, if search sucessfull.
	-** We position the stream to the last Block or Ntuple defined in
	-** the current event.
	-*/
	-{
	- u_int p1, p2;
	- int id, ntot, go;
	-
	- go = TRUE;
	-
	- while (go == TRUE) {
	- p1 = xdr_getpos(str->xdr);
	- if (xdr_mcfast_headerBlock(str->xdr, &id, &ntot, McfGenericVersion)
	- == FALSE) return NOTHING;
	- if ((id == EVENTTABLE) \|\| (id == EVENTHEADER)) {
	- str->currentPos = p1;
	- if(xdr_setpos(str->xdr, p1) == FALSE) return NOTHING;
	- return id;
	- }
	- }
	- return NOTHING; /* This statement is to make the compiler happy */
	-}
	-
	-static int mcfioC_nextspecevt(mcfStream *str, int inum, int istore,
	- int irun, int itrig)
	-/*
	-** For Input, Direct access streams, hunt for a psecific event
	-**
	-*/
	-{
	- int i, jstr, j, idtmp, ntot, found;
	- u_int p_evt, p1, p2, *p_ptr;
	-
	- if ((str->table == NULL) \|\|
	- ((str->table != NULL)&& (str->table->evtnums == NULL))) {
	- idtmp = mcfioC_gofornextevent(str);
	- if (idtmp != EVENTTABLE) {
	- fprintf(stderr,
	- " mcfio_SpecificEvent: No event table on stream %d \n", str->id);
	- return FALSE;
	- } else {
	- if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	- fprintf(stderr,
	- " mcfio_SpecificEvent: XDR Error decoding the EventTable \n");
	- return FALSE;
	- }
	- p2 = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((p2-str->currentPos)/4);
	- str->currentPos = p2;
	- str->table->ievt = 0;
	- /*
	- ** If table empty, cal this routine recursively to get
	- ** the next event
	- */
	- str->table->ievt = 0;
	- }
	- }
	- found = FALSE;
	- while (found == FALSE){
	- j = str->table->ievt;
	- if (str->table->ievt < str->table->numevts) {
	- if (((inum == 0)
	- \|\| ( inum != 0 && (str->table->evtnums[j] == inum))) &&
	- (((istore == 0)
	- \|\| (istore != 0) && (str->table->storenums[j] == istore))) &&
	- (((irun == 0)
	- \|\| (irun != 0) && (str->table->runnums[j] == irun))) &&
	- (((itrig == 0)
	- \|\| (itrig != 0) && (str->table->trigMasks[j] == itrig))))
	- found = TRUE;
	- p_evt = str->table->ptrEvents[str->table->ievt];
	- str->table->ievt++;
	- } else {
	- /*
	- ** decode the next table, if valid. If not, scrap the
	- ** existing table and call next event recursively.
	- */
	- if (str->table->nextLocator == -2) {
	- /*
	- ** Stream is at EOF
	- */
	- str->status = MCFIO_EOF;
	-
	- return FALSE;
	-
	- } else if (str->table->nextLocator == -1) {
	- fprintf(stderr,
	- " mcfio_NextEvent: Next EventTable corrupted, abandoning search \n");
	- return FALSE;
	- }
	- if (xdr_setpos(str->xdr, str->table->nextLocator)
	- == FALSE) { fprintf(stderr,
	- " mcfio_NextEvent: XDR Error repositioning to the next EventTable \n");
	- return FALSE;
	- } else {
	- if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NextEvent: XDR Error decoding the EventTable \n");
	- return FALSE;
	- }
	- }
	- p2 = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((p2-str->currentPos)/4);
	- str->currentPos = p2;
	- str->table->ievt = 0;
	- p_evt = str->table->ptrEvents[0];
	- }
	- }
	- if (found == FALSE) return FALSE;
	- /*
	- ** we should be pointing to a good event header here.
	- */
	- if (xdr_setpos(str->xdr, p_evt) == FALSE) return FALSE;
	- if( xdr_mcfast_eventheader(str->xdr, &idtmp,
	- &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return FALSE;
	- str->currentPos = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((str->currentPos - p_evt)/4);
	- return MCFIO_RUNNING;
	-
	-}
	Index: trunk/mcfio/Makefile.am
	===================================================================
	--- trunk/mcfio/Makefile.am (revision 8888)
	+++ trunk/mcfio/Makefile.am (revision 8889)
	@@ -1,93 +0,0 @@
	-## Makefile.am -- Makefile for WHIZARD
	-##
	-## Process this file with automake to produce Makefile.in
	-##
	-########################################################################
	-#
	-# Copyright (C) 1999-2023 by
	-# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	-# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	-# Juergen Reuter <juergen.reuter@desy.de>
	-# with contributions from
	-# cf. main AUTHORS file
	-#
	-# WHIZARD is free software; you can redistribute it and/or modify it
	-# under the terms of the GNU General Public License as published by
	-# the Free Software Foundation; either version 2, or (at your option)
	-# any later version.
	-#
	-# WHIZARD is distributed in the hope that it will be useful, but
	-# WITHOUT ANY WARRANTY; without even the implied warranty of
	-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	-# GNU General Public License for more details.
	-#
	-# You should have received a copy of the GNU General Public License
	-# along with this program; if not, write to the Free Software
	-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	-#
	-########################################################################
	-
	-## The files in this directory end up in an auxiliary libtool library.
	-AM_FCFLAGS =
	-AM_FFLAGS =
	-AM_CFLAGS = $(RPC_CFLAGS)
	-
	-noinst_LTLIBRARIES = libwo_mcfio.la
	-
	-libwo_mcfio_la_SOURCES = \
	- mcfio_FPrintDictionary.f \
	- mcfio_Util1.h \
	- mcfio_Util1.c \
	- mcf_ntuBldDbinc.h \
	- mcf_ntuBldDbinc.c \
	- mcf_NTuIOUtils.h \
	- mcf_NTuIOUtils.c \
	- mcf_NTuIOFiles.h \
	- mcf_NTuIOFiles.c \
	- mcfio_UserDictionary.h \
	- mcfio_UserDictionary.c \
	- mcf_evt_xdr.c \
	- mcfio_FBinding.c \
	- mcfio_Direct.h \
	- mcfio_Direct.c \
	- mcfio_SeqDummy.c \
	- mcfio_Block.c \
	- mcf_ntubldInit.c \
	- mcf_nTupleDescript.h \
	- mcf_ntubld_db.h \
	- mcf_xdr.h \
	- mcf_xdr_Ntuple.h \
	- mcfio_Block.h \
	- mcfio_Dict.h \
	- mcfio_Sequential.h
	-
	-SUFFIXES: .lo .$(FC_MODULE_EXT)
	-
	-########################################################################
	-## Default Fortran compiler options
	-
	-## Profiling
	-if FC_USE_PROFILING
	-AM_FCFLAGS += $(FCFLAGS_PROFILING)
	-AM_FFLAGS += $(FCFLAGS_PROFILING)
	-endif
	-
	-## OpenMP
	-if FC_USE_OPENMP
	-AM_FCFLAGS += $(FCFLAGS_OPENMP)
	-AM_FFLAGS += $(FCFLAGS_OPENMP)
	-endif
	-
	-########################################################################
	-## Non-standard cleanup tasks
	-
	-## Remove F90 module files
	-clean-local:
	- -rm -f *.$(FC_MODULE_EXT)
	-if FC_SUBMODULES
	- -rm -f *.smod
	-endif
	-
	-## Remove backup files
	-maintainer-clean-local:
	- -rm -f *~
	Index: trunk/mcfio/mcfio_Sequential.h
	===================================================================
	--- trunk/mcfio/mcfio_Sequential.h (revision 8888)
	+++ trunk/mcfio/mcfio_Sequential.h (revision 8889)
	@@ -1,15 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mc_Sequential.h -- Include file for mcfast Sequential i/o layer. *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-*******************************************************************************/
	-int mcfioC_OpenReadSequential(char device, char label, int filenumber);
	-int mcfioC_OpenWriteSequential(char device, char label, char *title,
	- char *comment, int numevts_pred,
	- int *blkIds, unsigned int nBlocks);
	-int mcfioC_NextEventSequential(int stream);
	-void mcfioC_CloseSequentialFile(int stream);
	-void mcfioC_CloseSequentialTape(int stream);
	Index: trunk/mcfio/mcfio_Direct.h
	===================================================================
	--- trunk/mcfio/mcfio_Direct.h (revision 8888)
	+++ trunk/mcfio/mcfio_Direct.h (revision 8889)
	@@ -1,24 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_Direct.h -- Include file for mcfast Direct i/o layer. *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-*******************************************************************************/
	-#define INITIATE 3
	-#define FLUSH 4
	-int mcfioC_OpenReadDirect(char *filename);
	-int mcfioC_OpenReadMapped(char *filename);
	-int mcfioC_OpenWriteDirect(char filename, char title, char *comment,
	- int numevts_pred, int *blkIds, u_int nBlocks);
	-int mcfioC_NextEvent(int stream);
	-int mcfioC_SpecificEvent(int stream, int ievt,
	- int istore, int irun, int itrig);
	-int mcfioC_NextSpecificEvent(int stream, int ievt,
	- int istore, int irun, int itrig);
	-void mcfioC_CloseDirect(int jstr);
	-void mcfioC_RewindDirect(int jstr);
	-int mcfioC_WrtEvt(mcfStream *str, int mode);
	-int mcfioC_Wrttable(mcfStream *str, int mode);
	-int mcfioC_Wrtfhead(mcfStream *str, int mode);
	Index: trunk/mcfio/mcfio_FBinding.c
	===================================================================
	--- trunk/mcfio/mcfio_FBinding.c (revision 8888)
	+++ trunk/mcfio/mcfio_FBinding.c (revision 8889)
	@@ -1,428 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_FBinding.c -- Utility routines for the McFast Monte-Carlo *
	-* Fortran Application Interface. *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun *
	-* The mallocNCopyMcfio and CleanFortranString have been borrowed from the *
	-* Nirvana project. *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <limits.h>
	-#include <stdlib.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcfio_Dict.h"
	-#include "mcfio_Util1.h"
	-#include "mcfio_UserDictionary.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcf_NTuIOFiles.h"
	-#include "mcfio_Direct.h"
	-#include "mcfio_Sequential.h"
	-#include "mcfio_Block.h"
	-
	-char mallocNCopyMcfio(char string, int length);
	-static void cleanFortranString(char *string, int length);
	-
	-void mcfio_init_(void)
	-{
	- mcfioC_Init();
	-}
	-
	-void mcfio_rewind_(int *stream)
	-{
	- mcfioC_Rewind(*stream);
	-}
	-
	-void mcfio_close_(int *stream)
	-{
	- mcfioC_Close(*stream);
	-}
	-
	-void mcfio_closesequentialfile_(int *stream)
	-{
	- mcfioC_CloseSequentialFile(*stream);
	-}
	-
	-void mcfio_closesequentialtape_(int *stream)
	-{
	- mcfioC_CloseSequentialTape(*stream);
	-}
	-
	-void mcfio_printdictionary_(void)
	-{
	- mcfioC_PrintDictionary();
	-}
	-
	-unsigned int mcfio_infonumstream_(int istreams, int nmax)
	-{
	- return mcfioC_InfoNumStream(istreams, (unsigned int) *nmax);
	-}
	-
	-void mcfio_infostreamint_(int stream, int key, int *values)
	-{
	- mcfioC_InfoStreamInt(stream, key, values);
	-}
	-
	-void mcfio_infostreamchar_(int stream, int key,
	- char answer, int lret, int length)
	-{
	- char *aString;
	- int ll1;
	- /* Rely on the fact that the maximum char. length is probably FILENAME_MAX
	- for information content, that is, 1024 on IRIX and other systems */
	- aString = (char ) malloc((FILENAME_MAX + 1) sizeof(char));
	- mcfioC_InfoStreamChar(stream, key, aString, lret);
	- ll1 = *lret;
	- if (ll1 > length) ll1 = length;
	- strncpy(answer, aString, ll1);
	- free(aString);
	-}
	-
	-void mcfio_infoeventint_(int Event, int key, int *values)
	-{
	- mcfioC_InfoEventInt(Event, key, values);
	-}
	-
	-void mcfio_infoeventchar_(int Event, int key, char *answer,
	- int *lret, int length)
	-{
	- char *aString;
	- int ll1;
	-
	- aString = (char ) malloc(sizeof(char) (FILENAME_MAX + 1));
	- mcfioC_InfoEventChar(Event, key, aString, lret);
	- ll1 = *lret;
	- if (ll1 > length) ll1 = length;
	- strncpy(answer, aString, ll1);
	- free(aString);
	-}
	-
	-void mcfio_seteventinfo_(int Event, int key, int *values)
	-{
	- mcfioC_SetEventInfo(Event, key, values);
	-}
	-
	-void mcfio_infoblockchar_(int Event, int blkId,
	- int key, char answer, int *lret, int length)
	-{
	- char *aString;
	-
	- int ll1;
	-
	- aString = (char ) malloc(sizeof(char) (FILENAME_MAX + 1));
	- mcfioC_InfoBlockChar(Event, blkId, *key, aString, lret);
	- ll1 = *lret;
	- if (ll1 > length) ll1 = length;
	- strncpy(answer, aString, ll1);
	- free(aString);
	-}
	-
	-void mcfio_getblockname_(int blkId, char answer, int length)
	-{
	- char *aString;
	-
	- aString = (char ) malloc(sizeof(char) (FILENAME_MAX + 1));
	- mcfioC_GetBlockName(*blkId, aString);
	- strncpy(answer, aString, length);
	- free(aString);
	-}
	-
	-void mcfio_defineuserblock_(int blkId, char name,
	- bool_t xdr_filter, int *current_size, int length)
	-{
	- char *aString;
	-
	- aString = mallocNCopyMcfio(name, length);
	- mcfioC_DefineUserBlock(*blkId, aString);
	- /* Original version which does not match mcfio_UserDictionary.c */
	- /* mcfioC_DefineUserBlock(blkId, aString, xdr_filter, current_size); /
	- free(aString);
	-}
	-
	-int mcfio_declarentuple_(int uid, chartitle, char *category,
	- int stream, char filename, int la, int lb, int lc)
	-{
	- char aString, bString, *cString;
	- int iret;
	-
	- aString = mallocNCopyMcfio(title, la);
	- bString = mallocNCopyMcfio(category, lb);
	- cString = mallocNCopyMcfio(filename, lc);
	- iret = mcfioC_DeclareNtuple(uid, aString, bString, stream, cString);
	- free(aString); free(bString); free(cString);
	- return iret;
	-}
	-
	-int mcfio_enddeclntuples_(int *stream)
	-{
	- return mcfioC_EndDeclNTuples(*stream);
	-}
	-
	-
	-int mcfio_getntupleids_(int stream, int ids, int *max)
	-{
	- return mcfioC_GetNTupleIds(stream, ids, max);
	-}
	-
	-int mcfio_getntupleuid_(int stream, int id)
	-{
	- return mcfioC_GetNTupleUID(stream, id);
	-}
	-
	-int mcfio_getntuplecategory_(int stream, int id, char *category, int ll)
	-{
	- int iret, lret;
	- char *aString;
	- mcfioC_GetNTupleCategory(stream, id, &aString);
	- lret = strlen(aString);
	- if (ll > lret) strcpy(category, aString);
	- else strncpy(category, aString, (ll-1));
	- return lret;
	-}
	-
	-int mcfio_getntupletitle_(int stream, int id, char *title, int ll)
	-{
	- int iret, lret;
	- char *aString;
	- mcfioC_GetNTupleTitle(stream, id, &aString);
	- lret = strlen(aString);
	- if (ll > lret) strcpy(title, aString);
	- else strncpy(title, aString, (ll-1));
	- return lret;
	-}
	-
	-int mcfio_getntuplename_(int stream, int id, char *name, int ll)
	-{
	- int iret, lret;
	- char *aString;
	- mcfioC_GetNTupleName(stream, id, &aString);
	- lret = strlen(aString);
	- if (ll > lret) strcpy(name, aString);
	- else strncpy(name, aString, (ll-1));
	- return lret;
	-}
	-
	-int mcfio_openreaddirect_(char *filename, int length)
	-{
	- char *aString;
	- int iret;
	-
	- aString = mallocNCopyMcfio(filename, length);
	- iret = mcfioC_OpenReadDirect(aString);
	- if (aString != NULL) free(aString);
	- return iret;
	-}
	-
	-int mcfio_openreadmapped_(char *filename, int length)
	-{
	- char *aString;
	- int iret;
	-
	- aString = mallocNCopyMcfio(filename, length);
	- iret = mcfioC_OpenReadMapped(aString);
	- if (aString != NULL) free(aString);
	- return iret;
	-}
	-
	-int mcfio_openreadsequential_(char device, char vsn,
	- int *filenumber, int l1, int l2)
	-{
	- char aString, bString;
	- int iret;
	-
	- aString = mallocNCopyMcfio(device, l1);
	- bString = mallocNCopyMcfio(vsn,l2);
	- iret = mcfioC_OpenReadSequential(aString, bString, *filenumber);
	- if (aString != NULL) free(aString);
	- if (bString != NULL) free(bString);
	- return iret;
	-}
	-
	-void mcfio_setforsavedecoding_(int *value)
	-{
	- mcfioC_SetForSaveDecoding(*value);
	-}
	-
	-int mcfio_openwritedirect_(char filename, char title, char *comment,
	- int numevts_pred, int blkIds, int *nBlocks,
	- int ll1, int ll2, int ll3)
	-{
	- char aString, bString, *cString;
	- int iret;
	-
	- aString = mallocNCopyMcfio(filename, ll1);
	- bString = mallocNCopyMcfio(title, ll2);
	- cString = mallocNCopyMcfio(comment, ll3);
	- iret = mcfioC_OpenWriteDirect(aString, bString, cString,
	- numevts_pred, blkIds, (unsigned int) nBlocks);
	- if (aString != NULL) free(aString);
	- if (bString != NULL) free(bString);
	- if (cString != NULL) free(cString);
	- return iret;
	-}
	-
	-int mcfio_openwritesequential_(char device, char vsn, char *title,
	- char comment, int numevts_pred, int *blkIds,
	- int *nBlocks, int ll1, int ll2, int ll3, int ll4)
	-{
	- char aString, bString, cString, dString;
	- int iret;
	-
	- aString = mallocNCopyMcfio(device, ll1);
	- bString = mallocNCopyMcfio(vsn, ll2);
	- cString = mallocNCopyMcfio(title, ll3);
	- dString = mallocNCopyMcfio(comment, ll4);
	- iret = mcfioC_OpenWriteSequential(aString, bString, cString, dString,
	- numevts_pred, blkIds, (unsigned int) nBlocks);
	- if (aString != NULL) free(aString);
	- if (bString != NULL) free(bString);
	- if (cString != NULL) free(cString);
	- if (dString != NULL) free(dString);
	- return iret;
	-}
	-
	-int mcfio_nextevent_(int *stream)
	-{
	- return mcfioC_NextEvent(*stream);
	-}
	-
	-int mcfio_specificevent_(int stream, int ievt,
	- int istore, int irun, int *itrig)
	-{
	- return mcfioC_SpecificEvent(stream, ievt, istore, irun, *itrig);
	-}
	-
	-int mcfio_nextspecificevent_(int stream,int ievt,
	- int istore, int irun, int *itrig)
	-{
	- return mcfioC_NextSpecificEvent(*stream,
	- ievt, istore, irun, itrig);
	-}
	-
	-int mcfio_block_(int stream, int blkid,
	- bool_t xdr_filtercode(XDR xdrs, int blockid, int ntot, char *version))
	-{
	- return mcfioC_Block(stream, blkid, xdr_filtercode);
	-}
	-
	-int mcfio_ntuple_(int stream, int ntupleid, char *version, int ll)
	-{
	-/*
	-** Note we do not copy the string this time, as we are interested in the
	-** address, not the content
	-*/
	- return mcfioC_NTuple(stream, ntupleid, version);
	-}
	-
	-
	-int mcfio_ntuplemult_(int stream, int ntupleid, char *version, int ll)
	-{
	- return mcfioC_NTupleMult(stream, ntupleid, version);
	-}
	-
	-int mcfio_ntuplevar_(int stream, int ntupleid, int *ivar,
	- char *version, int ll)
	-{
	- int ivarF;
	- ivarF = (*ivar) -1;
	- return mcfioC_NTupleVar(stream, ntupleid, ivarF, version);
	-}
	-
	-int mcfio_ntuplesubvar_(int stream, int ntupleid,
	- int ivar, int multIndex, char *version, int ll)
	-{
	- int ivarF, multIndexF;
	- ivarF = (*ivar) -1;
	- multIndexF = (*multIndex) -1;
	- return mcfioC_NTupleSubVar(stream, ntupleid,
	- ivarF, multIndexF, version);
	-}
	-
	-int mcfio_ntuplesubstruct_(int stream, int ntupleid,
	- int multIndex, char version, int ll)
	-{
	- int multIndexF;
	- multIndexF = (*multIndex) -1;
	- return mcfioC_NTupleSubStruct(stream, ntupleid,
	- multIndexF, version);
	-}
	-
	-
	-char mallocNCopyMcfio(char string, int length)
	-{
	- char *str;
	-
	- if (string == NULL) return NULL;
	- if (length < 0) {
	- fprintf(stderr,
	- "hs: Error. Character argument has negative length, setting to null\n");
	- length = 0;
	- }
	- str = malloc(length + 1);
	- if (length > 0)
	- strncpy(str, string, length);
	- str[length] = '\0';
	- /* printf(" string = /%s/, length: %d (before)\n", str, strlen(str)); */
	- cleanFortranString(str, length);
	- /* printf(" string = /%s/, length: %d (cleaned)\n", str, strlen(str)); */
	- return str;
	-}
	-
	-
	-/*
	-** clean junk out of fortran strings that might not have been
	-** fully initialized or have trailing blanks. Assumes enough
	-** room to append a null at the end of the string.
	-**
	-** This cleanFortranString continues after detecting a junk character and
	-** includes a few more valid characters than other cleanFortranString's.
	-*/
	-static void cleanFortranString(char *string, int length)
	-{
	- static char validChars[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
	-abcdefghijklmnopqrstuvwxyz1234567890/~!@#$%^&*()_+=-`\"\'?><,.\\[]{}:; \t";
	- char inPtr, outPtr;
	- int i;
	-
	- /* remove junk characters */
	- inPtr = outPtr = string;
	- for (i=1; i<=length; i++) {
	- if (strchr(validChars, *inPtr))
	- outPtr++ = inPtr++;
	- else
	- inPtr++;
	- }
	-
	- /* remove trailing spaces */
	- for (outPtr--; outPtr>=string; outPtr--)
	- if (outPtr != ' ' && outPtr != '\0')
	- break;
	-
	- /* add a null to terminate the string */
	- ++outPtr;
	- *outPtr = '\0';
	-}
	-
	-
	Index: trunk/mcfio/mcf_nTupleDescript.h
	===================================================================
	--- trunk/mcfio/mcf_nTupleDescript.h (revision 8888)
	+++ trunk/mcfio/mcf_nTupleDescript.h (revision 8889)
	@@ -1,86 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_nTupleDescript.h -- Include file for mcfast generalized nTuple *
	-* descriptors. This is a genric structres that can hold info about *
	-* specficic instances of a generalized nTuple. *
	-* *
	-* P. Lebrun, September 1995. *
	-* *
	-*******************************************************************************/
	-/*
	-** Information concerning a generic variable within an Ntuple
	-*/
	-enum varTypes {BYTE_NTU, CHARACTER_NTU, INTEGER2_NTU, LOGICAL_NTU,
	- INTEGER_NTU, REAL_NTU,
	- DBL_PRECISION_NTU, COMPLEX_NTU, DBL_COMPLEX_NTU, POINTER_NTU};
	-
	-enum orgStyles {PARALLEL_ARRAY_NTU, DATA_STRUCT_NTU};
	-
	-#define N_VAR_TYPES 10
	-#define MAX_VAR_NAME 31
	-#define MAX_NTU_TITLE 80
	-#define MAX_VAR_DESCRIP 1023
	-#define MAX_VAR_DIMENSIONS 4
	-#define NUM_START_VARIABLES 10
	-#define NTU_MAX_TITLE_LENGTH 80
	-#define NTU_MAX_CATEGORY_LENGTH 255
	-#define NTU_MAX_CATEGORY_DEPTH 40
	-#define NTU_START_LIST_SIZE 20
	-
	-typedef struct {
	- char nameBlank; /* flag indicating that the variable does not exist. */
	- char name; / Mnemonic name of the variable. */
	- char description;/ description for the variable */
	- int type; /* Variable type (int, ...) see above enum varTypes */
	- char isFixedSize; /* Variable is or is not indexed by nTuple multiplicity*/
	- int numDim; /* The variable dimensions, not counting mult. one */
	- int dimensions[MAX_VAR_DIMENSIONS+1];
	- /* Variable dims, not counting the multiplicity one*/
	- size_t lengthW; /* Used in XDR filtering, length in words */
	- size_t lengthB; /* Used in XDR filtering, length in byte */
	- long offset; /* The variable virtual address for a given instance */
	- u_int offsetXDR; /* The variable relative address within the struct. */
	-} varGenNtuple;
	-
	-typedef struct {
	- int numVariables; /* The total number of variables in the structure */
	- int numAvailable; /* The number of available var. in var. array */
	- char nameIndex[32]; /* The name for the Ntuple single index */
	- int maxMultiplicity; /* The maximum multiplicity for any instances */
	- char title; / Title for the structure */
	- char description; / Description of this structure. */
	- char version[8]; /* The version string */
	- int orgStyle; /* The organization of the indexed variables */
	- void address; / Virtual address of a particular instance */
	- long multOffset; /* Offset for the multiplicity offset */
	- u_int multXDROffset; /* Adress for the multiplicity offset */
	- long fenceOffset; /* Offset for the fence */
	- u_int fenceXDROffset; /* XDR offset for the fence */
	- long subOffset; / Offset for the sub structures */
	- u_int subXDROffset; / XDR offset for the sub structures */
	- varGenNtuple *variables; / The variable descriptions */
	- int varOrdering; / Ordering of the variables for the dbin, .h.. file*/
	- int firstIndexed; /* Once ordered, the first indexed for indexed part */
	-} descrGenNtuple;
	-
	-/*
	-** A Data structure to hold a DDL, without MOTIF widget, to be used in
	-** stand alone mode in mcfio.
	-*/
	-
	-typedef struct nTuDDLRec {
	- int id; /* The id of the NTuple, as returned to the user */
	- int seqNTuId; /* The sequential number for this particular stream */
	- int uid; /* The user Id, Unique (within a Category) id */
	- char *category;
	- char *title;
	- char dbinFileName; / dbin filename, not guarantted to be there. */
	- int streamId; /* The stream on which this ddl is assigned to */
	- int referenceId;
	- struct nTuDDLRec *reference;
	- /* the reference in case a similar ddl has already
	- been installed in the running image. */
	-
	- descrGenNtuple descrNtu; / The Ntuple Descriptor */
	-} nTuDDL;
	-
	Index: trunk/mcfio/mcf_evt_xdr.c
	===================================================================
	--- trunk/mcfio/mcf_evt_xdr.c (revision 8888)
	+++ trunk/mcfio/mcf_evt_xdr.c (revision 8889)
	@@ -1,1602 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_evt_xdr.c -- XDR Utility routines for the McFast Monte-Carlo *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include <stdlib.h>
	-#include <time.h>
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcf_xdr_Ntuple.h"
	-#include "mcf_NTuIOFiles.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcfio_Util1.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-
	-static bool_t xdr_mcfast_NTuDDL(XDR xdrs, char version, nTuDDL *ddl);
	-static bool_t xdr_mcfast_descrNTU(XDR xdrs, char version,
	- descrGenNtuple *dNTu);
	-static bool_t xdr_mcfast_varDescrNTU(XDR xdrs, char version,
	- varGenNtuple *var);
	-
	-extern nTuDDL **NTuDDLList;
	-extern int NumOfNTuples;
	-
	-bool_t xdr_mcfast_generic(XDR xdrs, int blockid,
	- int ntot, char* version, char** data)
	-{
	-/* Translate a Generic mcfFast block. This module will allocate memory
	- for the data. */
	-
	- unsigned int nn;
	-
	- if (xdrs->x_op == XDR_ENCODE) {
	- nn = strlen(*data);
	- *ntot = 12+nn;
	- strcpy(*version, "0.00");
	- } else if (xdrs->x_op == XDR_FREE) {
	- free(*data);
	- return 1;
	- }
	-
	- if (( xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	- == FALSE) return FALSE;
	- nn = *ntot - 12;
	- if (xdrs->x_op == XDR_DECODE) *data = NULL;
	- return (xdr_string(xdrs, data, nn));
	-}
	-
	-
	-bool_t xdr_mcfast_headerBlock(XDR xdrs, int blockid,
	- int ntot, char* version)
	-{
	-/* Translate a Generic mcfFast block. This module will allocate memory
	- for the data. */
	-
	- unsigned int nn;
	-
	- if (xdrs->x_op == XDR_ENCODE) {
	- printf ("xdr_mcfast_headerBlock: Internal error \n");
	- return FALSE;
	- }
	-
	- return ( xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH));
	-}
	-bool_t xdr_mcfast_fileheader(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrFileHeader **mcf,
	- int streamId)
	-{
	-/* Translate a mcf FileHeader block. This subroutine will allocate
	- the memory needed if the stream is DECODE */
	-
	- int i;
	- unsigned int nn, oldNumOfNTuples;
	- char **ctmp;
	- char atmp, btmp, *dtmp;
	- int *itmp;
	- bool_t ok;
	- mcfxdrFileHeader *mcftmp;
	- nTuDDL *ddl;
	- float fv;
	-
	-
	- mcftmp = *mcf;
	- if (xdrs->x_op == XDR_ENCODE) {
	- ntot = sizeof(mcfxdrFileHeader) - sizeof(int ) - sizeof(char **)
	- + 2 * sizeof(int) * mcftmp->nBlocks
	- - sizeof(char) * MCF_XDR_F_TITLE_LENGTH
	- + sizeof(char) * strlen(mcftmp->title) +
	- + sizeof(char) * strlen(mcftmp->comment) ;
	- for (i=0, ctmp = mcftmp->blockNames;
	- i< mcftmp->nBlocks; i++, ctmp++) ntot += strlen(ctmp);
	- strcpy(*version, "2.01");
	- } else if (xdrs->x_op == XDR_FREE) {
	- mcfioC_Free_FileHeader(mcf);
	- return 1;
	- } else if((xdrs->x_op == XDR_DECODE) && (*mcf == NULL)) {
	- mcftmp = (mcfxdrFileHeader *) malloc(sizeof(mcfxdrFileHeader));
	- *mcf = mcftmp;
	- }
	-
	-
	-
	- if (( xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	- == FALSE) return FALSE;
	-
	- /*
	- ** Code valid for version 1.00
	- */
	- if (strcmp(*version, "1.00") == 0) {
	- atmp = &(mcftmp->title[0]);
	- btmp = &(mcftmp->comment[0]);
	- dtmp = &(mcftmp->date[0]);
	-
	- if ((xdr_string(xdrs, &atmp, MCF_XDR_F_TITLE_LENGTH) &&
	- xdr_string(xdrs,&btmp, MCF_XDR_F_TITLE_LENGTH) &&
	- xdr_string(xdrs,&dtmp, 30)) == FALSE) return FALSE;
	-
	- if ((xdr_u_int(xdrs,&(mcftmp->numevts_expect)) &&
	- xdr_u_int(xdrs,&(mcftmp->numevts)) &&
	- xdr_u_int(xdrs,&(mcftmp->firstTable)) &&
	- xdr_u_int(xdrs,&(mcftmp->dimTable)) &&
	- xdr_u_int(xdrs,&(mcftmp->nBlocks))) == FALSE) return FALSE;
	- if(xdrs->x_op == XDR_DECODE) {
	- mcftmp->blockIds = (int ) malloc(sizeof(int) mcftmp->nBlocks);
	- mcftmp->blockNames =
	- (char*) malloc(sizeof(char ) * mcftmp->nBlocks);
	- for (i=0; i<mcftmp->nBlocks; i++)
	- mcftmp->blockNames[i] =
	- (char ) malloc(sizeof(char) (MCF_XDR_B_TITLE_LENGTH +1));
	- }
	- itmp = mcftmp->blockIds;
	- if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->nBlocks;
	- if (xdr_array(xdrs, (char **) &itmp, &nn,
	- mcftmp->nBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- for (i=0; i<mcftmp->nBlocks; i++) {
	- if (xdr_string(xdrs, &(mcftmp->blockNames[i]),
	- MCF_XDR_B_TITLE_LENGTH) == FALSE) return FALSE;
	- }
	- mcftmp->nNTuples = 0;
	- } else if (strncmp(*version, "2.",2) == 0){
	- sscanf(*version, "%f", &fv);
	- /*
	- ** Code valid for version 2.xx, adding the NTuples
	- */
	- atmp = &(mcftmp->title[0]);
	- btmp = &(mcftmp->comment[0]);
	- dtmp = &(mcftmp->date[0]);
	-
	- if ((xdr_string(xdrs, &atmp, MCF_XDR_F_TITLE_LENGTH) &&
	- xdr_string(xdrs,&btmp, MCF_XDR_F_TITLE_LENGTH) &&
	- xdr_string(xdrs,&dtmp, 30)) == FALSE) return FALSE;
	-
	- if (fv == 2.) strcpy(mcftmp->closingDate, mcftmp->date);
	- else {
	- atmp = &(mcftmp->closingDate[0]);
	- if (xdr_string(xdrs, &atmp, 30) == FALSE) return FALSE;
	- }
	- if ((xdr_u_int(xdrs,&(mcftmp->numevts_expect)) &&
	- xdr_u_int(xdrs,&(mcftmp->numevts)) &&
	- xdr_u_int(xdrs,&(mcftmp->firstTable)) &&
	- xdr_u_int(xdrs,&(mcftmp->dimTable)) &&
	- xdr_u_int(xdrs,&(mcftmp->nBlocks)) &&
	- xdr_u_int(xdrs,&(mcftmp->nNTuples))) == FALSE) return FALSE;
	- if((xdrs->x_op == XDR_DECODE) && (mcftmp->nBlocks > 0)) {
	- mcftmp->blockIds = (int ) malloc(sizeof(int) mcftmp->nBlocks);
	- mcftmp->blockNames =
	- (char*) malloc(sizeof(char ) * mcftmp->nBlocks);
	- for (i=0; i<mcftmp->nBlocks; i++)
	- mcftmp->blockNames[i] =
	- (char ) malloc(sizeof(char) (MCF_XDR_B_TITLE_LENGTH +1));
	- }
	- itmp = mcftmp->blockIds;
	- if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->nBlocks;
	- if (mcftmp->nBlocks > 0) {
	- if (xdr_array(xdrs, (char **) &itmp, &nn,
	- mcftmp->nBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- for (i=0; i<mcftmp->nBlocks; i++) {
	- if (xdr_string(xdrs, &(mcftmp->blockNames[i]),
	- MCF_XDR_B_TITLE_LENGTH) == FALSE) return FALSE;
	- }
	- } else {
	- mcftmp->blockNames = NULL;
	- mcftmp->blockIds = NULL;
	- }
	- /*
	- ** Now take care of the Ntuples
	- */
	- if((xdrs->x_op == XDR_DECODE) && (mcftmp->nNTuples > 0)) {
	- oldNumOfNTuples = NumOfNTuples;
	- for (i=0; i<mcftmp->nNTuples; i++) {
	- ddl = (nTuDDL * ) malloc(sizeof(nTuDDL));
	- AddNTuDDLtoList(ddl);
	- if (xdr_mcfast_NTuDDL(xdrs, *version, ddl) == FALSE)
	- return FALSE;
	- }
	- } else if ((xdrs->x_op == XDR_ENCODE) && (mcftmp->nNTuples > 0)) {
	- for (i=0; i<NumOfNTuples; i++) {
	- ddl =mcf_GetNTuByPtrID(i+1);
	- if ((ddl->streamId == streamId) &&
	- (xdr_mcfast_NTuDDL(xdrs, *version, ddl) == FALSE))
	- return FALSE;
	- }
	- }
	-
	- } else return FALSE; /* Other Futur version encoded here. */
	- return TRUE;
	-
	-}
	-
	-bool_t xdr_mcfast_eventtable(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrEventTable **mcf)
	-{
	-/* Translate a mcf EventTable block. This subroutine will allocate
	- the memory needed if the stream is DECODE */
	-
	- int i, *idat;
	- unsigned int nn, nnold, *uidat;
	- char **ctmp;
	- mcfxdrEventTable *mcftmp;
	-
	-
	- mcftmp = *mcf;
	- if (xdrs->x_op == XDR_ENCODE) {
	- ntot = sizeof(mcfxdrEventTable) + 4 sizeof(int)* mcftmp->dim
	- + sizeof(unsigned int)* mcftmp->dim - 2 * sizeof(int)
	- - 4 * sizeof(int ) - sizeof(u_int );
	- strcpy(*version, "1.00");
	- } else if (xdrs->x_op == XDR_FREE) {
	- mcfioC_Free_EventTable(mcf);
	- return 1;
	- } else if((xdrs->x_op == XDR_DECODE) && ( mcftmp == NULL)) {
	- mcftmp = (mcfxdrEventTable *) malloc(sizeof(mcfxdrEventTable));
	- *mcf = mcftmp;
	- }
	-
	-
	-
	- if (( xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	- == FALSE) return FALSE;
	-
	- /*
	- ** Code valid for version 1.00
	- */
	- if (strcmp(*version, "1.00") == 0) {
	-
	- if((xdrs->x_op == XDR_DECODE) && (mcftmp->evtnums != NULL))
	- nnold = mcftmp->previousnumevts;
	- else nnold = 0;
	- idat = &mcftmp->nextLocator;
	- uidat = (u_int *) &mcftmp->numevts;
	- if ((xdr_int(xdrs,idat) && xdr_u_int(xdrs,uidat )) == FALSE)
	- return FALSE;
	- if(xdrs->x_op == XDR_DECODE) {
	- if ((mcftmp->evtnums == NULL) \|\| (mcftmp->numevts > nnold)) {
	- if (mcftmp->evtnums != NULL) {
	- /*
	- ** I don't trust realloc.. just alloc again..
	- */
	- free(mcftmp->evtnums); free(mcftmp->storenums);
	- free(mcftmp->runnums); free(mcftmp->trigMasks);
	- free(mcftmp->ptrEvents);
	- }
	- mcftmp->evtnums = (int ) malloc(sizeof(int) mcftmp->dim);
	- mcftmp->storenums = (int ) malloc(sizeof(int) mcftmp->dim);
	- mcftmp->runnums = (int ) malloc(sizeof(int) mcftmp->dim);
	- mcftmp->trigMasks = (int ) malloc(sizeof(int) mcftmp->dim);
	- mcftmp->ptrEvents =
	- (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dim);
	- mcftmp->previousnumevts = mcftmp->dim;
	- }
	- }
	- if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dim;
	- idat = mcftmp->evtnums;
	- if (xdr_array(xdrs, (char **) &idat, &nn,
	- mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- idat = mcftmp->storenums;
	- if (xdr_array(xdrs, (char **) &idat, &nn,
	- mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- idat = mcftmp->runnums;
	- if (xdr_array(xdrs, (char **) &idat, &nn,
	- mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- idat = mcftmp->trigMasks;
	- if (xdr_array(xdrs, (char **) &idat, &nn,
	- mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- uidat = mcftmp->ptrEvents;
	- if (xdr_array(xdrs, (char **) &uidat, &nn,
	- mcftmp->dim, sizeof(int), (xdrproc_t)xdr_u_int) == FALSE)
	- return FALSE;
	- } else return FALSE; /* Future version encoded here. */
	- return TRUE;
	-
	-}
	-
	-bool_t xdr_mcfast_seqheader(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrSequentialHeader **mcf)
	-{
	-/* Translate a mcf EventTable block. This subroutine will allocate
	- the memory needed if the stream is DECODE */
	-
	- int i;
	- unsigned int nn;
	- char **ctmp;
	- mcfxdrSequentialHeader *mcftmp;
	-
	-
	- if (xdrs->x_op == XDR_ENCODE) {
	- mcftmp = *mcf;
	- *ntot = sizeof(mcfxdrSequentialHeader);
	- strcpy(*version, "1.00");
	- } else if (xdrs->x_op == XDR_FREE) {
	- mcfioC_Free_SeqHeader(mcf);
	- return 1;
	- } else if(xdrs->x_op == XDR_DECODE) {
	- if (*mcf == NULL) {
	- mcftmp = (mcfxdrSequentialHeader *)
	- malloc(sizeof(mcfxdrSequentialHeader));
	- *mcf = mcftmp;
	- } else mcftmp = *mcf;
	-
	- }
	-
	-
	-
	-/* if (( xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	- == FALSE) return FALSE;
	-*/
	- if (xdr_int(xdrs,blockid) == FALSE) return FALSE;
	- if (xdr_int(xdrs,ntot) == FALSE) return FALSE;
	- if (xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH)
	- == FALSE) return FALSE;
	- /*
	- ** Code valid for version 1.00
	- */
	- if (strcmp(*version, "1.00") == 0) {
	-
	- if (xdr_u_int(xdrs,&(mcftmp->nRecords)) == FALSE) return FALSE;
	- } else return FALSE; /* Futur version encoded here. */
	- return TRUE;
	-
	-}
	-
	-bool_t xdr_mcfast_eventheader(XDR xdrs, int blockid,
	- int ntot, char* version, mcfxdrEventHeader **mcf)
	-{
	-/* Translate a mcf Event header block. This subroutine will allocate
	- the memory needed if the stream is DECODE */
	-
	- int i, *itmp;
	- unsigned int nn, nnold, nNTuOld, *uitmp;
	- char **ctmp;
	- mcfxdrEventHeader *mcftmp;
	-
	-
	- mcftmp = *mcf;
	- if (xdrs->x_op == XDR_ENCODE) {
	- *ntot = sizeof(mcfxdrEventHeader)
	- + sizeof(unsigned int)* mcftmp->nBlocks
	- + sizeof(int ) * mcftmp->nBlocks
	- - sizeof(int ) - sizeof(u_int ) ;
	- strcpy(*version, "2.00");
	- } else if (xdrs->x_op == XDR_FREE) {
	- mcfioC_Free_EventHeader(mcf);
	- return 1;
	- } else if((xdrs->x_op == XDR_DECODE) && (mcftmp == NULL)) {
	- mcftmp =
	- (mcfxdrEventHeader *) malloc(sizeof(mcfxdrEventHeader));
	- *mcf = mcftmp;
	- mcftmp->blockIds = NULL;
	- mcftmp->ptrBlocks = NULL;
	- }
	-
	-
	-
	- if (( xdr_int(xdrs, blockid) &&
	- xdr_int(xdrs, ntot) &&
	- xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	- == FALSE) return FALSE;
	-
	- /*
	- ** Code valid for version 1.00
	- */
	- if (strcmp(*version, "1.00") == 0) {
	- if((xdrs->x_op == XDR_DECODE) && (mcftmp->blockIds != NULL))
	- nnold = mcftmp->dimBlocks;
	- else nnold = 0;
	- if ((xdr_int(xdrs,&(mcftmp->evtnum)) &&
	- xdr_int(xdrs,&(mcftmp->storenum)) &&
	- xdr_int(xdrs,&(mcftmp->runnum)) &&
	- xdr_int(xdrs,&(mcftmp->trigMask)) &&
	- xdr_u_int(xdrs,&(mcftmp->nBlocks)) &&
	- xdr_u_int(xdrs,&(mcftmp->dimBlocks))) == FALSE) return FALSE;
	- if(xdrs->x_op == XDR_DECODE) {
	- if ((mcftmp->blockIds == NULL) \|\| (mcftmp->dimBlocks > nnold)) {
	- if (mcftmp->blockIds != NULL) {
	- /*
	- ** I don't trust realloc.. just alloc again..
	- */
	- free(mcftmp->blockIds); free(mcftmp->ptrBlocks);
	- }
	- mcftmp->blockIds =
	- (int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	- mcftmp->ptrBlocks =
	- (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	- }
	- }
	- if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dimBlocks;
	- itmp = mcftmp->blockIds;
	- if (xdr_array(xdrs, (char **) &itmp, &nn,
	- mcftmp->dimBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- uitmp = mcftmp->ptrBlocks;
	- if (xdr_array(xdrs, (char **) &uitmp, &nn,
	- mcftmp->dimBlocks, sizeof(u_int), (xdrproc_t)xdr_u_int) == FALSE)
	- return FALSE;
	- } else if (strcmp(*version, "2.00") == 0) {
	- if (xdrs->x_op == XDR_DECODE) {
	- nnold = 0;
	- if (mcftmp->blockIds != NULL) nnold = mcftmp->dimBlocks;
	- nNTuOld = 0;
	- if (mcftmp->nTupleIds != NULL) nNTuOld = mcftmp->dimNTuples;
	- }
	- if ((xdr_int(xdrs,&(mcftmp->evtnum)) &&
	- xdr_int(xdrs,&(mcftmp->storenum)) &&
	- xdr_int(xdrs,&(mcftmp->runnum)) &&
	- xdr_int(xdrs,&(mcftmp->trigMask)) &&
	- xdr_u_int(xdrs,&(mcftmp->nBlocks)) &&
	- xdr_u_int(xdrs,&(mcftmp->dimBlocks)) &&
	- xdr_u_int(xdrs,&(mcftmp->nNTuples)) &&
	- xdr_u_int(xdrs,&(mcftmp->dimNTuples))) == FALSE) return FALSE;
	- if(xdrs->x_op == XDR_DECODE) {
	- if ((mcftmp->blockIds == NULL) \|\| (mcftmp->dimBlocks > nnold)) {
	- if (mcftmp->blockIds != NULL) {
	- free(mcftmp->blockIds);
	- free(mcftmp->ptrBlocks);
	- }
	- mcftmp->blockIds =
	- (int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	- mcftmp->ptrBlocks =
	- (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	- }
	- if ((mcftmp->nTupleIds == NULL) \|\| (mcftmp->dimNTuples > nNTuOld)) {
	- if (mcftmp->nTupleIds != NULL) {
	- free(mcftmp->nTupleIds);
	- free(mcftmp->ptrNTuples);
	- }
	- mcftmp->nTupleIds =
	- (int ) malloc(sizeof(unsigned int) mcftmp->dimNTuples);
	- mcftmp->ptrNTuples =
	- (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dimNTuples);
	- }
	- }
	- if (mcftmp->dimBlocks > 0) {
	- if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dimBlocks;
	- itmp = mcftmp->blockIds;
	- if (xdr_array(xdrs, (char **) &itmp, &nn,
	- mcftmp->dimBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- uitmp = mcftmp->ptrBlocks;
	- if (xdr_array(xdrs, (char **) &uitmp, &nn,
	- mcftmp->dimBlocks, sizeof(u_int), (xdrproc_t)xdr_u_int) == FALSE)
	- return FALSE;
	- }
	- if (mcftmp->dimNTuples > 0) {
	- if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dimNTuples;
	- itmp = mcftmp->nTupleIds;
	- if (xdr_array(xdrs, (char **) &itmp, &nn,
	- mcftmp->dimNTuples, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	- return FALSE;
	- uitmp = mcftmp->ptrNTuples;
	- if (xdr_array(xdrs, (char **) &uitmp, &nn,
	- mcftmp->dimNTuples, sizeof(u_int), (xdrproc_t)xdr_u_int) == FALSE)
	- return FALSE;
	- }
	- } else
	- return FALSE; /* Futur version encoded here. */
	- return TRUE;
	-
	-}
	-
	-static bool_t xdr_mcfast_NTuDDL(XDR xdrs, char version, nTuDDL *ddl)
	-{
	- int i, nc_title, nc_category, idRef;
	- descrGenNtuple *dNTu;
	-
	-
	- /*
	- ** This is the first version, let us not get too compilcated..
	- */
	- if (xdrs->x_op == XDR_ENCODE) {
	- nc_title = strlen(ddl->title);
	- nc_category = strlen(ddl->category);
	- idRef = -1;
	- /*
	- ** Cross reference is only valid within the same stream.
	- */
	- if ((ddl->reference != NULL) &&
	- (ddl->streamId == ddl->reference->streamId )) {
	- /*
	- ** compute the rerefence token. This is the sequential
	- ** number of the reference Ntuple for this stream.
	- */
	- for (i=0, idRef=0; i<NumOfNTuples; i++) {
	- if (NTuDDLList[i]->streamId == ddl->reference->streamId)
	- idRef++;
	- if (NTuDDLList[i]->id == ddl->reference->id) break;
	- }
	- }
	- }
	- if (xdr_int(xdrs, &nc_title) == FALSE) return FALSE;
	- if (xdr_int(xdrs, &nc_category) == FALSE) return FALSE;
	- if (xdr_int(xdrs, &idRef) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_DECODE) {
	- ddl->title = (char ) malloc(sizeof(char) (nc_title +1));
	- ddl->category = (char ) malloc(sizeof(char) (nc_category +1));
	- ddl->dbinFileName = NULL;
	- ddl->streamId = -1;
	- }
	- if (xdr_int(xdrs,&(ddl->uid)) == FALSE) return FALSE;
	- if (xdr_string(xdrs, &(ddl->title), nc_title) == FALSE) return FALSE;
	- if (xdr_string(xdrs, &(ddl->category),
	- nc_category) == FALSE) return FALSE;
	- if (idRef == -1) {
	- if (xdrs->x_op == XDR_DECODE)
	- ddl->descrNtu = (descrGenNtuple *) malloc (sizeof(descrGenNtuple));
	- if (ddl->descrNtu == NULL) dNTu = ddl->reference->descrNtu;
	- else dNTu = ddl->descrNtu;
	- if (xdr_mcfast_descrNTU(xdrs, version, dNTu) == FALSE)
	- return FALSE;
	- if (xdrs->x_op == XDR_DECODE) ddl->reference = NULL;
	- } else {
	- if (xdrs->x_op == XDR_DECODE) {
	- ddl->descrNtu = NULL;
	- ddl->referenceId = idRef;
	- /* we will set the reference pointer in mcfio_Direct */
	- }
	- }
	- return TRUE;
	-
	-}
	-
	-static bool_t xdr_mcfast_descrNTU(XDR xdrs, char version,
	- descrGenNtuple *dNTu)
	-{
	- int i, nc_desc, nc_title;
	- u_int nn;
	- char *tc;
	- /*
	- ** This is the first version, let us not get too compilcated..
	- */
	-
	- if (xdr_int(xdrs,&(dNTu->numVariables)) == FALSE) return FALSE;
	- dNTu->numAvailable = dNTu->numVariables;
	- if (xdr_int(xdrs,&(dNTu->maxMultiplicity)) == FALSE) return FALSE;
	- if (xdr_int(xdrs,&(dNTu->orgStyle)) == FALSE)return FALSE;
	- if (xdr_int(xdrs,&(dNTu->firstIndexed)) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_ENCODE) nc_title = strlen(dNTu->title);
	- if (xdr_int(xdrs, &nc_title) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_ENCODE) nc_desc = strlen(dNTu->description);
	- if (xdr_int(xdrs, &nc_desc) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_DECODE) {
	- dNTu->title = (char ) malloc(sizeof(char) (nc_title+1));
	- dNTu->subXDROffset = NULL;
	- dNTu->description = (char ) malloc(sizeof(char) (nc_desc+1));
	- dNTu->varOrdering = (int ) malloc(sizeof(int) dNTu->numVariables);
	- for (i=0; i<dNTu->numVariables; i++) dNTu->varOrdering[i] = i;
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- dNTu->subXDROffset = NULL;
	- dNTu->subOffset = NULL;
	- } else {
	- dNTu->subOffset =
	- (long ) malloc(sizeof(long) dNTu->maxMultiplicity);
	- dNTu->subXDROffset =
	- (u_int ) malloc(sizeof(long) dNTu->maxMultiplicity);
	- }
	- dNTu->variables =
	- (varGenNtuple *) malloc(sizeof(varGenNtuple ) * dNTu->numVariables);
	- for (i=0; i<dNTu->numVariables; i++)
	- dNTu->variables[i] = (varGenNtuple *) malloc(sizeof(varGenNtuple));
	- }
	- tc = dNTu->nameIndex;
	- if (xdr_string(xdrs, &tc, 31) == FALSE) return FALSE;
	- if (xdr_string(xdrs,
	- (char **) &(dNTu->title), nc_title) == FALSE) return FALSE;
	- if (xdr_string(xdrs,
	- &(dNTu->description), nc_desc) == FALSE) return FALSE;
	- tc = dNTu->version;
	- if (xdr_string(xdrs, &tc, 7) == FALSE) return FALSE;
	- if (xdr_long(xdrs, &(dNTu->multOffset)) == FALSE) return FALSE;
	- if (xdr_long(xdrs, &(dNTu->fenceOffset)) == FALSE) return FALSE;
	- nn = dNTu->maxMultiplicity;
	- if (dNTu->orgStyle != PARALLEL_ARRAY_NTU) {
	- if (xdr_array(xdrs,
	- (char **) &(dNTu->subOffset), &nn, nn, sizeof(long), (xdrproc_t)xdr_long) == FALSE)
	- return FALSE;
	- }
	- for (i=0; i<dNTu->numVariables; i++)
	- if (xdr_mcfast_varDescrNTU(xdrs, version, dNTu->variables[i]) == FALSE)
	- return FALSE;
	- return TRUE;
	-}
	-static bool_t xdr_mcfast_varDescrNTU(XDR xdrs, char version,
	- varGenNtuple *var)
	-{
	- int i, nc_name, nc_desc, *pdim;
	- u_int nn;
	-
	-
	-
	- if (xdrs->x_op == XDR_ENCODE) nc_name = strlen(var->name);
	- if (xdr_int(xdrs, &nc_name) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_ENCODE) {
	- if (var->description == NULL) nc_desc = 0;
	- else nc_desc = strlen(var->description);
	- }
	- if (xdr_int(xdrs, &nc_desc) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_DECODE) {
	- var->name = (char ) malloc(sizeof(char) (nc_name+1));
	- if (nc_desc>0)
	- var->description = (char ) malloc(sizeof(char) (nc_desc+1));
	- else var->description = NULL;
	- var->nameBlank = FALSE;
	- }
	-
	- if (xdr_string(xdrs, &(var->name), nc_name) == FALSE) return FALSE;
	- if (nc_desc > 0)
	- if (xdr_string(xdrs, &(var->description), nc_desc) == FALSE)
	- return FALSE;
	- if (xdr_int(xdrs,&(var->type)) == FALSE) return FALSE;
	- if (xdr_char(xdrs,&(var->isFixedSize)) == FALSE) return FALSE;
	- if (xdr_int(xdrs,&(var->numDim)) == FALSE) return FALSE;
	- nn = var->numDim;
	- pdim = var->dimensions;
	- if ((nn > 0) && (xdr_array(xdrs,
	- (char **) &pdim, &nn, nn, sizeof(int), (xdrproc_t)xdr_int)) == FALSE)
	- return FALSE;
	- if (xdrs->x_op == XDR_ENCODE) nn = (u_int) var->lengthB;
	- if (xdr_u_int(xdrs,&(nn)) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_DECODE) var->lengthB = (size_t) nn;
	- if (xdrs->x_op == XDR_ENCODE) nn = (u_int) var->lengthW;
	- if (xdr_u_int(xdrs,&(nn)) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_DECODE) var->lengthW = (size_t) nn;
	- if (xdr_long(xdrs,&(var->offset)) == FALSE) return FALSE;
	- return TRUE;
	-}
	-/*
	-** Generalized NTuple XDR filter
	-*/
	-bool_t xdr_mcfast_NTuple(XDR xdrs, descrGenNtuple dNTu,
	- int pnTot, int nTupleId, char version)
	-{
	- int i, j, id, nm, lastFixed;
	- u_int nn;
	- char vv, cDat, *start;
	- int *pnMult;
	- void *pnFence;
	- int *ipnFence;
	- void end, pt;
	- bool_t ok;
	-/*
	-** Upon write, check that the version token is identical to the one stored
	-** in the ddl.
	-*/
	- start = version;
	- if(dNTu->firstIndexed == -1) lastFixed = dNTu->numVariables;
	- else lastFixed = dNTu->firstIndexed;
	- if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	- nn = strlen(dNTu->version);
	- if (strncmp(version, dNTu->version, (size_t) nn ) != 0) {
	- fprintf (stderr, "mcfio_NTuple: version mismatch! \n\
	- Version used in the Event loop = %s\n\
	- ... in the DDl template = %s\n", version,dNTu->version);
	- return FALSE;
	- }
	- id = nTupleId;
	-/*
	-** Compute the total length
	-*/
	- cDat = start; cDat += dNTu->multOffset;
	- pnMult = (int *) cDat;
	- nm = *pnMult;
	- for (i=0, nn=0; i<lastFixed; i++)
	- nn += dNTu->variables[i]->lengthB;
	- if(dNTu->firstIndexed != -1)
	- for(i=dNTu->firstIndexed; i<dNTu->numVariables; i++)
	- nn += (dNTu->variables[i]->lengthB * nm);
	- *pnTot = 6 + nn/4;
	- }
	- if (xdr_int(xdrs, &id) == FALSE) return FALSE;
	- if (xdr_int(xdrs, pnTot) == FALSE) return FALSE;
	- if (xdrs->x_op == XDR_ENCODE) {
	- vv = dNTu->version;
	- if (xdr_string(xdrs, &vv, 11) == FALSE) return FALSE;
	- } else if (xdrs->x_op == XDR_DECODE) {
	- if (xdr_string(xdrs, &version, 11) == FALSE) return FALSE;
	- if (strcmp(version, dNTu->version) != 0) {
	- fprintf (stderr, "mcfio_NTuple: version mismatch! \n\
	- Version used in the Event loop = %s\n\
	- ... in the DDl template = %s\n", version,dNTu->version);
	- return FALSE;
	- }
	- if (id != nTupleId) {
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected NTuple identifier % instead of %d\n", id, nTupleId);
	- return FALSE;
	- }
	- }
	-
	- cDat = start; cDat += dNTu->multOffset;
	- pnMult = (int *) cDat;
	- if (xdr_int(xdrs, pnMult) == FALSE) return FALSE;
	- /*
	- ** Close the fence now, we will check it upon DECODE at the end
	- */
	- cDat = start; cDat += dNTu->fenceOffset;
	- pnFence = (void *) cDat;
	- if (xdrs->x_op == XDR_ENCODE) memcpy(pnFence, pnTot, sizeof(int));
	- if (xdr_int(xdrs, (int *) pnFence) == FALSE) return FALSE;
	- nm = *pnMult;
	- for (i=0; i<lastFixed; i++) {
	- if (dNTu->variables[i]->lengthW == 1) {
	- cDat = start; cDat += dNTu->variables[i]->offset;
	- pt = (void *) cDat;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_char(xdrs, (char *) pt);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_short(xdrs, (short *) pt);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_int(xdrs, (int *) pt);
	- break;
	- case REAL_NTU:
	- ok = xdr_float(xdrs, (float *) pt);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_double(xdrs, (double *) pt);
	- break;
	- case COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_long(xdrs, (long *) pt);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- }
	- else if (dNTu->variables[i]->lengthW > 0) {
	- cDat = start; cDat += dNTu->variables[i]->offset;
	- pt = (void *) cDat;
	- nn = dNTu->variables[i]->lengthW;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- if (ok == FALSE) return FALSE;
	- }
	- }
	- if (dNTu->firstIndexed != -1) {
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	- cDat = start; cDat += dNTu->variables[i]->offset;
	- pt = (void *) cDat;
	- nn = nm * dNTu->variables[i]->lengthW;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- vv = (char *) pt;
	- ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- if (ok == FALSE) return FALSE;
	- }
	- } else { /dump the substructures one a time /
	- for (j=0; j<nm; j++) {
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	- cDat = start;
	- cDat += (dNTu->subOffset[j] + dNTu->variables[i]->offset);
	- pt = (void *) cDat;
	- if (dNTu->variables[i]->lengthW == 1) {
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_char(xdrs, (char *) pt);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_short(xdrs, (short *) pt);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_int(xdrs, (int *) pt);
	- break;
	- case REAL_NTU:
	- ok = xdr_float(xdrs, (float *) pt);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_double(xdrs, (double *) pt);
	- break;
	- case COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_long(xdrs, (long *) pt);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- }
	- else if (dNTu->variables[i]->lengthW > 0) {
	- nn = dNTu->variables[i]->lengthW;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- if (ok == FALSE) return FALSE;
	- }
	- } /end of i loop /
	- } /end of j loop /
	- } /* End of orgStyle clause */
	- } /* End of firstIndexed clause */
	- /*
	- ** Check the fence..
	- */
	- ipnFence = (int *) pnFence;
	- if ((xdrs->x_op == XDR_DECODE) && (ipnFence != pnTot)) {
	- fprintf (stderr, "mcfio_NTuple: Suspected Data Overwrite! \n\
	- Fence content found on the input stream is = %d\n\
	- ... while we expect %d\n", ipnFence, pnTot);
	- return FALSE;
	- }
	- return TRUE;
	-}
	-
	-/*
	-** Generalized NTuple XDR filter, for DECODE only, used exclusively
	-** to establish the relative XDR pointers.
	-*/
	-bool_t xdr_mcfast_NTupleXDRPtr(XDR xdrs, descrGenNtuple dNTu,
	- int pnTot, int nTupleId, char version)
	-{
	- int i, j, id, nm, lastFixed;
	- u_int nn, startXDR;
	- char vv, cDat;
	- int pnMult, pnFence;
	- void start, end, *pt;
	- bool_t ok;
	-
	- /*
	- ** Allocate memory for supointer array if need be.
	- */
	- if(dNTu->firstIndexed == -1) lastFixed = dNTu->numVariables;
	- else lastFixed = dNTu->firstIndexed;
	-
	- if (dNTu->subXDROffset != NULL) free(dNTu->subXDROffset);
	- dNTu->subXDROffset =
	- (u_int ) malloc (sizeof(u_int) dNTu->maxMultiplicity);
	- start = (void *) version;
	- startXDR = xdr_getpos(xdrs);
	- if (xdr_int(xdrs, &id) == FALSE) return FALSE;
	- if (xdr_int(xdrs, pnTot) == FALSE) return FALSE;
	-
	- if (xdr_string(xdrs, &version, 11) == FALSE) return FALSE;
	- if (id != nTupleId) {
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected NTuple identifier % instead of %d\n", id, nTupleId);
	- return FALSE;
	- }
	- cDat = start; cDat += dNTu->multOffset;
	- pnMult = (int *) cDat;
	- dNTu->multXDROffset = xdr_getpos(xdrs) - startXDR;
	- if (xdr_int(xdrs, pnMult) == FALSE) return FALSE;
	- /*
	- ** Close the fence now, we will check it upon DECODE at the end
	- */
	- cDat = start; cDat += dNTu->fenceOffset;
	- pnFence = (int *) cDat;
	- dNTu->fenceXDROffset = xdr_getpos(xdrs) - startXDR;
	- if (xdr_int(xdrs, (int *) pnFence) == FALSE) return FALSE;
	- nm = *pnMult;
	- for (i=0; i<lastFixed; i++) {
	- dNTu->variables[i]->offsetXDR = 0;
	- if (dNTu->variables[i]->lengthW == 1) {
	- cDat = start; cDat += dNTu->variables[i]->offset;
	- pt = (void *) cDat;
	- dNTu->variables[i]->offsetXDR = xdr_getpos(xdrs) - startXDR;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_char(xdrs, (char *) pt);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_short(xdrs, (short *) pt);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_int(xdrs, (int *) pt);
	- break;
	- case REAL_NTU:
	- ok = xdr_float(xdrs, (float *) pt);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_double(xdrs, (double *) pt);
	- break;
	- case COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_long(xdrs, (long *) pt);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- }
	- else if (dNTu->variables[i]->lengthW > 0) {
	- cDat = start; cDat += dNTu->variables[i]->offset;
	- pt = (void *) cDat;
	- nn = dNTu->variables[i]->lengthW;
	- dNTu->variables[i]->offsetXDR = xdr_getpos(xdrs) - startXDR;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- if (ok == FALSE) return FALSE;
	- }
	- }
	- if (dNTu->firstIndexed != -1) {
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	- cDat =start; cDat += dNTu->variables[i]->offset;
	- pt = (void *) cDat;
	- nn = nm * dNTu->variables[i]->lengthW;
	- dNTu->variables[i]->offsetXDR = xdr_getpos(xdrs) - startXDR;
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- vv = (char *) pt;
	- ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- if (ok == FALSE) return FALSE;
	- }
	- } else { /dump the substructure one a time /
	- for (j=0; j<nm; j++) {
	- dNTu->subXDROffset[j] = xdr_getpos(xdrs) - startXDR;
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	- cDat = start;
	- cDat += (dNTu->subOffset[j] + dNTu->variables[i]->offset);
	- pt = (void *) cDat;
	- if (j == 0) dNTu->variables[i]->offsetXDR = 0;
	- if (dNTu->variables[i]->lengthW == 1) {
	- if (j == 0) dNTu->variables[i]->offsetXDR =
	- xdr_getpos(xdrs) - startXDR- dNTu->subXDROffset[j];
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_char(xdrs, (char *) pt);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_short(xdrs, (short *) pt);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_int(xdrs, (int *) pt);
	- break;
	- case REAL_NTU:
	- ok = xdr_float(xdrs, (float *) pt);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_double(xdrs, (double *) pt);
	- break;
	- case COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_long(xdrs, (long *) pt);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- }
	- else if (dNTu->variables[i]->lengthW > 0) {
	- nn = dNTu->variables[i]->lengthW;
	- if (j == 0) dNTu->variables[i]->offsetXDR =
	- xdr_getpos(xdrs) - startXDR - dNTu->subXDROffset[0];
	- switch (dNTu->variables[i]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(xdrs,
	- (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- fprintf (stderr, "mcfio_NTuple: internal error! \n\
	- Unexpected variables type %d on NTuple \n",
	- dNTu->variables[i]->type, nTupleId);
	- break;
	- }
	- if (ok == FALSE) return FALSE;
	- }
	- } /end of i loop /
	- } /end of j loop /
	- } /* End of orgStyle clause */
	- } /* End of firstIndexed clause */
	- /*
	- ** Check the fence..
	- */
	- if (pnFence != pnTot) {
	- fprintf (stderr, "mcfio_NTuple: Suspected Data Overwrite! \n\
	- Fence content found on the input stream is = %d\n\
	- ... while we expect %d\n", pnFence, pnTot);
	- return FALSE;
	- }
	- return TRUE;
	-}
	-/*
	-** Generalized NTuple XDR filter, used for Decode only.
	-** Simply decode the multiplicty value. No checks whatsoever!
	-*/
	-bool_t xdr_mcfast_NTupleMult(mcfStream str, descrGenNtuple dNTu,
	- char* version)
	-{
	- char *cDat;
	-
	- cDat = version;
	- cDat += dNTu->multOffset;
	- xdr_setpos(str->xdr, (str->currentPos + dNTu->multXDROffset) );
	- return (xdr_int(str->xdr, ((int *) cDat)));
	-}
	-
	-/*
	-** Generalized NTuple XDR filter, used for Decode only.
	-** Simply decode one variable (scalar) or array value. No checks whatsoever!
	-** Not applicable if the structure organization style is VAX FORTRAN d/s
	-** and the index corresponds to an indexed variable.
	-*/
	-bool_t xdr_mcfast_NTupleVar(mcfStream str, descrGenNtuple dNTu,
	- int ivar, char* version)
	-{
	- char *cDat;
	- u_int nn;
	- void *pt;
	- int ivarP;
	-
	- ivarP = ivar;
	- while (dNTu->variables[ivarP]->lengthW == 0) ivarP--;
	- cDat = version;
	- cDat += dNTu->variables[ivarP]->offset;
	- pt = (void *) cDat;
	- xdr_setpos(str->xdr,
	- (str->currentPos + dNTu->variables[ivarP]->offsetXDR));
	- if ((dNTu->variables[ivarP]->lengthW == 1) &&
	- (ivarP < dNTu->firstIndexed)) {
	- switch (dNTu->variables[ivarP]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- return xdr_char(str->xdr, (char *) pt);
	- case INTEGER2_NTU:
	- return xdr_short(str->xdr, (short *) pt);
	- case LOGICAL_NTU: case INTEGER_NTU:
	- return xdr_int(str->xdr, (int *) pt);
	- case REAL_NTU:
	- return xdr_float(str->xdr, (float *) pt);
	- case DBL_PRECISION_NTU:
	- return xdr_double(str->xdr, (double *) pt);
	- case COMPLEX_NTU:
	- nn =2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	- case POINTER_NTU:
	- return xdr_long(str->xdr, (long *) pt);
	- default :
	- return FALSE;
	- }
	- } else {
	- nn = dNTu->variables[ivarP]->lengthW;
	- switch (dNTu->variables[ivarP]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- return xdr_bytes(str->xdr, (char **) &pt, &nn, nn);
	- case INTEGER2_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(short), (xdrproc_t)xdr_short);
	- case LOGICAL_NTU: case INTEGER_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(int), (xdrproc_t)xdr_int);
	- case REAL_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- case DBL_PRECISION_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- case COMPLEX_NTU:
	- nn = nn*2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- case POINTER_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(long), (xdrproc_t)xdr_long);
	- default :
	- return FALSE;
	- }
	- }
	-}
	-/*
	-** Generalized NTuple XDR filter, used for Decode only.
	-** Simply decode one variable (scalar) or array value. No checks whatsoever!
	-** Not applicable if the structure organization style is parallel array
	-** or the index corresponds to a fixed size variable.
	-*/
	-bool_t xdr_mcfast_NTupleSubVar(mcfStream str, descrGenNtuple dNTu,
	- int ivar, int multIndex, char* version)
	-{
	- char *cDat;
	- u_int nn;
	- void *pt;
	- int ivarP;
	-
	- ivarP = ivar;
	- while (dNTu->variables[ivarP]->lengthW == 0) ivarP--;
	- cDat = version;
	- cDat += dNTu->subOffset[multIndex];
	- cDat += dNTu->variables[ivarP]->offset;
	- pt = (void *) cDat;
	- xdr_setpos(str->xdr,
	- (str->currentPos + dNTu->subXDROffset[multIndex] +
	- dNTu->variables[ivarP]->offsetXDR));
	- if (dNTu->variables[ivarP]->lengthW == 1) {
	- switch (dNTu->variables[ivarP]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- return xdr_char(str->xdr, (char *) pt);
	- case INTEGER2_NTU:
	- return xdr_short(str->xdr, (short *) pt);
	- case LOGICAL_NTU: case INTEGER_NTU:
	- return xdr_int(str->xdr, (int *) pt);
	- case REAL_NTU:
	- return xdr_float(str->xdr, (float *) pt);
	- case DBL_PRECISION_NTU:
	- return xdr_double(str->xdr, (double *) pt);
	- case COMPLEX_NTU:
	- nn =2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- case POINTER_NTU:
	- return xdr_long(str->xdr, (long *) pt);
	- default :
	- return FALSE;
	- }
	- } else {
	- nn = dNTu->variables[ivarP]->lengthW;
	- switch (dNTu->variables[ivarP]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- return xdr_bytes(str->xdr, (char **) &pt, &nn, nn);
	- case INTEGER2_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(short), (xdrproc_t)xdr_short);
	- case LOGICAL_NTU: case INTEGER_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(int), (xdrproc_t)xdr_int);
	- case REAL_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- case DBL_PRECISION_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- case COMPLEX_NTU:
	- nn = nn*2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- case POINTER_NTU:
	- return xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(long), (xdrproc_t)xdr_long);
	- default :
	- return FALSE;
	- }
	- }
	-}
	-/*
	-** Generalized NTuple XDR filter, used for Decode only.
	-** Simply decode a sub-structure given a value for the multiplicity index.
	-** Not applicable if the structure organization style is parallel array.
	-** No check whatsover!
	-*/
	-bool_t xdr_mcfast_NTupleSubStruct(mcfStream str, descrGenNtuple dNTu,
	- int multIndex, char* version)
	-{
	- char *cDat;
	- u_int nn;
	- void *pt;
	- int iv;
	- bool_t ok;
	-
	- xdr_setpos(str->xdr,
	- (str->currentPos + dNTu->subXDROffset[multIndex]));
	- for (iv=dNTu->firstIndexed; iv<dNTu->numVariables; iv++) {
	- cDat = version;
	- cDat +=
	- dNTu->subOffset[multIndex] + dNTu->variables[iv]->offset;
	- pt = (void *) cDat;
	- if (dNTu->variables[iv]->lengthW == 1) {
	- switch (dNTu->variables[iv]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_char(str->xdr, (char *) pt);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_short(str->xdr, (short *) pt);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_int(str->xdr, (int *) pt);
	- break;
	- case REAL_NTU:
	- ok = xdr_float(str->xdr, (float *) pt);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_double(str->xdr, (double *) pt);
	- break;
	- case COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn =2;
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_long(str->xdr, (long *) pt);
	- default :
	- return FALSE;
	- }
	- } else if (dNTu->variables[iv]->lengthW > 1){
	- nn = dNTu->variables[iv]->lengthW;
	- switch (dNTu->variables[iv]->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- ok = xdr_bytes(str->xdr, (char **) &pt, &nn, nn);
	- break;
	- case INTEGER2_NTU:
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(short), (xdrproc_t)xdr_short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(int), (xdrproc_t)xdr_int);
	- break;
	- case REAL_NTU:
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_PRECISION_NTU:
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(float), (xdrproc_t)xdr_float);
	- break;
	- case DBL_COMPLEX_NTU:
	- nn = nn*2;
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(double), (xdrproc_t)xdr_double);
	- break;
	- case POINTER_NTU:
	- ok = xdr_array(str->xdr,
	- (char **) &pt, &nn, nn,
	- sizeof(long), (xdrproc_t)xdr_long);
	- break;
	- default :
	- return FALSE;
	- }
	- }
	- }
	- return TRUE;
	-}
	Index: trunk/mcfio/mcf_ntubldInit.c
	===================================================================
	--- trunk/mcfio/mcf_ntubldInit.c (revision 8888)
	+++ trunk/mcfio/mcf_ntubldInit.c (revision 8889)
	@@ -1,31 +0,0 @@
	-/* Database default init routine */
	-/*** Generated automatically using the dbin tool. */
	-/*** Not to be modified by user. */
	-#include "mcf_ntubld_db.h"
	-void mcf_ntubldInit() {
	-
	-/*** template line_title ***/
	-/* char line " " */
	-/* end template */
	-*n_obj_line_title=0;
	-
	-/*** template header ***/
	-/* char title */
	-/* char version */
	-/* char nameMaxIndex */
	-/* int maxMult */
	-/* int orgStyle */
	-/* int nVar */
	-/* end template */
	-*n_obj_header=0;
	-
	-/*** template variable ***/
	-/* char name */
	-/* char description */
	-/* int type */
	-/* char isFixedSize */
	-/* int numDim */
	-/* int dimensions(5) */
	-/* end template */
	-*n_obj_variable=0;
	-}
	Index: trunk/mcfio/mcf_NTuIOUtils.c
	===================================================================
	--- trunk/mcfio/mcf_NTuIOUtils.c (revision 8888)
	+++ trunk/mcfio/mcf_NTuIOUtils.c (revision 8889)
	@@ -1,292 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_NTuIOUtils.c -- Utilities to manipulate files within the MCFIO Gen. *
	-* Ntuple schema *
	-* *
	-* P. Lebrun, September 1995. *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <stdlib.h>
	-#include <sys/param.h>
	-#include <limits.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcfio_Dict.h"
	-#include "mcf_NTuIOFiles.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcf_ntubld_db.h"
	-#ifndef False
	-#define False 0
	-#endif
	-#ifndef True
	-#define True 1
	-#endif
	-
	-extern nTuDDL **NTuDDLList;
	-extern int NumOfNTuples;
	-
	-nTuDDL *mcf_GetNTuByPtrID(int id)
	-{
	- int **ip;
	-
	- if ( (id < 1) \|\| (id > NumOfNTuples)) return NULL;
	- ip = (int **) NTuDDLList;
	- ip += (id-1);
	- return (nTuDDL ) ip;
	-}
	-
	-nTuDDL *mcf_GetNTuByStreamID(int stream, int id)
	-{
	- int i, num;
	- nTuDDL *ddl;
	-
	- for (i=0, num=0; i<NumOfNTuples; i++) {
	- ddl = NTuDDLList[i];
	- if ((ddl->streamId == stream) && (ddl->seqNTuId == id)) return ddl;
	- }
	- return NULL;
	-}
	-int mcf_NTuId(int uid, char *category)
	-/*
	- uid Unique User id
	- category Category name, must be an exact match
	-
	- Returns: Macfio_Ntuple id, or -1 if no items matched, or if
	- Category is illegal..
	-*/
	-{
	- int i, j, **ip;
	- nTuDDL *item;
	- char *cat;
	-
	- if (!mcf_CheckValidCat(category, FALSE)) return -1;
	- ip = (int **) NTuDDLList;
	- cat = mcf_ValidStr(category, NTU_MAX_CATEGORY_LENGTH, "category");
	- for (i=0; i< NumOfNTuples; i++, ip++) {
	- item = (nTuDDL ) ip;
	- if (item->uid == uid) { /* Look first at uid, if match, */
	- /* Confirm with Category */
	- if ((category == NULL) && (item->category == NULL))
	- return (item->id);
	- if (strcmp(category, item->category) == 0)
	- return (item->id);
	- j = strspn(category, " ");
	- if (strcmp((category+j), item->category) == 0)
	- return (item->id);
	- }
	- }
	- return -1;
	-}
	-
	-int mcfioC_GetNTupleIds(int stream, int *ids, int max)
	-{
	- int i, num;
	- nTuDDL *ddl;
	-
	- for (i=0, num=0; i<NumOfNTuples; i++) {
	- ddl = NTuDDLList[i];
	- if (ddl->streamId == stream) {
	- if (num < max ) ids[num] = ddl->id;
	- num++;
	- }
	- }
	- return num;
	-}
	-
	-int mcfioC_GetNTupleUID(int stream, int id)
	-{
	- nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	- return ddl->uid;
	-}
	-
	-void mcfioC_GetNTupleCategory(int stream, int id, char **answer)
	-{
	- nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	- *answer = ddl->category;
	-}
	-
	-void mcfioC_GetNTupleTitle(int stream, int id, char **answer)
	-{
	- nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	- *answer = ddl->title;
	-}
	-
	-void mcfioC_GetNTupleName(int stream, int id, char **answer)
	-{
	- nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	- if (ddl->reference == NULL)
	- *answer = ddl->descrNtu->title;
	- else *answer = ddl->reference->descrNtu->title;
	-}
	-
	-/*
	-** Copy utility routine for a General Ntuple Variable descriptor d/s
	-** It is the responsability of the usr to allocate memory for the
	-** structure where data will be copied to.
	-*/
	-void CopyVarGenNtuple(varGenNtuple vFrom, varGenNtuple vTo)
	-{
	- char string, tc, *tc2;
	- int i, ll;
	-
	- if ((vTo == NULL) \|\| (vFrom == NULL)) return;
	- vTo->nameBlank = vFrom->nameBlank;
	- if (vTo->name != NULL) {
	- free(vTo->name);
	- vTo->name = NULL;
	- }
	- if (vFrom->name != NULL) {
	- ll = (1 + strlen(vFrom->name));
	- vTo->name =
	- (char ) malloc(sizeof(char) ll);
	- strcpy(vTo->name, vFrom->name);
	- }
	- if (vTo->description != NULL) {
	- free(vTo->description);
	- vTo->description = NULL;
	- }
	- if (vFrom->description != NULL) {
	- vTo->description =
	- (char ) malloc(sizeof(char) (1 + strlen(vFrom->description)));
	- strcpy(vTo->description, vFrom->description);
	- }
	- vTo->type = vFrom->type;
	- vTo->isFixedSize = vFrom->isFixedSize;
	- vTo->numDim = vFrom->numDim;
	- if (vFrom->numDim > 0) {
	- for (i=0; i<vFrom->numDim; i++)
	- vTo->dimensions[i] = vFrom->dimensions[i];
	- }
	- vTo->offset = vFrom->offset;
	- vTo->offsetXDR = vFrom->offsetXDR;
	-}
	-/*
	-** insert this ddl into the Global List, expand the list if need be.
	-** Also increment the number of NTuples defined (don't do it twice!).
	-*/
	-void AddNTuDDLtoList(nTuDDL *ddl)
	-{
	- int i, **ipo;
	-
	- NumOfNTuples++;
	- ddl->id = NumOfNTuples;
	- /*
	- ** insert this ddl into the Global List, expand the list if need be
	- */
	- if( (NumOfNTuples - (NumOfNTuples/NTU_START_LIST_SIZE)*NTU_START_LIST_SIZE)
	- == 1 && (NumOfNTuples != 1)) {
	- ipo = (int **) NTuDDLList;
	- NTuDDLList = (nTuDDL *) malloc(sizeof(int )*
	- ((NumOfNTuples/NTU_START_LIST_SIZE + 1)*NTU_START_LIST_SIZE));
	- memcpy(NTuDDLList, ipo, (sizeof(int )(NumOfNTuples-1)));
	- free (ipo);
	- }
	- NTuDDLList[NumOfNTuples-1] = ddl;
	-
	-}
	-/*
	-** Free the memory for a Ntuple Data Descrp. Lang (DDL).
	-*/
	-void DestroyNTuDDL(nTuDDL *ddl)
	-{
	- int i;
	- if (ddl->title != NULL) free(ddl->title);
	- if (ddl->category != NULL) free(ddl->category);
	- if (ddl->dbinFileName != NULL) free(ddl->dbinFileName);
	- DestroyGenNtuple(ddl->descrNtu);
	- free(ddl);
	-}
	-/*
	-** Free the memory for a Description NTuple
	-** Note : the pointer to adrresses are lost, the user will have to give
	-** them to this application back..
	-*/
	-void DestroyGenNtuple(descrGenNtuple *dNTu)
	-{
	- int i;
	-
	- if (dNTu == NULL) return;
	- if (dNTu->title != NULL) free(dNTu->title);
	- if (dNTu->description != NULL) free(dNTu->description);
	- if (dNTu->varOrdering != NULL) free(dNTu->varOrdering);
	- if (dNTu->subOffset != NULL) free(dNTu->subOffset);
	- if (dNTu->subXDROffset != NULL) free(dNTu->subXDROffset);
	- for (i=0; i<dNTu->numAvailable; i++)
	- DestroyVarGenNtuple(dNTu->variables[i]);
	- free(dNTu->variables);
	- free(dNTu);
	-}
	-
	-
	-void DestroyVarGenNtuple(varGenNtuple *var)
	-{
	-
	- if (var == NULL) return;
	- if (var->name != NULL) free(var->name);
	- if (var->description != NULL) free(var->description);
	- free(var);
	-}
	-/*
	- * ValidStr - Validate strings supplied by user
	- *
	- * returns: pointer to valid same or new truncated string
	- *
	- * Note: copy string returned, if needed, before calling ValidStr again
	- */
	-char mcf_ValidStr(char string, int max_length, char *strKind)
	-{
	- static char str[NTU_MAX_CATEGORY_LENGTH+1]; /* make longest string */
	- static char str1[1] = "";
	-
	- if (string == NULL)
	- return str1; /* return empty string */
	- if (strlen(string) <= max_length)
	- return string; /* return pointer to same string */
	- fprintf(stderr,
	- "Mcfio_Ntuple: Error. Specified %s string is too long, truncating\n ->%s\n",
	- strKind, string);
	- memset(str, 0, NTU_MAX_CATEGORY_LENGTH+1);
	- return strncpy(str, string, max_length); /* return ptr to trunc. string */
	-}
	-/*
	-** Based on the HistoScope Check Category
	-*/
	-int mcf_CheckValidCat(char *category, int dotDotDot)
	-{
	- static char validChars[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
	-abcdefghijklmnopqrstuvwxyz1234567890/~!@#$%^&*()_+=-`\"\'\t?><,. ";
	- char strDots, error = NULL;
	- int len;
	-
	- if (category == NULL)
	- return 1;
	- len = strlen(category);
	- strDots = strstr(category, "...");
	- if (len >= NTU_MAX_CATEGORY_LENGTH)
	- error = "is too long";
	- else if (strspn(category, validChars) != len)
	- error = "contains invalid characters";
	- else if (strstr(category, "//") != NULL)
	- error = "contains \"//\"";
	- else if (category[0] == '/')
	- error = "contains leading slash";
	- else if (category[len-1] == '/')
	- error = "contains trailing slash";
	- else if ((dotDotDot == 0 && strDots != NULL)
	- \|\| (dotDotDot != 0 && strDots != NULL && strDots != category + len-3))
	- error = "contains invalid \"...\"";
	-
	- if (error != NULL) {
	- fprintf(stderr, "Error in declared category %s: %s\n",
	- error, category);
	- return 0;
	- } else {
	- return (strDots == NULL ? 1 : -1);
	- }
	-}
	-
	Index: trunk/mcfio/mcfio_Dict.h
	===================================================================
	--- trunk/mcfio/mcfio_Dict.h (revision 8888)
	+++ trunk/mcfio/mcfio_Dict.h (revision 8889)
	@@ -1,57 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_dict.h -- Dictionary for Key words used in Info routines. *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-*******************************************************************************/
	-#define MCFIO_VERSION 100
	-#define MCFIO_STATUS 101
	-#define MCFIO_RUNNING 102
	-#define MCFIO_BOF 103
	-#define MCFIO_EOF 104
	-#define MCFIO_NUMBLOCKS 501
	-#define MCFIO_READORWRITE 502
	-#define MCFIO_READ 1
	-#define MCFIO_WRITE 2
	-#define MCFIO_DIRECTORSEQUENTIAL 503
	-#define MCFIO_DIRECT 1
	-#define MCFIO_SEQUENTIAL 2
	-#define MCFIO_MEMMAPPED 3
	-#define MCFIO_BLOCKIDS 504
	-#define MCFIO_NUMWORDS 505
	-#define MCFIO_EFFICIENCY 506
	-#define MCFIO_NUMEVTS 507
	-#define MCFIO_FILENUMBER 508
	-#define MCFIO_MAXREC 509
	-#define MCFIO_MINREC 510
	-#define MCFIO_NUMRECORDS 511
	-#define MCFIO_RECORDLENGTHS 512
	-#define MCFIO_TITLE 1001
	-#define MCFIO_COMMENT 1002
	-#define MCFIO_CREATIONDATE 1003
	-#define MCFIO_CLOSINGDATE 1013
	-#define MCFIO_FILENAME 1004
	-#define MCFIO_DEVICENAME 1005
	-#define MCFIO_EVENTNUMBER 2001
	-#define MCFIO_STORENUMBER 2002
	-#define MCFIO_RUNNUMBER 2003
	-#define MCFIO_TRIGGERMASK 2004
	-#define MCFIO_NUMNTUPLES 4001
	-#define MCFIO_NTUPLESLIST 4002
	-/*
	-** Block definition now. Start counting at 101 See also mcfioC_GetBlockNames
	-*/
	-#define MCFIO_STDHEP 101
	-#define MCFIO_OFFTRACKARRAYS 102
	-#define MCFIO_OFFTRACKSTRUCT 103
	-#define MCFIO_TRACEARRAYS 104
	-#define MCFIO_STDHEPM 105
	-#define MCFIO_STDHEPBEG 106
	-#define MCFIO_STDHEPEND 107
	-#define MCFIO_STDHEPCXX 108
	-#define MCFIO_STDHEP4 201
	-#define MCFIO_STDHEP4M 202
	-#define MCFIO_HEPEUP 203
	-#define MCFIO_HEPRUP 204
	Index: trunk/mcfio/mcf_NTuIOFiles.c
	===================================================================
	--- trunk/mcfio/mcf_NTuIOFiles.c (revision 8888)
	+++ trunk/mcfio/mcf_NTuIOFiles.c (revision 8889)
	@@ -1,968 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_NTuIOFiles.c -- Utilities to manipulate files within the MCFIO Gen. *
	-* Ntuple schema *
	-* *
	-* P. Lebrun, September 1995. *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <unistd.h>
	-#include <string.h>
	-#include <stdlib.h>
	-#include <ctype.h>
	-#include <sys/param.h>
	-#include <limits.h>
	-#include <time.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#ifdef _HPUX_SOURCE
	-#include <unistd.h>
	-#endif
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcfio_Dict.h"
	-#include "mcfio_Direct.h"
	-#include "mcfio_Util1.h"
	-#include "mcf_ntuBldDbinc.h"
	-#include "mcf_NTuIOFiles.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcf_ntubld_db.h"
	-#ifndef False
	-#define False 0
	-#endif
	-#ifndef True
	-#define True 1
	-#endif
	-
	-extern char *VarTypesNamesF77[N_VAR_TYPES];
	-extern char *VarTypesNamesC[N_VAR_TYPES];
	-
	-extern struct line_title_c line_title_c_;
	-extern struct header_c header_c_;
	-extern struct variable_c variable_c_;
	-
	-/*
	-** Ntuple identifiers list, initialized here and in mcfio_Util1
	-*/
	-nTuDDL **NTuDDLList = NULL;
	-int NumOfNTuples = 0;
	-bool_t McfNTuPleSaveDecoding = True;
	-
	-static char makeStructName(char title, int orgStyle);
	-static size_t nDatVariable(varGenNtuple *varTmp);
	-static size_t sizeVariable(varGenNtuple *varTmp);
	-static char mcf_copyNtrim(char fromString);
	-
	-int mcfioC_DeclareNtuple(int uid, char title, char category,
	- int stream, char *filename)
	-{
	- nTuDDL ddl, ddlRef;
	- int i, l, j, jstr, dejaVu, id, ip, ipo, **ipt;
	-
	-
	- if ((stream < 1) \|\| (stream > MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,
	- " mcfio_NtupleDDLRead: Illegal MCFIO stream number.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_DeclareNtuple: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	-
	- if (McfStreamPtrList[jstr]->row != MCFIO_WRITE) {
	- fprintf(stderr,
	- " mcfio_DeclareNtuple: You must declare an Ntuple for an Output Stream\n");
	- return -1;
	- }
	-
	- if (!mcf_CheckValidCat(category, False)) return 0;
	-
	- /* Check that this item characterized by uid/Category has not already been
	- created. If so, do not create a new one. If associated to the same
	- stream, flag this as an error. */
	-
	- id = mcf_NTuId(uid, category);
	- if (id != -1) {
	- ddl = mcf_GetNTuByPtrID(id);
	- if (ddl->streamId == stream) {
	- fprintf(stderr,
	- "Mcfio Declare Ntuple: An item with this uid/Category already exists.\n");
	- fprintf(stderr, " uid = %d, Category = %s, ", uid, category);
	- fprintf(stderr, "Ntuple not created.\n");
	- return -1;
	- }
	- }
	- /*
	- ** May be this dbin template has already been digested. If so, refer
	- ** to it, to avoid re-computing all the offsets.
	- */
	- ip = (int **) NTuDDLList;
	- for (i=0, dejaVu=False; i< NumOfNTuples; i++, ip++) {
	- ddlRef = (nTuDDL ) ip;
	- if ((ddlRef->dbinFileName != NULL) &&
	- (strcmp(filename, ddlRef->dbinFileName) == 0)) {
	- dejaVu = True;
	- /* Create a holder for this Ntuple Description */
	- ddl = (nTuDDL * ) malloc(sizeof(nTuDDL));
	- /*
	- ** back up in the linked list if need be, until we
	- ** a fully documented descriptor.
	- */
	- while (ddlRef->descrNtu == NULL) ddlRef = ddlRef->reference;
	- ddl->reference = ddlRef;
	- ddl->descrNtu = NULL;
	- ddl->dbinFileName = NULL;
	- break;
	- }
	- }
	- if (dejaVu == False) {
	- ddl = mcf_GetFileNTuDDL(filename);
	- if (ddl == NULL) {
	- fprintf(stderr,
	- " mcfio_NtupleDDLRead: Error reading %s\n", filename );
	- return -1;
	- }
	- ddl->reference = NULL;
	- }
	- ddl->title = mcf_copyNtrim(mcf_ValidStr(title, NTU_MAX_TITLE_LENGTH,
	- "title"));
	- if (category == NULL)
	- ddl->category =
	- mcf_copyNtrim(mcf_ValidStr(category, NTU_MAX_CATEGORY_LENGTH,
	- "category"));
	- else {
	- ddl->category = mcf_copyNtrim(category);
	- }
	- AddNTuDDLtoList(ddl);
	-/*
	-** Now we compute the offssets.
	-*/
	- if (dejaVu == False) {
	- mcf_ComputeNTuOffsets(ddl);
	-/*
	-** Now we compute the lengths..
	-*/
	- mcf_ComputeNTuLengths(ddl);
	- }
	- ddl->uid = uid;
	- ddl->streamId = stream;
	- /*
	- ** Set the sequential id for this particular stream
	- */
	- for (i=0, j=0; i<NumOfNTuples; i++)
	- if (NTuDDLList[i]->streamId == ddl->streamId) j++;
	- ddl->seqNTuId = j;
	- (McfStreamPtrList[jstr]->fhead->nNTuples)++;
	- return ddl->seqNTuId;
	-}
	-
	-int mcfioC_EndDeclNTuples(int stream)
	-/*
	-** Routine to end theNtuple delcaration and rewrite the beginning of the
	-** file.
	-*/
	-{
	- int i, j, jstr, idtmp, ntot;
	- u_int p1, p2;
	- FILE *ff;
	- mcfStream *str;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_EndDeclNtuple: No stream open, No inialization.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_EndDeclNtuple: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str->row != MCFIO_WRITE) {
	- fprintf(stderr,
	- " mcfio_EndDeclNtuple: This routine is not applicable to Input streams...\n");
	- return -1;
	- }
	- if (str->fhead->nNTuples < 1) {
	- fprintf(stderr,
	- " mcfio_EndDeclNtuple: No Ntuple declared for this stream...\n");
	- return 0;
	- }
	- /*
	- ** Now we can try toto complete the file header. As it is now bigger,
	- ** and it is the first structure written, it is easier to start over.
	- ** Destroy the XDR stream, close the file, and reopen it.
	- */
	- xdr_destroy(str->xdr);
	- fclose(str->filePtr);
	- remove(str->filename);
	- ff = fopen(str->filename, "w");
	- if (ff == NULL) {
	- fprintf(stderr,
	- " mcfio_EndDeclNtuple: Problem re-opening file %s, message \n",
	- str->filename);
	- return -1;
	- }
	- xdrstdio_create(str->xdr, ff, XDR_ENCODE);
	- p1 = xdr_getpos(str->xdr);
	- str->firstPos = p1;
	- str->currentPos = p1;
	- /*
	- ** In the file header, we do not store the NTuple Ids, as they are
	- ** not necessarily valid in an other context, where we have different
	- ** streams/NTuples combinations. The SeqNTuId are trivial,
	- ** within a stream, at the file header (1,2,3,..)
	- ** But, of course, we must provide an array for the event header..
	- */
	- str->ehead->dimNTuples = str->fhead->nNTuples;
	- str->ehead->nNTuples = 0;
	- str->ehead->nTupleIds =
	- (int ) malloc(sizeof(int) str->fhead->nNTuples);
	-
	- str->ehead->ptrNTuples =
	- (u_int ) malloc(sizeof(u_int) str->fhead->nNTuples);
	- for (i=0; i<str->ehead->dimNTuples; i++) str->ehead->ptrNTuples[i]=0;
	-
	- str->status = MCFIO_BOF;
	- if (mcfioC_Wrtfhead(str, INITIATE) == FALSE){
	- mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	- fclose(ff);
	- return -1;
	- }
	- /*
	- ** Write the first dummy table
	- */
	- if (mcfioC_Wrttable(str, INITIATE) == FALSE) return -1;
	- /*
	- ** Write the first dummy event header
	- */
	- if (mcfioC_WrtEvt(str, INITIATE) == FALSE) return -1;
	- str->ehead->evtnum = 0;
	- str->status = MCFIO_RUNNING;
	- return (str->fhead->nNTuples);
	-}
	-
	-nTuDDL mcf_GetFileNTuDDL(charfilename)
	-{
	- nTuDDL *ddl;
	- int i, l, j;
	- char text, tc;
	- varGenNtuple *varTmp;
	- descrGenNtuple *dNTu;
	-
	- /* Create a holder for this Ntuple Description */
	- ddl = (nTuDDL * ) malloc(sizeof(nTuDDL));
	- ddl->dbinFileName = (char ) malloc(sizeof(char) (strlen(filename) +1));
	- strcpy(ddl->dbinFileName, filename);
	- ddl->descrNtu = (descrGenNtuple *) malloc(sizeof(descrGenNtuple));
	- dNTu = ddl->descrNtu;
	-
	- header_c_.n_obj_header = 0;
	- line_title_c_.n_obj_line_title = 0;
	- mcf_ntubldRead(filename);
	- if ((line_title_c_.n_obj_line_title < 1) \|\|
	- (header_c_.n_obj_header != 1)) {
	- fprintf(stderr,
	- " This file was not created by the ntuBuild aplication!");
	- return NULL;
	- }
	- if (strcmp(line_title_c_.line_title[0].line,
	- "ntuBuild Database, v1.0") != 0) {
	- fprintf(stderr,
	- " This file was not created by a wrong version of ntuBuild!");
	- return NULL;
	- }
	- /*
	- ** There are 80 character per lines in dbin..
	- */
	- text = (char *)
	- malloc(sizeof(char) * 80 * (line_title_c_.n_obj_line_title -1));
	- for (i=1, tc=text; i<line_title_c_.n_obj_line_title; i++) {
	- strcpy(tc, line_title_c_.line_title[i].line);
	- tc += strlen(line_title_c_.line_title[i].line);
	- *tc = '\n'; tc++;
	- }
	- *tc = '\0';
	- dNTu->description = text;
	-
	- l = strlen(header_c_.header[0].title);
	- dNTu->title = (char ) malloc(sizeof(char) (l+1));
	- strcpy(dNTu->title, header_c_.header[0].title);
	-
	- strcpy(dNTu->version, header_c_.header[0].version);
	-
	- strcpy(dNTu->nameIndex, header_c_.header[0].namemaxindex);
	-
	- dNTu->maxMultiplicity = header_c_.header[0].maxmult;
	-
	- dNTu->orgStyle = header_c_.header[0].orgstyle;
	- dNTu->numVariables = header_c_.header[0].nvar;
	- dNTu->numAvailable = dNTu->numVariables;
	- dNTu->variables =
	- (varGenNtuple *) malloc(sizeof(varGenNtuple ) * dNTu->numVariables);
	- /*
	- ** Now the variables
	- */
	- for (i=0; i<variable_c_.n_obj_variable; i++) {
	- dNTu->variables[i] =
	- (varGenNtuple *) malloc(sizeof(varGenNtuple));
	- varTmp = dNTu->variables[i];
	- varTmp->nameBlank = False;
	- varTmp->name = (char *)
	- malloc(sizeof(char) * (strlen(variable_c_.variable[i].name) + 1));
	- strcpy(varTmp->name, variable_c_.variable[i].name);
	-
	- if ((strlen(variable_c_.variable[i].description) > 1) \|\|
	- variable_c_.variable[i].description[0] != ' ') {
	- varTmp->description = (char ) malloc(sizeof(char)
	- (strlen(variable_c_.variable[i].description) + 1));
	- strcpy(varTmp->description, variable_c_.variable[i].description);
	- } else varTmp->description = NULL;
	- varTmp->type = variable_c_.variable[i].type;
	- varTmp->isFixedSize = True;
	- if (strncmp(variable_c_.variable[i].isfixedsize,"Yes",3))
	- varTmp->isFixedSize = False;
	- varTmp->numDim = variable_c_.variable[i].numdim;
	- if (varTmp->numDim > 0)
	- for (j=0; j< varTmp->numDim; j++)
	- varTmp->dimensions[j] = variable_c_.variable[i].dimensions[j];
	-
	- }
	- /*
	- ** Set the ordering. Trivial in this case, it has been ordered in
	- ** the save routine.
	- */
	- dNTu->varOrdering = (int ) malloc(sizeof(int) dNTu->numAvailable);
	- for (i=0; i<dNTu->numVariables; i++)
	- dNTu->varOrdering[i] = i;
	- dNTu->subOffset = NULL;
	- dNTu->subXDROffset = NULL;
	- return ddl;
	-
	-}
	-
	-/*
	-** Compute the offsets by writing a simple program, stand alone, that uses
	-** the d/s
	-*/
	-void mcf_ComputeNTuOffsets(nTuDDL *ddl)
	-{
	- char tmpName[128], tc, tc1, *nameCom;
	- int i, j, l, fd, firstIndexed, nDat;
	- char filenameInclude[128], filenameProgram[128], filenameExec[128];
	- char filenameData[128], nameMaxIndex[32];
	- char line[256];
	- void **ptrBegVar;
	- varGenNtuple *varTmp;
	- descrGenNtuple *dNTu;
	- FILE *Ffp;
	-
	- dNTu =ddl->descrNtu;
	- for (i=0; i< dNTu->numVariables; i++) {
	- varTmp = dNTu->variables[i];
	- varTmp->offset = 0;
	- }
	-
	- memset(tmpName, 0, 127);
	- tc = tmpName;
	- sprintf(tc, "tmp_%s_XXXXXX", ddl->descrNtu->title);
	-/* this is a kludge - we create a temporary file, close it, and use the name */
	- fd = mkstemp(tmpName);
	- if ( fd < 0 ) {
	- fprintf(stderr,
	- " Can not compose a tempoary name in mcf_ComputeOffsets!");
	- return;
	- }
	- tc1 = tc;
	- close(fd);
	- sprintf(filenameInclude, "%s.h", tc1);
	- sprintf(filenameProgram, "%s.c", tc1);
	- sprintf(filenameData, "%s.dat", tc1);
	- strcpy(filenameExec, tc1);
	- mcf_ComposeDoth(ddl->descrNtu, filenameInclude);
	-/*
	-** Compose a little moronic program that establishes the addresses of all
	-** variables. There might be a better way, though.. However, this ought to be
	-** safe.
	-*/
	- Ffp = fopen( filenameProgram, "w");
	- fprintf(Ffp, "#include <stdio.h>\n");
	- fprintf(Ffp, "#include \"%s\"\n",filenameInclude);
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU)
	- fprintf(Ffp, "#define NUM_VAR %d\n", (dNTu->numVariables+3));
	- else
	- fprintf(Ffp, "#define NUM_VAR %d\n",
	- (dNTu->numVariables + 3 + dNTu->maxMultiplicity) );
	-
	- nameCom = makeStructName(dNTu->title, dNTu->orgStyle);
	-
	- fprintf(Ffp, "%s_struct tmpStruct; \n", nameCom);
	- fprintf(Ffp, "main(int argc, char **argv)\n");
	- fprintf(Ffp, "{\n");
	- fprintf(Ffp, " void *ptrBegVar[NUM_VAR];\n");
	- fprintf(Ffp, " FILE *Ffp;\n");
	- fprintf(Ffp, " int i;\n");
	- fprintf(Ffp, "\n");
	- fprintf(Ffp, " ptrBegVar[0] = (void *) &tmpStruct.version[0];\n");
	- fprintf(Ffp,
	- " ptrBegVar[1] = (void *) &tmpStruct.%s;\n",dNTu->nameIndex);
	- for(i=0, firstIndexed=-1; i<dNTu->numVariables; i++) {
	- if (dNTu->variables[i]->isFixedSize == False) {
	- firstIndexed = i; break;
	- }
	- }
	- dNTu->firstIndexed = firstIndexed;
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- for(i=0; i<dNTu->numVariables; i++) {
	- varTmp = dNTu->variables[i];
	- /*
	- ** Assume that all the variables are properly
	- ** defined at this stage (e..g, coming from a valid DDL dbin file)
	- ** and in order
	- */
	- tc = line;
	- if ((varTmp->numDim == 0) && (varTmp->isFixedSize == True))
	- sprintf(tc,
	- " ptrBegVar[%d] = (void *) &tmpStruct.%s%n",
	- (i+2), varTmp->name, &l);
	- else
	- sprintf(tc,
	- " ptrBegVar[%d] = (void *) tmpStruct.%s%n",
	- (i+2), varTmp->name, &l);
	- tc+=l;
	- fprintf(Ffp, "%s;\n", line);
	- }
	- fprintf(Ffp,
	- " ptrBegVar[%d] = (void *) tmpStruct.fence;\n",dNTu->numVariables+2);
	- } else {
	- for(i=0; i<dNTu->numVariables; i++) {
	- varTmp = dNTu->variables[i];
	- tc = line;
	- if (varTmp->isFixedSize == True) {
	- if (varTmp->numDim == 0)
	- sprintf(tc,
	- " ptrBegVar[%d] = (void *) &tmpStruct.%s%n",
	- (i+2), varTmp->name, &l);
	- else
	- sprintf(tc,
	- " ptrBegVar[%d] = (void *) tmpStruct.%s%n",
	- (i+2), varTmp->name, &l);
	- } else {
	- if (varTmp->numDim == 0)
	- sprintf(tc,
	- " ptrBegVar[%d] = (void *) &tmpStruct.var[0].%s%n",
	- (i+2), varTmp->name, &l);
	- else
	- sprintf(tc,
	- " ptrBegVar[%d] = (void *) tmpStruct.var[0].%s%n",
	- (i+2), varTmp->name, &l);
	- }
	- fprintf(Ffp, "%s;\n", line);
	- }
	- tc1 = dNTu->nameIndex;
	- strcpy(nameMaxIndex, tc1);
	- l = strlen(tc1);
	- if (l > 26) {
	- strncpy(nameMaxIndex, tc1, 26);
	- sprintf(&nameMaxIndex[26],"_max");
	- } else
	- sprintf(nameMaxIndex, "%s_max", tc1);
	- fprintf(Ffp," for (i=0; i<%s; i++) \n", nameMaxIndex);
	- tc = line;
	- if (firstIndexed != -1) {
	- varTmp = dNTu->variables[firstIndexed];
	- sprintf(tc,
	- " ptrBegVar[i+%d] = (void *) &tmpStruct.var[i].%s%n",
	- (2+dNTu->numVariables), varTmp->name, &l); tc+=l;
	- if (varTmp->numDim > 0) for (j=0; j<varTmp->numDim; j++, tc+=l)
	- sprintf(tc, "[0]%n", &l);
	- fprintf(Ffp, "%s;\n", line);
	- }
	- fprintf(Ffp,
	- " ptrBegVar[%d] = (void *) tmpStruct.fence;\n",
	- dNTu->numVariables+2+dNTu->maxMultiplicity);
	- }
	- fprintf(Ffp, " ");
	- fprintf(Ffp," Ffp = fopen(\"%s\",\"w\");\n",filenameData);
	- fprintf(Ffp," fwrite((void ) ptrBegVar, sizeof(void ),\
	-(size_t) NUM_VAR, Ffp);\n");
	- fprintf(Ffp," fclose(Ffp);\n");
	- fprintf(Ffp,"}\n");
	- fclose(Ffp);
	- free(nameCom);
	- /*
	- ** Now compile, link and load this exec, read the result
	- */
	- sprintf(line,"rm -f %s", filenameExec);
	- system(line);
	-#ifdef _HPUX_SOURCE
	- sprintf(line,"cc -Aa -D_HPUX_SOURCE -o %s %s",
	- filenameExec, filenameProgram);
	-#else
	- sprintf(line,"cc -o %s %s", filenameExec, filenameProgram);
	-#endif
	- system(line);
	- sprintf(line,"./%s", filenameExec);
	- system(line);
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) nDat = dNTu->numVariables+3;
	- else nDat = dNTu->numVariables+3+dNTu->maxMultiplicity;
	- if (firstIndexed == -1) nDat = dNTu->numVariables+3;
	- ptrBegVar = (void *) malloc (sizeof(void ) * (nDat));
	- Ffp = fopen(filenameData, "r");
	- fread((void ) ptrBegVar, sizeof(void ), (size_t) nDat, Ffp);
	- fclose(Ffp);
	- /*
	- ** remove garbage files..
	- */
	- remove(filenameData); remove(filenameProgram); remove(filenameExec);
	- remove(filenameInclude);
	- /*
	- ** Convert these addresses to offsets
	- */
	- dNTu->multOffset = ((long) ptrBegVar[1] - (long) ptrBegVar[0]);
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- dNTu->fenceOffset =
	- ((long) ptrBegVar[dNTu->numVariables+2] - (long) ptrBegVar[0]);
	- for (i=0; i< dNTu->numVariables; i++)
	- dNTu->variables[i]->offset =
	- ((long) ptrBegVar[i+2] - (long) ptrBegVar[0]);
	- } else {
	- for (i=0; i< dNTu->numVariables; i++) {
	- varTmp = dNTu->variables[i];
	- if (varTmp->isFixedSize)
	- varTmp->offset =
	- ((long) ptrBegVar[i+2] - (long) ptrBegVar[0]);
	- else
	- varTmp->offset =
	- ((long) ptrBegVar[i+2] - (long)ptrBegVar[firstIndexed+2]);
	- }
	- if (dNTu->subOffset != NULL) free(dNTu->subOffset);
	- dNTu->subOffset =
	- (long ) malloc(sizeof(long) dNTu->maxMultiplicity);
	- if (firstIndexed != -1) {
	- for (i=0; i<dNTu->maxMultiplicity; i++)
	- dNTu->subOffset[i] =
	- ((long) ptrBegVar[i+2+dNTu->numVariables] -
	- (long) ptrBegVar[0]);
	- }
	- dNTu->fenceOffset =
	- ((long) ptrBegVar[dNTu->numVariables+2+dNTu->maxMultiplicity]
	- - (long) ptrBegVar[0]);
	- }
	- free(ptrBegVar);
	-}
	-
	-/*
	-** Compute the lengths for the XDR Array statements. It is assumed that the
	-** NTUple descriptor is sorted, no blank variables.
	-*/
	-void mcf_ComputeNTuLengths(nTuDDL *ddl)
	-{
	- int i, j, lastTmp, sameType;
	- size_t nDat, sizeItem;
	- varGenNtuple var1, var2;
	- descrGenNtuple *dNTu;
	-
	- dNTu =ddl->descrNtu;
	- if (dNTu->firstIndexed != -1) lastTmp = dNTu->firstIndexed;
	- else lastTmp = dNTu->numVariables;
	- /*
	- ** fixed size first..
	- */
	- for (i=0; i<lastTmp; i++)
	- dNTu->variables[i]->lengthW = nDatVariable(dNTu->variables[i]);
	-/*
	-** This, in principle, is the optimized version, where we collaps single
	-** fields of the same type into an array. However, this is machine
	-** dependant.
	-*/
	- for (i=0; i<lastTmp; i++) {
	- var1 = dNTu->variables[i];
	- if (var1->lengthW != 0) {
	- nDat = nDatVariable(var1);
	- j=i+1;
	- sizeItem = sizeVariable(var1);
	- sameType = True;
	- while ((j<lastTmp) && (sameType)) {
	- var2 = dNTu->variables[j];
	- if (var2->type != var1->type) sameType = False;
	- if (sameType && ((( var2->offset -
	- var1->offset)/sizeItem) ==
	- nDat)) {
	- nDat += nDatVariable(var2);
	- var2->lengthW = 0; j++;
	- }
	- }
	- var1->lengthW = nDat;
	- var1->lengthB = nDat*sizeItem;
	- }
	- }
	- /*
	- ** The variable size, similar code. This fill is very simple if the
	- ** if the organisation is parallel arrays, as we can not implmenent
	- ** compaction
	- */
	- if (dNTu->firstIndexed == -1) return;
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	- dNTu->variables[i]->lengthW
	- = nDatVariable(dNTu->variables[i]);
	- dNTu->variables[i]->lengthB = dNTu->variables[i]->lengthW
	- * sizeVariable(dNTu->variables[i]);
	- }
	- } else {
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++)
	- dNTu->variables[i]->lengthW = nDatVariable(dNTu->variables[i]);
	- for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	- var1 = dNTu->variables[i];
	- if (var1->lengthW != 0) {
	- nDat = nDatVariable(var1);
	- j=i+1;
	- sizeItem = sizeVariable(var1);
	- sameType = True;
	- while ((j<dNTu->numVariables) && (sameType)) {
	- var2 = dNTu->variables[j];
	- if (var2->type != var1->type) sameType = False;
	- if (sameType && (((var2->offset -
	- var1->offset)/sizeItem) ==
	- nDat)) {
	- nDat += nDatVariable(var2);
	- var2->lengthW = 0; j++;
	- }
	- }
	- var1->lengthW = nDat;
	- var1->lengthB = nDat*sizeItem;
	- }
	- }
	- }
	-
	-}
	-/*
	-** Compute, in size_t units (bytes, I hope) the length of a particular
	-** variable. Only the fixed size part, we will have to multiplity
	-** by the multiplicty in the XDR filter.
	-*/
	-
	-static size_t nDatVariable(varGenNtuple *var)
	-{
	- size_t n;
	- int i;
	-
	- n=1;
	- for (i=0; i<var->numDim; i++) n = n * var->dimensions[i];
	- return n;
	-}
	-static size_t sizeVariable(varGenNtuple *var)
	-{
	- size_t n;
	-
	- switch (var->type) {
	- case BYTE_NTU: case CHARACTER_NTU:
	- n = sizeof(char);
	- break;
	- case INTEGER2_NTU:
	- n = sizeof(short);
	- break;
	- case LOGICAL_NTU: case INTEGER_NTU:
	- n = sizeof(int);
	- break;
	- case REAL_NTU:
	- n = sizeof(float);
	- break;
	- case DBL_PRECISION_NTU:
	- n = sizeof(double);
	- break;
	- case COMPLEX_NTU:
	- n = 2 * sizeof(float);
	- break;
	- case DBL_COMPLEX_NTU:
	- n = 2 * sizeof(double);
	- break;
	- case POINTER_NTU:
	- n = sizeof(void *);
	- break;
	- default :
	- fprintf(stderr, " mcf_ComputNTuLength, internal error \n");
	- n = 0;
	- break;
	- }
	- return n;
	-}
	-
	-/*
	-** Compose the .h file. Called from NTuBldMenu and this file. The structure
	-** is assumed valid.
	-*/
	-void mcf_ComposeDoth(descrGenNtuple dNTu, char filename)
	-{
	- char nameCom, line[FILENAME_MAX+500], tmp, version, text, tc, tc2;
	- char nameMaxIndex[32], nameTmpIndex[32];
	- char nullDescr[4], *descrTmp;
	- int i, j, l, kmode, nc, ncTot, nl, iv;
	- time_t clock;
	- FILE *Ffp;
	- varGenNtuple *var;
	-
	- nameCom = makeStructName(dNTu->title, dNTu->orgStyle);
	- strcpy(nullDescr, "? ");
	- strcpy(line, filename);
	- tc = strchr(line, '.');
	- if (tc == NULL) {
	- l = strlen(filename);
	- tc = line; tc+=l;
	- }
	- strcpy(tc,".h");
	- Ffp = fopen(line, "w");
	- fprintf(Ffp,"/* ntuBuild\n");
	- time(&clock);
	- tmp = line; sprintf(tmp,"** Creation Date : %n", &l); tmp += l;
	- strncpy(tmp,ctime(&clock), 24); tmp += 24; tmp='\n'; tmp++; tmp = '\0';
	- fprintf(Ffp,line);
	- fprintf(Ffp,"** User Comments\n");
	- text = dNTu->description;
	- tc = text;
	- if (*tc == '\0')
	- fprintf(Ffp,"** no user comments\n");
	- else {
	- ncTot = strlen(tc); nc =0;
	- while (nc < ncTot) {
	- tc2 = strchr(tc,'\n');
	- nl = (int) (tc2-tc)/sizeof(char);
	- if ((tc2 == NULL) \|\| (nl > 75)) nl = 75;
	- strncpy(line, tc, nl); line[nl] = '\0';
	- fprintf (Ffp,"** %s\n", line);
	- tc += nl; nc += nl;
	- if (*tc == '\n') {
	- tc++;
	- nc++;
	- }
	- }
	- }
	- fprintf(Ffp,"*/ \n");
	- version = dNTu->version;
	- text = dNTu->nameIndex;
	- strcpy(nameTmpIndex, text);
	- l = strlen(text);
	- if (l > 26) {
	- strncpy(nameMaxIndex, text, 26);
	- sprintf(&nameMaxIndex[26],"_max");
	- } else
	- sprintf(nameMaxIndex, "%s_max", text);
	- fprintf(Ffp,"#define %s %d\n", nameMaxIndex, dNTu->maxMultiplicity);
	- if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	- fprintf(Ffp, "typedef struct _%s_struct {\n", nameCom);
	- /*
	- ** The first 64 bits contain the version token, as a char[8] string
	- ** floowed by the multiplicty variable, followed by an integer pad
	- */
	- fprintf(Ffp," char version[8]; /* Version token */\n");
	- fprintf(Ffp,
	- " int %s; /* Generalized Ntuple Multiplicity value */ \n",
	- nameTmpIndex);
	- fprintf(Ffp,
	- " int padding; /* Padding for 64 bit architecture */ \n");
	- for (iv=0; iv< dNTu->numVariables; iv++) {
	- for (j=0; j<dNTu->numAvailable; j++)
	- if (dNTu->varOrdering[j] == iv) i = j;
	- var = dNTu->variables[i];
	- kmode = 0; if (var->isFixedSize != True) kmode = 1;
	- if (var->description == NULL) descrTmp = nullDescr;
	- else descrTmp = var->description;
	- tc = line;
	- if ((var->type != COMPLEX_NTU) &&
	- (var->type != DBL_COMPLEX_NTU)) {
	- sprintf(tc," %s %n", VarTypesNamesC[var->type], &l);
	- tc +=l;
	- if ((var->numDim == 0) && (kmode ==0))
	- sprintf(tc," %s; /* %s */",
	- var->name, descrTmp);
	- else if (var->numDim == 0) {
	- sprintf(tc," %s[%s]; /* %s */",
	- var->name, nameMaxIndex, descrTmp);
	- } else {
	- sprintf(tc," %s%n",var->name, &l); tc+=l;
	- if (kmode == 1) {
	- sprintf(tc, "[%s]%n", nameMaxIndex, &l);
	- tc +=l;
	- }
	- for (j=var->numDim-1; j>-1; j--, tc+=l)
	- sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	-
	- sprintf (tc,"; /* %s */", descrTmp);
	- }
	- } else { /* got to convert to float or dbl */
	- if (var->type == COMPLEX_NTU)
	- sprintf(tc," float %n", &l);
	-
	- else if (var->type == DBL_COMPLEX_NTU)
	- sprintf(tc," double %n", &l);
	-
	- tc +=l;
	- if ((var->numDim == 0) && (kmode ==0))
	- sprintf(tc," %s[2]; /* %s */", var->name, descrTmp);
	- else if (var->numDim == 0) {
	- sprintf(tc," %s[%s][2]; /* %s */",
	- var->name, nameMaxIndex, descrTmp);
	- } else {
	- sprintf(tc," %s%n",var->name, &l); tc+=l;
	- if (kmode == 1) {
	- sprintf(tc, "[%s]%n", nameMaxIndex, &l);
	- tc +=l;
	- }
	- for (j=var->numDim-1; j>-1; j--, tc+=l)
	- sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	- sprintf (tc,"[2]; /* %s */", descrTmp);
	- }
	- }
	- fprintf(Ffp,"%s\n", line);
	- }
	- fprintf(Ffp," int fence[2]; \n");
	- fprintf(Ffp,"} %s_struct; \n", nameCom);
	- }else {
	- /*
	- ** The other type of organisation, using structure
	- */
	- fprintf(Ffp, "typedef struct _%s_v_struct{\n", nameCom);
	- for (iv=0; iv< dNTu->numVariables; iv++) {
	- for (j=0; j<dNTu->numAvailable; j++)
	- if (dNTu->varOrdering[j] == iv) i = j;
	- var = dNTu->variables[i];
	- if (var->isFixedSize == False) {
	- tc = line;
	- if (var->type == COMPLEX_NTU)
	- sprintf(tc," float %n", &l);
	- else if (var->type == DBL_COMPLEX_NTU)
	- sprintf(tc," double %n", &l);
	- else
	- sprintf(tc," %s %n", VarTypesNamesC[var->type], &l);
	- tc +=l;
	- sprintf(tc," %s%n",var->name, &l); tc+=l;
	- if (var->numDim != 0) {
	- for (j=var->numDim-1; j>-1; j--, tc+=l)
	- sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	- }
	- if ((var->type == COMPLEX_NTU) \|\|
	- (var->type == DBL_COMPLEX_NTU)) {
	- sprintf (tc,"[2]%n",&l);
	- tc += l;
	- }
	- if (var->description == NULL) descrTmp = nullDescr;
	- else descrTmp = var->description;
	- sprintf(tc,"; /* %s */%n", descrTmp, &l); tc += l;
	- fprintf(Ffp,"%s\n", line);
	- }
	- }
	- fprintf(Ffp,"} %s_v_struct; \n", nameCom);
	- fprintf(Ffp,"/* ----- */ \n", line);
	- /*
	- ** the mother structure now
	- */
	- fprintf(Ffp, "typedef struct _%s_struct{\n", nameCom);
	- fprintf(Ffp," char version[8]; /* Version token */\n");
	- fprintf(Ffp,
	- " int %s; /* Generalized Ntuple Multiplicity value */ \n",
	- nameTmpIndex);
	- fprintf(Ffp,
	- " int padding; /* Padding for 64 bit architecture */ \n");
	- for (iv=0; iv< dNTu->numVariables; iv++) {
	- for (j=0; j<dNTu->numAvailable; j++)
	- if (dNTu->varOrdering[j] == iv) i = j;
	- var = dNTu->variables[i];
	- if (var->isFixedSize == True) {
	- tc = line;
	- if (var->type == COMPLEX_NTU)
	- sprintf(tc," float %n", &l);
	- else if (var->type == DBL_COMPLEX_NTU)
	- sprintf(tc," double %n", &l);
	- else
	- sprintf(tc," %s %n", VarTypesNamesC[var->type], &l);
	- tc +=l;
	- sprintf(tc," %s%n",var->name, &l); tc+=l;
	- if (var->numDim != 0) {
	- for (j=var->numDim-1; j>-1; j--, tc+=l)
	- sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	- }
	- if ((var->type == COMPLEX_NTU) \|\|
	- (var->type == DBL_COMPLEX_NTU)) {
	- sprintf (tc,"[2]%n",&l);
	- tc += l;
	- }
	- if (var->description == NULL) descrTmp = nullDescr;
	- else descrTmp = var->description;
	- sprintf(tc,"; /* %s */%n", descrTmp, &l); tc += l;
	- fprintf(Ffp,"%s\n", line);
	- }
	- }
	- fprintf(Ffp,
	- " %s_v_struct var[%s]; /* The array of substructures */\n",
	- nameCom, nameMaxIndex);
	- fprintf(Ffp," int fence[2]; \n");
	- fprintf(Ffp,"} %s_struct; \n", nameCom);
	- }
	- free(nameCom);
	- fclose(Ffp);
	-
	-}
	-
	-void mcfioC_SetForSaveDecoding(int val)
	-{
	- if(val != 0) McfNTuPleSaveDecoding = True;
	- else McfNTuPleSaveDecoding = False;
	-}
	-
	-static char makeStructName(char title, int orgStyle)
	-{
	- char *out;
	- int i, l, nMax;
	-
	- l = strlen(title);
	- if (orgStyle == PARALLEL_ARRAY_NTU) nMax = 23;
	- else nMax = 21;
	- if (l > nMax) l = nMax;
	- out = (char ) malloc(sizeof(char) (l+1));
	- strncpy(out, title, l); out[l]='\0';
	- for (i=0; i<l; i++) if (out[i] == ' ') out[i] = '_';
	- return out;
	-}
	-/*
	-** CopyNtrim - Copy "fromString" to a malloc'd new string,
	-** trimming off leading and trailing spaces & tabs.
	-** The newly malloc'd string is returned.
	-** If fromString is NULL, NULL is returned.
	-*/
	-static char mcf_copyNtrim(char fromString)
	-{
	- char c, toString;
	- int len, i;
	-
	- if (fromString == NULL)
	- return NULL;
	- toString = (char *) malloc(strlen(fromString)+1);
	-
	- /* Find the first non-white character */
	- for (c=fromString; c == ' ' \|\| c == '\t'; c++);
	-
	- /* Copy the remainder of fromString to toString */
	- strcpy(toString, c);
	-
	- /* Remove trailing spaces and tabs by converting to nulls */
	- len = strlen(toString);
	- if (len == 0) /* special case for empty strings */
	- return toString;
	- for (i = len-1; i >= 0; --i) {
	- if (isspace(toString[i]))
	- toString[i] = '\0';
	- else
	- break;
	- }
	- return toString;
	-}
	-
	-
	-
	Index: trunk/mcfio/mcfio_Block.c
	===================================================================
	--- trunk/mcfio/mcfio_Block.c (revision 8888)
	+++ trunk/mcfio/mcfio_Block.c (revision 8889)
	@@ -1,486 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_Block.c -- Utility routines for the McFast Monte-Carlo *
	-* The routine to encode/decode a block *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#include <stdlib.h>
	-#include <time.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcf_xdr_Ntuple.h"
	-#include "mcfio_Dict.h"
	-#include "mcfio_Util1.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcfio_Direct.h"
	-#include "mcfio_Block.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-int mcfioC_Block(int stream, int blkid,
	- bool_t xdr_filtercode(XDR xdrs, int blockid, int ntot, char *version))
	-/*
	-** Routine to decode or encode a particular Block. Return 1 if O.K,
	-** -1 if a problem or unknow block.
	-**
	-** Adding Ntuple instances ... October 1995.
	-*/
	-{
	- int i, j, jstr, idtmp, ntot, nbuff;
	- bool_t ok;
	- u_int p1;
	- mcfStream *str;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_Block: You must first initialize by calling mcfio_Init.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_Block: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	- str = McfStreamPtrList[jstr];
	- if ((str->row == MCFIO_WRITE) &&
	- (str->fhead->nBlocks == str->ehead->nBlocks)) {
	- fprintf(stderr,
	- " mcfio_Block: Maximum number of Blocks reached for stream %d ...\n", stream);
	- fprintf(stderr,
	- " Please upgrade the declaration mcfio_Open statement \n");
	- return -1;
	- }
	-
	- if (str->row == MCFIO_READ) {
	- for(i=0, j=-1; i<str->ehead->nBlocks; i++) {
	- if (str->ehead->blockIds[i] == blkid) j = i;
	- }
	- if (j == -1) {
	- fprintf(stderr,
	- " mcfio_Block: Unable to find block i.d. %d in Stream %d \n", blkid, stream);
	- return -1;
	- }
	- if (xdr_setpos(str->xdr,str->ehead->ptrBlocks[j]) == FALSE) {
	- fprintf(stderr,
	- " mcfio_Block: Unable to position stream at block %d \n", blkid);
	- return -1;
	- }
	- str->currentPos = str->ehead->ptrBlocks[j];
	- } else if (str->row == MCFIO_WRITE) {
	- idtmp = blkid;
	- /*
	- ** if to Sequential media, one first has to make sure we have
	- ** enough room in the buffer.
	- */
	- if (str->dos == MCFIO_SEQUENTIAL) {
	- str->xdr->x_op = XDR_MCFIOCODE;
	- ok = xdr_filtercode(str->xdr, &idtmp, &ntot, McfGenericVersion);
	- str->xdr->x_op = XDR_ENCODE;
	- if ((str->currentPos + 4*(ntot + 1)) > str->bufferSize) {
	- /*
	- ** Once again, I don't trust realloc, got to copy to the second
	- ** buffer.
	- */
	- nbuff = 1 +
	- (((4*(ntot + 1)) + (str->currentPos - str->firstPos))/
	- str->maxlrec);
	- str->buffer2 =
	- (char ) malloc (sizeof(char) (str->maxlrec *nbuff));
	- memcpy(str->buffer2, str->buffer,
	- (str->currentPos - str->firstPos));
	- free(str->buffer);
	- str->buffer = str->buffer2;
	- str->buffer2 = NULL;
	- str->bufferSize = str->maxlrec * nbuff;
	- xdrmem_create(str->xdr, str->buffer, str->bufferSize, XDR_ENCODE);
	- if (xdr_setpos(str->xdr, str->currentPos) == FALSE) {
	- fprintf(stderr,
	- " mcfio_Block:\n\
	- Unable to position stream %d at block %d after realocation.\n", stream, blkid);
	- return -1;
	- }
	- }
	- }
	- }
	- p1 = str->currentPos;
	- ok = xdr_filtercode(str->xdr, &idtmp, &ntot, McfGenericVersion);
	- if (ok == FALSE) {
	- fprintf(stderr,
	- " mcfio_Block: Unable to encode or decode block I.D. %d \n", blkid);
	- j = str->ehead->nBlocks;
	- if (xdr_setpos(str->xdr,p1) == FALSE)
	- fprintf(stderr,
	- " mcfio_Block: Unable to position stream at block %d \n", blkid);
	- return -1;
	- }
	- if(blkid != idtmp) {
	- fprintf(stderr,
	- " mcfio_Block: Unexpected I.D = %d found instead of I.D. %d \n",
	- idtmp, blkid);
	- return -1;
	- }
	- if (str->row == MCFIO_WRITE) {
	- str->ehead->blockIds[str->ehead->nBlocks] = blkid;
	- str->ehead->ptrBlocks[str->ehead->nBlocks] = p1;
	- str->ehead->nBlocks++;
	- }
	- str->currentPos = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((str->currentPos-p1)/4);
	- return 1;
	-
	-}
	-int mcfioC_NTuple(int stream, int nTupleId, char * version)
	-{
	- int i, j, jstr, idtmp, ntot, nbuff;
	- bool_t ok;
	- u_int p1;
	- mcfStream *str;
	- nTuDDL *ddl;
	- descrGenNtuple *dNTu;
	-
	- if (McfStreamPtrList == NULL) {
	- fprintf(stderr,
	- " mcfio_NTuple: You must first initialize by calling mcfio_Init.\n");
	- return -1;
	- }
	- jstr = stream-1;
	- if (McfStreamPtrList[jstr] == NULL) {
	- fprintf(stderr,
	- " mcfio_NTuple: First, declare the stream by calling mcfio_Open...\n");
	- return -1;
	- }
	-
	- ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	- if (ddl == NULL) {
	- fprintf(stderr,
	- " mcfio_NTuple: Illegal or inexistant NTuple Id %d for stream %d \n",
	- nTupleId, stream);
	- return -1;
	- }
	- if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	- else dNTu = ddl->reference->descrNtu;
	- str = McfStreamPtrList[jstr];
	- if ((str->row == MCFIO_WRITE) &&
	- (str->fhead->nNTuples == str->ehead->nNTuples)) {
	- fprintf(stderr,
	-" mcfio_NTuple: Maximum number of NTuples reached for stream %d ...\n", stream);
	- fprintf(stderr,
	- " Please upgrade the Ntuple declarations statements. \n");
	- return -1;
	- }
	-
	- if (str->row == MCFIO_READ) {
	- for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	- if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	- }
	- if (j == -1) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to find NTuple i.d. %d in Stream %d \n",
	- nTupleId, stream);
	- return -1;
	- }
	- if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- str->currentPos = str->ehead->ptrNTuples[j];
	- } else if (str->row == MCFIO_WRITE) {
	- /*
	- ** if to Sequential media, one first has to make sure we have
	- ** enough room in the buffer.
	- */
	- if (str->dos == MCFIO_SEQUENTIAL) {
	- str->xdr->x_op = XDR_MCFIOCODE;
	- ok = xdr_mcfast_NTuple(str->xdr, dNTu, &ntot,
	- ddl->seqNTuId, version);
	- str->xdr->x_op = XDR_ENCODE;
	- if (ok == FALSE) {
	- fprintf(stderr,
	- "mcfio_NTuple: can not Encode or Decode Ntuple id % on Seq. Stream %d ",
	- nTupleId, stream);
	- return -1;
	- }
	- if ((str->currentPos + 4*(ntot + 1)) > str->bufferSize) {
	- /*
	- ** Once again, I don't trust realloc, got to copy to the second
	- ** buffer.
	- */
	- nbuff = 1 +
	- (((4*(ntot + 1)) + (str->currentPos - str->firstPos))/
	- str->maxlrec);
	- str->buffer2 =
	- (char ) malloc (sizeof(char) (str->maxlrec *nbuff));
	- memcpy(str->buffer2, str->buffer,
	- (str->currentPos - str->firstPos));
	- free(str->buffer);
	- str->buffer = str->buffer2;
	- str->buffer2 = NULL;
	- str->bufferSize = str->maxlrec * nbuff;
	- xdrmem_create(str->xdr, str->buffer, str->bufferSize, XDR_ENCODE);
	- if (xdr_setpos(str->xdr, str->currentPos) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple:\n\
	- Unable to position stream %d at Ntuple %d after realocation.\n",
	- stream, nTupleId);
	- return -1;
	- }
	- }
	- }
	- }
	- p1 = str->currentPos;
	- ok = xdr_mcfast_NTuple(str->xdr, dNTu, &ntot, ddl->seqNTuId, version);
	- if (ok == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	- nTupleId);
	- j = str->ehead->nNTuples;
	- if (xdr_setpos(str->xdr,p1) == FALSE)
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- if (str->row == MCFIO_WRITE) {
	- str->ehead->nTupleIds[str->ehead->nNTuples] = ddl->seqNTuId;
	- str->ehead->ptrNTuples[str->ehead->nNTuples] = p1;
	- str->ehead->nNTuples++;
	- }
	- str->currentPos = xdr_getpos(str->xdr);
	- str->numWordsC += (ntot/4);
	- str->numWordsT += ((str->currentPos-p1)/4);
	- return 1;
	-
	-}
	-/*
	-** Optimized version used exclusively to read the multiplicity value
	-** within an NTuple. It is assumed that the stream is open read direct
	-** access (No checks!), and the event table is available, and the
	-** NTuple is accessible. Once again, No checks! Use at your onw risk.
	-** Also, we do not keep record of the number of byte Read.
	-*/
	-int mcfioC_NTupleMult(int stream, int nTupleId, char * version)
	-{
	- int i, j, jstr, idtmp, ntot, nbuff;
	- bool_t ok;
	- mcfStream *str;
	- nTuDDL *ddl;
	- descrGenNtuple *dNTu;
	-
	- jstr = stream-1;
	- ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	- if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	- else dNTu = ddl->reference->descrNtu;
	- str = McfStreamPtrList[jstr];
	- for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	- if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	- }
	- if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTupleMult: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- str->currentPos = str->ehead->ptrNTuples[j];
	- if (dNTu->multXDROffset == 0)
	- ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	- ddl->seqNTuId, version);
	- else ok = xdr_mcfast_NTupleMult(str, dNTu, version);
	- if (ok == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	- nTupleId);
	- j = str->ehead->nNTuples;
	- if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- /*
	- ** This probably could be optimized away. Note the that the current
	- ** position of the stream strored in str->currentPos is no longer
	- ** valied exiting this routine. However, there is enough redundancy
	- ** in the data structure to figure out where we could go..
	- */
	- /* xdr_setpos(str->xdr, str->currentPos); */
	- return TRUE;
	-
	-}
	-
	-/*
	-** Optimized version used exclusively to read a specific variable
	-** within an NTuple. Valid only if the variable is of fixed size
	-** (e.g. not indexed by multiplicity) or if the data structure organization is
	-** of type parallel array. It is assumed that the stream is open read direct
	-** access (No checks!), and the event table is available, and the
	-** NTuple is accessible. Once again, No checks! Use at your own risk.
	-*/
	-int mcfioC_NTupleVar(int stream, int nTupleId, int ivar, char * version)
	-{
	- int i, j, jstr, idtmp, ntot, nbuff;
	- bool_t ok;
	- mcfStream *str;
	- nTuDDL *ddl;
	- descrGenNtuple *dNTu;
	-
	- jstr = stream-1;
	- ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	- if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	- else dNTu = ddl->reference->descrNtu;
	- str = McfStreamPtrList[jstr];
	- for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	- if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	- }
	- if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTupleVar: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- str->currentPos = str->ehead->ptrNTuples[j];
	- if (dNTu->multXDROffset == 0)
	- ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	- ddl->seqNTuId, version);
	- else ok = xdr_mcfast_NTupleVar(str, dNTu, ivar, version);
	- if (ok == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	- nTupleId);
	- j = str->ehead->nNTuples;
	- if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- return TRUE;
	-
	-}
	-/*
	-** Optimized version used exclusively to read a specific variable within a
	-** substructure within an NTuple. Valid only if of type indexed
	-** and if the data structure organization is
	-** of type VAX FORTRAN d/s. It is assumed that the stream is open read direct
	-** access (No checks!), and the event table is available, and the
	-** NTuple is accessible. Once again, No checks! Use at your own risk.
	-*/
	-int mcfioC_NTupleSubVar(int stream, int nTupleId, int ivar, int multIndex,
	- char * version)
	-{
	- int i, j, jstr, idtmp, ntot, nbuff;
	- bool_t ok;
	- mcfStream *str;
	- nTuDDL *ddl;
	- descrGenNtuple *dNTu;
	-
	- jstr = stream-1;
	- ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	- if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	- else dNTu = ddl->reference->descrNtu;
	- str = McfStreamPtrList[jstr];
	- for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	- if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	- }
	- if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTupleVar: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- str->currentPos = str->ehead->ptrNTuples[j];
	- if (dNTu->multXDROffset == 0)
	- ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	- ddl->seqNTuId, version);
	- else ok = xdr_mcfast_NTupleSubVar(str, dNTu, ivar, multIndex, version);
	- if (ok == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	- nTupleId);
	- j = str->ehead->nNTuples;
	- if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- return TRUE;
	-
	-}
	-/*
	-** Optimized version used exclusively to read a specific
	-** substructure within an NTuple. Valid only if of type indexed
	-** and if the data structure organization is
	-** of type VAX FORTRAN d/s. It is assumed that the stream is open read direct
	-** access (No checks!), and the event table is available, and the
	-** NTuple is accessible. Once again, No checks! Use at your own risk.
	-*/
	-int mcfioC_NTupleSubStruct(int stream, int nTupleId, int multIndex,
	- char * version)
	-{
	- int i, j, jstr, idtmp, ntot, nbuff;
	- bool_t ok;
	- mcfStream *str;
	- nTuDDL *ddl;
	- descrGenNtuple *dNTu;
	-
	- jstr = stream-1;
	- ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	- if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	- else dNTu = ddl->reference->descrNtu;
	- str = McfStreamPtrList[jstr];
	- for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	- if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	- }
	- if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTupleVar: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- str->currentPos = str->ehead->ptrNTuples[j];
	- if (dNTu->multXDROffset == 0)
	- ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	- ddl->seqNTuId, version);
	- else ok = xdr_mcfast_NTupleSubStruct(str, dNTu, multIndex, version);
	- if (ok == FALSE) {
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	- nTupleId);
	- j = str->ehead->nNTuples;
	- if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	- fprintf(stderr,
	- " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	- return -1;
	- }
	- return TRUE;
	-
	-}
	Index: trunk/mcfio/mcfio_FPrintDictionary.f
	===================================================================
	--- trunk/mcfio/mcfio_FPrintDictionary.f (revision 8888)
	+++ trunk/mcfio/mcfio_FPrintDictionary.f (revision 8889)
	@@ -1,108 +0,0 @@
	- subroutine mcfio_FPrintDictionary(ilun)
	-
	-c*******************************************************************************
	-c *
	-c mcfio_FPrintDictionary.F -- Fortran version of PrintDictionary *
	-c *
	-c Copyright (c) 1994 Universities Research Association, Inc. *
	-c All rights reserved. *
	-c *
	-c This material resulted from work developed under a Government Contract and *
	-c is subject to the following license: The Government retains a paid-up, *
	-c nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-c works, perform publicly and display publicly by or for the Government, *
	-c including the right to distribute to other Government contractors. Neither *
	-c the United States nor the United States Department of Energy, nor any of *
	-c their employees, makes any warranty, express or implied, or assumes any *
	-c legal liability or responsibility for the accuracy, completeness, or *
	-c usefulness of any information, apparatus, product, or process disclosed, or *
	-c represents that its use would not infringe privately owned rights. *
	-c *
	-c *
	-c Written by Paul Lebrun, Lynn Garren *
	-c *
	-c *
	-c*******************************************************************************
	-
	- integer ilun
	- write(ilun,1001)
	-1001 format(//
	- 1 ' Mcfast I/o Dictionary for Key words used in mcfio_Info',
	- 2 ' routines'/
	- 3 ' --------------------------------------------------------',
	- 4 '-------')
	-
	- write(ilun,1002)
	-1002 format(/
	- 1 ' For Streams '/
	- 2 ' -------------- '/
	- 3 ' MCFIO_STATUS: The current status of the file; '/
	- 4 ' the answer can be set to: '/
	- 5 ' MCFIO_BOF : at beginning of file '/
	- 6 ' MCFIO_EOF : at the end of file '/
	- 7 ' MCFIO_RUNNING: At least a valid file header has been',
	- 8 ' read or written'/
	- 9 ' MCFIO_READORWRITE: if set MCFIO_READ, open for read only '/
	- 1 ' if set MCFIO_WRITE, open for write only '/
	- 2 ' MCFIO_DIRECTORSEQUENTIAL: if set MCFIO_DIRECT, accessing a',
	- 3 ' UNIX file '/
	- 4 ' : if set MCFIO_SEQUENTIAL,',
	- 5 ' accessing a tape '/
	- 6 ' MCFIO_NUMEVTS : Total number of events encode/decoded',
	- 7 ' so far.'/
	- 8 ' MCFIO_NUMBLOCK: The number of blocks defined in the file.')
	-
	- write(ilun,1003)
	-1003 format(
	- 1 ' MCFIO_BLOCKIDS: The I.D. of the block defined in the file.'/
	- 2 ' MCFIO_NUMWORDS: Total number of 4-bytes words',
	- 2 ' encoded/decoded so far. '/
	- 3 ' MCFIO_EFFICIENCY: The overhead in blocking and XDR',
	- 3 ' (*10000 ) '/
	- 4 ' MCFIO_CREATIONDATE: The date (30 Character) when the file',
	- 4 ' was written '/
	- 5 ' MCFIO_TITLE: The title (255 Characters max) for the job '/
	- 6 ' MCFIO_COMMENT: The comment (255 Characters max) for the job')
	-
	- write(ilun,1004)
	-1004 format(/
	- 1 ' For Sequential Access only '/
	- 2 ' -------------------------- '/
	- 2 ' MCFIO_FILENUMBER : The Sequential file number currently',
	- 2 ' accessed.'/
	- 3 ' MCFIO_MAXLREC: Maximum Record length'/
	- 4 ' MCFIO_MINLREC: Minumum Record length'/
	- 5 ' MCFIO_NUMRECORDS: The number of records in the current',
	- 5 ' event'/
	- 6 ' MCFIO_RECORDLENGTHS: The record lengths for the current',
	- 6 ' event'/
	- 7 ' MCFIO_DEVICENAME: The device name opened by the stream '/
	- 8 ' (character string, 255 l.)')
	-
	- write(ilun,1005)
	-1005 format(/
	- 1 ' For Direct Access only '/
	- 2 ' ----------------------- '/
	- 2 ' MCFIO_FILENAME: The UNIX file name opened by the stream '/
	- 3 ' (character string, 255 l.)')
	-
	- write(ilun,1006)
	-1006 format(/
	- 1 ' For Events '/
	- 2 ' -------------- '/
	- 3 ' MCFIO_NUMBLOCK: The number of blocks defined in the event.'/
	- 4 ' MCFIO_BLOCKIDS: The I.D. of the block defined in the event.'/
	- 5 ' MCFIO_EVENTNUMBER: The Event Number for this event. '/
	- 6 ' MCFIO_STORENUMBER: The Store Number for this event. '/
	- 7 ' MCFIO_RUNNUMBER: The Run Number for this event. '/
	- 8 ' MCFIO_TRIGGERMASK: The Trigger Mask for this event. '/
	- 9 ' MCFIO_VERSION: The 4-Character version of the event header')
	-
	- write(ilun,1007)
	-1007 format(/
	- 1 ' For Blocks '/
	- 2 ' -------------- '/
	- 3 ' MCFIO_VERSION: The 4-Character version of a particular',
	- 4 ' block'/)
	- return
	- end
	Index: trunk/mcfio/mcf_NTuIOUtils.h
	===================================================================
	--- trunk/mcfio/mcf_NTuIOUtils.h (revision 8888)
	+++ trunk/mcfio/mcf_NTuIOUtils.h (revision 8889)
	@@ -1,24 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_NTuIOUtil.h -- Utilities to manipulate files within the MCFIO Gen. *
	-* Ntuple schema *
	-* *
	-* P. Lebrun, October 1995. *
	-* *
	-*******************************************************************************/
	-nTuDDL *mcf_GetNTuByPtrID(int id);
	-nTuDDL *mcf_GetNTuByStreamID(int stream, int id);
	-int mcf_CheckValidCat(char *category, int dotDotDot);
	-char mcf_ValidStr(char string, int max_length, char *strKind);
	-int mcf_NTuId(int uid, char *category);
	-int mcfioC_GetNTupleIds(int stream, int *ids, int max);
	-int mcfioC_GetNTupleUID(int stream, int id);
	-void mcfioC_GetNTupleCategory(int stream, int id, char **answer);
	-void mcfioC_GetNTupleTitle(int stream, int id, char **answer);
	-void mcfioC_GetNTupleName(int stream, int id, char **answer);
	-void AddNTuDDLtoList(nTuDDL *ddl);
	-void DestroyNTuDDL(nTuDDL *ddl);
	-void DestroyVarGenNtuple(varGenNtuple *var);
	-void CopyVarGenNtuple(varGenNtuple vFrom, varGenNtuple vTo);
	-void DestroyGenNtuple(descrGenNtuple *dNTu);
	-void mcfioC_SetForSaveDecoding(int val);
	Index: trunk/mcfio/mcf_NTuIOFiles.h
	===================================================================
	--- trunk/mcfio/mcf_NTuIOFiles.h (revision 8888)
	+++ trunk/mcfio/mcf_NTuIOFiles.h (revision 8889)
	@@ -1,15 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_NTuIOFiles.h -- Utilities to manipulate files within the MCFIO Gen. *
	-* Ntuple schema *
	-* *
	-* P. Lebrun, September 1995. *
	-* *
	-*******************************************************************************/
	-int mcfioC_DeclareNtuple(int uid, char title, char category,
	- int stream, char *filename);
	-int mcfioC_EndDeclNTuples(int stream);
	-nTuDDL mcf_GetFileNTuDDL(charfilename);
	-void mcf_ComputeNTuOffsets(nTuDDL *ddl);
	-void mcf_ComputeNTuLengths(nTuDDL *ddl);
	-void mcf_ComposeDoth(descrGenNtuple dNtu, char filename);
	Index: trunk/mcfio/mcfio_Util1.c
	===================================================================
	--- trunk/mcfio/mcfio_Util1.c (revision 8888)
	+++ trunk/mcfio/mcfio_Util1.c (revision 8889)
	@@ -1,914 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_Init.c -- Utility routines for the McFast Monte-Carlo *
	-* Initialisation & info routines *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#include <stdlib.h>
	-#ifdef SUNOS
	-#include <floatingpoint.h>
	-#else /* SUNOS */
	-#include <float.h>
	-#endif /* SUNOS */
	-#include <time.h>
	-#include "mcf_nTupleDescript.h"
	-#include "mcf_xdr.h"
	-#include "mcfio_Util1.h"
	-#include "mcfio_Direct.h"
	-#include "mcfio_Sequential.h"
	-#include "mcfio_Dict.h"
	-#include "mcf_ntubld_db.h"
	-#include "mcf_NTuIOFiles.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcf_NTuIOUtils.h"
	-#include "mcfio_UserDictionary.h"
	-#ifndef FALSE
	-#define FALSE 0
	-#endif
	-#ifndef TRUE
	-#define TRUE 1
	-#endif
	-
	-mcfStream **McfStreamPtrList=NULL;
	-unsigned int McfNumOfStreamActive=0;
	-char **McfGenericVersion=NULL;
	-
	-/*
	-** This stuff is needed for dbin utilities...
	-*/
	-struct line_title_c line_title_c_;
	-struct header_c header_c_;
	-struct variable_c variable_c_;
	-/*
	-** Names of variable types for Ntuple utilities
	-*/
	-char *VarTypesNamesF77[N_VAR_TYPES];
	-char *VarTypesNamesC[N_VAR_TYPES];
	-/*
	-** Ntuple global list
	-*/
	-extern nTuDDL **NTuDDLList;
	-extern int NumOfNTuples;
	-
	-
	-void mcfioC_Init(void)
	-/* Global Initialisation routine. Simply set the
	-**
	-*/
	-{
	- int i;
	- char env, line;
	- FILE *Ffp;
	-
	-/*
	-** This is no longer needed...
	-
	- env = NULL;
	- env = getenv("MCFIO_DIR");
	- if (env == NULL) {
	- printf ("You must first set the environment variable MCFIO_DIR\n");
	- printf (" by either setting up mcfio (Fermi UPS), or setting \n");
	- printf
	- (" this env. variable to the place where mcf_NTuBld.db resides.\n");
	- exit(0);
	- } */
	-
	-
	- /*
	- ** Check now that the master template exist.
	-
	- line = (char ) malloc(sizeof(char) (FILENAME_MAX+1));
	- sprintf(line,"%s/mcf_NTuBld.db", env);
	- Ffp = fopen(line, "r");
	- if (Ffp == NULL) {
	- printf ("The file %s could not be opened. \n", line);
	- printf (" Please check MCFIO installation. \n");
	- exit(0);
	- }
	- fclose(Ffp);
	- free(line);
	-
	-*/
	- /*
	- ** Use only one version for now. Possible extension here.
	- */
	- McfGenericVersion = (char *) malloc(sizeof(char ));
	- McfGenericVersion = (char ) malloc(sizeof(char) * 8);
	-
	- VarTypesNamesF77[0]= "Byte ";
	- VarTypesNamesF77[1]= "Character ";
	- VarTypesNamesF77[2]= "Integer*2 ";
	- VarTypesNamesF77[3]= "Logical ";
	- VarTypesNamesF77[4]= "Integer ";
	- VarTypesNamesF77[5]= "Real ";
	- VarTypesNamesF77[6]= "Double Precision";
	- VarTypesNamesF77[7]= "Complex ";
	- VarTypesNamesF77[8]= "Double Complex ";
	- VarTypesNamesF77[9]= "Pointer ";
	-
	- VarTypesNamesC[0]= "char ";
	- VarTypesNamesC[1]= "char ";
	- VarTypesNamesC[2]= "short ";
	- VarTypesNamesC[3]= "int ";
	- VarTypesNamesC[4]= "int ";
	- VarTypesNamesC[5]= "float ";
	- VarTypesNamesC[6]= "double ";
	- VarTypesNamesC[7]= "float[2] ";
	- VarTypesNamesC[8]= "double[2] ";
	- VarTypesNamesC[9]= "void * ";
	-
	- if (NTuDDLList != NULL) {
	- for (i=0; i<NumOfNTuples; i++) DestroyNTuDDL(NTuDDLList[i]);
	- free(NTuDDLList);
	- }
	- NTuDDLList = (nTuDDL *) malloc(sizeof(int )* NTU_START_LIST_SIZE);
	- NumOfNTuples = 0;
	-
	- if (McfStreamPtrList == NULL) {
	- McfStreamPtrList = (mcfStream **)
	- malloc(sizeof(mcfStream ) MCF_STREAM_NUM_MAX);
	- for (i=0; i< MCF_STREAM_NUM_MAX; i++) McfStreamPtrList[i] = NULL;
	- return;
	- }
	- for (i=0; i< MCF_STREAM_NUM_MAX; i++) McfStreamPtrList[i] = NULL;
	- mcfioC_Close(0);
	- McfNumOfStreamActive=0;
	-
	-}
	-
	-void mcfioC_Close(int istream)
	-/*
	-** Closing a Stream istream is the F77 index to the array of mcf Streams.
	-*/
	-{
	- int i;
	-
	- if (McfStreamPtrList == NULL) return;
	- if ((istream < 0) \|\| (istream > MCF_STREAM_NUM_MAX)) {
	- fprintf (stderr, "mcf_close, Illegal argument, stream = %d \n", istream);
	- return;
	- }
	- if (istream == 0) {
	- for (i=0; i<MCF_STREAM_NUM_MAX; i++) {
	- if (McfStreamPtrList[i] != NULL) {
	- switch (McfStreamPtrList[i]->dos) {
	- case MCFIO_DIRECT: case MCFIO_MEMMAPPED:
	- mcfioC_CloseDirect(i);
	- break;
	- case MCFIO_SEQUENTIAL:
	- mcfioC_CloseSequentialTape(i);
	- break;
	- default:
	- fprintf
	- (stderr," mcf_close, Internal Error, please report \n");
	- break;
	- }
	- mcfioC_FreeStream(&McfStreamPtrList[i]);
	- }
	- }
	- return;
	- }
	- i = istream -1;
	- if (McfStreamPtrList[i] != NULL) {
	- switch (McfStreamPtrList[i]->dos) {
	- case MCFIO_DIRECT: case MCFIO_MEMMAPPED:
	- mcfioC_CloseDirect(i);
	- break;
	- case MCFIO_SEQUENTIAL:
	- mcfioC_CloseSequentialTape(i);
	- break;
	- default:
	- fprintf
	- (stderr," mcf_close, Internal Error, please report \n");
	- break;
	- }
	- mcfioC_FreeStream(&McfStreamPtrList[i]);
	- }
	-}
	-
	-void mcfioC_Rewind(int istream)
	-/*
	-** Closing a Stream istream is the F77 index to the array of mcf Streams.
	-*/
	-{
	- int i;
	-
	- if (McfStreamPtrList == NULL) return;
	- if ((istream <= 0) \|\| (istream > MCF_STREAM_NUM_MAX)) {
	- fprintf (stderr, "mcfio_Rewind, Illegal argument, stream = %d \n",
	- istream);
	- return;
	- }
	- i = istream -1;
	-
	- if (McfStreamPtrList[i] != NULL) {
	- if(McfStreamPtrList[i]->row == MCFIO_WRITE) {
	- fprintf
	- (stderr," mcf_Rewind, Not support for Output Stream \n");
	- return;
	- }
	- switch (McfStreamPtrList[i]->dos) {
	- case MCFIO_DIRECT: case MCFIO_MEMMAPPED:
	- mcfioC_RewindDirect(i);
	- break;
	- case MCFIO_SEQUENTIAL:
	- fprintf
	- (stderr," mcf_Rewind, Sequential, done by a close Sequential File\n\
	- Then reopening a stream on the same sequential media \n");
	- break;
	- default:
	- fprintf
	- (stderr," mcf_Rewind, Internal Error, please report \n");
	- break;
	- }
	- McfStreamPtrList[i]->numWordsC = 0;
	- McfStreamPtrList[i]->numWordsT = 0;
	- }
	-}
	-
	-void mcfioC_Free_FileHeader(mcfxdrFileHeader **p)
	-{
	- int i;
	- mcfxdrFileHeader head = p;
	-
	- if (head == NULL) return;
	- for (i=0; i<head->nBlocks; i++)
	- if (head->blockNames[i] != NULL) free(head->blockNames[i]);
	- if (head->blockNames != NULL) free (head->blockNames);
	- if (head->blockIds != NULL) free(head->blockIds);
	- free(head);
	- *p = NULL;
	-}
	-
	-void mcfioC_Free_SeqHeader(mcfxdrSequentialHeader **p)
	-{
	- mcfxdrSequentialHeader head = p;
	-
	- if (head == NULL) return;
	- free(head);
	- *p = NULL;
	-}
	-
	-void mcfioC_Free_EventHeader(mcfxdrEventHeader **p)
	-{
	- mcfxdrEventHeader head = p;
	-
	- if (head == NULL) return;
	- if (head->ptrBlocks != NULL) free(head->ptrBlocks);
	- if (head->blockIds != NULL) free(head->blockIds);
	- if (head->ptrNTuples != NULL) free(head->ptrNTuples);
	- if (head->nTupleIds != NULL) free(head->nTupleIds);
	- free(head);
	- *p = NULL;
	-}
	-
	-void mcfioC_Free_EventTable(mcfxdrEventTable **p)
	-{
	- mcfxdrEventTable table = p;
	-
	- if (table == NULL) return;
	- if (table->evtnums != NULL) free(table->evtnums);
	- if (table->storenums != NULL) free(table->storenums);
	- if (table->runnums != NULL) free(table->runnums);
	- if (table->trigMasks != NULL) free(table->trigMasks);
	- if (table->ptrEvents != NULL) free(table->ptrEvents);
	- free(table);
	- *p = NULL;
	-}
	-
	-void mcfioC_FreeStream(mcfStream **stream)
	-{
	- mcfStream str = stream;
	- if (str == NULL) return;
	- if (str->filename != NULL) free (str->filename);
	- if (str->device != NULL) free (str->device);
	- if (str->vsn != NULL) free (str->vsn);
	- if (str->fhead != NULL) mcfioC_Free_FileHeader(&(str->fhead));
	- if (str->shead != NULL) mcfioC_Free_SeqHeader(&(str->shead));
	- if (str->ehead != NULL) mcfioC_Free_EventHeader(&(str->ehead));
	- if (str->table != NULL) mcfioC_Free_EventTable(&(str->table));
	- if (str->buffer != NULL) free (str->buffer);
	- if (str->buffer2 != NULL) free (str->buffer2);
	- free(str);
	- *stream = NULL;
	- McfNumOfStreamActive--;
	-}
	-
	-
	-void mcfioC_PrintDictionary(void)
	-{
	- printf (" \n");
	- printf
	- (" Mcfast I/o Dictionary for Key words used in mcfio_Info routines \n");
	-
	- printf
	- (" --------------------------------------------------------------- \n");
	- printf (" \n");
	- printf (" For Streams \n");
	- printf (" -------------- \n");
	- printf (" MCFIO_STATUS: The current status of the file; \n");
	- printf (" the answer can be set to: \n");
	- printf
	- (" MCFIO_BOF : at beginning of file \n");
	- printf
	- (" MCFIO_EOF : at the end of file \n");
	- printf
	- (" MCFIO_RUNNING: At least a valid file header has been read or written\n");
	-
	- printf
	- (" MCFIO_READORWRITE: if set MCFIO_READ, open for read only \n");
	- printf
	- (" if set MCFIO_WRITE, open for write only \n");
	- printf
	- (" MCFIO_DIRECTORSEQUENTIAL: if set MCFIO_DIRECT, accessing a UNIX file \n");
	- printf
	- (" : if set MCFIO_SEQUENTIAL, accessing a tape \n");
	- printf
	- (" MCFIO_NUMEVTS : Total number of events encode/decoded so far. \n");
	- printf
	- (" MCFIO_NUMBLOCK: The number of blocks defined in the file. \n");
	-
	- printf
	- (" MCFIO_BLOCKIDS: The I.D. of the block defined in the file.\n");
	- printf
	- (" MCFIO_NUMWORDS: Total number of 4-bytes words encode/decoded so far. \n");
	- printf
	- (" MCFIO_EFFICIENCY: The overhead in blocking and XDR (*10000 ) \n");
	- printf
	- (" MCFIO_CREATIONDATE: The date (30 Character) when the file was opened \n");
	- printf
	- (" MCFIO_CLOSINGDATE: The date (30 Character) when the file was closed \n");
	- printf
	- (" MCFIO_TITLE: The title (255 Characters max) for the job \n");
	- printf
	- (" MCFIO_COMMENT: The comment (255 Characters max) for the job \n");
	-
	- printf (" \n");
	- printf (" For Sequential Access only \n");
	- printf
	- (" MCFIO_FILENUMBER : The Sequential file number currently accessed.\n");
	- printf (" MCFIO_MAXLREC: Maximum Record length\n");
	- printf (" MCFIO_MINLREC: Minumum Record length\n");
	- printf
	- (" MCFIO_NUMRECORDS: The number of records in the current event\n");
	- printf
	- (" MCFIO_RECORDLENGTHS: The record lengths for the current event\n");
	- printf (" MCFIO_DEVICENAME: The device name opened by the stream\n ");
	- printf (" (character string, 255 l.)\n");
	- printf (" \n");
	- printf (" For Direct Access only \n");
	- printf (" MCFIO_FILENAME: The UNIX file name opened by the stream\n ");
	- printf (" (character string, 255 l.)\n");
	-
	- printf (" \n");
	- printf (" For Events \n");
	- printf (" -------------- \n");
	- printf
	- (" MCFIO_NUMBLOCK: The number of blocks defined in the event.\n");
	-
	- printf
	- (" MCFIO_BLOCKIDS: The I.D. of the block defined in the event.\n");
	- printf
	- (" MCFIO_EVENTNUMBER: The Event Number for this event. \n");
	- printf
	- (" MCFIO_STORENUMBER: The Store Number for this event. \n");
	- printf
	- (" MCFIO_RUNNUMBER: The Run Number for this event. \n");
	- printf
	- (" MCFIO_TRIGGERMASK: The Trigger Mask for this event. \n");
	- printf (" MCFIO_VERSION: The 4-Character version of the event header \n ");
	-
	- printf (" \n");
	- printf (" For Blocks \n");
	- printf (" -------------- \n");
	- printf (" MCFIO_VERSION: The 4-Character version of a particular block \n ");
	-
	- printf (" \n");
	- printf (" For NTuples \n");
	- printf (" -------------- \n");
	- printf (" MCFIO_NUMNTUPLES: The number of defined NTuples on a stream \n ");
	- printf (" See also mcfio_GetNTupleIds, mcfio_GetNTupleUID, \n");
	- printf (" mcfio_GetNTupleCategory, mcfio_GetNTupleTitle and \n");
	- printf (" mcfio_GetNTupleName \n");
	-
	-}
	-
	-unsigned int mcfioC_InfoNumStream(int *istreams, unsigned int nmax)
	-/*
	-** Returns in the arrary istream the list of active stream indices.
	-**
	-*/
	-{
	- int i,j;
	-
	- if (nmax >= MCF_STREAM_NUM_MAX) {
	- fprintf(stderr, "mcfio_Info, Illegal size of Stream Pointer array \n");
	- return 0;
	- }
	- for (i=0,j=0; i<MCF_STREAM_NUM_MAX; i++) {
	- if (McfStreamPtrList[i] != NULL) {
	- if (j < nmax) istreams[j] = McfStreamPtrList[i]->id;
	- j++;
	- }
	- }
	- return McfNumOfStreamActive;
	-}
	-
	-void mcfioC_InfoStreamInt(int stream, int key, int *values)
	-/*
	-** Information routine for the Stream. Based on key, return in *values
	-** the requested information
	-*/
	-{
	- int i, num, jstr;
	- float a;
	- mcfStream *str;
	- jstr = stream - 1;
	- if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	- stream);
	- return;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str == NULL) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	- stream);
	- return;
	- }
	- switch (key) {
	- case MCFIO_STATUS:
	- *values = str->status;
	- break;
	- case MCFIO_READORWRITE:
	- *values = str->row;
	- break;
	- case MCFIO_DIRECTORSEQUENTIAL:
	- *values = str->dos;
	- break;
	- case MCFIO_NUMWORDS:
	- *values = str->numWordsT;
	- break;
	- case MCFIO_EFFICIENCY:
	- a = ((float ) (str->numWordsC))/ (float) (str->numWordsT);
	- values = (int) (10000. a);
	- break;
	- case MCFIO_NUMEVTS:
	- if(str->fhead != NULL) *values = str->fhead->numevts;
	- break;
	- case MCFIO_NUMBLOCKS:
	- if(str->fhead != NULL) *values = str->fhead->nBlocks;
	- break;
	- case MCFIO_BLOCKIDS:
	- /*
	- ** Crash bug possibility here, if the dimension is wrong !
	- */
	- if(str->fhead != NULL) {
	- for (i=0; i<str->fhead->nBlocks; i++)
	- values[i] = str->fhead->blockIds[i];
	- }
	- break;
	- /*
	- ** Now the specific items for Sequential stuff
	- */
	- case MCFIO_FILENUMBER:
	- if (str->dos != MCFIO_SEQUENTIAL) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_FILENUMBER\n",
	- stream);
	- return;
	- }
	- *values = str->filenumber;
	- break;
	- case MCFIO_MAXREC:
	- if (str->dos != MCFIO_SEQUENTIAL) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_MAXREC\n",
	- stream);
	- return;
	- }
	- *values = str->maxlrec;
	- break;
	- case MCFIO_MINREC:
	- if (str->dos != MCFIO_SEQUENTIAL) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_MINREC \n",
	- stream);
	- return;
	- }
	- *values = str->minlrec;
	- break;
	- case MCFIO_NUMRECORDS:
	- if ((str->dos != MCFIO_SEQUENTIAL) \|\| (str->shead == NULL) ) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_NUMRECORDS \n",
	- stream);
	- return;
	- }
	- *values = str->shead->nRecords;
	- break;
	- case MCFIO_RECORDLENGTHS:
	- if ((str->dos != MCFIO_SEQUENTIAL) \|\| (str->shead == NULL) ) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_RECORDLENGTHS \n",
	- stream);
	- return;
	- }
	- *values = str->maxlrec;
	- break;
	- case MCFIO_NUMNTUPLES:
	- for (i=0, num=0; i<NumOfNTuples; i++)
	- if (NTuDDLList[i]->streamId == stream) num++;
	- *values = num;
	- break;
	- default:
	- fprintf(stderr,
	- "mcfio_InfoStream: Unrecognized Keyword %d\n", key);
	- }
	-}
	-
	-void mcfioC_InfoStreamChar(int stream, int key, char answer, int lret)
	-/*
	-** Information routine for the Stream. Based on key, return in *values
	-** the requested information
	-*/
	-{
	- int i, jstr;
	- float a;
	- mcfStream *str;
	- jstr = stream - 1;
	- if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str == NULL) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- switch (key) {
	- case MCFIO_TITLE:
	- if (str->fhead != NULL) strcpy(answer,str->fhead->title);
	- break;
	- case MCFIO_COMMENT:
	- if (str->fhead != NULL) strcpy(answer,str->fhead->comment);
	- break;
	- case MCFIO_CREATIONDATE:
	- if (str->fhead != NULL) strcpy(answer,str->fhead->date);
	- break;
	- case MCFIO_CLOSINGDATE:
	- if (str->fhead != NULL) strcpy(answer,str->fhead->closingDate);
	- break;
	- case MCFIO_FILENAME:
	- if (str->dos == MCFIO_SEQUENTIAL) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_FILENAME \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- strcpy(answer,str->filename);
	- break;
	- case MCFIO_DEVICENAME:
	- if (str->dos != MCFIO_SEQUENTIAL) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_DEVICENAME \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- strcpy(answer,str->device);
	- break;
	- default:
	- fprintf(stderr,
	- "mcfio_InfoStream: Unrecognized Keyword %d\n", key);
	- *lret = 0;
	- return;
	-
	- }
	- *lret = strlen(answer);
	-}
	-void mcfioC_InfoEventInt(int stream, int key, int *values)
	-/*
	-** Information routine for the current Event.
	-** Based on key, return in *values the requested information
	-*/
	-{
	- int i, jstr;
	- float a;
	- mcfStream *str;
	- jstr = stream - 1;
	- if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,"mcfio_InfoEvent: Stream id %d is illegal \n",
	- stream);
	- return;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str == NULL) {
	- fprintf(stderr,"mcfio_InfoEvent: Stream id %d is inactive \n",
	- stream);
	- return;
	- }
	- if (str->ehead ==NULL) {
	- fprintf(stderr,"mcfio_InfoEvent: Stream id %d is at beginning \n",
	- stream);
	- return;
	- }
	- switch (key) {
	- case MCFIO_EVENTNUMBER:
	- *values = str->ehead->evtnum;
	- break;
	- case MCFIO_STORENUMBER:
	- *values = str->ehead->storenum;
	- break;
	- case MCFIO_RUNNUMBER:
	- *values = str->ehead->runnum;
	- break;
	- case MCFIO_TRIGGERMASK:
	- *values = str->ehead->trigMask;
	- break;
	- case MCFIO_NUMBLOCKS:
	- *values = str->ehead->nBlocks;
	- break;
	- case MCFIO_BLOCKIDS:
	- for(i=0; i<str->ehead->nBlocks; i++)
	- values[i] = str->ehead->blockIds[i];
	- break;
	- case MCFIO_NUMNTUPLES:
	- *values = str->ehead->nNTuples;
	- break;
	- case MCFIO_NTUPLESLIST:
	- for(i=0; i<str->ehead->nNTuples; i++)
	- values[i] = str->ehead->nTupleIds[i];
	- break;
	- default:
	- fprintf(stderr,
	- "mcfio_InfoEvent: Unrecognized Keyword %d\n", key);
	-
	- }
	-}
	-
	-void mcfioC_SetEventInfo(int stream, int key, int *values)
	-/*
	-** Set anciallary information for the current Event.
	-** Based on key, return in *values the requested information
	-** Only valid for Output Streams.
	-*/
	-{
	- int i, jstr;
	- float a;
	- mcfStream *str;
	- jstr = stream - 1;
	- if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	- stream);
	- return;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str == NULL) {
	- fprintf(stderr,"mcfio_SetEvent: Stream id %d is inactive \n",
	- stream);
	- return;
	- }
	- if (str->ehead ==NULL) {
	- fprintf(stderr,"mcfio_SetEvent: Stream id %d is at beginning \n",
	- stream);
	- return;
	- }
	- if (str->row != MCFIO_WRITE) {
	- fprintf(stderr,
	- "mcfio_SetEvent: Stream id %d must be an Output stream \n",
	- stream);
	- return;
	- }
	- switch (key) {
	- case MCFIO_EVENTNUMBER:
	- str->ehead->evtnum = *values;
	- break;
	- case MCFIO_STORENUMBER:
	- str->ehead->storenum = *values;
	- break;
	- case MCFIO_RUNNUMBER:
	- str->ehead->runnum = *values;
	- break;
	- case MCFIO_TRIGGERMASK:
	- str->ehead->trigMask = *values;
	- break;
	- case MCFIO_NUMBLOCKS: case MCFIO_BLOCKIDS:
	- fprintf(stderr,
	- "mcfio_SetEvent: Blocks and Block contents are set by mcfio_Blocks\n" );
	- return;
	- default:
	- fprintf(stderr,
	- "mcfio_SetEvent: Unrecognized Keyword %d\n", key);
	-
	- }
	-}
	-
	-void mcfioC_InfoEventChar(int stream, int key, char answer, int lret)
	-/*
	-** Information routine for the current Event.
	-** Based on key, return in *values the requested information
	-*/
	-{
	- int i, jstr;
	- float a;
	- mcfStream *str;
	- jstr = stream - 1;
	- if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str == NULL) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- if (str->ehead ==NULL) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is at beginning \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- switch (key) {
	- case MCFIO_VERSION:
	- strcpy(answer, str->ehead->version);
	- break;
	-
	- default:
	- fprintf(stderr,
	- "mcfio_InfoEvent: Unrecognized Keyword %d\n", key);
	- *lret = 0;
	- return;
	-
	- }
	- *lret = strlen(answer);
	-}
	-
	-void mcfioC_InfoBlockChar(int stream, int blkid,
	- int key, char answer, int lret)
	-/*
	-** Information routine for a particular block within the current Event.
	-** Based on key, return the requested information in string answer.
	-*/
	-{
	- int i, jstr, itmp, nn;
	- u_int pos;
	- bool_t tt;
	- XDR *xx;
	- char* data, *vv;
	- mcfStream *str;
	- jstr = stream - 1;
	- if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- str = McfStreamPtrList[jstr];
	- if (str == NULL) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- if (str->ehead ==NULL) {
	- fprintf(stderr,"mcfio_InfoStream: Stream id %d is at beginning \n",
	- stream);
	- *lret = 0;
	- return;
	- }
	- pos = 0;
	- if(str->xdr != NULL) for(i=0; i<str->ehead->nBlocks; i++)
	- if( str->ehead->blockIds[i] == blkid) pos = str->ehead->ptrBlocks[i];
	- if (pos == 0) {
	- fprintf(stderr,
	- "mcfio_InfoStream: Stream id %d event %d does not contain block %d \n",
	- stream,str->ehead->evtnum, blkid );
	- *lret = 0;
	- return;
	- }
	-
	- switch (key) {
	- case MCFIO_VERSION:
	- tt = xdr_setpos(str->xdr, pos);
	- tt = xdr_mcfast_generic(str->xdr, &itmp, &nn, &vv, &data);
	- xdr_free((xdrproc_t)xdr_string, data);
	- strcpy(answer, vv);
	- break;
	-
	- default:
	- fprintf(stderr,
	- "mcfio_InfoEvent: Unrecognized Keyword %d\n", key);
	- *lret = 0;
	- return;
	-
	- }
	- *lret = strlen(answer);
	-}
	-void mcfioC_GetBlockName(int blkId, char *answer)
	-/*
	-** Get a Block name from the dictionary..It is assume that answer has
	-** pre-malloc, size MCF_XDR_B_TITLE_LENGTH
	-*/
	-{
	- char *uDescr;
	- switch (blkId) {
	- case MCFIO_STDHEP:
	- strcpy(answer,
	- " Standard HEP COMMON block, see STDHEP Product");
	- break;
	-
	- case MCFIO_STDHEPM:
	- strcpy(answer,
	- " Standard HEP COMMON block with multiple interaction, see STDHEP Product");
	- break;
	-
	- case MCFIO_STDHEP4:
	- strcpy(answer,
	- " Standard HEP COMMON block with Les Houches, see STDHEP Product");
	- break;
	-
	- case MCFIO_STDHEP4M:
	- strcpy(answer,
	- " Standard HEP COMMON block with Les Houches and multiple interaction");
	- break;
	-
	- case MCFIO_HEPEUP:
	- strcpy(answer,
	- " Les Houches HEPEUP common block");
	- break;
	-
	- case MCFIO_HEPRUP:
	- strcpy(answer,
	- " Les Houches HEPRUP common block");
	- break;
	-
	- case MCFIO_STDHEPCXX:
	- strcpy(answer,
	- " StdHep::Event class, see StdHepC++ Product");
	- break;
	-
	- case MCFIO_STDHEPBEG:
	- strcpy(answer,
	- " Stdhep begin run record, see STDHEP Product");
	- break;
	-
	- case MCFIO_STDHEPEND:
	- strcpy(answer,
	- " Stdhep end run record, see STDHEP Product");
	- break;
	-
	- case MCFIO_OFFTRACKARRAYS:
	- strcpy(answer,
	- " The mcfast Offline Tracks, saved into parallel arrays");
	- break;
	-
	- case MCFIO_OFFTRACKSTRUCT:
	- strcpy(answer,
	- " The mcfast Offline Tracks, saved as the structure");
	- break;
	- default:
	- sprintf(answer, " Private User Block number %d ", blkId );
	- uDescr = mcfioC_UserBlockDescript(blkId);
	- if (uDescr == NULL) fprintf(stderr,
	- "mcfio_GetBlockName: Warning Unrecognized block I.D. %d\n", blkId);
	- else answer = uDescr;
	- }
	-
	-}
	-
	-
	-
	Index: trunk/mcfio/mcfio_Block.h
	===================================================================
	--- trunk/mcfio/mcfio_Block.h (revision 8888)
	+++ trunk/mcfio/mcfio_Block.h (revision 8889)
	@@ -1,19 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_Block.h -- Include file for mcfast Direct i/o layer. *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-*******************************************************************************/
	-int mcfioC_Block(int stream, int blkid,
	- bool_t xdr_filtercode(XDR xdrs, int blockid, int ntot, char *version));
	-int mcfioC_NTuple(int stream, int nTupleid, char * version);
	-int mcfioC_NTupleMult(int stream, int nTupleid, char * version);
	-int mcfioC_NTupleVar(int stream, int nTupleid, int ivar, char * version);
	-int mcfioC_NTupleSubVar(int stream, int nTupleid, int ivar, int multIndex,
	- char * version);
	-int mcfioC_NTupleSubStruct(int stream, int nTupleid, int multIndex,
	- char * version);
	-
	-
	Index: trunk/mcfio/mcf_ntuBldDbinc.c
	===================================================================
	--- trunk/mcfio/mcf_ntuBldDbinc.c (revision 8888)
	+++ trunk/mcfio/mcf_ntuBldDbinc.c (revision 8889)
	@@ -1,527 +0,0 @@
	-/*
	- * dbin.cc
	- *
	- * C++ utility routines for the dbin package: see dbin.lex
	- *
	- * N.B. The Strings class from the CLHEP library is used.
	- *
	- * Torre Wenaus 04/01/1994
	- *
	- * Modifications:
	- * 8/21/95 T. Wenaus Mod history started
	- * 8/21/95 TW Strings class removed from dbin generated code.
	- * 8/22/95 TW Strings class removed from dbinc.cc
	- *
	- * November 1995: some clean up to be able to run this code and
	- * standard dbin simulateneously..
	- * Make some routine & variable static, and change the name of routine
	- * called from the outside, following the Nirvana/mcfio conventions.
	- *
	- */
	-
	-#include <stdlib.h>
	-#include <string.h>
	-#include <stdio.h>
	-#include <limits.h>
	-#include "mcf_ntuBldDbinc.h"
	-#include "mcf_ntubld_db.h"
	-
	-static void dbin_debug();
	-static void lineparse();
	-static void dbinparse(char* str, char* typ, char* nam,
	- char* var, char* com, char* dim);
	-static void getmembers(long nmems);
	-static void getvalues();
	-static char* stlower(char*);
	-static void chrcat(char* str, char chr);
	-static char* token(char** str, char* sep);
	-static int testsep(char chr, char *sep);
	-static void mcf_ntubld_interpret();
	-
	-static char varname[40], objname[40], curstruct[40];
	-static char chvalues[500], *values, dim[20];
	-static char tok1[30], tok2[30], tok3[100], com[100];
	-static char line[1000];
	-static int n_instance_line_title, n_instance_header, n_instance_variable;
	-
	-static double dvar[100];
	-static float rvar[100];
	-static char chvar[100][80];
	-static char dbpath[FILENAME_MAX+1], filename[FILENAME_MAX+1];
	-static long nvars, morevalues, n_templates;
	-static long inc_depth, n_instance, debug_on;
	-static int isl;
	-static long n_significant, lnlen=0;
	-static FILE inFile, curFile1, curFile2, curFile3, curFile4, curFile5;
	-static const char *fnamep;
	-static void dbin_getrec(char* fname[],void (*)(void));
	-
	-static void dbin_getrec(char* fname[],void (*interpret)(void))
	-{
	- char chr;
	- int istat;
	- long inc_depth_old = 0;
	- const int nchmx = 300;
	- /*
	- ** Start be intializing all these globals, to be able to call this routine
	- ** more than once..
	- */
	- inc_depth = 0;
	- n_instance = 0;
	- lnlen = 0;
	- /* extract path from filename */
	- strcpy(filename,*fname);
	- if (strrchr(filename,'/') != NULL) {
	- strcpy(dbpath,filename);
	- *(strrchr(dbpath,'/')+1)='\0';
	- } else {
	- dbpath[0] = '\0';
	- }
	-
	- /* open file */
	- inFile = fopen(*fname,"r");
	- if (inFile == NULL) {
	- fprintf(stdout,"Error opening %s\n",*fname);
	- return;
	- }
	- else
	- {
	- if (debug_on) fprintf(stdout,"Opened %s\n",*fname);
	- }
	- /* read a line */
	- while (inc_depth>=0) {
	- istat=1;
	- while (istat!=EOF) {
	- if (inc_depth > inc_depth_old) /* need to open new file */
	- {
	- long ifstat;
	- ifstat=1;
	- fnamep = (const char *)filename;
	- if (inc_depth==1) {curFile1 = fopen(fnamep,"r");
	- if (curFile1==NULL) {
	- fprintf(stdout,"Error opening %s\n",fnamep);
	- ifstat=0;
	- }
	- else {
	- if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	- }
	- }
	- if (inc_depth==2) {curFile2 = fopen(fnamep,"r");
	- if (curFile2==NULL) {
	- fprintf(stdout,"Error opening %s\n",fnamep);
	- ifstat=0;
	- }
	- else {
	- if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	- }
	- }
	- if (inc_depth==3) {curFile3 = fopen(fnamep,"r");
	- if (curFile3==NULL) {
	- fprintf(stdout,"Error opening %s\n",fnamep);
	- ifstat=0;
	- }
	- else {
	- if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	- }
	- }
	- if (inc_depth==4) {curFile4 = fopen(fnamep,"r");
	- if (curFile4==NULL) {
	- fprintf(stdout,"Error opening %s\n",fnamep);
	- ifstat=0;
	- }
	- else {
	- if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	- }
	- }
	- if (inc_depth==5) {curFile5 = fopen(fnamep,"r");
	- if (curFile5==NULL) {
	- fprintf(stdout,"Error opening %s\n",fnamep);
	- ifstat=0;
	- }
	- else {
	- if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	- }
	- }
	- }
	- inc_depth_old = inc_depth;
	- if (inc_depth==0) istat=fgetc(inFile);
	- if (inc_depth==1) istat=fgetc(curFile1);
	- if (inc_depth==2) istat=fgetc(curFile2);
	- if (inc_depth==3) istat=fgetc(curFile3);
	- if (inc_depth==4) istat=fgetc(curFile4);
	- if (inc_depth==5) istat=fgetc(curFile5);
	- chr = istat;
	- if (chr == '\t') chr = ' '; /* remove tabs */
	- if (chr == '\n') { /* line is complete; process it */
	- if (morevalues == 1) { /* line extension containing values */
	- /* if final significant char is '/', mark next
	- line as values continuation */
	- int i;
	- isl=0;
	- for (i=0;i<strlen(line);i++) {
	- if (line[i] == '!') i=strlen(line);
	- if (line[i] == '/') isl=i;
	- }
	- if (isl != 0) {
	- n_significant = 0;
	- for (i=isl;i<strlen(line);i++) {
	- if (line[i] == '!') i=strlen(line);
	- if (line[i]!='/' && line[i]!=' ' && line[i]!='\t'
	- && i < strlen(line) ) n_significant++;
	- }
	- if (n_significant != 0) morevalues = 0;
	- } else {
	- morevalues = 0;
	- }
	- strcat(values," ");
	- if (morevalues == 0) {
	- strcat(values,line);
	- } else {
	- strncat(values,line,isl-1);
	- }
	- } else { /* line is not an extension. Parse it. */
	- dbinparse(line, tok1, tok2, tok3, com, dim);
	- }
	- if (morevalues == 0) {
	- /* no more line extensions to read. Process line. */
	- /* now interpret the line */
	- if (tok1[0] != '\0') {
	- if (debug_on) fprintf(stdout,"%s %s %s\n",tok1,tok2,values);
	- lineparse();
	- (*interpret)();
	- }
	- }
	- line[0] = '\0';
	- lnlen = 0;
	- } else {
	- /* add to line */
	- if (chr != '\r') { line[lnlen++]=chr; line[lnlen]='\0'; }
	- }
	- }
	- inc_depth--; line[0] = '\0';
	- }
	- return;
	-}
	-
	-/****************************************************************************/
	-static void lineparse()
	-{
	- char* tokn, env, envName, tmp1, tmp2;
	- long l, in_template;
	- varname[0] = '\0';
	- objname[0] = '\0';
	- if (!strcmp(tok1,"end")) {strcpy(curstruct,"--"); in_template = 0;}
	- if (!strcmp(tok1,"structure")) {strcpy(curstruct,tok2);}
	- if (!strcmp(tok1,"database")) ;
	- if (!strcmp(tok1,"incname")) ;
	- if (!strcmp(tok1,"index")) ;
	- if (!strcmp(tok1,"provide")) ;
	- if (!strcmp(tok1,"parent")) ;
	- if (!strcmp(tok1,"child")) ;
	- if (!strcmp(tok1,"dimension")) ;
	- if (!strcmp(tok1,"template")) {in_template = 1; strcpy(curstruct,tok2);
	- n_instance = 0;}
	- if (!strcmp(tok1,"command")) {in_template = 1; strcpy(curstruct,tok2);}
	- if (!strcmp(tok1,"include")) { /* switch input to specified file */
	- /*
	- ** Commented out, we use absolute path name in the includes.
	- ** This allows us to go to more than one directory..
	- */
	-/* strcpy(filename,dbpath); */
	-/* strcat(filename,tok2); */
	-/*
	-** We now implement translation of environmental variable
	-**
	-*/
	- if (tok2[0] == '$') {
	- tmp1 = strchr(&tok2[1], '/');
	- if (tmp1 == NULL) {
	- fprintf(stderr, "DBin error, Unkonw path %s\n", tok2);
	- return;
	- }
	- envName = (char ) malloc(sizeof(char) (strlen(tok2)+1));
	- strcpy(envName, &tok2[1]);
	- tmp2 = strchr(envName, '/'); *tmp2 = '\0';
	- env = getenv(envName);
	- free(envName);
	-
	- if (env == NULL) {
	- fprintf(stderr, "DBin error, Unkonw path %s\n", tok2);
	- return;
	- }
	- strcpy(filename,env); l = strlen(env); filename[l] = '/'; l++;
	- strcpy(&filename[l], tmp1);
	-
	- } else strcpy(filename, tok2);
	- inc_depth++;
	- }
	- if (!strcmp(tok1,"make")) {
	- n_instance++;
	- strcpy(varname,"TEMPLATE_");
	- strcat(varname,stlower(tok2));
	- }
	- if (!strcmp(tok1,"define")) {
	- /* get first token (name) from values list */
	- tokn = token(&values," \t");
	- strcpy(varname,"TEMPLATE_");
	- strcat(varname,tok2);
	- strcpy(objname,tok2);
	- strcat(objname,"_");
	- strcat(objname,tokn);
	- }
	- if (!strcmp(tok1,"call")) {
	- /* get first token (name) from values list */
	- tokn = token(&values," \t");
	- strcpy(varname,"COMMAND_");
	- strcat(varname,tok2);
	- }
	- if (!strncmp(tok1,"int",3) \|\| !strcmp(tok1,"real") \|\| !strcmp(tok1,"double") \|\|
	- !strncmp(tok1,"char",4) \|\| !strcmp(tok1,"material") ) {
	- if ((! strncmp(curstruct,"--",2)) && (in_template == 0)) {
	- fprintf(stdout,"dbin: Parameter \"%s\" not in structure; ignored:\n",
	- tok2);
	- fprintf(stdout," %s\n",line);
	- } else {
	- /* parse values */
	- strcpy(varname,curstruct);
	- strcat(varname,".");
	- strcat(varname,tok2);
	- getvalues();
	- }
	- }
	-}
	-
	-/****************************************************************************/
	-static void dbinparse(char* str, char* typ,
	- char* nam, char* var, char* com, char* dim)
	-{
	-/* Parse from line the type, name, value, comment */
	- int i;
	- long nc = 0;
	-
	- nvars = 1;
	- chvalues[0] = dim[0] = typ[0] = nam[0] = var[0] = com[0] = '\0';
	- values = chvalues;
	-
	-/* if final significant char is '/', mark next line as values continuation */
	- isl=strlen(str);
	- for (i=0;i<strlen(str);i++) {
	- if (str[i] == '!') i=strlen(str);
	- if (str[i] == '/') isl=i;
	- }
	- morevalues = 0;
	- if (isl != strlen(str)) {
	- n_significant = 0;
	- for (i=isl;i<strlen(str);i++) {
	- if (str[i] == '!') i=strlen(str);
	- if (str[i]!='/' && str[i]!=' ' && str[i]!='\t'
	- && i < strlen(line) ) n_significant++;
	- }
	- if (n_significant == 0) morevalues = 1;
	- }
	-
	- /* initial whitespace, type, whitespace */
	- while ((str[nc] == ' ') \|\| (str[nc] == '\t')) ++nc;
	- while ((str[nc] != ' ') && (str[nc] != '\t')
	- && (nc < strlen(str))) chrcat(typ,str[nc++]);
	- while ((str[nc] == ' ') \|\| (str[nc] == '\t')) ++nc;
	- /* name, whitespace, dimension? */
	- while ((str[nc] != ' ') && (str[nc] != '\t') && (str[nc] != '(' )
	- && (nc < strlen(str))) chrcat(nam,str[nc++]);
	- while ((str[nc] == ' ') \|\| (str[nc] == '\t')
	- && (nc < strlen(str))) ++nc;
	- if (str[nc] == '(') { /* have a dimensioned array */
	- /* get dimension */
	- while (str[++nc] != ')') chrcat(dim,str[nc]); nc++;
	- nvars = atol(dim);
	- }
	- /* skip over value(s) to comment */
	- while ( (str[nc] != '!') &&
	- (str[nc] != '/' \|\| ( morevalues && (nc != isl) ) ) &&
	- ( (nc < strlen(str)) \|\| ( morevalues && (nc < isl)) ) ) chrcat(chvalues,str[nc++]);
	- /* comment */
	- while (((str[nc] == '!') \|\| (str[nc] == '\t'))
	- && (nc < strlen(str))) ++nc;
	- while (nc <= strlen(str)) { chrcat(com,str[nc++]); }
	- /* turn mnemonic num into variable name var */
	- var = nam;
	-}
	-
	-/****************************************************************************/
	-
	-static void getvalues()
	-{
	- char* tokn;
	- long nv=0; while (nv < nvars) {
	- /* get next token and trim it from the values list. */
	- if (!strncmp(tok1,"char",4) \|\| !strncmp(tok1,"material",8) ) {
	- char iq1, iq2;
	- iq1 = strchr(values,'"');
	- iq2 = strrchr(values,'"');
	- if (iq1 != NULL) {
	- strncpy(chvar[nv],iq1+1,iq2-iq1-1);
	- chvar[nv][iq2-iq1-1] = '\0';
	- }
	- else
	- strcpy(chvar[nv],values);
	- } else {
	- tokn = token(&values," \t");
	- if (tokn != NULL) {
	- if (!strncmp(tok1,"int",3)) rvar[nv] = atol(tokn);
	- if (!strcmp(tok1,"real")) rvar[nv] = atof(tokn);
	- if (!strcmp(tok1,"double")) dvar[nv] = atof(tokn);
	- }
	- }
	- nv++;
	- }
	-}
	-
	-/****************************************************************************/
	-
	-static void getmembers(long nmems)
	-{
	- char tokn, iq1, *iq2;
	- long n, nq, nv=0;
	- /* fill string interiors with '@' so they are delineated as tokens */
	- n=0; nq=0; while (n<strlen(values)) {
	- if (values[n]=='"') nq++;
	- if ((values[n]==' '\|\|values[n]=='\t') && nq%2==1) values[n] = '@';
	- n++;
	- }
	- while (nv < nmems) {
	- /* get next token and trim it from the values list. */
	- tokn = token(&values," \t");
	- if ( tokn[0]=='"' ) {
	- n=0; while (n<strlen(tokn))
	- { if (tokn[n]=='@') tokn[n] = ' '; n++; }
	- iq1 = strchr(tokn,'"');
	- iq2 = strrchr(tokn,'"');
	- strncpy(chvar[nv],iq1+1,iq2-iq1-1);
	- chvar[nv][iq2-iq1-1] = '\0';
	- } else {
	- strcpy(chvar[nv],tokn);
	- }
	- rvar[nv] = atof(tokn);
	- nv++;
	- }
	-}
	-
	-/****************************************************************************/
	-static void dbin_debug()
	-{
	- debug_on = 1;
	-}
	-
	-/****************************************************************************/
	-static void chrcat(char* str, char chr)
	-{
	- int ln;
	- ln = strlen(str);
	- str[ln] = chr;
	- str[ln+1]='\0';
	-}
	-
	-/****************************************************************************/
	-static char * stlower(char* st) {
	- int i=0;
	- while (st[i] != '\0') {
	- if (st[i] >= 'A' && st[i] <= 'Z') st[i] = st[i] + 'a' - 'A';
	- i++;
	- }
	- return st;
	-}
	-
	-/****************************************************************************/
	-static char* token(char** str, char* sep)
	-{
	- int i=0;
	- char if1=NULL, if2=NULL, strend = str + strlen(*str);
	- /* if1 = rel. pointer to 1st token char */
	- i=0; while (if1 == NULL && i<strlen(*str)) {
	- if (!testsep((str+i),sep))
	- if1= *str+i;
	- i++;
	- }
	- if (if1 == NULL) return if1;
	- /* if2 = 1st char past the token */
	- i=0; while (if2 == NULL && i<strlen(if1))
	- { if (testsep(if1[i],sep)) if2=&if1[i]; i++; }
	- if (if2<strend && if2 != NULL) {
	- if (if2 != NULL) *if2 = '\0';
	- *str = if2+1;
	- } else {
	- *str = strend;
	- }
	- return if1;
	-}
	-
	-/****************************************************************************/
	-static int testsep(char chr, char *sep)
	-{
	- int ist=0, i=0;
	- while (sep[i] != '\0')
	- if (sep[i++] == chr \|\| chr == '\0' \|\| chr == '\n' ) ist=1;
	- return ist;
	-}
	-/* Database read routine */
	-/*** Generated automatically using the dbin tool. */
	-/*** Not to be modified by user. */
	-/*
	-** Modifiedt by P.L., to abe able to load all the templates into
	-** one file... And included in this file, to avoid defining too many
	-** global symbols. This clearly breaks the dbin mold, to be discussed
	-** later..
	-*/
	-void mcf_ntubldRead(char* fname)
	-{
	- void (pf)(); / pointer to interpreter */
	- inc_depth = 0;
	- n_instance =0;
	- lnlen=0;
	- debug_on = 0;
	- pf = &mcf_ntubld_interpret;
	- mcf_ntubldInit();
	- n_instance_line_title = 0;
	- n_instance_header = 0;
	- n_instance_variable = 0;
	- dbin_getrec(&fname,pf);
	-}
	-static void mcf_ntubld_interpret()
	-{
	-int inum, index, i, ndim, iok;
	-iok=0;
	-if ( !strcmp(varname,"TEMPLATE_line_title") ) {
	- inum = 0; iok = 1;
	- getmembers(n_el_line_title);
	- index = n_instance_line_title;
	- *n_obj_line_title = n_instance_line_title+1;
	- strcpy(line_title[index].line,chvar[inum++]);
	- n_instance_line_title++;
	-}
	-if ( !strcmp(varname,"TEMPLATE_header") ) {
	- inum = 0; iok = 1;
	- getmembers(n_el_header);
	- index = n_instance_header;
	- *n_obj_header = n_instance_header+1;
	- strcpy(header[index].title,chvar[inum++]);
	- strcpy(header[index].version,chvar[inum++]);
	- strcpy(header[index].namemaxindex,chvar[inum++]);
	- header[index].maxmult = rvar[inum++];
	- header[index].orgstyle = rvar[inum++];
	- header[index].nvar = rvar[inum++];
	- n_instance_header++;
	-}
	-if ( !strcmp(varname,"TEMPLATE_variable") ) {
	- inum = 0; iok = 1;
	- getmembers(n_el_variable);
	- index = n_instance_variable;
	- *n_obj_variable = n_instance_variable+1;
	- strcpy(variable[index].name,chvar[inum++]);
	- strcpy(variable[index].description,chvar[inum++]);
	- variable[index].type = rvar[inum++];
	- strcpy(variable[index].isfixedsize,chvar[inum++]);
	- variable[index].numdim = rvar[inum++];
	- for (i=0;i<5;i++) variable[index].dimensions[i] = rvar[inum++];
	- n_instance_variable++;
	-}
	-}
	Index: trunk/mcfio/mcf_xdr_Ntuple.h
	===================================================================
	--- trunk/mcfio/mcf_xdr_Ntuple.h (revision 8888)
	+++ trunk/mcfio/mcf_xdr_Ntuple.h (revision 8889)
	@@ -1,32 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcf_xdr_Ntuple.h -- Include file for mcfast Xdrlayer used in the *
	-* Ntuple code. Refers to a bunch of structure not included in this file. * Specifies the headers *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warrenty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-*******************************************************************************/
	-bool_t xdr_mcfast_NTuple(XDR xdrs, descrGenNtuple dNTu,
	- int ntot, int nTupleId, char version);
	-bool_t xdr_mcfast_NTupleXDRPtr(XDR xdrs, descrGenNtuple dNTu,
	- int ntot, int nTupleId, char version);
	-bool_t xdr_mcfast_NTupleMult(mcfStream *str,
	- descrGenNtuple dNTu, char version);
	-bool_t xdr_mcfast_NTupleVar(mcfStream *str,
	- descrGenNtuple dNTu, int ivar, char version);
	-bool_t xdr_mcfast_NTupleSubVar(mcfStream *str,
	- descrGenNtuple dNTu, int ivar, int multIndex, char version);
	-bool_t xdr_mcfast_NTupleSubStruct(mcfStream *str,
	- descrGenNtuple dNTu, int multIndex, char version);
	Index: trunk/mcfio/mcfio_Util1.h
	===================================================================
	--- trunk/mcfio/mcfio_Util1.h (revision 8888)
	+++ trunk/mcfio/mcfio_Util1.h (revision 8889)
	@@ -1,27 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_Util1.h -- Include file for mcfast initialisation & info i/o layer. *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-*******************************************************************************/
	-void mcfioC_Init(void);
	-void mcfioC_Close(int istream);
	-void mcfioC_PrintDictionary(void);
	-unsigned int mcfioC_InfoNumSream(int *istreams, unsigned int nmax);
	-void mcfioC_InfoStreamInt(int istream, int key, int *value);
	-void mcfioC_InfoStreamChar(int istream, int key, char answer, int lret);
	-void mcfioC_InfoEventInt(int istream, int key, int *value);
	-void mcfioC_InfoEventChar(int istream, int key, char answer, int lret);
	-void mcfioC_SetEventInfo(int istream, int key, int *value);
	-void mcfioC_Free_FileHeader(mcfxdrFileHeader **p);
	-void mcfioC_Free_SeqHeader(mcfxdrSequentialHeader **p);
	-void mcfioC_Free_EventHeader(mcfxdrEventHeader **p);
	-void mcfioC_Free_EventTable(mcfxdrEventTable **p);
	-void mcfioC_FreeStream(mcfStream **stream);
	-void mcfioC_InfoBlockChar(int stream, int blk, int key,
	- char answer, int lret);
	-unsigned int mcfioC_InfoNumStream(int *istreams, unsigned int nmax);
	-void mcfioC_GetBlockName(int blkId, char *answer);
	-void mcfioC_Rewind(int istream);
	Index: trunk/mcfio/mcfio_UserDictionary.c
	===================================================================
	--- trunk/mcfio/mcfio_UserDictionary.c (revision 8888)
	+++ trunk/mcfio/mcfio_UserDictionary.c (revision 8889)
	@@ -1,58 +0,0 @@
	-/*
	-** A small container to hold a set of user block declaration
	-**
	-* Written by Paul Lebrun, Aug 2001
	-*/
	-#include <stdio.h>
	-#include <string.h>
	-#include <sys/param.h>
	-#include <rpc/types.h>
	-#include <sys/types.h>
	-#include <rpc/xdr.h>
	-#include <limits.h>
	-#include <stdlib.h>
	-#include "mcfio_UserDictionary.h"
	-
	-#define NUMUSERBLOCKDEFAULT 100
	-
	-allMCFIO_UserBlockDecl *AllMCFIO_UserBlockDecl = NULL;
	-
	-
	-char *mcfioC_UserBlockDescript(int blkn)
	-{
	- int i;
	- if (AllMCFIO_UserBlockDecl == NULL) return NULL;
	- for (i=0; i<AllMCFIO_UserBlockDecl->num; i++) {
	- if (AllMCFIO_UserBlockDecl->decls[i]->blkNum == blkn)
	- return AllMCFIO_UserBlockDecl->decls[i]->title;
	- }
	- return NULL;
	-}
	-
	-void mcfioC_DefineUserBlock(int blkN, char *descr){
	- int i;
	- aUserBlockDecl *abd;
	-
	- if (AllMCFIO_UserBlockDecl == NULL) {
	-
	- AllMCFIO_UserBlockDecl = (allMCFIO_UserBlockDecl *) malloc (
	- sizeof(allMCFIO_UserBlockDecl));
	- AllMCFIO_UserBlockDecl->numPreAlloc = NUMUSERBLOCKDEFAULT;
	- AllMCFIO_UserBlockDecl->num = 0;
	- AllMCFIO_UserBlockDecl->decls = (aUserBlockDecl **) malloc(
	- NUMUSERBLOCKDEFAULT * sizeof(aUserBlockDecl *));
	- }
	- if (AllMCFIO_UserBlockDecl->num == AllMCFIO_UserBlockDecl->numPreAlloc) {
	- AllMCFIO_UserBlockDecl->numPreAlloc += NUMUSERBLOCKDEFAULT;
	- AllMCFIO_UserBlockDecl->decls =
	- (aUserBlockDecl *) realloc (((void ) AllMCFIO_UserBlockDecl->decls),
	- (AllMCFIO_UserBlockDecl->numPreAlloc * sizeof(aUserBlockDecl *)));
	- }
	- AllMCFIO_UserBlockDecl->decls[AllMCFIO_UserBlockDecl->num] =
	- (aUserBlockDecl *) malloc (sizeof(aUserBlockDecl));
	- abd = AllMCFIO_UserBlockDecl->decls[AllMCFIO_UserBlockDecl->num];
	- AllMCFIO_UserBlockDecl->num++;
	- abd->blkNum = blkN;
	- abd->title = (char ) malloc (sizeof(char) (strlen(descr) + 1));
	- strcpy(abd->title, descr);
	-}
	Index: trunk/mcfio/mcfio_SeqDummy.c
	===================================================================
	--- trunk/mcfio/mcfio_SeqDummy.c (revision 8888)
	+++ trunk/mcfio/mcfio_SeqDummy.c (revision 8889)
	@@ -1,65 +0,0 @@
	-/*******************************************************************************
	-* *
	-* mcfio_SeqDummy.c -- Utility routines for the McFast Monte-Carlo *
	-* Dummy Sequential routines, for the library without Sequential *
	-* *
	-* Copyright (c) 1994 Universities Research Association, Inc. *
	-* All rights reserved. *
	-* *
	-* This material resulted from work developed under a Government Contract and *
	-* is subject to the following license: The Government retains a paid-up, *
	-* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	-* works, perform publicly and display publicly by or for the Government, *
	-* including the right to distribute to other Government contractors. Neither *
	-* the United States nor the United States Department of Energy, nor any of *
	-* their employees, makes any warranty, express or implied, or assumes any *
	-* legal liability or responsibility for the accuracy, completeness, or *
	-* usefulness of any information, apparatus, product, or process disclosed, or *
	-* represents that its use would not infringe privately owned rights. *
	-* *
	-* *
	-* Written by Paul Lebrun *
	-* *
	-* *
	-*******************************************************************************/
	-#include <stdio.h>
	-#include <string.h>
	-#include "mcfio_Sequential.h"
	-
	-int mcfioC_OpenReadSequential(char device, char label, int filenumber)
	-{
	- fprintf(stderr,
	- "mcfioC_OpenReadSequential: Not available in this library. \n");
	- return -1;
	-}
	-
	-
	-int mcfioC_OpenWriteSequential(char device, char label, char *title,
	- char *comment, int numevts_pred,
	- int *blkIds, unsigned int nBlocks)
	-{
	- fprintf(stderr,
	- "mcfioC_OpenWriteSequential: Not available in this library. \n");
	- return -1;
	-}
	-
	-int mcfioC_NextEventSequential(int stream)
	-{
	- fprintf(stderr,
	- "mcfioC_NextEventSequential: Not available in this library. \n");
	- return -1;
	-}
	-
	-void mcfioC_CloseSequentialFile(int jstr)
	-{
	- fprintf(stderr,
	- "mcfioC_CloseSequentialFile: Not available in this library. \n");
	- return;
	-}
	-
	-void mcfioC_CloseSequentialTape(int jstr)
	-{
	- fprintf(stderr,
	- "mcfioC_CloseSequentialTape: Not available in this library. \n");
	- return;
	-}
	Index: trunk/mcfio/mcf_ntuBldDbinc.h
	===================================================================
	--- trunk/mcfio/mcf_ntuBldDbinc.h (revision 8888)
	+++ trunk/mcfio/mcf_ntuBldDbinc.h (revision 8889)
	@@ -1,21 +0,0 @@
	-/*
	- * dbin.h
	- *
	- * C++ utility routines for the dbin package: see dbin.lex
	- *
	- * N.B. The Strings class from the CLHEP library is used.
	- *
	- * Torre Wenaus 04/01/1994
	- *
	- * Modifications:
	- * 8/21/95 T. Wenaus Mod history started
	- * 8/21/95 TW Strings class removed from dbin generated code.
	- * 8/22/95 TW Strings class removed from dbinc.cc
	- *
	- * November 1995: some clean up to be able to run this code and
	- * standard dbin simulateneously..
	- * Make some routine & variable static, and change the name of routine
	- * called from the outside, following the Nirvana/mcfio conventions.
	- *
	- */
	-void mcf_ntubldRead(char* fname);
	Index: trunk/tauola/photos.f
	===================================================================
	--- trunk/tauola/photos.f (revision 8888)
	+++ trunk/tauola/photos.f (revision 8889)
	@@ -1,3367 +0,0 @@
	-*///////////////////////////////////////////////////////////////////////
	-*//
	-*// !!!!!!! WARNING!!!!! This source may be agressive !!!!
	-*//
	-*// Due to short common block names it may owerwrite variables in other
	-*// parts of the code.
	-*//
	-*// One should add suffix c_Photos_ to names of all commons as soon as
	-*// possible!!
	-*///////////////////////////////////////////////////////////////////////
	-
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOtos CDE-s
	-C.
	-C. Purpose: Keep definitions for PHOTOS QED correction Monte Carlo.
	-C.
	-C. Input Parameters: None
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): Z. Was, B. van Eijk Created at: 29/11/89
	-C. Last Update: 10/08/93
	-C.
	-C. =========================================================
	-C. General Structure Information: =
	-C. =========================================================
	-C: ROUTINES:
	-C. 1) INITIALIZATION:
	-C. PHOCDE
	-C. PHOINI
	-C. PHOCIN
	-C. PHOINF
	-C. 2) GENERAL INTERFACE:
	-C. PHOTOS
	-C. PHOTOS_GET
	-C. PHOTOS_SET
	-C. PHOTOS_MAKE
	-C. PHOBOS
	-C. PHOIN
	-C. PHOTWO (specific interface
	-C. PHOOUT
	-C. PHOCHK
	-C. PHTYPE (specific interface
	-C. PHOMAK (specific interface
	-C. 3) QED PHOTON GENERATION:
	-C. PHINT
	-C. PHOBW
	-C. PHOPRE
	-C. PHOOMA
	-C. PHOENE
	-C. PHOCOR
	-C. PHOFAC
	-C. PHODO
	-C. 4) UTILITIES:
	-C. PHOTRI
	-C. PHOAN1
	-C. PHOAN2
	-C. PHOBO3
	-C. PHORO2
	-C. PHORO3
	-C. PHORIN
	-C. PHORAN
	-C. PHOCHA
	-C. PHOSPI
	-C. PHOERR
	-C. PHOREP
	-C. PHLUPA
	-C. PHCORK
	-C. IPHQRK
	-C. IPHEKL
	-C. COMMONS:
	-C. NAME USED IN SECT. # OF OCC. Comment
	-C. PHOQED 1) 2) 3 Flags whether emisson to be gen.
	-C. PHOLUN 1) 4) 6 Output device number
	-C. PHOCOP 1) 3) 4 photon coupling & min energy
	-C. PHPICO 1) 3) 4) 5 PI & 2*PI
	-C. PHSEED 1) 4) 3 RN seed
	-C. PHOSTA 1) 4) 3 Status information
	-C. PHOKEY 1) 2) 3) 7 Keys for nonstandard application
	-C. PHOVER 1) 1 Version info for outside
	-C. HEPEVT 2) 2 PDG common
	-C. PH_HEPEVT2) 8 PDG common internal
	-C. PHOEVT 2) 3) 10 PDG branch
	-C. PHOIF 2) 3) 2 emission flags for PDG branch
	-C. PHOMOM 3) 5 param of char-neutr system
	-C. PHOPHS 3) 5 photon momentum parameters
	-C. PHOPRO 3) 4 var. for photon rep. (in branch)
	-C. PHOCMS 2) 3 parameters of boost to branch CMS
	-C. PHNUM 4) 1 event number from outside
	-C.----------------------------------------------------------------------
	- SUBROUTINE PHOINI
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays INItialisation
	-C.
	-C. Purpose: Initialisation routine for the PHOTOS QED radiation
	-C. package. Should be called at least once before a call
	-C. to the steering program 'PHOTOS' is made.
	-C.
	-C. Input Parameters: None
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	-C. Last Update: 12/04/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER INIT,IDUM,IPHQRK,IPHEKL
	- SAVE INIT
	- DATA INIT/ 0/
	-C--
	-C-- Return if already initialized...
	- IF (INIT.NE.0) RETURN
	- INIT=1
	-C--
	-C-- all the following parameter setters can be called after PHOINI.
	-C-- Initialization of kinematic correction against rounding errors.
	-C-- The set values will be used later if called wit zero.
	-C-- Default parameter is 1 (no correction) optionally 2, 3, 4
	-C-- In case of exponentiation new version 5 is needed in most cases.
	-C-- Definition given here will be thus overwritten in such a case
	-C-- below in routine PHOCIN
	- CALL PHCORK(1)
	-C-- blocks emission from quarks if parameter is 1 (enables if 2),
	-C-- physical treatment
	-C-- will be 3, option 2 is not realistic and for tests only,
	- IDUM= IPHQRK(1) ! default is 1
	-C-- blocks emission in pi0 to gamma e+ e- if parameter is gt.1
	-C-- (enables otherwise)
	- IDUM= IPHEKL(2) ! default is 1
	-C--
	-C-- Preset parameters in PHOTOS commons
	- CALL PHOCIN
	-C--
	-C-- Print info
	- CALL PHOINF
	-
	-C--
	-C-- Initialize Marsaglia and Zaman random number generator
	- CALL PHORIN
	- RETURN
	- END
	- SUBROUTINE PHOCIN
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton Common INitialisation
	-C.
	-C. Purpose: Initialisation of parameters in common blocks.
	-C.
	-C. Input Parameters: None
	-C.
	-C. Output Parameters: Commons /PHOLUN/, /PHOPHO/, /PHOCOP/, /PHPICO/
	-C. and /PHSEED/.
	-C.
	-C. Author(s): B. van Eijk Created at: 26/11/89
	-C. Z. Was Last Update: 29/01/05
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER d_h_NMXHEP
	-
	-
	-
	- PARAMETER (d_h_NMXHEP=4000)
	- LOGICAL QEDRAD
	- COMMON/PHOQED/QEDRAD(d_h_NMXHEP)
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	- double precision ALPHA,XPHCUT
	- COMMON/PHOCOP/ALPHA,XPHCUT
	- double precision PI,TWOPI
	- COMMON/PHPICO/PI,TWOPI
	- INTEGER ISEED,I97,J97
	- double precision URAN,CRAN,CDRAN,CMRAN
	- COMMON/PHSEED/ISEED(2),I97,J97,URAN(97),CRAN,CDRAN,CMRAN
	- INTEGER PHOMES
	- PARAMETER (PHOMES=10)
	- INTEGER STATUS
	- COMMON/PHOSTA/STATUS(PHOMES)
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- INTEGER INIT,I
	- SAVE INIT
	- DATA INIT/ 0/
	-C--
	-C-- Return if already initialized...
	- IF (INIT.NE.0) RETURN
	- INIT=1
	-C--
	-C-- Preset switch for photon emission to 'TRUE' for each particle in
	-C-- /PH_HEPEVT/, this interface is needed for KORALB and KORALZ...
	- DO 10 I=1,d_h_NMXHEP
	- 10 QEDRAD(I)=.TRUE.
	-C--
	-C-- Logical output unit for printing of PHOTOS error messages
	- PHLUN=6
	-C--
	-C-- Set cut parameter for photon radiation
	- XPHCUT=0.01 D0 ! 0.0001D0! to go to low valuex (IEXP excepted)
	-C-- ! switch to - VARIANT B
	-C--
	-C-- Define some constants
	- ALPHA=0.00729735039D0
	- PI=3.14159265358979324D0
	- TWOPI=6.28318530717958648D0
	-C--
	-C-- Default seeds Marsaglia and Zaman random number generator
	- ISEED(1)=1802
	- ISEED(2)=9373
	-C--
	-C-- Iitialization for extra options
	-C-- (1)
	-C-- Interference weight now universal.
	- INTERF=.TRUE.
	-C-- (2)
	-C-- Second order - double photon switch
	- ISEC=.TRUE.
	-C-- Third/fourth order - triple (or quatric) photon switch,
	-C-- see dipswitch ifour
	- ITRE=.FALSE.
	-C-- Exponentiation on:
	- IEXP=.FALSE. !.TRUE.
	- IF (IEXP) THEN
	- ISEC=.FALSE.
	- ITRE=.FALSE.
	- CALL PHCORK(5) ! in case of exponentiation correction of ph space
	- ! is a default mandatory
	- XPHCUT=0.000 000 1
	- EXPEPS=1D-4
	- ENDIF
	-C-- (3)
	-C-- Emision in the hard process g g (q qbar) --> t tbar
	-C-- t --> W b
	- IFTOP=.TRUE.
	-C--
	-C-- further initialization done automatically
	-C-- see places with - VARIANT A - VARIANT B - all over
	-C-- to switch between options.
	-C ----------- SLOWER VARIANT A, but stable ------------------
	-C --- it is limiting choice for small XPHCUT in fixed orer
	-C --- modes of operation
	- IF (INTERF) THEN
	-C-- best choice is if FINT=2**N where N+1 is maximal number
	-C-- of charged daughters
	-C-- see report on overweihted events
	-C FINT=2.0D0
	- FINT=2.5D0
	- ELSE
	- FINT=1.0D0
	- ENDIF
	-C ----------- FASTER VARIANT B ------------------
	-C -- it is good for tests of fixed order and small XPHCUT
	-C -- but is less promising for more complex cases of interference
	-C -- sometimes fails because of that
	-C
	-C IF (INTERF) THEN
	-C FINT=1.80D0
	-C ELSE
	-C FINT=0.0D0
	-C ENDIF
	-C----------END VARIANTS A B -----------------------
	-
	-C-- Effects of initial state charge (in leptonic W decays)
	-C--
	- IFW=.TRUE.
	-C-- Initialise status counter for warning messages
	- DO 20 I=1,PHOMES
	- 20 STATUS(I)=0
	- RETURN
	- END
	- SUBROUTINE PHOINF
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays general INFo
	-C.
	-C. Purpose: Print PHOTOS info
	-C.
	-C. Input Parameters: PHOLUN
	-C.
	-C. Output Parameters: PHOVN1, PHOVN2
	-C.
	-C. Author(s): B. van Eijk Created at: 12/04/90
	-C. Last Update: 27/06/04
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER IV1,IV2,IV3
	- INTEGER PHOVN1,PHOVN2
	- COMMON/PHOVER/PHOVN1,PHOVN2
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision ALPHA,XPHCUT
	- COMMON/PHOCOP/ALPHA,XPHCUT
	-C--
	-C-- PHOTOS version number and release date
	- PHOVN1=215
	- PHOVN2=111005
	-C--
	-C-- Print info
	- WRITE(PHLUN,9000)
	- WRITE(PHLUN,9020)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9030)
	- IV1=PHOVN1/100
	- IV2=PHOVN1-IV1*100
	- WRITE(PHLUN,9040) IV1,IV2
	- IV1=PHOVN2/10000
	- IV2=(PHOVN2-IV1*10000)/100
	- IV3=PHOVN2-IV110000-IV2100
	- WRITE(PHLUN,9050) IV1,IV2,IV3
	- WRITE(PHLUN,9030)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9060)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9070)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9020)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9064) INTERF,ISEC,ITRE,IEXP,IFTOP,IFW,ALPHA,XPHCUT
	- WRITE(PHLUN,9010)
	- IF (INTERF) WRITE(PHLUN,9061)
	- IF (ISEC) WRITE(PHLUN,9062)
	- IF (ITRE) WRITE(PHLUN,9066)
	- IF (IEXP) WRITE(PHLUN,9067) EXPEPS
	- IF (IFTOP) WRITE(PHLUN,9063)
	- IF (IFW) WRITE(PHLUN,9065)
	- WRITE(PHLUN,9080)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9020)
	- RETURN
	- 9000 FORMAT(1H1)
	- 9010 FORMAT(1H ,'',T81,'')
	- 9020 FORMAT(1H ,80('*'))
	- 9030 FORMAT(1H ,'',26X,26('='),T81,'')
	- 9040 FORMAT(1H ,'',28X,'PHOTOS, Version: ',I2,'.',I2,T81,'')
	- 9050 FORMAT(1H ,'',28X,'Released at: ',I2,'/',I2,'/',I2,T81,'')
	- 9060 FORMAT(1H ,'*',18X,'PHOTOS QED Corrections in Particle Decays',
	- &T81,'*')
	- 9061 FORMAT(1H ,'*',18X,'option with interference is active ',
	- &T81,'*')
	- 9062 FORMAT(1H ,'*',18X,'option with double photons is active ',
	- &T81,'*')
	- 9066 FORMAT(1H ,'*',18X,'option with triple/quatric photons is active',
	- &T81,'*')
	- 9067 FORMAT(1H ,'*',18X,'option with exponentiation is active EPSEXP=',
	- &E10.4,T81,'*')
	- 9063 FORMAT(1H ,'*',18X,'emision in t tbar production is active ',
	- &T81,'*')
	- 9064 FORMAT(1H ,'',18X,'Internal input parameters:',T81,''
	- &,/, 1H ,'',T81,''
	- &,/, 1H ,'*',18X,'INTERF=',L2,' ISEC=',L2,' ITRE=',L2,
	- & ' IEXP=',L2,' IFTOP=',L2,
	- & ' IFW=',L2,T81,'*'
	- &,/, 1H ,'',18X,'ALPHA_QED=',F8.5,' XPHCUT=',E8.3,T81,'')
	- 9065 FORMAT(1H ,'*',18X,'correction wt in decay of W is active ',
	- &T81,'*')
	- 9070 FORMAT(1H ,'*',9X,
	- &'Monte Carlo Program - by E. Barberio, B. van Eijk and Z. Was',
	- & T81,'*',/,
	- & 1H ,'',9X,'Version 2.09 - by P. Golonka and Z.W.',T81,'')
	- 9080 FORMAT( 1H ,'',9X,' ',T81,'',/,
	- & 1H ,'*',9X,
	- & ' WARNING (1): /HEPEVT/ is not anymore the standard common block'
	- & ,T81,'*',/,
	- & 1H ,'',9X,' ',T81,'',/,
	- & 1H ,'*',9X,
	- & ' PHOTOS expects /HEPEVT/ to have REAL*8 variables. To change to'
	- & ,T81,'',/, 1H ,'',9X,
	- & ' REAL*4 modify its declaration in subr. PHOTOS_GET PHOTOS_SET:'
	- & ,T81,'',/, 1H ,'',9X,
	- & ' REAL*8 d_h_phep, d_h_vhep'
	- & ,T81,'',/, 1H ,'',9X,
	- & ' WARNING (2): check dims. of /hepevt/ /phoqed/ /ph_hepevt/.'
	- & ,T81,'',/, 1H ,'',9X,
	- & ' HERE: d_h_nmxhep=4000 and NMXHEP=10000'
	- & ,T81,'*')
	- END
	- SUBROUTINE PHOTOS(ID)
	- IMPLICIT double precision(A-H,O-Z)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: General search routine + _GET + _SET
	-C.
	-C. Purpose: /HEPEVT/ is not anymore a standard at least
	-C. REAL8 REAL4 are in use. PHOTOS_GET and PHOTOS_SET
	-C. were to be introduced.
	-C.
	-C.
	-C. Input Parameters: ID see routine PHOTOS_MAKE
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): Z. Was Created at: 21/07/98
	-C. Last Update: 21/07/98
	-C.
	-C.----------------------------------------------------------------------
	- COMMON /PHLUPY/ IPOIN,IPOINM
	- INTEGER IPOIN,IPOINM
	- COMMON /PHNUM/ IEV
	- INTEGER IEV
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	-
	- IF (1.GT.IPOINM.AND.1.LT.IPOIN ) THEN
	- WRITE(PHLUN,*) 'EVENT NR=',IEV,
	- $ 'WE ARE TESTING /HEPEVT/ at IPOINT=1 (input)'
	- CALL PHODMP
	- ENDIF
	- CALL PHOTOS_GET
	- CALL PHOTOS_MAKE(ID)
	- CALL PHOTOS_SET
	- IF (1.GT.IPOINM.AND.1.LT.IPOIN ) THEN
	- WRITE(PHLUN,*) 'EVENT NR=',IEV,
	- $ 'WE ARE TESTING /HEPEVT/ at IPOINT=1 (output)'
	- CALL PHODMP
	- ENDIF
	-
	- END
	-
	- SUBROUTINE PHOTOS_GET
	-C.----------------------------------------------------------------------
	-C.
	-C. Getter for PHOTOS:
	-C.
	-C. Purpose: Copies /HEPEVT/ into /PH_HEPEVT/
	-C.
	-C.
	-C. Input Parameters: None
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): Z. Was Created at: 21/07/98
	-C. Last Update: 21/07/98
	-C.
	-C.----------------------------------------------------------------------
	-
	- IMPLICIT NONE
	- INTEGER d_h_nmxhep ! maximum number of particles
	- PARAMETER (d_h_NMXHEP=4000)
	- double precision d_h_phep, d_h_vhep
	- INTEGER d_h_nevhep,d_h_nhep,d_h_isthep,d_h_idhep,d_h_jmohep,
	- $ d_h_jdahep
	- COMMON /hepevt/
	- $ d_h_nevhep, ! serial number
	- $ d_h_nhep, ! number of particles
	- $ d_h_isthep(d_h_nmxhep), ! status code
	- $ d_h_idhep(d_h_nmxhep), ! particle ident KF
	- $ d_h_jmohep(2,d_h_nmxhep), ! parent particles
	- $ d_h_jdahep(2,d_h_nmxhep), ! childreen particles
	- $ d_h_phep(5,d_h_nmxhep), ! four-momentum, mass [GeV]
	- $ d_h_vhep(4,d_h_nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL d_h_qedrad
	- COMMON /phoqed/
	- $ d_h_qedrad(d_h_nmxhep) ! Photos flag
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- LOGICAL QEDRAD
	- COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	- integer k,l
	- nevhep= d_h_nevhep ! serial number
	- nhep = d_h_nhep ! number of particles
	- DO K=1,nhep
	- isthep(k) =d_h_isthep(k) ! status code
	- idhep(k) =d_h_idhep(k) ! particle ident KF
	- jmohep(1,k) =d_h_jmohep(1,k) ! parent particles
	- jdahep(1,k) =d_h_jdahep(1,k) ! childreen particles
	- jmohep(2,k) =d_h_jmohep(2,k) ! parent particles
	- jdahep(2,k) =d_h_jdahep(2,k) ! childreen particles
	- DO l=1,4
	- phep(l,k) =d_h_phep(l,k) ! four-momentum, mass [GeV]
	- vhep(l,k) =d_h_vhep(l,k) ! vertex [mm]
	- ENDDO
	- phep(5,k) =d_h_phep(5,k) ! four-momentum, mass [GeV]
	- qedrad(k) =d_h_qedrad(k) ! Photos special flag
	- ENDDO
	- END
	-
	-
	- SUBROUTINE PHOTOS_SET
	-C.----------------------------------------------------------------------
	-C.
	-C. Setter for PHOTOS:
	-C.
	-C. Purpose: Copies /PH_HEPEVT/ into /HEPEVT/
	-C.
	-C.
	-C. Input Parameters: None
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): Z. Was Created at: 21/07/98
	-C. Last Update: 21/07/98
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER d_h_nmxhep ! maximum number of particles
	- PARAMETER (d_h_NMXHEP=4000)
	- double precision d_h_phep, d_h_vhep
	- INTEGER d_h_nevhep,d_h_nhep,d_h_isthep,d_h_idhep,d_h_jmohep,
	- $ d_h_jdahep
	- COMMON /hepevt/
	- $ d_h_nevhep, ! serial number
	- $ d_h_nhep, ! number of particles
	- $ d_h_isthep(d_h_nmxhep), ! status code
	- $ d_h_idhep(d_h_nmxhep), ! particle ident KF
	- $ d_h_jmohep(2,d_h_nmxhep), ! parent particles
	- $ d_h_jdahep(2,d_h_nmxhep), ! childreen particles
	- $ d_h_phep(5,d_h_nmxhep), ! four-momentum, mass [GeV]
	- $ d_h_vhep(4,d_h_nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL d_h_qedrad
	- COMMON /phoqed/
	- $ d_h_qedrad(d_h_nmxhep) ! Photos flag
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- LOGICAL QEDRAD
	- COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	- INTEGER K,L
	-
	- d_h_nevhep= nevhep ! serial number
	- d_h_nhep = nhep ! number of particles
	- DO K=1,nhep
	- d_h_isthep(k) =isthep(k) ! status code
	- d_h_idhep(k) =idhep(k) ! particle ident KF
	- d_h_jmohep(1,k) =jmohep(1,k) ! parent particles
	- d_h_jdahep(1,k) =jdahep(1,k) ! childreen particles
	- d_h_jmohep(2,k) =jmohep(2,k) ! parent particles
	- d_h_jdahep(2,k) =jdahep(2,k) ! childreen particles
	- DO l=1,4
	- d_h_phep(l,k) =phep(l,k) ! four-momentum, mass [GeV]
	- d_h_vhep(l,k) =vhep(l,k) ! vertex [mm]
	- ENDDO
	- d_h_phep(5,k) =phep(5,k) ! four-momentum, mass [GeV]
	- d_h_qedrad(k) =qedrad(k) ! Photos special flag
	- ENDDO
	- END
	- SUBROUTINE PHOTOS_MAKE(IPARR)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS_MAKE: General search routine
	-C.
	-C. Purpose: Search through the /PH_HEPEVT/ standard HEP common, sta-
	-C. rting from the IPPAR-th particle. Whenevr branching
	-C. point is found routine PHTYPE(IP) is called.
	-C. Finally if calls on PHTYPE(IP) modified entries, common
	-C /PH_HEPEVT/ is ordered.
	-C.
	-C. Input Parameter: IPPAR: Pointer to decaying particle in
	-C. /PH_HEPEVT/ and the common itself,
	-C.
	-C. Output Parameters: Common /PH_HEPEVT/, either with or without
	-C. new particles added.
	-C.
	-C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	-C. Last Update: 30/08/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- double precision PHOTON(5)
	- INTEGER IP,IPARR,IPPAR,I,J,K,L,NLAST
	- DOUBLE PRECISION DATA
	- INTEGER MOTHER,POSPHO
	- LOGICAL CASCAD
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- LOGICAL QEDRAD
	- COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER ISTACK(0:NMXPHO),NUMIT,NTRY,KK,LL,II,NA,FIRST,LAST
	- INTEGER FIRSTA,LASTA,IPP,IDA1,IDA2,MOTHER2,IDPHO,ISPHO
	- double precision PORIG(5,NMXPHO)
	-C--
	- IPPAR=ABS(IPARR)
	-C-- Store pointers for cascade treatement...
	- IP=IPPAR
	- NLAST=NHEP
	- CASCAD=.FALSE.
	-C--
	-C-- Check decay multiplicity and minimum of correctness..
	- IF ((JDAHEP(1,IP).EQ.0).OR.(JMOHEP(1,JDAHEP(1,IP)).NE.IP)) RETURN
	-C--
	-C-- single branch mode
	-C-- we start looking for the decay points in the cascade
	-C-- IPPAR is original position where the program was called
	- ISTACK(0)=IPPAR
	-C-- NUMIT denotes number of secondary decay branches
	- NUMIT=0
	-C-- NTRY denotes number of secondary branches already checked for
	-C-- for existence of further branches
	- NTRY=0
	-C-- let-s search if IPARR does not prevent searching.
	- IF (IPARR.GT.0) THEN
	- 30 CONTINUE
	- DO I=JDAHEP(1,IP),JDAHEP(2,IP)
	- IF (JDAHEP(1,I).NE.0.AND.JMOHEP(1,JDAHEP(1,I)).EQ.I) THEN
	- NUMIT=NUMIT+1
	- IF (NUMIT.GT.NMXPHO) THEN
	- DATA=NUMIT
	- CALL PHOERR(7,'PHOTOS',DATA)
	- ENDIF
	- ISTACK(NUMIT)=I
	- ENDIF
	- ENDDO
	- IF(NUMIT.GT.NTRY) THEN
	- NTRY=NTRY+1
	- IP=ISTACK(NTRY)
	- GOTO 30
	- ENDIF
	- ENDIF
	-C-- let-s do generation
	- DO 25 KK=0,NUMIT
	- NA=NHEP
	- FIRST=JDAHEP(1,ISTACK(KK))
	- LAST=JDAHEP(2,ISTACK(KK))
	- DO II=1,LAST-FIRST+1
	- DO LL=1,5
	- PORIG(LL,II)=PHEP(LL,FIRST+II-1)
	- ENDDO
	- ENDDO
	-C--
	- CALL PHTYPE(ISTACK(KK))
	-C--
	-C-- Correct energy/momentum of cascade daughters
	- IF(NHEP.GT.NA) THEN
	- DO II=1,LAST-FIRST+1
	- IPP=FIRST+II-1
	- FIRSTA=JDAHEP(1,IPP)
	- LASTA=JDAHEP(2,IPP)
	- IF(JMOHEP(1,IPP).EQ.ISTACK(KK))
	- $ CALL PHOBOS(IPP,PORIG(1,II),PHEP(1,IPP),FIRSTA,LASTA)
	- ENDDO
	- ENDIF
	- 25 CONTINUE
	-C--
	-C-- rearrange /PH_HEPEVT/ to get correct order..
	- IF (NHEP.GT.NLAST) THEN
	- DO 160 I=NLAST+1,NHEP
	-C--
	-C-- Photon mother and position...
	- MOTHER=JMOHEP(1,I)
	- POSPHO=JDAHEP(2,MOTHER)+1
	-C-- Intermediate save of photon energy/momentum and pointers
	- DO 90 J=1,5
	- 90 PHOTON(J)=PHEP(J,I)
	- ISPHO =ISTHEP(I)
	- IDPHO =IDHEP(I)
	- MOTHER2 =JMOHEP(2,I)
	- IDA1 =JDAHEP(1,I)
	- IDA2 =JDAHEP(2,I)
	-C--
	-C-- Exclude photon in sequence !
	- IF (POSPHO.NE.NHEP) THEN
	-C--
	-C--
	-C-- Order /PH_HEPEVT/
	- DO 120 K=I,POSPHO+1,-1
	- ISTHEP(K)=ISTHEP(K-1)
	- QEDRAD(K)=QEDRAD(K-1)
	- IDHEP(K)=IDHEP(K-1)
	- DO 100 L=1,2
	- JMOHEP(L,K)=JMOHEP(L,K-1)
	- 100 JDAHEP(L,K)=JDAHEP(L,K-1)
	- DO 110 L=1,5
	- 110 PHEP(L,K)=PHEP(L,K-1)
	- DO 120 L=1,4
	- 120 VHEP(L,K)=VHEP(L,K-1)
	-C--
	-C-- Correct pointers assuming most dirty /PH_HEPEVT/...
	- DO 130 K=1,NHEP
	- DO 130 L=1,2
	- IF ((JMOHEP(L,K).NE.0).AND.(JMOHEP(L,K).GE.
	- & POSPHO)) JMOHEP(L,K)=JMOHEP(L,K)+1
	- IF ((JDAHEP(L,K).NE.0).AND.(JDAHEP(L,K).GE.
	- & POSPHO)) JDAHEP(L,K)=JDAHEP(L,K)+1
	- 130 CONTINUE
	-C--
	-C-- Store photon energy/momentum
	- DO 140 J=1,5
	- 140 PHEP(J,POSPHO)=PHOTON(J)
	- ENDIF
	-C--
	-C-- Store pointers for the photon...
	- JDAHEP(2,MOTHER)=POSPHO
	- ISTHEP(POSPHO)=ISPHO
	- IDHEP(POSPHO)=IDPHO
	- JMOHEP(1,POSPHO)=MOTHER
	- JMOHEP(2,POSPHO)=MOTHER2
	- JDAHEP(1,POSPHO)=IDA1
	- JDAHEP(2,POSPHO)=IDA2
	-C--
	-C-- Get photon production vertex position
	- DO 150 J=1,4
	- 150 VHEP(J,POSPHO)=VHEP(J,POSPHO-1)
	- 160 CONTINUE
	- ENDIF
	- RETURN
	- END
	- SUBROUTINE PHOBOS(IP,PBOOS1,PBOOS2,FIRST,LAST)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOBOS: PHOton radiation in decays BOoSt routine
	-C.
	-C. Purpose: Boost particles in cascade decay to parent rest frame
	-C. and boost back with modified boost vector.
	-C.
	-C. Input Parameters: IP: pointer of particle starting chain
	-C. to be boosted
	-C. PBOOS1: Boost vector to rest frame,
	-C. PBOOS2: Boost vector to modified frame,
	-C. FIRST: Pointer to first particle to be boos-
	-C. ted (/PH_HEPEVT/),
	-C. LAST: Pointer to last particle to be boos-
	-C. ted (/PH_HEPEVT/).
	-C.
	-C. Output Parameters: Common /PH_HEPEVT/.
	-C.
	-C. Author(s): B. van Eijk Created at: 13/02/90
	-C. Z. Was Last Update: 16/11/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION BET1(3),BET2(3),GAM1,GAM2,PB,DATA
	- INTEGER I,J,FIRST,LAST,MAXSTA,NSTACK,IP
	- PARAMETER (MAXSTA=10000)
	- INTEGER STACK(MAXSTA)
	- double precision PBOOS1(5),PBOOS2(5)
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- IF ((LAST.EQ.0).OR.(LAST.LT.FIRST)) RETURN
	- NSTACK=0
	- DO 10 J=1,3
	- BET1(J)=-PBOOS1(J)/PBOOS1(5)
	- 10 BET2(J)=PBOOS2(J)/PBOOS2(5)
	- GAM1=PBOOS1(4)/PBOOS1(5)
	- GAM2=PBOOS2(4)/PBOOS2(5)
	-C--
	-C-- Boost vector to parent rest frame...
	- 20 DO 50 I=FIRST,LAST
	- PB=BET1(1)PHEP(1,I)+BET1(2)PHEP(2,I)+BET1(3)*PHEP(3,I)
	- IF (JMOHEP(1,I).EQ.IP) THEN
	- DO 30 J=1,3
	- 30 PHEP(J,I)=PHEP(J,I)+BET1(J)*(PHEP(4,I)+PB/(GAM1+1.D0))
	- PHEP(4,I)=GAM1*PHEP(4,I)+PB
	-C--
	-C-- ...and boost back to modified parent frame.
	- PB=BET2(1)PHEP(1,I)+BET2(2)PHEP(2,I)+BET2(3)*PHEP(3,I)
	- DO 40 J=1,3
	- 40 PHEP(J,I)=PHEP(J,I)+BET2(J)*(PHEP(4,I)+PB/(GAM2+1.D0))
	- PHEP(4,I)=GAM2*PHEP(4,I)+PB
	- IF (JDAHEP(1,I).NE.0) THEN
	- NSTACK=NSTACK+1
	-C--
	-C-- Check on stack length...
	- IF (NSTACK.GT.MAXSTA) THEN
	- DATA=NSTACK
	- CALL PHOERR(7,'PHOBOS',DATA)
	- ENDIF
	- STACK(NSTACK)=I
	- ENDIF
	- ENDIF
	- 50 CONTINUE
	- IF (NSTACK.NE.0) THEN
	-C--
	-C-- Now go one step further in the decay tree...
	- FIRST=JDAHEP(1,STACK(NSTACK))
	- LAST=JDAHEP(2,STACK(NSTACK))
	- IP=STACK(NSTACK)
	- NSTACK=NSTACK-1
	- GOTO 20
	- ENDIF
	- RETURN
	- END
	- SUBROUTINE PHOIN(IP,BOOST,NHEP0)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOIN: PHOtos INput
	-C.
	-C. Purpose: copies IP branch of the common /PH_HEPEVT/ into /PHOEVT/
	-C. moves branch into its CMS system.
	-C.
	-C. Input Parameters: IP: pointer of particle starting branch
	-C. to be copied
	-C. BOOST: Flag whether boost to CMS was or was
	-C . not performed.
	-C.
	-C. Output Parameters: Commons: /PHOEVT/, /PHOCMS/
	-C.
	-C. Author(s): Z. Was Created at: 24/05/93
	-C. Last Update: 16/11/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- INTEGER IP,IP2,I,FIRST,LAST,LL,NA
	- LOGICAL BOOST
	- INTEGER J,NHEP0
	- DOUBLE PRECISION BET(3),GAM,PB
	- COMMON /PHOCMS/ BET,GAM
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	-C--
	-C let-s calculate size of the little common entry
	- FIRST=JDAHEP(1,IP)
	- LAST =JDAHEP(2,IP)
	- NPHO=3+LAST-FIRST+NHEP-NHEP0
	- NEVPHO=NPHO
	-C let-s take in decaying particle
	- IDPHO(1)=IDHEP(IP)
	- JDAPHO(1,1)=3
	- JDAPHO(2,1)=3+LAST-FIRST
	- DO I=1,5
	- PPHO(I,1)=PHEP(I,IP)
	- ENDDO
	-C let-s take in eventual second mother
	- IP2=JMOHEP(2,JDAHEP(1,IP))
	- IF((IP2.NE.0).AND.(IP2.NE.IP)) THEN
	- IDPHO(2)=IDHEP(IP2)
	- JDAPHO(1,2)=3
	- JDAPHO(2,2)=3+LAST-FIRST
	- DO I=1,5
	- PPHO(I,2)=PHEP(I,IP2)
	- ENDDO
	- ELSE
	- IDPHO(2)=0
	- DO I=1,5
	- PPHO(I,2)=0.0D0
	- ENDDO
	- ENDIF
	-C let-s take in daughters
	- DO LL=0,LAST-FIRST
	- IDPHO(3+LL)=IDHEP(FIRST+LL)
	- JMOPHO(1,3+LL)=JMOHEP(1,FIRST+LL)
	- IF (JMOHEP(1,FIRST+LL).EQ.IP) JMOPHO(1,3+LL)=1
	- DO I=1,5
	- PPHO(I,3+LL)=PHEP(I,FIRST+LL)
	- ENDDO
	- ENDDO
	- IF (NHEP.GT.NHEP0) THEN
	-C let-s take in illegitimate daughters
	- NA=3+LAST-FIRST
	- DO LL=1,NHEP-NHEP0
	- IDPHO(NA+LL)=IDHEP(NHEP0+LL)
	- JMOPHO(1,NA+LL)=JMOHEP(1,NHEP0+LL)
	- IF (JMOHEP(1,NHEP0+LL).EQ.IP) JMOPHO(1,NA+LL)=1
	- DO I=1,5
	- PPHO(I,NA+LL)=PHEP(I,NHEP0+LL)
	- ENDDO
	- ENDDO
	-C-- there is NHEP-NHEP0 daugters more.
	- JDAPHO(2,1)=3+LAST-FIRST+NHEP-NHEP0
	- ENDIF
	- IF(IDPHO(NPHO).EQ.22)CALL PHLUPA(100001)
	-! IF(IDPHO(NPHO).EQ.22) stop
	- CALL PHCORK(0)
	- IF(IDPHO(NPHO).EQ.22)CALL PHLUPA(100002)
	-C special case of t tbar production process
	- IF(IFTOP) CALL PHOTWO(0)
	- BOOST=.FALSE.
	-C-- Check whether parent is in its rest frame...
	- IF ( (ABS(PPHO(4,1)-PPHO(5,1)).GT.PPHO(5,1)*1.D-8)
	- $ .AND.(PPHO(5,1).NE.0)) THEN
	- BOOST=.TRUE.
	-C--
	-C-- Boost daughter particles to rest frame of parent...
	-C-- Resultant neutral system already calculated in rest frame !
	- DO 10 J=1,3
	- 10 BET(J)=-PPHO(J,1)/PPHO(5,1)
	- GAM=PPHO(4,1)/PPHO(5,1)
	- DO 30 I=JDAPHO(1,1),JDAPHO(2,1)
	- PB=BET(1)PPHO(1,I)+BET(2)PPHO(2,I)+BET(3)*PPHO(3,I)
	- DO 20 J=1,3
	- 20 PPHO(J,I)=PPHO(J,I)+BET(J)*(PPHO(4,I)+PB/(GAM+1.D0))
	- 30 PPHO(4,I)=GAM*PPHO(4,I)+PB
	-C-- Finally boost mother as well
	- I=1
	- PB=BET(1)PPHO(1,I)+BET(2)PPHO(2,I)+BET(3)*PPHO(3,I)
	- DO J=1,3
	- PPHO(J,I)=PPHO(J,I)+BET(J)*(PPHO(4,I)+PB/(GAM+1.D0))
	- ENDDO
	- PPHO(4,I)=GAM*PPHO(4,I)+PB
	- ENDIF
	-C special case of t tbar production process
	- IF(IFTOP) CALL PHOTWO(1)
	- CALL PHLUPA(2)
	- IF(IDPHO(NPHO).EQ.22) CALL PHLUPA(10000)
	-! IF(IDPHO(NPHO-1).EQ.22) stop
	- END
	- SUBROUTINE PHOTWO(MODE)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTWO: PHOtos but TWO mothers allowed
	-C.
	-C. Purpose: Combines two mothers into one in /PHOEVT/
	-C. necessary eg in case of g g (q qbar) --> t tbar
	-C.
	-C. Input Parameters: Common /PHOEVT/ (/PHOCMS/)
	-C.
	-C. Output Parameters: Common /PHOEVT/, (stored mothers)
	-C.
	-C. Author(s): Z. Was Created at: 5/08/93
	-C. Last Update:10/08/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- DOUBLE PRECISION BET(3),GAM
	- COMMON /PHOCMS/ BET,GAM
	- INTEGER I,MODE
	- double precision MPASQR
	- LOGICAL IFRAD
	-C logical IFRAD is used to tag cases when two mothers may be
	-C merged to the sole one.
	-C So far used in case:
	-C 1) of t tbar production
	-C
	-C t tbar case
	- IF(MODE.EQ.0) THEN
	- IFRAD=(IDPHO(1).EQ.21).AND.(IDPHO(2).EQ.21)
	- IFRAD=IFRAD.OR.(IDPHO(1).EQ.-IDPHO(2).AND.ABS(IDPHO(1)).LE.6)
	- IFRAD=IFRAD
	- & .AND.(ABS(IDPHO(3)).EQ.6).AND.(ABS(IDPHO(4)).EQ.6)
	- MPASQR= (PPHO(4,1)+PPHO(4,2))2-(PPHO(3,1)+PPHO(3,2))2
	- & -(PPHO(2,1)+PPHO(2,2))2-(PPHO(1,1)+PPHO(1,2))2
	- IFRAD=IFRAD.AND.(MPASQR.GT.0.0D0)
	- IF(IFRAD) THEN
	-c.....combining first and second mother
	- DO I=1,4
	- PPHO(I,1)=PPHO(I,1)+PPHO(I,2)
	- ENDDO
	- PPHO(5,1)=SQRT(MPASQR)
	-c.....removing second mother,
	- DO I=1,5
	- PPHO(I,2)=0.0D0
	- ENDDO
	- ENDIF
	- ELSE
	-C boosting of the mothers to the reaction frame not implemented yet.
	-C to do it in mode 0 original mothers have to be stored in new comon (?)
	-C and in mode 1 boosted to cms.
	- ENDIF
	- END
	- SUBROUTINE PHOOUT(IP,BOOST,NHEP0)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOOUT: PHOtos OUTput
	-C.
	-C. Purpose: copies back IP branch of the common /PH_HEPEVT/ from
	-C. /PHOEVT/ moves branch back from its CMS system.
	-C.
	-C. Input Parameters: IP: pointer of particle starting branch
	-C. to be given back.
	-C. BOOST: Flag whether boost to CMS was or was
	-C . not performed.
	-C.
	-C. Output Parameters: Common /PHOEVT/,
	-C.
	-C. Author(s): Z. Was Created at: 24/05/93
	-C. Last Update:
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- INTEGER IP,LL,FIRST,LAST,I
	- LOGICAL BOOST
	- INTEGER NN,J,K,NHEP0,NA
	- DOUBLE PRECISION BET(3),GAM,PB
	- COMMON /PHOCMS/ BET,GAM
	- IF(NPHO.EQ.NEVPHO) RETURN
	-C-- When parent was not in its rest-frame, boost back...
	- CALL PHLUPA(10)
	- IF (BOOST) THEN
	- DO 110 J=JDAPHO(1,1),JDAPHO(2,1)
	- PB=-BET(1)PPHO(1,J)-BET(2)PPHO(2,J)-BET(3)*PPHO(3,J)
	- DO 100 K=1,3
	- 100 PPHO(K,J)=PPHO(K,J)-BET(K)*(PPHO(4,J)+PB/(GAM+1.D0))
	- 110 PPHO(4,J)=GAM*PPHO(4,J)+PB
	-C-- ...boost photon, or whatever else has shown up
	- DO NN=NEVPHO+1,NPHO
	- PB=-BET(1)PPHO(1,NN)-BET(2)PPHO(2,NN)-BET(3)*PPHO(3,NN)
	- DO 120 K=1,3
	- 120 PPHO(K,NN)=PPHO(K,NN)-BET(K)*(PPHO(4,NN)+PB/(GAM+1.D0))
	- PPHO(4,NN)=GAM*PPHO(4,NN)+PB
	- ENDDO
	- ENDIF
	- FIRST=JDAHEP(1,IP)
	- LAST =JDAHEP(2,IP)
	-C let-s take in original daughters
	- DO LL=0,LAST-FIRST
	- IDHEP(FIRST+LL) = IDPHO(3+LL)
	- DO I=1,5
	- PHEP(I,FIRST+LL) = PPHO(I,3+LL)
	- ENDDO
	- ENDDO
	-C let-s take newcomers to the end of HEPEVT.
	- NA=3+LAST-FIRST
	- DO LL=1,NPHO-NA
	- IDHEP(NHEP0+LL) = IDPHO(NA+LL)
	- ISTHEP(NHEP0+LL)=ISTPHO(NA+LL)
	- JMOHEP(1,NHEP0+LL)=IP
	- JMOHEP(2,NHEP0+LL)=JMOHEP(2,JDAHEP(1,IP))
	- JDAHEP(1,NHEP0+LL)=0
	- JDAHEP(2,NHEP0+LL)=0
	- DO I=1,5
	- PHEP(I,NHEP0+LL) = PPHO(I,NA+LL)
	- ENDDO
	- ENDDO
	- NHEP=NHEP+NPHO-NEVPHO
	- CALL PHLUPA(20)
	- END
	- SUBROUTINE PHOCHK(JFIRST)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOCHK: checking branch.
	-C.
	-C. Purpose: checks whether particles in the common block /PHOEVT/
	-C. can be served by PHOMAK.
	-C. JFIRST is the position in /PH_HEPEVT/ (!) of the first
	-C. daughter of sub-branch under action.
	-C.
	-C.
	-C. Author(s): Z. Was Created at: 22/10/92
	-C. Last Update: 11/12/00
	-C.
	-C.----------------------------------------------------------------------
	-C ********************
	- IMPLICIT NONE
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- LOGICAL CHKIF
	- COMMON/PHOIF/CHKIF(NMXPHO)
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- LOGICAL QEDRAD
	- COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	- INTEGER JFIRST
	- LOGICAL F
	- INTEGER IDABS,NLAST,I,IPPAR
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW,IFNPI0,IFKL
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- LOGICAL IFRAD
	- INTEGER IDENT,K,IQRK,IPHQRK,IEKL,IPHEKL
	-C these are OK .... if you do not like somebody else, add here.
	- F(IDABS)=
	- & ( ((IDABS.GT.9.OR.IQRK.NE.1).AND.(IDABS.LE.40))
	- & .OR.(IDABS.GT.100) )
	- & .AND.(IDABS.NE.21)
	- $ .AND.(IDABS.NE.2101).AND.(IDABS.NE.3101).AND.(IDABS.NE.3201)
	- & .AND.(IDABS.NE.1103).AND.(IDABS.NE.2103).AND.(IDABS.NE.2203)
	- & .AND.(IDABS.NE.3103).AND.(IDABS.NE.3203).AND.(IDABS.NE.3303)
	-C
	- IQRK=IPHQRK(0) ! switch for emission from quark
	- IEKL=IPHEKL(0)
	- NLAST = NPHO
	-C
	- IPPAR=1
	-C checking for good particles
	- IFNPI0=.TRUE.
	- IF (IEKL.GT.1) THEN ! exclude radiative corr in decay of pi0
	-C ! and Kl --> ee gamma
	- IFNPI0= (IDPHO(1).NE.111) ! pi0
	- IFKL = ((IDPHO(1).EQ.130).AND. ! Kl --> ee gamma
	- $ ((IDPHO(3).EQ.22).OR.(IDPHO(4).EQ.22).OR.
	- $ (IDPHO(5).EQ.22)).AND.
	- $ ((IDPHO(3).EQ.11).OR.(IDPHO(4).EQ.11).OR.
	- $ (IDPHO(5).EQ.11)) )
	-
	- IFNPI0=(IFNPI0.AND.(.NOT.IFKL))
	- ENDIF
	- DO 10 I=IPPAR,NLAST
	- IDABS = ABS(IDPHO(I))
	-C possibly call on PHZODE is a dead (to be omitted) code.
	- CHKIF(I)= F(IDABS) .AND.F(ABS(IDPHO(1)))
	- & .AND. (IDPHO(2).EQ.0)
	- IF(I.GT.2) CHKIF(I)=CHKIF(I).AND.QEDRAD(JFIRST+I-IPPAR-2)
	- & .AND.IFNPI0
	- 10 CONTINUE
	-C--
	-C now we go to special cases, where CHKIF(I) will be overwritten
	-C--
	- IF(IFTOP) THEN
	-C special case of top pair production
	- DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	- IF(IDPHO(K).NE.22) THEN
	- IDENT=K
	- GOTO 15
	- ENDIF
	- ENDDO
	- 15 CONTINUE
	- IFRAD=((IDPHO(1).EQ.21).AND.(IDPHO(2).EQ.21))
	- & .OR. ((ABS(IDPHO(1)).LE.6).AND.((IDPHO(2)).EQ.(-IDPHO(1))))
	- IFRAD=IFRAD
	- & .AND.(ABS(IDPHO(3)).EQ.6).AND.((IDPHO(4)).EQ.(-IDPHO(3)))
	- & .AND.(IDENT.EQ.4)
	- IF(IFRAD) THEN
	- DO 20 I=IPPAR,NLAST
	- CHKIF(I)= .TRUE.
	- IF(I.GT.2) CHKIF(I)=CHKIF(I).AND.QEDRAD(JFIRST+I-IPPAR-2)
	- 20 CONTINUE
	- ENDIF
	- ENDIF
	-C--
	-C--
	- IF(IFTOP) THEN
	-C special case of top decay
	- DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	- IF(IDPHO(K).NE.22) THEN
	- IDENT=K
	- GOTO 25
	- ENDIF
	- ENDDO
	- 25 CONTINUE
	- IFRAD=((ABS(IDPHO(1)).EQ.6).AND.(IDPHO(2).EQ.0))
	- IFRAD=IFRAD
	- & .AND.((ABS(IDPHO(3)).EQ.24).AND.(ABS(IDPHO(4)).EQ.5)
	- & .OR.(ABS(IDPHO(3)).EQ.5).AND.(ABS(IDPHO(4)).EQ.24))
	- & .AND.(IDENT.EQ.4)
	- IF(IFRAD) THEN
	- DO 30 I=IPPAR,NLAST
	- CHKIF(I)= .TRUE.
	- IF(I.GT.2) CHKIF(I)=CHKIF(I).AND.QEDRAD(JFIRST+I-IPPAR-2)
	- 30 CONTINUE
	- ENDIF
	- ENDIF
	-C--
	-C--
	- END
	- SUBROUTINE PHTYPE(ID)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHTYPE: Central manadgement routine.
	-C.
	-C. Purpose: defines what kind of the
	-C. actions will be performed at point ID.
	-C.
	-C. Input Parameters: ID: pointer of particle starting branch
	-C. in /PH_HEPEVT/ to be treated.
	-C.
	-C. Output Parameters: Common /PH_HEPEVT/.
	-C.
	-C. Author(s): Z. Was Created at: 24/05/93
	-C. P. Golonka Last Update: 27/06/04
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- LOGICAL EXPINI
	- INTEGER NX,K,NCHAN
	- PARAMETER (NX=10)
	- double precision PRO,PRSUM,ESU
	- COMMON /PHOEXP/ PRO(NX),NCHAN,EXPINI
	-
	- INTEGER ID,NHEP0
	- LOGICAL IPAIR
	- double precision RN,PHORAN,SUM
	- INTEGER WTDUM
	- LOGICAL IFOUR
	-C--
	- IFOUR=(.TRUE.).AND.(ITRE) ! we can make internal choice whether
	- ! we want 3 or four photons at most.
	- IPAIR=.TRUE.
	-C-- Check decay multiplicity..
	- IF (JDAHEP(1,ID).EQ.0) RETURN
	-C IF (JDAHEP(1,ID).EQ.JDAHEP(2,ID)) RETURN
	-C--
	- NHEP0=NHEP
	-C--
	- IF (IEXP) THEN
	- EXPINI=.TRUE. ! Initialization/cleaning
	- DO NCHAN=1,NX
	- PRO(NCHAN)=0.D0
	- ENDDO
	- NCHAN=0
	-
	- FSEC=1.0D0
	- CALL PHOMAK(ID,NHEP0)! Initialization/crude formfactors into
	- ! PRO(NCHAN)
	- EXPINI=.FALSE.
	- RN=PHORAN(WTDUM)
	- PRSUM=0
	- DO K=1,NX
	- PRSUM=PRSUM+PRO(K)
	- ENDDO
	- ESU=EXP(-PRSUM) ! exponent for crude Poissonian multiplicity
	- ! distribution, will be later overwritten
	- ! to give probability for k
	- SUM=ESU ! distribuant for the crude Poissonian
	- ! at first for k=0
	- DO K=1,100 ! hard coded max (photon) multiplicity is 100
	- IF(RN.LT.SUM) GOTO 100
	- ESU=ESUPRSUM/K ! we get at K ESU=EXP(-PRSUM)PRSUM**K/K!
	- SUM=SUM+ESU ! thus we get distribuant at K.
	- NCHAN=0
	- CALL PHOMAK(ID,NHEP0) ! LOOPING
	- IF(SUM.GT.1D0-EXPEPS) GOTO 100
	- ENDDO
	- 100 CONTINUE
	- ELSEIF(IFOUR) THEN
	-C-- quatro photon emission
	- FSEC=1.0D0
	- RN=PHORAN(WTDUM)
	- IF (RN.GE.23.D0/24D0) THEN
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- ELSEIF (RN.GE.17.D0/24D0) THEN
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- ELSEIF (RN.GE.9.D0/24D0) THEN
	- CALL PHOMAK(ID,NHEP0)
	- ENDIF
	- ELSEIF(ITRE) THEN
	-C-- triple photon emission
	- FSEC=1.0D0
	- RN=PHORAN(WTDUM)
	- IF (RN.GE.5.D0/6D0) THEN
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- ELSEIF (RN.GE.2.D0/6D0) THEN
	- CALL PHOMAK(ID,NHEP0)
	- ENDIF
	- ELSEIF(ISEC) THEN
	-C-- double photon emission
	- FSEC=1.0D0
	- RN=PHORAN(WTDUM)
	- IF (RN.GE.0.5D0) THEN
	- CALL PHOMAK(ID,NHEP0)
	- CALL PHOMAK(ID,NHEP0)
	- ENDIF
	- ELSE
	-C-- single photon emission
	- FSEC=1.0D0
	- CALL PHOMAK(ID,NHEP0)
	- ENDIF
	-C--
	-C-- electron positron pair (coomented out for a while
	-C IF (IPAIR) CALL PHOPAR(ID,NHEP0)
	- END
	- SUBROUTINE PHOMAK(IPPAR,NHEP0)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOMAK: PHOtos MAKe
	-C.
	-C. Purpose: Single or double bremstrahlung radiative corrections
	-C. are generated in the decay of the IPPAR-th particle in
	-C. the HEP common /PH_HEPEVT/. Example of the use of
	-C. general tools.
	-C.
	-C. Input Parameter: IPPAR: Pointer to decaying particle in
	-C. /PH_HEPEVT/ and the common itself
	-C.
	-C. Output Parameters: Common /PH_HEPEVT/, either with or without
	-C. particles added.
	-C.
	-C. Author(s): Z. Was, Created at: 26/05/93
	-C. Last Update: 29/01/05
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION DATA
	- double precision PHORAN
	- INTEGER IP,IPPAR,NCHARG
	- INTEGER WTDUM,IDUM,NHEP0
	- INTEGER NCHARB,NEUDAU
	- double precision RN,WT,PHINT
	- LOGICAL BOOST
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=10000)
	- INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	- double precision PHEP,VHEP
	- COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	-C--
	- IP=IPPAR
	- IDUM=1
	- NCHARG=0
	-C--
	- CALL PHOIN(IP,BOOST,NHEP0)
	- CALL PHOCHK(JDAHEP(1,IP))
	- WT=0.0D0
	- CALL PHOPRE(1,WT,NEUDAU,NCHARB)
	-
	- IF (WT.EQ.0.0D0) RETURN
	- RN=PHORAN(WTDUM)
	-C PHODO is caling PHORAN, thus change of series if it is moved before if
	- CALL PHODO(1,NCHARB,NEUDAU)
	-C we eliminate /FINT in variant B.
	- IF (INTERF) WT=WT*PHINT(IDUM) /FINT ! FINT must be in variant A
	- IF (IFW) CALL PHOBW(WT) ! extra weight for leptonic W decay
	- DATA=WT
	- IF (WT.GT.1.0D0) CALL PHOERR(3,'WT_INT',DATA)
	-C weighting
	- IF (RN.LE.WT) THEN
	- CALL PHOOUT(IP,BOOST,NHEP0)
	- ENDIF
	- RETURN
	- END
	- FUNCTION PHINT1(IDUM)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHINT: PHotos INTerference (Old version kept for tests only.
	-C.
	-C. Purpose: Calculates interference between emission of photons from
	-C. different possible chaged daughters stored in
	-C. the HEP common /PHOEVT/.
	-C.
	-C. Input Parameter: commons /PHOEVT/ /PHOMOM/ /PHOPHS/
	-C.
	-C.
	-C. Output Parameters:
	-C.
	-C.
	-C. Author(s): Z. Was, Created at: 10/08/93
	-C. Last Update: 15/03/99
	-C.
	-C.----------------------------------------------------------------------
	-
	- IMPLICIT NONE
	- double precision PHINT,phint1
	- double precision PHOCHA
	- INTEGER IDUM
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- DOUBLE PRECISION MCHSQR,MNESQR
	- double precision PNEUTR
	- COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	- DOUBLE PRECISION COSTHG,SINTHG
	- double precision XPHMAX,XPHOTO
	- COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	- double precision MPASQR,XX,BETA
	- LOGICAL IFINT
	- INTEGER K,IDENT
	-C
	- DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	- IF(IDPHO(K).NE.22) THEN
	- IDENT=K
	- GOTO 20
	- ENDIF
	- ENDDO
	- 20 CONTINUE
	-C check if there is a photon
	- IFINT= NPHO.GT.IDENT
	-C check if it is two body + gammas reaction
	- IFINT= IFINT.AND.(IDENT-JDAPHO(1,1)).EQ.1
	-C check if two body was particle antiparticle
	- IFINT= IFINT.AND.IDPHO(JDAPHO(1,1)).EQ.-IDPHO(IDENT)
	-C check if particles were charged
	- IFINT= IFINT.AND.PHOCHA(IDPHO(IDENT)).NE.0
	-C calculates interference weight contribution
	- IF(IFINT) THEN
	- MPASQR = PPHO(5,1)**2
	- XX=4.D0MCHSQR/MPASQR(1.D0-XPHOTO)/(1.D0-XPHOTO+(MCHSQR-MNESQR)
	- & /MPASQR)**2
	- BETA=SQRT(1.D0-XX)
	- PHINT = 2D0/(1D0+COSTHG*2BETA**2)
	- ELSE
	- PHINT = 1D0
	- ENDIF
	- phint1=1
	- END
	-
	- FUNCTION PHINT2(IDUM)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHINT: PHotos INTerference
	-C.
	-C. Purpose: Calculates interference between emission of photons from
	-C. different possible chaged daughters stored in
	-C. the HEP common /PHOEVT/.
	-C.
	-C. Input Parameter: commons /PHOEVT/ /PHOMOM/ /PHOPHS/
	-C.
	-C.
	-C. Output Parameters:
	-C.
	-C.
	-C. Author(s): Z. Was, Created at: 10/08/93
	-C. Last Update:
	-C.
	-C.----------------------------------------------------------------------
	-
	- IMPLICIT NONE
	- double precision PHINT,PHINT1,PHINT2
	- double precision PHOCHA
	- INTEGER IDUM
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- DOUBLE PRECISION MCHSQR,MNESQR
	- double precision PNEUTR
	- COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	- DOUBLE PRECISION COSTHG,SINTHG
	- double precision XPHMAX,XPHOTO
	- COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	- double precision MPASQR,XX,BETA,PQ1(4),PQ2(4),PPHOT(4)
	- double precision SS,PP2,PP,E1,E2,Q1,Q2,COSTHE
	- LOGICAL IFINT
	- INTEGER K,IDENT
	-C
	- DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	- IF(IDPHO(K).NE.22) THEN
	- IDENT=K
	- GOTO 20
	- ENDIF
	- ENDDO
	- 20 CONTINUE
	-C check if there is a photon
	- IFINT= NPHO.GT.IDENT
	-C check if it is two body + gammas reaction
	- IFINT= IFINT.AND.(IDENT-JDAPHO(1,1)).EQ.1
	-C check if two body was particle antiparticle (we improve on it !
	-C IFINT= IFINT.AND.IDPHO(JDAPHO(1,1)).EQ.-IDPHO(IDENT)
	-C check if particles were charged
	- IFINT= IFINT.AND.abs(PHOCHA(IDPHO(IDENT))).GT.0.01D0
	-C check if they have both charge
	- IFINT= IFINT.AND.
	- $ abs(PHOCHA(IDPHO(JDAPHO(1,1)))).gt.0.01D0
	-C calculates interference weight contribution
	- IF(IFINT) THEN
	- MPASQR = PPHO(5,1)**2
	- XX=4.D0MCHSQR/MPASQR(1.-XPHOTO)/(1.-XPHOTO+(MCHSQR-MNESQR)/
	- & MPASQR)**2
	- BETA=SQRT(1.D0-XX)
	- PHINT = 2D0/(1D0+COSTHG*2BETA**2)
	- SS =MPASQR*(1.D0-XPHOTO)
	- PP2=((SS-MCHSQR-MNESQR)*2-4MCHSQR*MNESQR)/SS/4
	- PP =SQRT(PP2)
	- E1 =SQRT(PP2+MCHSQR)
	- E2 =SQRT(PP2+MNESQR)
	- PHINT= (E1+E2)*2/((E2+COSTHGPP)*2+(E1-COSTHGPP)**2)
	-C
	- q1=PHOCHA(IDPHO(JDAPHO(1,1)))
	- q2=PHOCHA(IDPHO(IDENT))
	- do k=1,4
	- pq1(k)=ppho(k,JDAPHO(1,1))
	- pq2(k)=ppho(k,JDAPHO(1,1)+1)
	- pphot(k)=ppho(k,npho)
	- enddo
	- costhe=(pphot(1)pq1(1)+pphot(2)pq1(2)+pphot(3)*pq1(3))
	- costhe=costhe/sqrt(pq1(1)2+pq1(2)2+pq1(3)**2)
	- costhe=costhe/sqrt(pphot(1)2+pphot(2)2+pphot(3)**2)
	-C
	-! --- this IF checks whether JDAPHO(1,1) was MCH or MNE.
	-! --- COSTHG angle (and in-generation variables) may be better choice
	-! --- than costhe. note that in the formulae below amplitudes were
	-! --- multiplied by (E2+COSTHGPP)(E1-COSTHG*PP).
	- IF (costhg*costhe.GT.0) then
	-
	- PHINT= (q1(E2+COSTHGPP)-q2(E1-COSTHGPP))**2
	- & /(q1*2(E2+COSTHGPP)2+q22(E1-COSTHGPP)*2)
	- ELSE
	-
	- PHINT= (q1(E1-COSTHGPP)-q2(E2+COSTHGPP))**2
	- & /(q1*2(E1-COSTHGPP)2+q22(E2+COSTHGPP)*2)
	- ENDIF
	- ELSE
	- PHINT = 1D0
	- ENDIF
	- phint1=1
	- phint2=1
	- END
	-
	-
	- SUBROUTINE PHOPRE(IPARR,WT,NEUDAU,NCHARB)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: Photon radiation in decays
	-C.
	-C. Purpose: Order (alpha) radiative corrections are generated in
	-C. the decay of the IPPAR-th particle in the HEP-like
	-C. common /PHOEVT/. Photon radiation takes place from one
	-C. of the charged daughters of the decaying particle IPPAR
	-C. WT is calculated, eventual rejection will be performed
	-C. later after inclusion of interference weight.
	-C.
	-C. Input Parameter: IPPAR: Pointer to decaying particle in
	-C. /PHOEVT/ and the common itself,
	-C.
	-C. Output Parameters: Common /PHOEVT/, either with or without a
	-C. photon(s) added.
	-C. WT weight of the configuration
	-C.
	-C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	-C. Last Update: 29/01/05
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION MINMAS,MPASQR,MCHREN
	- DOUBLE PRECISION BETA,EPS,DEL1,DEL2,DATA,BIGLOG
	- double precision PHOCHA,PHOSPI,PHORAN,PHOCOR,MASSUM
	- INTEGER IP,IPARR,IPPAR,I,J,ME,NCHARG,NEUPOI,NLAST,THEDUM
	- INTEGER IDABS,IDUM
	- INTEGER NCHARB,NEUDAU
	- double precision WT,WGT
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- LOGICAL CHKIF
	- COMMON/PHOIF/CHKIF(NMXPHO)
	- INTEGER CHAPOI(NMXPHO)
	- DOUBLE PRECISION MCHSQR,MNESQR
	- double precision PNEUTR
	- COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	- DOUBLE PRECISION COSTHG,SINTHG
	- double precision XPHMAX,XPHOTO
	- COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	- double precision ALPHA,XPHCUT
	- COMMON/PHOCOP/ALPHA,XPHCUT
	- INTEGER IREP
	- double precision PROBH,CORWT,XF
	- COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	-C may be it is not the best place, but ...
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	-
	-C--
	- IPPAR=IPARR
	-C-- Store pointers for cascade treatement...
	- IP=IPPAR
	- NLAST=NPHO
	- IDUM=1
	-C--
	-C-- Check decay multiplicity..
	- IF (JDAPHO(1,IP).EQ.0) RETURN
	-C--
	-C-- Loop over daughters, determine charge multiplicity
	- 10 NCHARG=0
	- IREP=0
	- MINMAS=0.D0
	- MASSUM=0.D0
	- DO 20 I=JDAPHO(1,IP),JDAPHO(2,IP)
	-C--
	-C--
	-C-- Exclude marked particles, quarks and gluons etc...
	- IDABS=ABS(IDPHO(I))
	- IF (CHKIF(I-JDAPHO(1,IP)+3)) THEN
	- IF (PHOCHA(IDPHO(I)).NE.0) THEN
	- NCHARG=NCHARG+1
	- IF (NCHARG.GT.NMXPHO) THEN
	- DATA=NCHARG
	- CALL PHOERR(1,'PHOTOS',DATA)
	- ENDIF
	- CHAPOI(NCHARG)=I
	- ENDIF
	- MINMAS=MINMAS+PPHO(5,I)**2
	- ENDIF
	- MASSUM=MASSUM+PPHO(5,I)
	- 20 CONTINUE
	- IF (NCHARG.NE.0) THEN
	-C--
	-C-- Check that sum of daughter masses does not exceed parent mass
	- IF ((PPHO(5,IP)-MASSUM)/PPHO(5,IP).GT.2.D0*XPHCUT) THEN
	-C--
	-C-- Order charged particles according to decreasing mass, this to
	-C-- increase efficiency (smallest mass is treated first).
	- IF (NCHARG.GT.1) CALL PHOOMA(1,NCHARG,CHAPOI)
	-C--
	- 30 CONTINUE
	- DO 70 J=1,3
	- 70 PNEUTR(J)=-PPHO(J,CHAPOI(NCHARG))
	- PNEUTR(4)=PPHO(5,IP)-PPHO(4,CHAPOI(NCHARG))
	-C--
	-C-- Calculate invariant mass of 'neutral' etc. systems
	- MPASQR=PPHO(5,IP)**2
	- MCHSQR=PPHO(5,CHAPOI(NCHARG))**2
	- IF ((JDAPHO(2,IP)-JDAPHO(1,IP)).EQ.1) THEN
	- NEUPOI=JDAPHO(1,IP)
	- IF (NEUPOI.EQ.CHAPOI(NCHARG)) NEUPOI=JDAPHO(2,IP)
	- MNESQR=PPHO(5,NEUPOI)**2
	- PNEUTR(5)=PPHO(5,NEUPOI)
	- ELSE
	- MNESQR=PNEUTR(4)2-PNEUTR(1)2-PNEUTR(2)2-PNEUTR(3)2
	- MNESQR=MAX(MNESQR,MINMAS-MCHSQR)
	- PNEUTR(5)=SQRT(MNESQR)
	- ENDIF
	-C--
	-C-- Determine kinematical limit...
	- XPHMAX=(MPASQR-(PNEUTR(5)+PPHO(5,CHAPOI(NCHARG)))**2)/MPASQR
	-C--
	-C-- Photon energy fraction...
	- CALL PHOENE(MPASQR,MCHREN,BETA,BIGLOG,IDPHO(CHAPOI(NCHARG)))
	-C--
	- IF (XPHOTO.LT.-4D0) THEN
	- NCHARG=0 ! we really stop trials
	- XPHOTO=0d0! in this case !!
	-C-- Energy fraction not too large (very seldom) ? Define angle.
	- ELSEIF ((XPHOTO.LT.XPHCUT).OR.(XPHOTO.GT.XPHMAX)) THEN
	-C--
	-C-- No radiation was accepted, check for more daughters that may ra-
	-C-- diate and correct radiation probability...
	- NCHARG=NCHARG-1
	- IF (NCHARG.GT.0) THEN
	- IREP=IREP+1
	- GOTO 30
	- ENDIF
	- ELSE
	-C--
	-C-- Angle is generated in the frame defined by charged vector and
	-C-- PNEUTR, distribution is taken in the infrared limit...
	- EPS=MCHREN/(1.D0+BETA)
	-C--
	-C-- Calculate sin(theta) and cos(theta) from interval variables
	- DEL1=(2.D0-EPS)(EPS/(2.D0-EPS))*PHORAN(THEDUM)
	- DEL2=2.D0-DEL1
	-
	-C ----------- VARIANT B ------------------
	-CC corrections for more efiicient interference correction,
	-CC instead of doubling crude distribution, we add flat parallel channel
	-C IF (PHORAN(THEDUM).LT.BIGLOG/BETA/(BIGLOG/BETA+2*FINT)) THEN
	-C COSTHG=(1.D0-DEL1)/BETA
	-C SINTHG=SQRT(DEL1*DEL2-MCHREN)/BETA
	-C ELSE
	-C COSTHG=-1D0+2*PHORAN(THEDUM)
	-C SINTHG= SQRT(1D0-COSTHG**2)
	-C ENDIF
	-C
	-C IF (FINT.GT.1.0D0) THEN
	-C
	-C WGT=1D0/(1D0-BETA*COSTHG)
	-C WGT=WGT/(WGT+FINT)
	-C ! WGT=1D0 ! ??
	-C
	-C ELSE
	-C WGT=1D0
	-C ENDIF
	-C
	-C ----------- END OF VARIANT B ------------------
	-
	-C ----------- VARIANT A ------------------
	- COSTHG=(1.D0-DEL1)/BETA
	- SINTHG=SQRT(DEL1*DEL2-MCHREN)/BETA
	- WGT=1D0
	-C ----------- END OF VARIANT A ------------------
	-
	-C--
	-C-- Determine spin of particle and construct code for matrix element
	- ME=2.D0*PHOSPI(IDPHO(CHAPOI(NCHARG)))+1.D0
	-C--
	-C-- Weighting procedure with 'exact' matrix element, reconstruct kine-
	-C-- matics for photon, neutral and charged system and update /PHOEVT/.
	-C-- Find pointer to the first component of 'neutral' system
	- DO I=JDAPHO(1,IP),JDAPHO(2,IP)
	- IF (I.NE.CHAPOI(NCHARG)) THEN
	- NEUDAU=I
	- GOTO 51
	- ENDIF
	- ENDDO
	-C--
	-C-- Pointer not found...
	- DATA=NCHARG
	- CALL PHOERR(5,'PHOKIN',DATA)
	- 51 CONTINUE
	- NCHARB=CHAPOI(NCHARG)
	- NCHARB=NCHARB-JDAPHO(1,IP)+3
	- NEUDAU=NEUDAU-JDAPHO(1,IP)+3
	- WT=PHOCOR(MPASQR,MCHREN,ME)*WGT
	- ENDIF
	- ELSE
	- DATA=PPHO(5,IP)-MASSUM
	- CALL PHOERR(10,'PHOTOS',DATA)
	- ENDIF
	- ENDIF
	-C--
	- RETURN
	- END
	- SUBROUTINE PHOOMA(IFIRST,ILAST,POINTR)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays Order MAss vector
	-C.
	-C. Purpose: Order the contents of array 'POINTR' according to the
	-C. decreasing value in the array 'MASS'.
	-C.
	-C. Input Parameters: IFIRST, ILAST: Pointers to the vector loca-
	-C. tion be sorted,
	-C. POINTR: Unsorted array with pointers to
	-C. /PHOEVT/.
	-C.
	-C. Output Parameter: POINTR: Sorted arrays with respect to
	-C. particle mass 'PPHO(5,*)'.
	-C.
	-C. Author(s): B. van Eijk Created at: 28/11/89
	-C. Last Update: 27/05/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- INTEGER IFIRST,ILAST,I,J,BUFPOI,POINTR(NMXPHO)
	- double precision BUFMAS,MASS(NMXPHO)
	- IF (IFIRST.EQ.ILAST) RETURN
	-C--
	-C-- Copy particle masses
	- DO 10 I=IFIRST,ILAST
	- 10 MASS(I)=PPHO(5,POINTR(I))
	-C--
	-C-- Order the masses in a decreasing series
	- DO 30 I=IFIRST,ILAST-1
	- DO 20 J=I+1,ILAST
	- IF (MASS(J).LE.MASS(I)) GOTO 20
	- BUFPOI=POINTR(J)
	- POINTR(J)=POINTR(I)
	- POINTR(I)=BUFPOI
	- BUFMAS=MASS(J)
	- MASS(J)=MASS(I)
	- MASS(I)=BUFMAS
	- 20 CONTINUE
	- 30 CONTINUE
	- RETURN
	- END
	- SUBROUTINE PHOENE(MPASQR,MCHREN,BETA,BIGLOG,IDENT)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays calculation of photon ENErgy
	-C. fraction
	-C.
	-C. Purpose: Subroutine returns photon energy fraction (in (parent
	-C. mass)/2 units) for the decay bremsstrahlung.
	-C.
	-C. Input Parameters: MPASQR: Mass of decaying system squared,
	-C. XPHCUT: Minimum energy fraction of photon,
	-C. XPHMAX: Maximum energy fraction of photon.
	-C.
	-C. Output Parameter: MCHREN: Renormalised mass squared,
	-C. BETA: Beta factor due to renormalisation,
	-C. XPHOTO: Photon energy fraction,
	-C. XF: Correction factor for PHOFAC.
	-C.
	-C. Author(s): S. Jadach, Z. Was Created at: 01/01/89
	-C. B. van Eijk, P.Golonka Last Update: 29/01/05
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION MPASQR,MCHREN,BIGLOG,BETA,DATA
	- INTEGER IWT1,IRN,IWT2
	- double precision PRSOFT,PRHARD,PHORAN,PHOFAC
	- DOUBLE PRECISION MCHSQR,MNESQR
	- double precision PNEUTR
	- INTEGER IDENT
	- double precision PHOCHA,PRKILL,RRR
	- COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	- DOUBLE PRECISION COSTHG,SINTHG
	- double precision XPHMAX,XPHOTO
	- COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	- double precision ALPHA,XPHCUT
	- COMMON/PHOCOP/ALPHA,XPHCUT
	- double precision PI,TWOPI
	- COMMON/PHPICO/PI,TWOPI
	- INTEGER IREP
	- double precision PROBH,CORWT,XF
	- COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- INTEGER NX,NCHAN,K
	- PARAMETER (NX=10)
	- LOGICAL EXPINI
	- double precision PRO,PRSUM
	- COMMON /PHOEXP/ PRO(NX),NCHAN,EXPINI
	-C--
	- IF (XPHMAX.LE.XPHCUT) THEN
	- BETA=PHOFAC(-1) ! to zero counter, here beta is dummy
	- XPHOTO=0.0D0
	- RETURN
	- ENDIF
	-C-- Probabilities for hard and soft bremstrahlung...
	- MCHREN=4.D0MCHSQR/MPASQR/(1.D0+MCHSQR/MPASQR)*2
	- BETA=SQRT(1.D0-MCHREN)
	-
	-C ----------- VARIANT B ------------------
	-CC we replace 1D0/BETABIGLOG with (1D0/BETABIGLOG+2*FINT)
	-CC for integral of new crude
	-C BIGLOG=LOG(MPASQR/MCHSQR(1.D0+BETA)2/4.D0
	-C & (1.D0+MCHSQR/MPASQR)**2)
	-C PRHARD=ALPHA/PI(1D0/BETABIGLOG+2FINT)(LOG(XPHMAX/XPHCUT)
	-C &-.75D0+XPHCUT/XPHMAX-.25D0XPHCUT2/XPHMAX*2)
	-C PRHARD=PRHARDPHOCHA(IDENT)2FSEC
	-C ----------- END OF VARIANT B ------------------
	-
	-C ----------- VARIANT A ------------------
	- BIGLOG=LOG(MPASQR/MCHSQR(1.D0+BETA)2/4.D0
	- & (1.D0+MCHSQR/MPASQR)**2)
	- PRHARD=ALPHA/PI(1D0/BETABIGLOG)*
	- &(LOG(XPHMAX/XPHCUT)-.75D0+XPHCUT/XPHMAX-.25D0XPHCUT2/XPHMAX*2)
	- PRHARD=PRHARDPHOCHA(IDENT)2FSEC*FINT
	-C ----------- END OF VARIANT A ------------------
	- IF (IREP.EQ.0) PROBH=0.D0
	- PRKILL=0d0
	- IF (IEXP) THEN ! IEXP
	- NCHAN=NCHAN+1
	- IF (EXPINI) THEN ! EXPINI
	- PRO(NCHAN)=PRHARD+0.05*(1.0+FINT) ! we store hard photon emission prob
	- !for leg NCHAN
	- PRHARD=0D0 ! to kill emission at initialization call
	- PROBH=PRHARD
	- ELSE ! EXPINI
	- PRSUM=0
	- DO K=NCHAN,NX
	- PRSUM=PRSUM+PRO(K)
	- ENDDO
	- PRHARD=PRHARD/PRSUM ! note that PRHARD may be smaller than
	- !PRO(NCHAN) because it is calculated
	- ! for kinematical configuartion as is
	- ! (with effects of previous photons)
	- PRKILL=PRO(NCHAN)/PRSUM-PRHARD !
	-
	- ENDIF ! EXPINI
	- PRSOFT=1.D0-PRHARD
	- ELSE ! IEXP
	- PRHARD=PRHARD*PHOFAC(0) ! PHOFAC is used to control eikonal
	- ! formfactors for non exp version only
	- ! here PHOFAC(0)=1 at least now.
	- PROBH=PRHARD
	- ENDIF ! IEXP
	- PRSOFT=1.D0-PRHARD
	-C--
	-C-- Check on kinematical bounds
	- IF (IEXP) THEN
	- IF (PRSOFT.LT.-5.0D-8) THEN
	- DATA=PRSOFT
	- CALL PHOERR(2,'PHOENE',DATA)
	- ENDIF
	- ELSE
	- IF (PRSOFT.LT.0.1D0) THEN
	- DATA=PRSOFT
	- CALL PHOERR(2,'PHOENE',DATA)
	- ENDIF
	- ENDIF
	-
	- RRR=PHORAN(IWT1)
	- IF (RRR.LT.PRSOFT) THEN
	-C--
	-C-- No photon... (ie. photon too soft)
	- XPHOTO=0.D0
	- IF (RRR.LT.PRKILL) XPHOTO=-5d0 ! No photon...no further trials
	- ELSE
	-C--
	-C-- Hard photon... (ie. photon hard enough).
	-C-- Calculate Altarelli-Parisi Kernel
	- 10 XPHOTO=EXP(PHORAN(IRN)*LOG(XPHCUT/XPHMAX))
	- XPHOTO=XPHOTO*XPHMAX
	- IF (PHORAN(IWT2).GT.((1.D0+(1.D0-XPHOTO/XPHMAX)**2)/2.D0))
	- & GOTO 10
	- ENDIF
	-C--
	-C-- Calculate parameter for PHOFAC function
	- XF=4.D0MCHSQRMPASQR/(MPASQR+MCHSQR-MNESQR)**2
	- RETURN
	- END
	- FUNCTION PHOCOR(MPASQR,MCHREN,ME)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays CORrection weight from
	-C. matrix elements
	-C.
	-C. Purpose: Calculate photon angle. The reshaping functions will
	-C. have to depend on the spin S of the charged particle.
	-C. We define: ME = 2 * S + 1 !
	-C.
	-C. Input Parameters: MPASQR: Parent mass squared,
	-C. MCHREN: Renormalised mass of charged system,
	-C. ME: 2 * spin + 1 determines matrix element
	-C.
	-C. Output Parameter: Function value.
	-C.
	-C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	-C. Last Update: 21/03/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION MPASQR,MCHREN,BETA,XX,YY,DATA
	- INTEGER ME
	- double precision PHOCOR,PHOFAC,WT1,WT2,WT3
	- DOUBLE PRECISION MCHSQR,MNESQR
	- double precision PNEUTR
	- COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	- DOUBLE PRECISION COSTHG,SINTHG
	- double precision XPHMAX,XPHOTO
	- COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	- INTEGER IREP
	- double precision PROBH,CORWT,XF
	- COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	-C--
	-C-- Shaping (modified by ZW)...
	- XX=4.D0MCHSQR/MPASQR(1.D0-XPHOTO)/(1.D0-XPHOTO+(MCHSQR-MNESQR)/
	- &MPASQR)**2
	- IF (ME.EQ.1) THEN
	- YY=1.D0
	- WT3=(1.D0-XPHOTO/XPHMAX)/((1.D0+(1.D0-XPHOTO/XPHMAX)**2)/2.D0)
	- ELSEIF (ME.EQ.2) THEN
	- YY=0.5D0*(1.D0-XPHOTO/XPHMAX+1.D0/(1.D0-XPHOTO/XPHMAX))
	- WT3=1.D0
	- ELSEIF ((ME.EQ.3).OR.(ME.EQ.4).OR.(ME.EQ.5)) THEN
	- YY=1.D0
	- WT3=(1.D0+(1.D0-XPHOTO/XPHMAX)2-(XPHOTO/XPHMAX)3)/
	- & (1.D0+(1.D0-XPHOTO/XPHMAX)** 2)
	- ELSE
	- DATA=(ME-1.D0)/2.D0
	- CALL PHOERR(6,'PHOCOR',DATA)
	- YY=1.D0
	- WT3=1.D0
	- ENDIF
	- BETA=SQRT(1.D0-XX)
	- WT1=(1.D0-COSTHGSQRT(1.D0-MCHREN))/(1.D0-COSTHGBETA)
	- WT2=(1.D0-XX/YY/(1.D0-BETA*2COSTHG*2))(1.D0+COSTHG*BETA)/2.D0
	- WT2=WT2*PHOFAC(1)
	- PHOCOR=WT1WT2WT3
	- CORWT=PHOCOR
	- IF (PHOCOR.GT.1.D0) THEN
	- DATA=PHOCOR
	- CALL PHOERR(3,'PHOCOR',DATA)
	- ENDIF
	- RETURN
	- END
	- FUNCTION PHOFAC(MODE)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays control FACtor
	-C.
	-C. Purpose: This is the control function for the photon spectrum and
	-C. final weighting. It is called from PHOENE for genera-
	-C. ting the raw photon energy spectrum (MODE=0) and in PHO-
	-C. COR to scale the final weight (MODE=1). The factor con-
	-C. sists of 3 terms. Addition of the factor FF which mul-
	-C. tiplies PHOFAC for MODE=0 and divides PHOFAC for MODE=1,
	-C. does not affect the results for the MC generation. An
	-C. appropriate choice for FF can speed up the calculation.
	-C. Note that a too small value of FF may cause weight over-
	-C. flow in PHOCOR and will generate a warning, halting the
	-C. execution. PRX should be included for repeated calls
	-C. for the same event, allowing more particles to radiate
	-C. photons. At the first call IREP=0, for more than 1
	-C. charged decay products, IREP >= 1. Thus, PRSOFT (no
	-C. photon radiation probability in the previous calls)
	-C. appropriately scales the strength of the bremsstrahlung.
	-C.
	-C. Input Parameters: MODE, PROBH, XF
	-C.
	-C. Output Parameter: Function value
	-C.
	-C. Author(s): S. Jadach, Z. Was Created at: 01/01/89
	-C. B. van Eijk, P.Golonka Last Update: 26/06/04
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- double precision PHOFAC,FF,PRX
	- INTEGER MODE
	- INTEGER IREP
	- double precision PROBH,CORWT,XF
	- COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	- LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- double precision FINT,FSEC,EXPEPS
	- COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	- SAVE PRX,FF
	- DATA PRX,FF/ 0.D0, 0.D0/
	- IF (IEXP) THEN ! In case of exponentiation this routine is useles
	- PHOFAC=1
	- RETURN
	- ENDIF
	- IF (MODE.EQ.-1) THEN
	- PRX=1.D0
	- FF=1.D0
	- PROBH=0.0
	- ELSEIF (MODE.EQ.0) THEN
	- IF (IREP.EQ.0) PRX=1.D0
	- PRX=PRX/(1.D0-PROBH)
	- FF=1.D0
	-C--
	-C-- Following options are not considered for the time being...
	-C-- (1) Good choice, but does not save very much time:
	-C-- FF=(1.0D0-SQRT(XF)/2.0D0)/(1.0+SQRT(XF)/2.0D0)
	-C-- (2) Taken from the blue, but works without weight overflows...
	-C-- FF=(1.D0-XF/(1-(1-SQRT(XF))*2))(1+(1-SQRT(XF))/SQRT(1-XF))/2
	- PHOFAC=FF*PRX
	- ELSE
	- PHOFAC=1.D0/FF
	- ENDIF
	- END
	- SUBROUTINE PHOBW(WT)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOtos Boson W correction weight
	-C.
	-C. Purpose: calculates correction weight due to amplitudes of
	-C. emission from W boson.
	-C.
	-C.
	-C.
	-C.
	-C.
	-C. Input Parameters: Common /PHOEVT/, with photon added.
	-C. wt to be corrected
	-C.
	-C.
	-C.
	-C. Output Parameters: wt
	-C.
	-C. Author(s): G. Nanava, Z. Was Created at: 13/03/03
	-C. Last Update: 13/03/03
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION WT
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- INTEGER I
	- DOUBLE PRECISION EMU,MCHREN,BETA,COSTHG,MPASQR,XPH
	-C--
	- IF (ABS(IDPHO(1)).EQ.24.AND.
	- $ ABS(IDPHO(JDAPHO(1,1) )).GE.11.AND.
	- $ ABS(IDPHO(JDAPHO(1,1) )).LE.16.AND.
	- $ ABS(IDPHO(JDAPHO(1,1)+1)).GE.11.AND.
	- $ ABS(IDPHO(JDAPHO(1,1)+1)).LE.16 ) THEN
	-
	- IF(
	- $ ABS(IDPHO(JDAPHO(1,1) )).EQ.11.OR.
	- $ ABS(IDPHO(JDAPHO(1,1) )).EQ.13.OR.
	- $ ABS(IDPHO(JDAPHO(1,1) )).EQ.15 ) THEN
	- I=JDAPHO(1,1)
	- ELSE
	- I=JDAPHO(1,1)+1
	- ENDIF
	- EMU=PPHO(4,I)
	- MCHREN=ABS(PPHO(4,I)2-PPHO(3,I)2
	- $ -PPHO(2,I)2-PPHO(1,I)2)
	- BETA=SQRT(1- MCHREN/ PPHO(4,I)**2)
	- COSTHG=(PPHO(3,I)PPHO(3,NPHO)+PPHO(2,I)PPHO(2,NPHO)
	- $ +PPHO(1,I)*PPHO(1,NPHO))/
	- $ SQRT(PPHO(3,I)2+PPHO(2,I)2+PPHO(1,I)**2) /
	- $ SQRT(PPHO(3,NPHO)2+PPHO(2,NPHO)2+PPHO(1,NPHO)**2)
	- MPASQR=PPHO(4,1)**2
	- XPH=PPHO(4,NPHO)
	- WT=WT(1-8EMUXPH(1-COSTHGBETA)
	- $ (MCHREN+2XPHSQRT(MPASQR))/
	- $ MPASQR**2/(1-MCHREN/MPASQR)/(4-MCHREN/MPASQR))
	- ENDIF
	-c write(,) IDPHO(1),IDPHO(JDAPHO(1,1)),IDPHO(JDAPHO(1,1)+1)
	-c write(,) emu,xph,costhg,beta,mpasqr,mchren
	-
	- END
	- SUBROUTINE PHODO(IP,NCHARB,NEUDAU)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays DOing of KINematics
	-C.
	-C. Purpose: Starting from the charged particle energy/momentum,
	-C. PNEUTR, photon energy fraction and photon angle with
	-C. respect to the axis formed by charged particle energy/
	-C. momentum vector and PNEUTR, scale the energy/momentum,
	-C. keeping the original direction of the neutral system in
	-C. the lab. frame untouched.
	-C.
	-C. Input Parameters: IP: Pointer to decaying particle in
	-C. /PHOEVT/ and the common itself
	-C. NCHARB: pointer to the charged radiating
	-C. daughter in /PHOEVT/.
	-C. NEUDAU: pointer to the first neutral daughter
	-C. Output Parameters: Common /PHOEVT/, with photon added.
	-C.
	-C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	-C. Last Update: 27/05/93
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION PHOAN1,PHOAN2,ANGLE,FI1,FI3,FI4,FI5,TH1,TH3,TH4
	- DOUBLE PRECISION PARNE,QNEW,QOLD,DATA
	- INTEGER IP,FI3DUM,I,J,NEUDAU,FIRST,LAST
	- INTEGER NCHARB
	- double precision EPHOTO,PMAVIR,PHOTRI
	- double precision GNEUT,PHORAN,CCOSTH,SSINTH,PVEC(4)
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- DOUBLE PRECISION MCHSQR,MNESQR
	- double precision PNEUTR
	- COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	- DOUBLE PRECISION COSTHG,SINTHG
	- double precision XPHMAX,XPHOTO
	- COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	- double precision PI,TWOPI
	- COMMON/PHPICO/PI,TWOPI
	-C--
	- EPHOTO=XPHOTO*PPHO(5,IP)/2.D0
	- PMAVIR=SQRT(PPHO(5,IP)(PPHO(5,IP)-2.D0EPHOTO))
	-C--
	-C-- Reconstruct kinematics of charged particle and neutral system
	- FI1=PHOAN1(PNEUTR(1),PNEUTR(2))
	-C--
	-C-- Choose axis along z of PNEUTR, calculate angle between x and y
	-C-- components and z and x-y plane and perform Lorentz transform...
	- TH1=PHOAN2(PNEUTR(3),SQRT(PNEUTR(1)2+PNEUTR(2)2))
	- CALL PHORO3(-FI1,PNEUTR(1))
	- CALL PHORO2(-TH1,PNEUTR(1))
	-C--
	-C-- Take away photon energy from charged particle and PNEUTR ! Thus
	-C-- the onshell charged particle decays into virtual charged particle
	-C-- and photon. The virtual charged particle mass becomes:
	-C-- SQRT(PPHO(5,IP)(PPHO(5,IP)-2EPHOTO)). Construct new PNEUTR mo-
	-C-- mentum in the rest frame of the parent:
	-C-- 1) Scaling parameters...
	- QNEW=PHOTRI(PMAVIR,PNEUTR(5),PPHO(5,NCHARB))
	- QOLD=PNEUTR(3)
	- GNEUT=(QNEW2+QOLD2+MNESQR)/(QNEWQOLD+SQRT((QNEW2+MNESQR)
	- &(QOLD**2+MNESQR)))
	- IF (GNEUT.LT.1.D0) THEN
	- DATA=0.D0
	- CALL PHOERR(4,'PHOKIN',DATA)
	- ENDIF
	- PARNE=GNEUT-SQRT(MAX(GNEUT**2-1.0D0,0.D0))
	-C--
	-C-- 2) ...reductive boost...
	- CALL PHOBO3(PARNE,PNEUTR)
	-C--
	-C-- ...calculate photon energy in the reduced system...
	- NPHO=NPHO+1
	- ISTPHO(NPHO)=1
	- IDPHO(NPHO) =22
	-C-- Photon mother and daughter pointers !
	- JMOPHO(1,NPHO)=IP
	- JMOPHO(2,NPHO)=0
	- JDAPHO(1,NPHO)=0
	- JDAPHO(2,NPHO)=0
	- PPHO(4,NPHO)=EPHOTO*PPHO(5,IP)/PMAVIR
	-C--
	-C-- ...and photon momenta
	- CCOSTH=-COSTHG
	- SSINTH=SINTHG
	- TH3=PHOAN2(CCOSTH,SSINTH)
	- FI3=TWOPI*PHORAN(FI3DUM)
	- PPHO(1,NPHO)=PPHO(4,NPHO)SINTHGCOS(FI3)
	- PPHO(2,NPHO)=PPHO(4,NPHO)SINTHGSIN(FI3)
	-C--
	-C-- Minus sign because axis opposite direction of charged particle !
	- PPHO(3,NPHO)=-PPHO(4,NPHO)*COSTHG
	- PPHO(5,NPHO)=0.D0
	-C--
	-C-- Rotate in order to get photon along z-axis
	- CALL PHORO3(-FI3,PNEUTR(1))
	- CALL PHORO3(-FI3,PPHO(1,NPHO))
	- CALL PHORO2(-TH3,PNEUTR(1))
	- CALL PHORO2(-TH3,PPHO(1,NPHO))
	- ANGLE=EPHOTO/PPHO(4,NPHO)
	-C--
	-C-- Boost to the rest frame of decaying particle
	- CALL PHOBO3(ANGLE,PNEUTR(1))
	- CALL PHOBO3(ANGLE,PPHO(1,NPHO))
	-C--
	-C-- Back in the parent rest frame but PNEUTR not yet oriented !
	- FI4=PHOAN1(PNEUTR(1),PNEUTR(2))
	- TH4=PHOAN2(PNEUTR(3),SQRT(PNEUTR(1)2+PNEUTR(2)2))
	- CALL PHORO3(FI4,PNEUTR(1))
	- CALL PHORO3(FI4,PPHO(1,NPHO))
	-C--
	- DO 60 I=2,4
	- 60 PVEC(I)=0.D0
	- PVEC(1)=1.D0
	- CALL PHORO3(-FI3,PVEC)
	- CALL PHORO2(-TH3,PVEC)
	- CALL PHOBO3(ANGLE,PVEC)
	- CALL PHORO3(FI4,PVEC)
	- CALL PHORO2(-TH4,PNEUTR)
	- CALL PHORO2(-TH4,PPHO(1,NPHO))
	- CALL PHORO2(-TH4,PVEC)
	- FI5=PHOAN1(PVEC(1),PVEC(2))
	-C--
	-C-- Charged particle restores original direction
	- CALL PHORO3(-FI5,PNEUTR)
	- CALL PHORO3(-FI5,PPHO(1,NPHO))
	- CALL PHORO2(TH1,PNEUTR(1))
	- CALL PHORO2(TH1,PPHO(1,NPHO))
	- CALL PHORO3(FI1,PNEUTR)
	- CALL PHORO3(FI1,PPHO(1,NPHO))
	-C-- See whether neutral system has multiplicity larger than 1...
	- IF ((JDAPHO(2,IP)-JDAPHO(1,IP)).GT.1) THEN
	-C-- Find pointers to components of 'neutral' system
	-C--
	- FIRST=NEUDAU
	- LAST=JDAPHO(2,IP)
	- DO 70 I=FIRST,LAST
	- IF (I.NE.NCHARB.AND.(JMOPHO(1,I).EQ.IP)) THEN
	-C--
	-C-- Reconstruct kinematics...
	- CALL PHORO3(-FI1,PPHO(1,I))
	- CALL PHORO2(-TH1,PPHO(1,I))
	-C--
	-C-- ...reductive boost
	- CALL PHOBO3(PARNE,PPHO(1,I))
	-C--
	-C-- Rotate in order to get photon along z-axis
	- CALL PHORO3(-FI3,PPHO(1,I))
	- CALL PHORO2(-TH3,PPHO(1,I))
	-C--
	-C-- Boost to the rest frame of decaying particle
	- CALL PHOBO3(ANGLE,PPHO(1,I))
	-C--
	-C-- Back in the parent rest-frame but PNEUTR not yet oriented.
	- CALL PHORO3(FI4,PPHO(1,I))
	- CALL PHORO2(-TH4,PPHO(1,I))
	-C--
	-C-- Charged particle restores original direction
	- CALL PHORO3(-FI5,PPHO(1,I))
	- CALL PHORO2(TH1,PPHO(1,I))
	- CALL PHORO3(FI1,PPHO(1,I))
	- ENDIF
	- 70 CONTINUE
	- ELSE
	-C--
	-C-- ...only one 'neutral' particle in addition to photon!
	- DO 80 J=1,4
	- 80 PPHO(J,NEUDAU)=PNEUTR(J)
	- ENDIF
	-C--
	-C-- All 'neutrals' treated, fill /PHOEVT/ for charged particle...
	- DO 90 J=1,3
	- 90 PPHO(J,NCHARB)=-(PPHO(J,NPHO)+PNEUTR(J))
	- PPHO(4,NCHARB)=PPHO(5,IP)-(PPHO(4,NPHO)+PNEUTR(4))
	-C--
	- END
	- FUNCTION PHOTRI(A,B,C)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays calculation of TRIangle fie
	-C.
	-C. Purpose: Calculation of triangle function for phase space.
	-C.
	-C. Input Parameters: A, B, C (Virtual) particle masses.
	-C.
	-C. Output Parameter: Function value =
	-C. SQRT(LAMBDA(A2,B2,C*2))/(2A)
	-C.
	-C. Author(s): B. van Eijk Created at: 15/11/89
	-C. Last Update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION DA,DB,DC,DAPB,DAMB,DTRIAN
	- double precision A,B,C,PHOTRI
	- DA=A
	- DB=B
	- DC=C
	- DAPB=DA+DB
	- DAMB=DA-DB
	- DTRIAN=SQRT((DAMB-DC)(DAPB+DC)(DAMB+DC)*(DAPB-DC))
	- PHOTRI=DTRIAN/(DA+DA)
	- RETURN
	- END
	- FUNCTION PHOAN1(X,Y)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays calculation of ANgle '1'
	-C.
	-C. Purpose: Calculate angle from X and Y
	-C.
	-C. Input Parameters: X, Y
	-C.
	-C. Output Parameter: Function value
	-C.
	-C. Author(s): S. Jadach Created at: 01/01/89
	-C. B. van Eijk Last Update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION PHOAN1
	- double precision X,Y
	- double precision PI,TWOPI
	- COMMON/PHPICO/PI,TWOPI
	- IF (ABS(Y).LT.ABS(X)) THEN
	- PHOAN1=ATAN(ABS(Y/X))
	- IF (X.LE.0.D0) PHOAN1=PI-PHOAN1
	- ELSE
	- PHOAN1=ACOS(X/SQRT(X2+Y2))
	- ENDIF
	- IF (Y.LT.0.D0) PHOAN1=TWOPI-PHOAN1
	- RETURN
	- END
	- FUNCTION PHOAN2(X,Y)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays calculation of ANgle '2'
	-C.
	-C. Purpose: Calculate angle from X and Y
	-C.
	-C. Input Parameters: X, Y
	-C.
	-C. Output Parameter: Function value
	-C.
	-C. Author(s): S. Jadach Created at: 01/01/89
	-C. B. van Eijk Last Update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION PHOAN2
	- double precision X,Y
	- double precision PI,TWOPI
	- COMMON/PHPICO/PI,TWOPI
	- IF (ABS(Y).LT.ABS(X)) THEN
	- PHOAN2=ATAN(ABS(Y/X))
	- IF (X.LE.0.D0) PHOAN2=PI-PHOAN2
	- ELSE
	- PHOAN2=ACOS(X/SQRT(X2+Y2))
	- ENDIF
	- RETURN
	- END
	- SUBROUTINE PHOBO3(ANGLE,PVEC)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays BOost routine '3'
	-C.
	-C. Purpose: Boost vector PVEC along z-axis where ANGLE = EXP(ETA),
	-C. ETA is the hyperbolic velocity.
	-C.
	-C. Input Parameters: ANGLE, PVEC
	-C.
	-C. Output Parameter: PVEC
	-C.
	-C. Author(s): S. Jadach Created at: 01/01/89
	-C. B. van Eijk Last Update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION QPL,QMI,ANGLE
	- double precision PVEC(4)
	- QPL=(PVEC(4)+PVEC(3))*ANGLE
	- QMI=(PVEC(4)-PVEC(3))/ANGLE
	- PVEC(3)=(QPL-QMI)/2.D0
	- PVEC(4)=(QPL+QMI)/2.D0
	- RETURN
	- END
	- SUBROUTINE PHORO2(ANGLE,PVEC)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays ROtation routine '2'
	-C.
	-C. Purpose: Rotate x and z components of vector PVEC around angle
	-C. 'ANGLE'.
	-C.
	-C. Input Parameters: ANGLE, PVEC
	-C.
	-C. Output Parameter: PVEC
	-C.
	-C. Author(s): S. Jadach Created at: 01/01/89
	-C. B. van Eijk Last Update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION CS,SN,ANGLE
	- double precision PVEC(4)
	- CS=COS(ANGLE)PVEC(1)+SIN(ANGLE)PVEC(3)
	- SN=-SIN(ANGLE)PVEC(1)+COS(ANGLE)PVEC(3)
	- PVEC(1)=CS
	- PVEC(3)=SN
	- RETURN
	- END
	- SUBROUTINE PHORO3(ANGLE,PVEC)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays ROtation routine '3'
	-C.
	-C. Purpose: Rotate x and y components of vector PVEC around angle
	-C. 'ANGLE'.
	-C.
	-C. Input Parameters: ANGLE, PVEC
	-C.
	-C. Output Parameter: PVEC
	-C.
	-C. Author(s): S. Jadach Created at: 01/01/89
	-C. B. van Eijk Last Update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION CS,SN,ANGLE
	- double precision PVEC(4)
	- CS=COS(ANGLE)PVEC(1)-SIN(ANGLE)PVEC(2)
	- SN=SIN(ANGLE)PVEC(1)+COS(ANGLE)PVEC(2)
	- PVEC(1)=CS
	- PVEC(2)=SN
	- RETURN
	- END
	- SUBROUTINE PHORIN
	- RETURN
	- END
	- FUNCTION PHORAN(IDUM)
	- IMPLICIT NONE
	- double precision PHORAN
	- INTEGER IDUM
	- double precision PYR
	- PHORAN=PYR(IDUM)
	- RETURN
	- END
	- FUNCTION PHOCHA(IDHEP)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays CHArge determination
	-C.
	-C. Purpose: Calculate the charge of particle with code IDHEP. The
	-C. code of the particle is defined by the Particle Data
	-C. Group in Phys. Lett. B204 (1988) 1.
	-C.
	-C. Input Parameter: IDHEP
	-C.
	-C. Output Parameter: Funtion value = charge of particle with code
	-C. IDHEP
	-C.
	-C. Author(s): E. Barberio and B. van Eijk Created at: 29/11/89
	-C. Last update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- double precision PHOCHA
	- INTEGER IDHEP,IDABS,Q1,Q2,Q3
	-C--
	-C-- Array 'CHARGE' contains the charge of the first 101 particles ac-
	-C-- cording to the PDG particle code... (0 is added for convenience)
	- double precision CHARGE(0:100)
	- DATA CHARGE/ 0.D0,
	- &-0.3333333333D0, 0.6666666667D0, -0.3333333333D0, 0.6666666667D0,
	- &-0.3333333333D0, 0.6666666667D0, -0.3333333333D0, 0.6666666667D0,
	- & 20.D0, -1.D0, 0.D0, -1.D0, 0.D0, -1.D0, 0.D0, -1.D0, 60.D0,
	- & 1.D0, 120.D0, 1.D0, 630.D0/
	- IDABS=ABS(IDHEP)
	- IF (IDABS.LE.100) THEN
	-C--
	-C-- Charge of quark, lepton, boson etc....
	- PHOCHA = CHARGE(IDABS)
	- ELSE
	-C--
	-C-- Check on particle build out of quarks, unpack its code...
	- Q3=MOD(IDABS/1000,10)
	- Q2=MOD(IDABS/100,10)
	- Q1=MOD(IDABS/10,10)
	- IF (Q3.EQ.0) THEN
	-C--
	-C-- ...meson...
	- IF(MOD(Q2,2).EQ.0) THEN
	- PHOCHA=CHARGE(Q2)-CHARGE(Q1)
	- ELSE
	- PHOCHA=CHARGE(Q1)-CHARGE(Q2)
	- ENDIF
	- ELSE
	-C--
	-C-- ...diquarks or baryon.
	- PHOCHA=CHARGE(Q1)+CHARGE(Q2)+CHARGE(Q3)
	- ENDIF
	- ENDIF
	-C--
	-C-- Find the sign of the charge...
	- IF (IDHEP.LT.0.D0) PHOCHA=-PHOCHA
	- IF (PHOCHA**2.lt.1d-6) PHOCHA=0.D0
	- RETURN
	- END
	- FUNCTION PHOSPI(IDHEP)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays function for SPIn determina-
	-C. tion
	-C.
	-C. Purpose: Calculate the spin of particle with code IDHEP. The
	-C. code of the particle is defined by the Particle Data
	-C. Group in Phys. Lett. B204 (1988) 1.
	-C.
	-C. Input Parameter: IDHEP
	-C.
	-C. Output Parameter: Funtion value = spin of particle with code
	-C. IDHEP
	-C.
	-C. Author(s): E. Barberio and B. van Eijk Created at: 29/11/89
	-C. Last update: 02/01/90
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- double precision PHOSPI
	- INTEGER IDHEP,IDABS
	-C--
	-C-- Array 'SPIN' contains the spin of the first 100 particles accor-
	-C-- ding to the PDG particle code...
	- double precision SPIN(100)
	- DATA SPIN/ 8.5D0, 1.D0, 0.D0, 8.5D0, 20.D0, 41.D0, 76*0.D0/
	- IDABS=ABS(IDHEP)
	-C--
	-C-- Spin of quark, lepton, boson etc....
	- IF (IDABS.LE.100) THEN
	- PHOSPI=SPIN(IDABS)
	- ELSE
	-C--
	-C-- ...other particles, however...
	- PHOSPI=(MOD(IDABS,10)-1.D0)/2.D0
	-C--
	-C-- ...K_short and K_long are special !!
	- PHOSPI=MAX(PHOSPI,0.D0)
	- ENDIF
	- RETURN
	- END
	- SUBROUTINE PHOERR(IMES,TEXT,DATA)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays ERRror handling
	-C.
	-C. Purpose: Inform user about (fatal) errors and warnings generated
	-C. by either the user or the program.
	-C.
	-C. Input Parameters: IMES, TEXT, DATA
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): B. van Eijk Created at: 29/11/89
	-C. Last Update: 10/01/92
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- DOUBLE PRECISION DATA
	- INTEGER IMES,IERROR
	- double precision SDATA
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	- INTEGER PHOMES
	- PARAMETER (PHOMES=10)
	- INTEGER STATUS
	- COMMON/PHOSTA/STATUS(PHOMES)
	- CHARACTER TEXT()
	- SAVE IERROR
	-C-- security STOP switch
	- LOGICAL ISEC
	- SAVE ISEC
	-C DATA ISEC /.TRUE./
	- DATA ISEC /.FALSE./
	- DATA IERROR/ 0/
	- IF (IMES.LE.PHOMES) STATUS(IMES)=STATUS(IMES)+1
	-C--
	-C-- Count number of non-fatal errors...
	- IF ((IMES.EQ. 6).AND.(STATUS(IMES).GE.2)) RETURN
	- IF ((IMES.EQ.10).AND.(STATUS(IMES).GE.2)) RETURN
	- SDATA=DATA
	- WRITE(PHLUN,9000)
	- WRITE(PHLUN,9120)
	- GOTO (10,20,30,40,50,60,70,80,90,100),IMES
	- WRITE(PHLUN,9130) IMES
	- GOTO 120
	- 10 WRITE(PHLUN,9010) TEXT,INT(SDATA)
	- GOTO 110
	- 20 WRITE(PHLUN,9020) TEXT,SDATA
	- GOTO 110
	- 30 WRITE(PHLUN,9030) TEXT,SDATA
	- GOTO 110
	- 40 WRITE(PHLUN,9040) TEXT
	- GOTO 110
	- 50 WRITE(PHLUN,9050) TEXT,INT(SDATA)
	- GOTO 110
	- 60 WRITE(PHLUN,9060) TEXT,SDATA
	- GOTO 130
	- 70 WRITE(PHLUN,9070) TEXT,INT(SDATA)
	- GOTO 110
	- 80 WRITE(PHLUN,9080) TEXT,INT(SDATA)
	- GOTO 110
	- 90 WRITE(PHLUN,9090) TEXT,INT(SDATA)
	- GOTO 110
	- 100 WRITE(PHLUN,9100) TEXT,SDATA
	- GOTO 130
	- 110 CONTINUE
	- WRITE(PHLUN,9140)
	- WRITE(PHLUN,9120)
	- WRITE(PHLUN,9000)
	- IF (ISEC) THEN
	- STOP
	- ELSE
	- GOTO 130
	- ENDIF
	- 120 IERROR=IERROR+1
	- IF (IERROR.GE.10) THEN
	- WRITE(PHLUN,9150)
	- WRITE(PHLUN,9120)
	- WRITE(PHLUN,9000)
	- IF (ISEC) THEN
	- STOP
	- ELSE
	- GOTO 130
	- ENDIF
	- ENDIF
	- 130 WRITE(PHLUN,9120)
	- WRITE(PHLUN,9000)
	- RETURN
	- 9000 FORMAT(1H ,80('*'))
	- 9010 FORMAT(1H ,'* ',A,': Too many charged Particles, NCHARG =',I6,T81,
	- &'*')
	- 9020 FORMAT(1H ,'* ',A,': Too much Bremsstrahlung required, PRSOFT = ',
	- &F15.6,T81,'*')
	- 9030 FORMAT(1H ,'* ',A,': Combined Weight is exceeding 1., Weight = ',
	- &F15.6,T81,'*')
	- 9040 FORMAT(1H ,'* ',A,
	- &': Error in Rescaling charged and neutral Vectors',T81,'*')
	- 9050 FORMAT(1H ,'* ',A,
	- &': Non matching charged Particle Pointer, NCHARG = ',I5,T81,'*')
	- 9060 FORMAT(1H ,'* ',A,
	- &': Do you really work with a Particle of Spin: ',F4.1,' ?',T81,
	- &'*')
	- 9070 FORMAT(1H ,'* ',A, ': Stack Length exceeded, NSTACK = ',I5 ,T81,
	- &'*')
	- 9080 FORMAT(1H ,'* ',A,
	- &': Random Number Generator Seed(1) out of Range: ',I8,T81,'*')
	- 9090 FORMAT(1H ,'* ',A,
	- &': Random Number Generator Seed(2) out of Range: ',I8,T81,'*')
	- 9100 FORMAT(1H ,'* ',A,
	- &': Available Phase Space below Cut-off: ',F15.6,' GeV/c^2',T81,
	- &'*')
	- 9120 FORMAT(1H ,'',T81,'')
	- 9130 FORMAT(1H ,'* Funny Error Message: ',I4,' ! What to do ?',T81,'*')
	- 9140 FORMAT(1H ,'* Fatal Error Message, I stop this Run !',T81,'*')
	- 9150 FORMAT(1H ,'* 10 Error Messages generated, I stop this Run !',T81,
	- &'*')
	- END
	- SUBROUTINE PHOREP
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays run summary REPort
	-C.
	-C. Purpose: Inform user about success and/or restrictions of PHOTOS
	-C. encountered during execution.
	-C.
	-C. Input Parameters: Common /PHOSTA/
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): B. van Eijk Created at: 10/01/92
	-C. Last Update: 10/01/92
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	- INTEGER PHOMES
	- PARAMETER (PHOMES=10)
	- INTEGER STATUS
	- COMMON/PHOSTA/STATUS(PHOMES)
	- INTEGER I
	- LOGICAL ERROR
	- ERROR=.FALSE.
	- WRITE(PHLUN,9000)
	- WRITE(PHLUN,9010)
	- WRITE(PHLUN,9020)
	- WRITE(PHLUN,9030)
	- WRITE(PHLUN,9040)
	- WRITE(PHLUN,9030)
	- WRITE(PHLUN,9020)
	- DO 10 I=1,PHOMES
	- IF (STATUS(I).EQ.0) GOTO 10
	- IF ((I.EQ.6).OR.(I.EQ.10)) THEN
	- WRITE(PHLUN,9050) I,STATUS(I)
	- ELSE
	- ERROR=.TRUE.
	- WRITE(PHLUN,9060) I,STATUS(I)
	- ENDIF
	- 10 CONTINUE
	- IF (.NOT.ERROR) WRITE(PHLUN,9070)
	- WRITE(PHLUN,9020)
	- WRITE(PHLUN,9010)
	- RETURN
	- 9000 FORMAT(1H1)
	- 9010 FORMAT(1H ,80('*'))
	- 9020 FORMAT(1H ,'',T81,'')
	- 9030 FORMAT(1H ,'',26X,25('='),T81,'')
	- 9040 FORMAT(1H ,'',30X,'PHOTOS Run Summary',T81,'')
	- 9050 FORMAT(1H ,'',22X,'Warning #',I2,' occured',I6,' times',T81,'')
	- 9060 FORMAT(1H ,'',23X,'Error #',I2,' occured',I6,' times',T81,'')
	- 9070 FORMAT(1H ,'*',16X,'PHOTOS Execution has successfully terminated',
	- &T81,'*')
	- END
	- SUBROUTINE PHLUPA(IPOINT)
	- IMPLICIT NONE
	-C.----------------------------------------------------------------------
	-C.
	-C. PHLUPA: debugging tool
	-C.
	-C. Purpose: NONE, eventually may printout content of the
	-C. /PHOEVT/ common
	-C.
	-C. Input Parameters: Common /PHOEVT/ and /PHNUM/
	-C. latter may have number of the event.
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): Z. Was Created at: 30/05/93
	-C. Last Update: 09/10/05
	-C.
	-C.----------------------------------------------------------------------
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO,I,J,IPOINT
	- INTEGER IPOIN,IPOIN0,IPOINM,IEV
	- INTEGER IOUT
	- double precision PPHO,VPHO,SUM
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- COMMON /PHNUM/ IEV
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	- DIMENSION SUM(5)
	- DATA IPOIN0/ -5/
	- COMMON /PHLUPY/ IPOIN,IPOINM
	- SAVE IPOIN0
	- IF (IPOIN0.LT.0) THEN
	- IPOIN0=300 000 ! maximal no-print point
	- IPOIN =IPOIN0
	- IPOINM=300 001 ! minimal no-print point
	- ENDIF
	- IF (IPOINT.LE.IPOINM.OR.IPOINT.GE.IPOIN ) RETURN
	- IOUT=56
	- IF (IEV.LT.1000) THEN
	- DO I=1,5
	- SUM(I)=0.0D0
	- ENDDO
	- WRITE(PHLUN,*) 'EVENT NR=',IEV,
	- $ 'WE ARE TESTING /PHOEVT/ at IPOINT=',IPOINT
	- WRITE(PHLUN,10)
	- I=1
	- WRITE(PHLUN,20) IDPHO(I),PPHO(1,I),PPHO(2,I),PPHO(3,I),
	- $ PPHO(4,I),PPHO(5,I),JDAPHO(1,I),JDAPHO(2,I)
	- I=2
	- WRITE(PHLUN,20) IDPHO(I),PPHO(1,I),PPHO(2,I),PPHO(3,I),
	- $ PPHO(4,I),PPHO(5,I),JDAPHO(1,I),JDAPHO(2,I)
	- WRITE(PHLUN,*) ' '
	- DO I=3,NPHO
	- WRITE(PHLUN,20) IDPHO(I),PPHO(1,I),PPHO(2,I),PPHO(3,I),
	- $ PPHO(4,I),PPHO(5,I),JMOPHO(1,I),JMOPHO(2,I)
	- DO J=1,4
	- SUM(J)=SUM(J)+PPHO(J,I)
	- ENDDO
	- ENDDO
	- SUM(5)=SQRT(ABS(SUM(4)2-SUM(1)2-SUM(2)2-SUM(3)2))
	- WRITE(PHLUN,30) SUM
	- 10 FORMAT(1X,' ID ','p_x ','p_y ','p_z ',
	- $ 'E ','m ',
	- $ 'ID-MO_DA1','ID-MO DA2' )
	- 20 FORMAT(1X,I4,5(F14.9),2I9)
	- 30 FORMAT(1X,' SUM',5(F14.9))
	- ENDIF
	- END
	-
	-
	-
	- FUNCTION IPHQRK(MODCOR)
	- implicit none
	-C.----------------------------------------------------------------------
	-C.
	-C. IPHQRK: enables blocks emision from quarks
	-C.
	-C
	-C. Input Parameters: MODCOR
	-C. MODCOR >0 type of action
	-C. =1 blocks
	-C. =2 enables
	-C. =0 execution mode (retrns stored value)
	-C.
	-C.
	-C. Author(s): Z. Was Created at: 11/12/00
	-C. Modified :
	-C.----------------------------------------------------------------------
	- INTEGER IPHQRK
	- INTEGER PHLUN,MODCOR,MODOP
	- COMMON/PHOLUN/PHLUN
	- DATA MODOP /0/
	- IF (MODCOR.NE.0) THEN
	-C INITIALIZATION
	- MODOP=MODCOR
	-
	- WRITE(PHLUN,*)
	- $ 'Message from PHOTOS: IPHQRK(MODCOR):: (re)initialization'
	- IF (MODOP.EQ.1) THEN
	- WRITE(PHLUN,*)
	- $ 'MODOP=1 -- blocks emission from light quarks: DEFAULT'
	- ELSEIF (MODOP.EQ.2) THEN
	- WRITE(PHLUN,*)
	- $ 'MODOP=2 -- enables emission from light quarks: TEST '
	- ELSE
	- WRITE(PHLUN,*) 'IPHQRK wrong MODCOR=',MODCOR
	- STOP
	- ENDIF
	- RETURN
	- ENDIF
	-
	- IF (MODOP.EQ.0.AND.MODCOR.EQ.0) THEN
	- WRITE(PHLUN,*) 'IPHQRK lack of initialization'
	- STOP
	- ENDIF
	- IPHQRK=MODOP
	- END
	-
	-
	- FUNCTION IPHEKL(MODCOR)
	- implicit none
	-C.----------------------------------------------------------------------
	-C.
	-C. IPHEKL: enables/blocks emision in: pi0 to gamma e+ e-
	-C.
	-C
	-C. Input Parameters: MODCOR
	-C. MODCOR >0 type of action
	-C. =1 blocks
	-C. =2 enables
	-C. =0 execution mode (retrns stored value)
	-C.
	-C.
	-C. Author(s): Z. Was Created at: 11/12/00
	-C. Modified :
	-C.----------------------------------------------------------------------
	- INTEGER IPHEKL,MODCOR,MODOP
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	-
	- SAVE MODOP
	- DATA MODOP /0/
	-
	- IF (MODCOR.NE.0) THEN
	-C INITIALIZATION
	- MODOP=MODCOR
	-
	- WRITE(PHLUN,*)
	- $ 'Message from PHOTOS: IPHEKL(MODCOR):: (re)initialization'
	- IF (MODOP.EQ.2) THEN
	- WRITE(PHLUN,*)
	- $ 'MODOP=2 -- blocks emission in pi0 to gamma e+e-: DEFAULT'
	- WRITE(PHLUN,*)
	- $ 'MODOP=2 -- blocks emission in Kl to gamma e+e-: DEFAULT'
	- ELSEIF (MODOP.EQ.1) THEN
	- WRITE(PHLUN,*)
	- $ 'MODOP=1 -- enables emission in pi0 to gamma e+e- : TEST '
	- WRITE(PHLUN,*)
	- $ 'MODOP=1 -- enables emission in Kl to gamma e+e- : TEST '
	- ELSE
	- WRITE(PHLUN,*) 'IPHEKL wrong MODCOR=',MODCOR
	- STOP
	- ENDIF
	- RETURN
	- ENDIF
	-
	- IF (MODOP.EQ.0.AND.MODCOR.EQ.0) THEN
	- WRITE(PHLUN,*) 'IPHELK lack of initialization'
	- STOP
	- ENDIF
	- IPHEKL=MODOP
	- END
	-
	- SUBROUTINE PHCORK(MODCOR)
	- implicit none
	-C.----------------------------------------------------------------------
	-C.
	-C. PHCORK: corrects kinmatics of subbranch needed if host program
	-C. produces events with the shaky momentum conservation
	-C
	-C. Input Parameters: Common /PHOEVT/, MODCOR
	-C. MODCOR >0 type of action
	-C. =1 no action
	-C. =2 corrects energy from mass
	-C. =3 corrects mass from energy
	-C. =4 corrects energy from mass for
	-C. particles up to .4 GeV mass,
	-C. for heavier ones corrects mass,
	-C. =5 most complete correct also of mother
	-C. often necessary for exponentiation.
	-C. =0 execution mode
	-C.
	-C. Output Parameters: corrected /PHOEVT/
	-C.
	-C. Author(s): P.Golonka, Z. Was Created at: 01/02/99
	-C. Modified : 08/02/99
	-C.----------------------------------------------------------------------
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	-
	- double precision M,P2,PX,PY,PZ,E,EN,MCUT,XMS
	- INTEGER MODCOR,MODOP,I,IEV,IPRINT,K
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	-
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	-
	- COMMON /PHNUM/ IEV
	- SAVE MODOP
	- DATA MODOP /0/
	- SAVE IPRINT
	- DATA IPRINT /0/
	- SAVE MCUT
	- IF (MODCOR.NE.0) THEN
	-C INITIALIZATION
	- MODOP=MODCOR
	-
	- WRITE(PHLUN,*) 'Message from PHCORK(MODCOR):: initialization'
	- IF (MODOP.EQ.1) THEN
	- WRITE(PHLUN,*) 'MODOP=1 -- no corrections on event: DEFAULT'
	- ELSEIF (MODOP.EQ.2) THEN
	- WRITE(PHLUN,*) 'MODOP=2 -- corrects Energy from mass'
	- ELSEIF (MODOP.EQ.3) THEN
	- WRITE(PHLUN,*) 'MODOP=3 -- corrects mass from Energy'
	- ELSEIF (MODOP.EQ.4) THEN
	- WRITE(PHLUN,*) 'MODOP=4 -- corrects Energy from mass to Mcut'
	- WRITE(PHLUN,*) ' and mass from energy above Mcut '
	- MCUT=0.4
	- WRITE(PHLUN,*) 'Mcut=',MCUT,'GeV'
	- ELSEIF (MODOP.EQ.5) THEN
	- WRITE(PHLUN,*) 'MODOP=5 -- corrects Energy from mass+flow'
	-
	- ELSE
	- WRITE(PHLUN,*) 'PHCORK wrong MODCOR=',MODCOR
	- STOP
	- ENDIF
	- RETURN
	- ENDIF
	-
	- IF (MODOP.EQ.0.AND.MODCOR.EQ.0) THEN
	- WRITE(PHLUN,*) 'PHCORK lack of initialization'
	- STOP
	- ENDIF
	-
	-C execution mode
	-C ==============
	-C ==============
	-
	-
	- PX=0
	- PY=0
	- PZ=0
	- E =0
	-
	- IF (MODOP.EQ.1) THEN
	-C -----------------------
	-C In this case we do nothing
	- RETURN
	- ELSEIF(MODOP.EQ.2) THEN
	-C -----------------------
	-CC lets loop thru all daughters and correct their energies
	-CC according to E^2=p^2+m^2
	-
	- DO I=3,NPHO
	-
	- PX=PX+PPHO(1,I)
	- PY=PY+PPHO(2,I)
	- PZ=PZ+PPHO(3,I)
	-
	- P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	-
	- EN=SQRT( PPHO(5,I)**2 + P2)
	-
	- IF (IPRINT.EQ.1)
	- & WRITE(PHLUN,*) "CORRECTING ENERGY OF ",I,":",
	- & PPHO(4,I),"=>",EN
	-
	- PPHO(4,I)=EN
	- E = E+PPHO(4,I)
	-
	- ENDDO
	-
	- ELSEIF(MODOP.EQ.5) THEN
	-C -----------------------
	-CC lets loop thru all daughters and correct their energies
	-CC according to E^2=p^2+m^2
	-
	- DO I=3,NPHO
	-
	- PX=PX+PPHO(1,I)
	- PY=PY+PPHO(2,I)
	- PZ=PZ+PPHO(3,I)
	-
	- P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	-
	- EN=SQRT( PPHO(5,I)**2 + P2)
	-
	- IF (IPRINT.EQ.1)
	- & WRITE(PHLUN,*) "CORRECTING ENERGY OF ",I,":",
	- & PPHO(4,I),"=>",EN
	-
	- PPHO(4,I)=EN
	- E = E+PPHO(4,I)
	-
	- ENDDO
	- DO K=1,4
	- PPHO(K,1)=0d0
	- DO I=3,NPHO
	- PPHO(K,1)=PPHO(K,1)+PPHO(K,I)
	- ENDDO
	- ENDDO
	- XMS=SQRT(PPHO(4,1)2-PPHO(3,1)2-PPHO(2,1)2-PPHO(1,1)2)
	- PPHO(5,1)=XMS
	- ELSEIF(MODOP.EQ.3) THEN
	-C -----------------------
	-
	-CC lets loop thru all daughters and correct their masses
	-CC according to E^2=p^2+m^2
	-
	- DO I=3,NPHO
	-
	- PX=PX+PPHO(1,I)
	- PY=PY+PPHO(2,I)
	- PZ=PZ+PPHO(3,I)
	- E = E+PPHO(4,I)
	-
	- P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	-
	- M=SQRT(ABS( PPHO(4,I)**2 - P2))
	-
	- IF (IPRINT.EQ.1)
	- & WRITE(PHLUN,*) "CORRECTING MASS OF ",I,":",
	- & PPHO(5,I),"=>",M
	-
	- PPHO(5,I)=M
	-
	- ENDDO
	-
	-
	- ELSEIF(MODOP.EQ.4) THEN
	-C -----------------------
	-
	-CC lets loop thru all daughters and correct their masses
	-CC or energies according to E^2=p^2+m^2
	-
	- DO I=3,NPHO
	-
	- PX=PX+PPHO(1,I)
	- PY=PY+PPHO(2,I)
	- PZ=PZ+PPHO(3,I)
	-
	- P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	-
	- M=SQRT(ABS( PPHO(4,I)**2 - P2))
	-
	- IF (M.GT.MCUT) THEN
	- IF (IPRINT.EQ.1)
	- & WRITE(PHLUN,*) "CORRECTING MASS OF ",I,":",
	- & PPHO(5,I),"=>",M
	- PPHO(5,I)=M
	- E = E+PPHO(4,I)
	- ELSE
	-
	- EN=SQRT( PPHO(5,I)**2 + P2)
	-
	- IF (IPRINT.EQ.1)
	- & WRITE(PHLUN,*) "CORRECTING ENERGY OF ",I,":",
	- & PPHO(4,I),"=>",EN
	-
	- PPHO(4,I)=EN
	- E = E+PPHO(4,I)
	- ENDIF
	-
	- ENDDO
	- ENDIF
	-C -----
	-
	- IF (IPRINT.EQ.1) THEN
	- WRITE(PHLUN,*) "CORRECTING MOTHER"
	- WRITE(PHLUN,*) "PX:",PPHO(1,1),"=>",PX-PPHO(1,2)
	- WRITE(PHLUN,*) "PY:",PPHO(2,1),"=>",PY-PPHO(2,2)
	- WRITE(PHLUN,*) "PZ:",PPHO(3,1),"=>",PZ-PPHO(3,2)
	- WRITE(PHLUN,*) " E:",PPHO(4,1),"=>",E-PPHO(4,2)
	- ENDIF
	-
	- PPHO(1,1)=PX-PPHO(1,2)
	- PPHO(2,1)=PY-PPHO(2,2)
	- PPHO(3,1)=PZ-PPHO(3,2)
	- PPHO(4,1)=E -PPHO(4,2)
	-
	- P2=PPHO(1,1)2+PPHO(2,1)2+PPHO(3,1)**2
	-
	- IF (PPHO(4,1)**2.GT.P2) THEN
	- M=SQRT( PPHO(4,1)**2 - P2 )
	- IF (IPRINT.EQ.1)
	- & WRITE(PHLUN,*) " M:",PPHO(5,1),"=>",M
	- PPHO(5,1)=M
	- ENDIF
	-
	- CALL PHLUPA(25)
	-
	- END
	-
	-
	-
	- FUNCTION PHINT(IDUM)
	-C --- can be used with VARIANT A. For B use PHINT1 or 2 --------------
	-C.----------------------------------------------------------------------
	-C.
	-C. PHINT: PHotos universal INTerference correction weight
	-C.
	-C. Purpose: calculates correction weight as expressed by
	-C formula (17) from CPC 79 (1994), 291.
	-C.
	-C. Input Parameters: Common /PHOEVT/, with photon added.
	-C.
	-C. Output Parameters: correction weight
	-C.
	-C. Author(s): Z. Was, P.Golonka Created at: 19/01/05
	-C. Last Update: 25/01/05
	-C.
	-C.----------------------------------------------------------------------
	- IMPLICIT NONE
	- double precision PHINT,PHINT2
	- INTEGER IDUM
	- INTEGER NMXPHO
	- PARAMETER (NMXPHO=10000)
	- INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	- double precision PPHO,VPHO
	- COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	- &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	- INTEGER I,K,L
	- DOUBLE PRECISION EMU,MCHREN,BETA,COSTHG,MPASQR,XPH, XC1, XC2,XDENO
	- DOUBLE PRECISION XNUM1,XNUM2
	- DOUBLE PRECISION EPS1(4),EPS2(4),PH(4),PL(4)
	- double precision PHOCHA
	-C--
	-
	-C Calculate polarimetric vector: ph, eps1, eps2 are orthogonal
	-
	- DO K=1,4
	- PH(K)=PPHO(K,NPHO)
	- EPS2(K)=1D0
	- ENDDO
	-
	- CALL PHOEPS(PH,EPS2,EPS1)
	- CALL PHOEPS(PH,EPS1,EPS2)
	-
	-
	- XNUM1=0D0
	- XNUM2=0D0
	- XDENO=0D0
	-
	- DO K=JDAPHO(1,1),NPHO-1 ! or JDAPHO(1,2)
	-
	-C momenta of charged particle in PL
	- DO L=1,4
	- PL(L)=PPHO(L,K)
	- ENDDO
	-C scalar products: epsilonp/kp
	-
	- XC1 = - PHOCHA(IDPHO(K)) *
	- & ( PL(1)EPS1(1) + PL(2)EPS1(2) + PL(3)*EPS1(3) ) /
	- & ( PH(4)PL(4) - PH(1)PL(1) - PH(2)PL(2) - PH(3)PL(3) )
	-
	- XC2 = - PHOCHA(IDPHO(K)) *
	- & ( PL(1)EPS2(1) + PL(2)EPS2(2) + PL(3)*EPS2(3) ) /
	- & ( PH(4)PL(4) - PH(1)PL(1) - PH(2)PL(2) - PH(3)PL(3) )
	-
	-
	-C accumulate the currents
	- XNUM1 = XNUM1+XC1
	- XNUM2 = XNUM2+XC2
	-
	- XDENO = XDENO + XC12 + XC22
	-
	- ENDDO
	-
	- PHINT=(XNUM12 + XNUM22) / XDENO
	- PHINT2=PHINT
	-
	- END
	-
	-
	- SUBROUTINE PHOEPS (VEC1, VEC2, EPS)
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOEPS: PHOeps vector product (normalized to unity)
	-C.
	-C. Purpose: calculates vector product, then normalizes its length.
	-C used to generate orthogonal vectors, i.e. to
	-C generate polarimetric vectors for photons.
	-C.
	-C. Input Parameters: VEC1,VEC2 - input 4-vectors
	-C.
	-C. Output Parameters: EPS - normalized 4-vector, orthogonal to
	-C VEC1 and VEC2
	-C.
	-C. Author(s): Z. Was, P.Golonka Created at: 19/01/05
	-C. Last Update: 25/01/05
	-C.
	-C.----------------------------------------------------------------------
	-
	- DOUBLE PRECISION VEC1(4), VEC2(4), EPS(4),XN
	-
	- EPS(1)=VEC1(2)VEC2(3) - VEC1(3)VEC2(2)
	- EPS(2)=VEC1(3)VEC2(1) - VEC1(1)VEC2(3)
	- EPS(3)=VEC1(1)VEC2(2) - VEC1(2)VEC2(1)
	- EPS(4)=0D0
	-
	- XN=SQRT( EPS(1)2 +EPS(2)2 +EPS(3)**2)
	-
	- EPS(1)=EPS(1)/XN
	- EPS(2)=EPS(2)/XN
	- EPS(3)=EPS(3)/XN
	-
	-
	- END
	- SUBROUTINE PHODMP
	-C.----------------------------------------------------------------------
	-C.
	-C. PHOTOS: PHOton radiation in decays event DuMP routine
	-C.
	-C. Purpose: Print event record.
	-C.
	-C. Input Parameters: Common /HEPEVT/
	-C.
	-C. Output Parameters: None
	-C.
	-C. Author(s): B. van Eijk Created at: 05/06/90
	-C. Last Update: 05/06/90
	-C.
	-C.----------------------------------------------------------------------
	-C IMPLICIT NONE
	- DOUBLE PRECISION SUMVEC(5)
	- INTEGER I,J
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	- INTEGER PHLUN
	- COMMON/PHOLUN/PHLUN
	- DO 10 I=1,5
	- 10 SUMVEC(I)=0.
	-C--
	-C-- Print event number...
	- WRITE(PHLUN,9000)
	- WRITE(PHLUN,9010) NEVHEP
	- WRITE(PHLUN,9080)
	- WRITE(PHLUN,9020)
	- DO 30 I=1,NHEP
	-C--
	-C-- For 'stable particle' calculate vector momentum sum
	- IF (JDAHEP(1,I).EQ.0) THEN
	- DO 20 J=1,4
	- 20 SUMVEC(J)=SUMVEC(J)+PHEP(J,I)
	- IF (JMOHEP(2,I).EQ.0) THEN
	- WRITE(PHLUN,9030) I,IDHEP(I),JMOHEP(1,I),(PHEP(J,I),J=1,5)
	- ELSE
	- WRITE(PHLUN,9040) I,IDHEP(I),JMOHEP(1,I),JMOHEP(2,I),(PHEP
	- & (J,I),J=1,5)
	- ENDIF
	- ELSE
	- IF (JMOHEP(2,I).EQ.0) THEN
	- WRITE(PHLUN,9050) I,IDHEP(I),JMOHEP(1,I),JDAHEP(1,I),
	- & JDAHEP(2,I),(PHEP(J,I),J=1,5)
	- ELSE
	- WRITE(PHLUN,9060) I,IDHEP(I),JMOHEP(1,I),JMOHEP(2,I),
	- & JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
	- ENDIF
	- ENDIF
	- 30 CONTINUE
	- SUMVEC(5)=SQRT(SUMVEC(4)2-SUMVEC(1)2-SUMVEC(2)**2-
	- &SUMVEC(3)**2)
	- WRITE(PHLUN,9070) (SUMVEC(J),J=1,5)
	- RETURN
	- 9000 FORMAT(1H0,80('='))
	- 9010 FORMAT(1H ,29X,'Event No.:',I10)
	- 9020 FORMAT(1H0,1X,'Nr',3X,'Type',3X,'Parent(s)',2X,'Daughter(s)',6X,
	- &'Px',7X,'Py',7X,'Pz',7X,'E',4X,'Inv. M.')
	- 9030 FORMAT(1H ,I4,I7,3X,I4,9X,'Stable',2X,5F9.2)
	- 9040 FORMAT(1H ,I4,I7,I4,' - ',I4,5X,'Stable',2X,5F9.2)
	- 9050 FORMAT(1H ,I4,I7,3X,I4,6X,I4,' - ',I4,5F9.2)
	- 9060 FORMAT(1H ,I4,I7,I4,' - ',I4,2X,I4,' - ',I4,5F9.2)
	- 9070 FORMAT(1H0,23X,'Vector Sum: ', 5F9.2)
	- 9080 FORMAT(1H0,6X,'Particle Parameters')
	- END
	Index: trunk/tauola/tauola_photos_ini.f
	===================================================================
	--- trunk/tauola/tauola_photos_ini.f (revision 8888)
	+++ trunk/tauola/tauola_photos_ini.f (revision 8889)
	@@ -1,802 +0,0 @@
	-
	-
	-C this file is created by hand from taumain.F
	-C actions: Remove routines: TAUDEM DECTES TAUFIL FILHEP
	-C add: INIETC will not necesarily work fine ...
	-C replace TRALO4
	-C rename INIPHY to INIPHX
	-
	- SUBROUTINE INIETC(jakk1,jakk2,itd,ifpho)
	- implicit DOUBLE PRECISION (a-h,o-z)
	- COMMON / IDFC / IDFF
	- COMMON / TAURAD / XK0DEC,ITDKRC
	- DOUBLE PRECISION XK0DEC
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	- COMMON /PHOACT/ IFPHOT
	- SAVE
	-C KTO=1 will denote tau+, thus :: IDFF=-15
	- IDFF=-15
	-C XK0 for tau decays.
	- XK0DEC=0.01
	-C radiative correction switch in tau --> e (mu) decays !
	- ITDKRC=itd
	-C switches of tau+ tau- decay modes !!
	- JAK1=jakk1
	- JAK2=jakk2
	-C photos activation switch
	- IFPHOT=IFPHO
	- end
	-
	- SUBROUTINE TRALO4(KTOS,PHOI,PHOF,AM)
	- implicit DOUBLE PRECISION (a-h,o-z)
	-!! Corrected 11.10.96 (ZW) tralor for KORALW.
	-!! better treatment is to cascade from tau rest-frame through W
	-!! restframe down to LAB.
	- COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
	- COMMON /TRALID/ idtra
	- double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
	- double precision P1QQ(4),P2QQ(4)
	- double precision PIN(4),POUT(4),PBST(4),PBS1(4),QQ(4),PI
	- double precision THET,PHI,EXE
	- double precision PHOI(4),PHOF(4)
	- SAVE
	- DATA PI /3.141592653589793238462643D0/
	- AM=SQRT(ABS
	- $ (PHOI(4)2-PHOI(3)2-PHOI(2)2-PHOI(1)2))
	- idtra=KTOS
	- DO K=1,4
	- PIN(K)=PHOI(K)
	- PHOF(K)=PHOI(K)
	- ENDDO
	-! write(,) idtra
	- IF (idtra.EQ.1) THEN
	- DO K=1,4
	- PBST(K)=P1(K)
	- QQ(K)=Q1(K)
	- ENDDO
	- ELSEIF(idtra.EQ.2) THEN
	- DO K=1,4
	- PBST(K)=P2(K)
	- QQ(K)=Q1(K)
	- ENDDO
	- ELSEIF(idtra.EQ.3) THEN
	- DO K=1,4
	- PBST(K)=P3(K)
	- QQ(K)=Q2(K)
	- ENDDO
	- ELSE
	- DO K=1,4
	- PBST(K)=P4(K)
	- QQ(K)=Q2(K)
	- ENDDO
	- ENDIF
	-
	-
	-
	- CALL BOSTDQ(1,QQ,PBST,PBST)
	- CALL BOSTDQ(1,QQ,P1,P1QQ)
	- CALL BOSTDQ(1,QQ,P2,P2QQ)
	- PBS1(4)=PBST(4)
	- PBS1(3)=SQRT(PBST(3)2+PBST(2)2+PBST(1)**2)
	- PBS1(2)=0D0
	- PBS1(1)=0D0
	- EXE=(PBS1(4)+PBS1(3))/DSQRT(PBS1(4)2-PBS1(3)2)
	-C for KTOS=1 boost is antiparallel to 4-momentum of P2.
	-C restframes of tau+ tau- and 'first' frame of 'higgs' are all connected
	-C by boosts along z axis
	- IF(KTOS.EQ.1) EXE=(PBS1(4)-PBS1(3))/DSQRT(PBS1(4)2-PBS1(3)2)
	- CALL BOSTD3(EXE,PIN,POUT)
	-
	-C once in Z/gamma/Higgs rest frame we control further kinematics by P2QQ for KTOS=1,2
	- THET=ACOS(P2QQ(3)/SQRT(P2QQ(3)2+P2QQ(2)2+P2QQ(1)**2))
	-c PHI=0D0
	-c PHI=ACOS(P2QQ(1)/SQRT(P2QQ(2)2+P2QQ(1)2))
	-c IF(P2QQ(2).LT.0D0) PHI=2*PI-PHI
	-c JRR: Catch numerical exceptions in boosts.
	- if (ABS(P2QQ(1)) < 1D-11 .AND. ABS(P2QQ(1)) < 1D-11) then
	- PHI=0
	- ELSE
	- PHI=ATAN2(P2QQ(2),P2QQ(1))
	- ENDIF
	-
	- CALL ROTPOX(THET,PHI,POUT)
	- CALL BOSTDQ(-1,QQ,POUT,POUT)
	- DO K=1,4
	- PHOF(K)=POUT(K)
	- ENDDO
	- END
	-
	-
	- SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
	- $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
	- implicit DOUBLE PRECISION (a-h,o-z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- AMROP=1.1
	- GAMROP=0.36
	- AMOM=.782
	- GAMOM=0.0084
	-C XXXXA CORRESPOND TO S2 CHANNEL !
	- IF(MNUM.EQ.0) THEN
	- PROB1=0.5
	- PROB2=0.5
	- AMRX =AMA1
	- GAMRX=GAMA1
	- AMRA =AMRO
	- GAMRA=GAMRO
	- AMRB =AMRO
	- GAMRB=GAMRO
	- ELSEIF(MNUM.EQ.1) THEN
	- PROB1=0.5
	- PROB2=0.5
	- AMRX =1.57
	- GAMRX=0.9
	- AMRB =AMKST
	- GAMRB=GAMKST
	- AMRA =AMRO
	- GAMRA=GAMRO
	- ELSEIF(MNUM.EQ.2) THEN
	- PROB1=0.5
	- PROB2=0.5
	- AMRX =1.57
	- GAMRX=0.9
	- AMRB =AMKST
	- GAMRB=GAMKST
	- AMRA =AMRO
	- GAMRA=GAMRO
	- ELSEIF(MNUM.EQ.3) THEN
	- PROB1=0.5
	- PROB2=0.5
	- AMRX =1.27
	- GAMRX=0.3
	- AMRA =AMKST
	- GAMRA=GAMKST
	- AMRB =AMKST
	- GAMRB=GAMKST
	- ELSEIF(MNUM.EQ.4) THEN
	- PROB1=0.5
	- PROB2=0.5
	- AMRX =1.27
	- GAMRX=0.3
	- AMRA =AMKST
	- GAMRA=GAMKST
	- AMRB =AMKST
	- GAMRB=GAMKST
	- ELSEIF(MNUM.EQ.5) THEN
	- PROB1=0.5
	- PROB2=0.5
	- AMRX =1.27
	- GAMRX=0.3
	- AMRA =AMKST
	- GAMRA=GAMKST
	- AMRB =AMRO
	- GAMRB=GAMRO
	- ELSEIF(MNUM.EQ.6) THEN
	- PROB1=0.4
	- PROB2=0.4
	- AMRX =1.27
	- GAMRX=0.3
	- AMRA =AMRO
	- GAMRA=GAMRO
	- AMRB =AMKST
	- GAMRB=GAMKST
	- ELSEIF(MNUM.EQ.7) THEN
	- PROB1=0.0
	- PROB2=1.0
	- AMRX =1.27
	- GAMRX=0.9
	- AMRA =AMRO
	- GAMRA=GAMRO
	- AMRB =AMRO
	- GAMRB=GAMRO
	- ELSEIF(MNUM.EQ.8) THEN
	- PROB1=0.0
	- PROB2=1.0
	- AMRX =AMROP
	- GAMRX=GAMROP
	- AMRB =AMOM
	- GAMRB=GAMOM
	- AMRA =AMRO
	- GAMRA=GAMRO
	- ELSEIF(MNUM.EQ.101) THEN
	- PROB1=.35
	- PROB2=.35
	- AMRX =1.2
	- GAMRX=.46
	- AMRB =AMOM
	- GAMRB=GAMOM
	- AMRA =AMOM
	- GAMRA=GAMOM
	- ELSEIF(MNUM.EQ.102) THEN
	- PROB1=0.0
	- PROB2=0.0
	- AMRX =1.4
	- GAMRX=.6
	- AMRB =AMOM
	- GAMRB=GAMOM
	- AMRA =AMOM
	- GAMRA=GAMOM
	- ELSE
	- PROB1=0.0
	- PROB2=0.0
	- AMRX =AMA1
	- GAMRX=GAMA1
	- AMRA =AMRO
	- GAMRA=GAMRO
	- AMRB =AMRO
	- GAMRB=GAMRO
	- ENDIF
	-C
	- IF (RR.LE.PROB1) THEN
	- ICHAN=1
	- ELSEIF(RR.LE.(PROB1+PROB2)) THEN
	- ICHAN=2
	- AX =AMRA
	- GX =GAMRA
	- AMRA =AMRB
	- GAMRA=GAMRB
	- AMRB =AX
	- GAMRB=GX
	- PX =PROB1
	- PROB1=PROB2
	- PROB2=PX
	- ELSE
	- ICHAN=3
	- ENDIF
	-C
	- PROB3=1.0-PROB1-PROB2
	- END
	- SUBROUTINE INITDK
	- implicit DOUBLE PRECISION (a-h,o-z)
	-* ----------------------------------------------------------------------
	-* INITIALISATION OF TAU DECAY PARAMETERS and routines
	-*
	-* called by : KORALZ
	-* ----------------------------------------------------------------------
	-
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-*
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
	- COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	- double precision BRA1,BRK0,BRK0B,BRKS
	-
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	-
	-
	-
	-
	-
	-
	- CHARACTER OLDNAMES(7)*31
	- CHARACTER*80 bxINIT
	- PARAMETER (
	- $ bxINIT ='(1x,1h,g17.8, 16x, a31,a4,a4, 1x,1h)'
	- $ )
	- double precision PI,POL1(4)
	-*
	-*
	-* LIST OF BRANCHING RATIOS
	-CAM normalised to e nu nutau channel
	-CAM enu munu pinu rhonu A1nu Knu K*nu pi
	-CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
	-
	-CAM /0.1779,0.1731,0.1106,0.2530,0.1811,0.0072,0.0139
	-CAM DATA GAMPRT / 1.000,0.9732,0.6217,1.4221,1.0180,0.0405,0.0781
	-CAM DATA GAMPRT /1.000,0.9676,0.6154,1.3503,1.0225,0.0368,O.O758
	-CAM
	-C
	-C conventions of particles names
	-c
	-cam mode (JAK) 8 9
	-CAM channel pi- pi- pi0 pi+ 3pi0 pi-
	-cam particle code -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
	-CAM BR relative to electron .2414, .0601,
	-c
	-* 10 11
	-* 1 3pi+- 2pi0 5pi+-
	-* 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
	-* 1 .0281, .0045,
	-
	-* 12 13
	-* 2 5pi+- pi0 3pi+- 3pi0
	-* 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
	-* 2 .0010, .0062,
	-
	-* 14 15
	-* 3 K- pi- K+ K0 pi- KB
	-* 3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
	-* 3 .0096, .0169,
	-
	-* 16 17
	-* 4 K- pi0 K0 2pi0 K-
	-* 4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
	-* 4 .0056, .0045,
	-
	-* 18 19
	-* 5 K- pi- pi+ pi- KB pi0
	-* 5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
	-* 5 .0219, .0180,
	-
	-* 20 21
	-* 6 eta pi- pi0 pi- pi0 gamma
	-* 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
	-* 6 .0096, .0088,
	-
	-* 22 /
	-* 7 K- K0 /
	-* 7 -3, 4 /
	-* 7 .0146 /
	-C
	- DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
	-*AM outgoing multiplicity and flavors of multi-pion /multi-K modes
	- DATA NPIK / 4, 4,
	- 1 5, 5,
	- 2 6, 6,
	- 3 3, 3,
	- 4 3, 3,
	- 5 3, 3,
	- 6 3, 3,
	- 7 2 /
	- DATA NOPIK / -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
	- 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
	- 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
	- 3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
	- 4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
	- 5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
	- 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
	- 7 -3, 4, 0, 0, 0, 0 /
	-* LIST OF BRANCHING RATIOS
	- NCHAN = NMODE + 7
	- DO 1 I = 1,30
	- IF (I.LE.NCHAN) THEN
	- JLIST(I) = I
	- IF(I.EQ. 1) GAMPRT(I) = 1.0000
	- IF(I.EQ. 2) GAMPRT(I) = .9732
	- IF(I.EQ. 3) GAMPRT(I) = .6217
	- IF(I.EQ. 4) GAMPRT(I) = 1.4221
	- IF(I.EQ. 5) GAMPRT(I) = 1.0180
	- IF(I.EQ. 6) GAMPRT(I) = .0405
	- IF(I.EQ. 7) GAMPRT(I) = .0781
	- IF(I.EQ. 8) GAMPRT(I) = .2414
	- IF(I.EQ. 9) GAMPRT(I) = .0601
	- IF(I.EQ.10) GAMPRT(I) = .0281
	- IF(I.EQ.11) GAMPRT(I) = .0045
	- IF(I.EQ.12) GAMPRT(I) = .0010
	- IF(I.EQ.13) GAMPRT(I) = .0062
	- IF(I.EQ.14) GAMPRT(I) = .0096
	- IF(I.EQ.15) GAMPRT(I) = .0169
	- IF(I.EQ.16) GAMPRT(I) = .0056
	- IF(I.EQ.17) GAMPRT(I) = .0045
	- IF(I.EQ.18) GAMPRT(I) = .0219
	- IF(I.EQ.19) GAMPRT(I) = .0180
	- IF(I.EQ.20) GAMPRT(I) = .0096
	- IF(I.EQ.21) GAMPRT(I) = .0088
	- IF(I.EQ.22) GAMPRT(I) = .0146
	- IF(I.EQ. 1) OLDNAMES(I)=' TAU- --> E- '
	- IF(I.EQ. 2) OLDNAMES(I)=' TAU- --> MU- '
	- IF(I.EQ. 3) OLDNAMES(I)=' TAU- --> PI- '
	- IF(I.EQ. 4) OLDNAMES(I)=' TAU- --> PI-, PI0 '
	- IF(I.EQ. 5) OLDNAMES(I)=' TAU- --> A1- (two subch) '
	- IF(I.EQ. 6) OLDNAMES(I)=' TAU- --> K- '
	- IF(I.EQ. 7) OLDNAMES(I)=' TAU- --> K*- (two subch) '
	- IF(I.EQ. 8) NAMES(I-7)=' TAU- --> 2PI-, PI0, PI+ '
	- IF(I.EQ. 9) NAMES(I-7)=' TAU- --> 3PI0, PI- '
	- IF(I.EQ.10) NAMES(I-7)=' TAU- --> 2PI-, PI+, 2PI0 '
	- IF(I.EQ.11) NAMES(I-7)=' TAU- --> 3PI-, 2PI+, '
	- IF(I.EQ.12) NAMES(I-7)=' TAU- --> 3PI-, 2PI+, PI0 '
	- IF(I.EQ.13) NAMES(I-7)=' TAU- --> 2PI-, PI+, 3PI0 '
	- IF(I.EQ.14) NAMES(I-7)=' TAU- --> K-, PI-, K+ '
	- IF(I.EQ.15) NAMES(I-7)=' TAU- --> K0, PI-, K0B '
	- IF(I.EQ.16) NAMES(I-7)=' TAU- --> K- PI0 K0 '
	- IF(I.EQ.17) NAMES(I-7)=' TAU- --> PI0 PI0 K- '
	- IF(I.EQ.18) NAMES(I-7)=' TAU- --> K- PI- PI+ '
	- IF(I.EQ.19) NAMES(I-7)=' TAU- --> PI- K0B PI0 '
	- IF(I.EQ.20) NAMES(I-7)=' TAU- --> ETA PI- PI0 '
	- IF(I.EQ.21) NAMES(I-7)=' TAU- --> PI- PI0 GAM '
	- IF(I.EQ.22) NAMES(I-7)=' TAU- --> K- K0 '
	- ELSE
	- JLIST(I) = 0
	- GAMPRT(I) = 0.
	- ENDIF
	- 1 CONTINUE
	- DO I=1,NMODE
	- MULPIK(I)=NPIK(I)
	- DO J=1,MULPIK(I)
	- IDFFIN(J,I)=NOPIK(J,I)
	- ENDDO
	- ENDDO
	-*
	-*
	-* --- COEFFICIENTS TO FIX RATIO OF:
	-* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
	-* --- PROBABILITY OF K0 TO BE KS
	-* --- PROBABILITY OF K0B TO BE KS
	-* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
	-* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
	-* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
	-* --- NEGLECTS MASS-PHASE SPACE EFFECTS
	- BRA1=0.5
	- BRK0=0.5
	- BRK0B=0.5
	- BRKS=0.6667
	-*
	-
	- GFERMI = 1.16637E-5
	- CCABIB = 0.975
	- GV = 1.0
	- GA =-1.0
	-
	-
	-
	-* ZW 13.04.89 HERE WAS AN ERROR
	- SCABIB = SQRT(1.-CCABIB**2)
	- PI =4.*ATAN(1.)
	- GAMEL = GFERMI*2AMTAU*5/(192PI**3)
	-*
	- CALL DEXAY(-1,POL1)
	-*
	- RETURN
	- END
	- double precision FUNCTION DCDMAS(IDENT)
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-*
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- IF (IDENT.EQ. 1) THEN
	- APKMAS=AMPI
	- ELSEIF (IDENT.EQ.-1) THEN
	- APKMAS=AMPI
	- ELSEIF (IDENT.EQ. 2) THEN
	- APKMAS=AMPIZ
	- ELSEIF (IDENT.EQ.-2) THEN
	- APKMAS=AMPIZ
	- ELSEIF (IDENT.EQ. 3) THEN
	- APKMAS=AMK
	- ELSEIF (IDENT.EQ.-3) THEN
	- APKMAS=AMK
	- ELSEIF (IDENT.EQ. 4) THEN
	- APKMAS=AMKZ
	- ELSEIF (IDENT.EQ.-4) THEN
	- APKMAS=AMKZ
	- ELSEIF (IDENT.EQ. 8) THEN
	- APKMAS=0.0001
	- ELSEIF (IDENT.EQ.-8) THEN
	- APKMAS=0.0001
	- ELSEIF (IDENT.EQ. 9) THEN
	- APKMAS=0.5488
	- ELSEIF (IDENT.EQ.-9) THEN
	- APKMAS=0.5488
	- ELSE
	- PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
	- STOP
	- ENDIF
	- DCDMAS=APKMAS
	- END
	- integer FUNCTION LUNPIK(ID,ISGN)
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	- double precision BRA1,BRK0,BRK0B,BRKS
	- double precision XIO(1)
	- IDENT=ID*ISGN
	- IF (IDENT.EQ. 1) THEN
	- IPKDEF= 211
	- ELSEIF (IDENT.EQ.-1) THEN
	- IPKDEF=-211
	- ELSEIF (IDENT.EQ. 2) THEN
	- IPKDEF= 111
	- ELSEIF (IDENT.EQ.-2) THEN
	- IPKDEF= 111
	- ELSEIF (IDENT.EQ. 3) THEN
	- IPKDEF= 321
	- ELSEIF (IDENT.EQ.-3) THEN
	- IPKDEF=-321
	- ELSEIF (IDENT.EQ. 4) THEN
	-*
	-* K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
	- CALL RANMAR(XIO,1)
	- IF (XIO(1).GT.BRK0) THEN
	- IPKDEF= 130
	- ELSE
	- IPKDEF= 310
	- ENDIF
	- ELSEIF (IDENT.EQ.-4) THEN
	-*
	-* K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
	- CALL RANMAR(XIO,1)
	- IF (XIO(1).GT.BRK0B) THEN
	- IPKDEF= 130
	- ELSE
	- IPKDEF= 310
	- ENDIF
	- ELSEIF (IDENT.EQ. 8) THEN
	- IPKDEF= 22
	- ELSEIF (IDENT.EQ.-8) THEN
	- IPKDEF= 22
	- ELSEIF (IDENT.EQ. 9) THEN
	- IPKDEF= 221
	- ELSEIF (IDENT.EQ.-9) THEN
	- IPKDEF= 221
	- ELSE
	- PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
	- STOP
	- ENDIF
	- LUNPIK=IPKDEF
	- END
	-
	-
	-
	- SUBROUTINE TAURDF(KTO)
	- implicit DOUBLE PRECISION (a-h,o-z)
	-* THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
	-* IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
	-* CONTENTS
	- COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	- double precision BRA1,BRK0,BRK0B,BRKS
	- COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
	- IF (KTO.EQ.1) THEN
	-* ==================
	-* LIST OF BRANCHING RATIOS
	- NCHAN = 19
	- DO 1 I = 1,30
	- IF (I.LE.NCHAN) THEN
	- JLIST(I) = I
	- IF(I.EQ. 1) GAMPRT(I) = .0000
	- IF(I.EQ. 2) GAMPRT(I) = .0000
	- IF(I.EQ. 3) GAMPRT(I) = .0000
	- IF(I.EQ. 4) GAMPRT(I) = .0000
	- IF(I.EQ. 5) GAMPRT(I) = .0000
	- IF(I.EQ. 6) GAMPRT(I) = .0000
	- IF(I.EQ. 7) GAMPRT(I) = .0000
	- IF(I.EQ. 8) GAMPRT(I) = 1.0000
	- IF(I.EQ. 9) GAMPRT(I) = 1.0000
	- IF(I.EQ.10) GAMPRT(I) = 1.0000
	- IF(I.EQ.11) GAMPRT(I) = 1.0000
	- IF(I.EQ.12) GAMPRT(I) = 1.0000
	- IF(I.EQ.13) GAMPRT(I) = 1.0000
	- IF(I.EQ.14) GAMPRT(I) = 1.0000
	- IF(I.EQ.15) GAMPRT(I) = 1.0000
	- IF(I.EQ.16) GAMPRT(I) = 1.0000
	- IF(I.EQ.17) GAMPRT(I) = 1.0000
	- IF(I.EQ.18) GAMPRT(I) = 1.0000
	- IF(I.EQ.19) GAMPRT(I) = 1.0000
	- ELSE
	- JLIST(I) = 0
	- GAMPRT(I) = 0.
	- ENDIF
	- 1 CONTINUE
	-* --- COEFFICIENTS TO FIX RATIO OF:
	-* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
	-* --- PROBABILITY OF K0 TO BE KS
	-* --- PROBABILITY OF K0B TO BE KS
	-* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
	-* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
	-* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
	-* --- NEGLECTS MASS-PHASE SPACE EFFECTS
	- BRA1=0.5
	- BRK0=0.5
	- BRK0B=0.5
	- BRKS=0.6667
	- ELSE
	-* ====
	-* LIST OF BRANCHING RATIOS
	- NCHAN = 19
	- DO 2 I = 1,30
	- IF (I.LE.NCHAN) THEN
	- JLIST(I) = I
	- IF(I.EQ. 1) GAMPRT(I) = .0000
	- IF(I.EQ. 2) GAMPRT(I) = .0000
	- IF(I.EQ. 3) GAMPRT(I) = .0000
	- IF(I.EQ. 4) GAMPRT(I) = .0000
	- IF(I.EQ. 5) GAMPRT(I) = .0000
	- IF(I.EQ. 6) GAMPRT(I) = .0000
	- IF(I.EQ. 7) GAMPRT(I) = .0000
	- IF(I.EQ. 8) GAMPRT(I) = 1.0000
	- IF(I.EQ. 9) GAMPRT(I) = 1.0000
	- IF(I.EQ.10) GAMPRT(I) = 1.0000
	- IF(I.EQ.11) GAMPRT(I) = 1.0000
	- IF(I.EQ.12) GAMPRT(I) = 1.0000
	- IF(I.EQ.13) GAMPRT(I) = 1.0000
	- IF(I.EQ.14) GAMPRT(I) = 1.0000
	- IF(I.EQ.15) GAMPRT(I) = 1.0000
	- IF(I.EQ.16) GAMPRT(I) = 1.0000
	- IF(I.EQ.17) GAMPRT(I) = 1.0000
	- IF(I.EQ.18) GAMPRT(I) = 1.0000
	- IF(I.EQ.19) GAMPRT(I) = 1.0000
	- ELSE
	- JLIST(I) = 0
	- GAMPRT(I) = 0.
	- ENDIF
	- 2 CONTINUE
	-* --- COEFFICIENTS TO FIX RATIO OF:
	-* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
	-* --- PROBABILITY OF K0 TO BE KS
	-* --- PROBABILITY OF K0B TO BE KS
	-* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
	-* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
	-* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
	-* --- NEGLECTS MASS-PHASE SPACE EFFECTS
	- BRA1=0.5
	- BRK0=0.5
	- BRK0B=0.5
	- BRKS=0.6667
	- ENDIF
	-* =====
	- END
	-
	- SUBROUTINE INIPHX(XK00)
	- implicit DOUBLE PRECISION (a-h,o-z)
	-* ----------------------------------------------------------------------
	-* INITIALISATION OF PARAMETERS
	-* USED IN QED and/or GSW ROUTINES
	-* ----------------------------------------------------------------------
	- COMMON / QEDPRM /ALFINV,ALFPI,XK0
	- double precision ALFINV,ALFPI,XK0
	- double precision PI8,XK00
	-*
	- PI8 = 4.D0*DATAN(1.D0)
	- ALFINV = 137.03604D0
	- ALFPI = 1D0/(ALFINV*PI8)
	- XK0=XK00
	- END
	-
	- SUBROUTINE INIMAS
	- implicit DOUBLE PRECISION (a-h,o-z)
	-C ----------------------------------------------------------------------
	-C INITIALISATION OF MASSES
	-C
	-C called by : KORALZ
	-C ----------------------------------------------------------------------
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-*
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	-C IN-COMING / OUT-GOING FERMION MASSES
	- AMTAU = 1.7842
	-C --- tau mass must be the same as in the host program, what-so-ever
	- AMTAU = 1.777
	- AMNUTA = 0.010
	- AMEL = 0.0005111
	- AMNUE = 0.0
	- AMMU = 0.105659
	- AMNUMU = 0.0
	-*
	-* MASSES USED IN TAU DECAYS
	- AMPIZ = 0.134964
	- AMPI = 0.139568
	- AMRO = 0.7714
	- GAMRO = 0.153
	-cam AMRO = 0.773
	-cam GAMRO = 0.145
	- AMA1 = 1.251! PMAS(LUCOMP(ia1),1) ! AMA1 = 1.251
	- GAMA1 = 0.599! PMAS(LUCOMP(ia1),2) ! GAMA1 = 0.599
	- print *,'INIMAS a1 mass= ',ama1,gama1
	- AMK = 0.493667
	- AMKZ = 0.49772
	- AMKST = 0.8921
	- GAMKST = 0.0513
	-
	- RETURN
	- END
	- subroutine bostdq(idir,vv,pp,q)
	-* *******************************
	-c Boost along arbitrary vector v (see eg. J.D. Jacson, Classical
	-c Electrodynamics).
	-c Four-vector pp is boosted from an actual frame to the rest frame
	-c of the four-vector v (for idir=1) or back (for idir=-1).
	-c q is a resulting four-vector.
	-c Note: v must be time-like, pp may be arbitrary.
	-c
	-c Written by: Wieslaw Placzek date: 22.07.1994
	-c Last update: 3/29/95 by: M.S.
	-c
	- implicit DOUBLE PRECISION (a-h,o-z)
	- parameter (nout=6)
	- DOUBLE PRECISION v(4),p(4),q(4),pp(4),vv(4)
	- save
	-!
	- do 1 i=1,4
	- v(i)=vv(i)
	- 1 p(i)=pp(i)
	- amv=(v(4)2-v(1)2-v(2)2-v(3)2)
	- if (amv.le.0d0) then
	- write(6,) 'bostdq: warning amv*2=',amv
	- write(6,*) 'Skipping boost'
	- q(1:4) = p(1:4)
	- else
	- amv=sqrt(abs(amv))
	- if (idir.eq.-1) then
	- q(4)=( p(1)v(1)+p(2)v(2)+p(3)v(3)+p(4)v(4))/amv
	- wsp =(q(4)+p(4))/(v(4)+amv)
	- elseif (idir.eq.1) then
	- q(4)=(-p(1)v(1)-p(2)v(2)-p(3)v(3)+p(4)v(4))/amv
	- wsp =-(q(4)+p(4))/(v(4)+amv)
	- else
	- write(nout,*)' >>> boostv: wrong value of idir = ',idir
	- endif
	- q(1)=p(1)+wsp*v(1)
	- q(2)=p(2)+wsp*v(2)
	- q(3)=p(3)+wsp*v(3)
	- endif
	- end
	-
	- double precision FUNCTION DILOGY(X)
	-C *****************
	- IMPLICIT double precision(A-H,O-Z)
	-CERN C304 VERSION 29/07/71 DILOG 59 C
	- Z=-1.64493406684822
	- IF(X .LT.-1.0) GO TO 1
	- IF(X .LE. 0.5) GO TO 2
	- IF(X .EQ. 1.0) GO TO 3
	- IF(X .LE. 2.0) GO TO 4
	- Z=3.2898681336964
	- 1 T=1.0/X
	- S=-0.5
	- Z=Z-0.5* LOG(ABS(X))**2
	- GO TO 5
	- 2 T=X
	- S=0.5
	- Z=0.
	- GO TO 5
	- 3 DILOGY=1.64493406684822
	- RETURN
	- 4 T=1.0-X
	- S=-0.5
	- Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
	- 5 Y=2.66666666666666 *T+0.66666666666666
	- B= 0.00000 00000 00001
	- A=Y*B +0.00000 00000 00004
	- B=Y*A-B+0.00000 00000 00011
	- A=Y*B-A+0.00000 00000 00037
	- B=Y*A-B+0.00000 00000 00121
	- A=Y*B-A+0.00000 00000 00398
	- B=Y*A-B+0.00000 00000 01312
	- A=Y*B-A+0.00000 00000 04342
	- B=Y*A-B+0.00000 00000 14437
	- A=Y*B-A+0.00000 00000 48274
	- B=Y*A-B+0.00000 00001 62421
	- A=Y*B-A+0.00000 00005 50291
	- B=Y*A-B+0.00000 00018 79117
	- A=Y*B-A+0.00000 00064 74338
	- B=Y*A-B+0.00000 00225 36705
	- A=Y*B-A+0.00000 00793 87055
	- B=Y*A-B+0.00000 02835 75385
	- A=Y*B-A+0.00000 10299 04264
	- B=Y*A-B+0.00000 38163 29463
	- A=Y*B-A+0.00001 44963 00557
	- B=Y*A-B+0.00005 68178 22718
	- A=Y*B-A+0.00023 20021 96094
	- B=Y*A-B+0.00100 16274 96164
	- A=Y*B-A+0.00468 63619 59447
	- B=Y*A-B+0.02487 93229 24228
	- A=Y*B-A+0.16607 30329 27855
	- A=Y*A-B+1.93506 43008 6996
	- DILOGY=ST(A-B)+Z
	- RETURN
	-C=======================================================================
	-C===================END OF CPC PART ====================================
	-C=======================================================================
	- END
	Index: trunk/tauola/tauface-jetset.f
	===================================================================
	--- trunk/tauola/tauface-jetset.f (revision 8888)
	+++ trunk/tauola/tauface-jetset.f (revision 8889)
	@@ -1,1744 +0,0 @@
	- SUBROUTINE TAUOLA(MODE,KEYPOL)
	-C *************************************
	-C general tauola interface, should work in every case until
	-C hepevt is OK, does not check if hepevt is 'clean'
	-C in particular will decay decayed taus...
	-C only longitudinal spin effects are included.
	-C in W decay v-a vertex is assumed
	-C date: 12 DEC 1998. date: 21 June 1999. date: 24 Jan 2001 date: 24 Aug 2001
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- IMPLICIT double precision(A-H,O-Z)
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	- COMMON /TAUPOS/ NP1, NP2
	- double precision PHOI(4),PHOF(4)
	- double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
	- COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
	-* tauola, photos and jetset overall switches
	- COMMON /LIBRA/ JAK1,JAK2,ITDKRC,IFPHOT,IFHADM,IFHADP
	- double precision RRR(1)
	- LOGICAL IFPSEUDO
	- common /pseudocoup/ csc,ssc
	- double precision csc,ssc
	- save pseudocoup
	- COMMON / INOUT / INUT,IOUT
	-
	- double precision PLZAPX
	-
	-C to switch tau polarization OFF in taus
	- DIMENSION POL1(4), POL2(4)
	- double precision POL1x(4), POL2x(4)
	- INTEGER ION(3)
	- DATA POL1 /0.0D0,0.0D0,0.0D0,0.0D0/
	- DATA POL2 /0.0D0,0.0D0,0.0D0,0.0D0/
	- DATA PI /3.141592653589793238462643D0/
	-
	-C store decay vertexes
	- DIMENSION IMOTHER (20)
	- INTEGER KFHIGGS(3)
	-
	-C store daughter pointers
	- INTEGER ISON
	- COMMON /ISONS_TAU/ISON(2)
	- SAVE /ISONS_TAU/
	-
	- INTEGER NCN,NCNMX
	- DATA NCN/0/
	- DATA NCNMX/50/
	- SAVE NCN,NCNMX
	- IF(MODE.EQ.-1) THEN
	-C ***********************
	-
	- JAK1 = 0 ! decay mode first tau
	- JAK2 = 0 ! decay mode second tau
	- ITDKRC=1.0 ! switch of radiative corrections in decay
	- IFPHOT=1.0 ! PHOTOS switch
	- IFHADM=1.0
	- IFHADP=1.0
	- POL=1.0 ! tau polarization dipswitch must be 1 or 0
	-
	- KFHIGGS(1) = 25
	- KFHIGGS(2) = 35
	- KFHIGGS(3) = 36
	- KFHIGCH = 37
	- KFZ0 = 23
	- KFGAM = 22
	- KFTAU = 15
	- KFNUE = 16
	-C couplings of the 'pseudoscalar higgs' as in CERN-TH/2003-166
	- psi=0.5PI ! 0.15PI
	- xmtau=1.777 ! tau mass
	- xmh=120 ! higgs boson mass
	- betah=sqrt(1d0-4xmtau2/xmh*2)
	- csc=cos(psi)*betah
	- ssc=sin(psi)
	-C write(,) ' scalar component=',csc,' pseudo-scalar component=',ssc
	- IF (IFPHOT.EQ.1) CALL PHOINI ! this if PHOTOS was not initialized earlier
	- CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
	- CALL INIMAS
	- CALL INIPHX(0.01d0)
	- CALL INITDK
	-C activation of pi0 and eta decays: (1) means on, (0) off
	- ION(1)=0
	- ION(2)=0
	- ION(3)=0
	- CALL TAUPI0(-1,1,ION)
	- CALL DEKAY(-1,POL1x)
	- WRITE(IOUT,7001) pol,psi,ION(1),ION(2),ION(3)
	- ELSEIF(MODE.EQ.0) THEN
	-C ***********************
	- NCN=NCN+1
	-C
	-C..... find tau-s and fill common block /TAUPOS/
	-C this is to avoid LUND history fillings. This call is optional
	- CALL PHYFIX(NSTOP,NSTART)
	-C clear mothers of the previous event
	-! print *, " tauola point 001 nstart,nhep= ", nstart,nhep
	- DO II=1,20
	- IMOTHER(II)=0
	- ENDDO
	-
	- DO II=1,2
	- ISON(II)=0
	- ENDDO
	-C ... and to find mothers giving taus.
	- NDEC = 0
	-C(BPK)--> LOOK FOR MOTHER, CHECK THAT IT IS NOT THE HISTORY ENTRY (E.G. MSTP(128)=0)
	- DO I=NSTART,NHEP
	- IF(ABS(IDHEP(I)).EQ.KFTAU.AND.ISTHEP(I).EQ.1.AND.
	- $ (ISTHEP(I).GE.125.OR.ISTHEP(I).LT.120)) THEN
	- IMOTH=JMOHEP(1,I)
	- DO WHILE (ABS(IDHEP(IMOTH)).EQ.KFTAU) ! KEEP WALKING UP
	- IMOTH=JMOHEP(1,IMOTH)
	- ENDDO
	- IF (ISTHEP(IMOTH).EQ.3.OR.
	- $ (ISTHEP(IMOTH).GE.120.AND.ISTHEP(IMOTH).LE.125)) THEN
	- DO J=NSTART,NHEP ! WE HAVE WALKED INTO HARD RECORD
	- IF (IDHEP(J).EQ.IDHEP(IMOTH).AND.
	- $ JMOHEP(1,J).EQ.IMOTH.AND.
	- $ ISTHEP(J).EQ.2) THEN
	- JMOTH=J
	- GOTO 66
	- ENDIF
	- ENDDO
	- ELSE
	- JMOTH=IMOTH
	- ENDIF
	- 66 CONTINUE
	- DO II=1,NDEC
	- IF(JMOTH.EQ.IMOTHER(II)) GOTO 9999
	- ENDDO
	-C(BPK)--<
	- NDEC=NDEC+1
	- IMOTHER(NDEC)= JMOTH
	- ENDIF
	- 9999 CONTINUE
	- ENDDO
	-
	-C ... taus of every mother are treated in this main loop
	- DO II=1,NDEC
	- IM=IMOTHER(II)
	- NCOUNT=0
	- NP1=0
	- NP2=0
	-
	-
	-C(BPK)-->
	-C CORRECTING HEPEVT IS OUT OF QUESTION AT THIS POINT..
	- IM0=IM
	- IF (IDHEP(JMOHEP(1,IM0)).EQ.IDHEP(IM0)) IM0=JMOHEP(1,IM0)
	- ISEL=-1
	- DO I=NSTART,NHEP
	- IF (ISTHEP(I).EQ.3.OR.
	- $ (ISTHEP(I).GE.120.AND.ISTHEP(I).LE.125)) THEN ! HARD RECORD
	- GOTO 76
	- ENDIF
	- IMOTH=JMOHEP(1,I)
	- DO WHILE (IDHEP(IMOTH).EQ.IDHEP(I).OR.
	- $ ABS(IDHEP(IMOTH)).EQ.KFTAU) ! KEEP WALKING UP
	- IMOTH=JMOHEP(1,IMOTH)
	- ENDDO
	- IF ((IMOTH.EQ.IM0.OR.IMOTH.EQ.IM).AND.ISEL.EQ.-1) THEN
	- ISON(1)=I
	- ISEL=0
	- ELSEIF ((IMOTH.EQ.IM0.OR.IMOTH.EQ.IM).AND.ISEL.EQ.0) THEN
	- ISON(2)=I
	- ELSEIF ((IMOTH.NE.IM0.AND.IMOTH.NE.IM).AND.ISEL.EQ.0) THEN
	- ISEL=1
	- GOTO 77
	- ENDIF
	- 76 CONTINUE
	- ENDDO
	- 77 CONTINUE
	-C(BPK)--<
	-
	-
	-C ... we correct HEPEVT (fix developped with Catherine BISCARAT)
	-c IF (JDAHEP(2,IM).EQ.0) THEN ! ID of second daughter was missing
	-c ISECU=1
	-c DO I=JDAHEP(1,IM)+1,NHEP ! OK lets look for it
	-c IF (JMOHEP(1,I).EQ.IM.AND.ISECU.EQ.1) THEN ! we have found one
	-c JDAHEP(2,IM)=I
	-c ELSEIF (JMOHEP(1,I).EQ.IM.AND.ISECU.NE.1) THEN ! we have found one after there
	-c JDAHEP(2,IM)=0 ! was something else, lets kill game
	-c ENDIF
	-c IF (JMOHEP(1,I).NE.IM) ISECU=0 ! other stuff starts
	-c ENDDO
	-c ENDIF
	-
	-C ... we check whether there are just two or more tau-likes
	- DO I=ISON(1),ISON(2)
	- IF(IDHEP(I).EQ.-KFTAU.OR.IDHEP(I).EQ.-KFNUE) NCOUNT=NCOUNT+1
	- IF(IDHEP(I).EQ. KFTAU.OR.IDHEP(I).EQ. KFNUE) NCOUNT=NCOUNT+1
	- ENDDO
	-
	-C ... if there will be more we will come here again
	- 666 CONTINUE
	-
	-C(BPK)-->
	- DO I=MAX(NP1+1,ISON(1)),ISON(2)
	-C(BPK)--<
	- IF(IDHEP(I).EQ.-KFTAU.OR.IDHEP(I).EQ.-KFNUE) NP1=I
	- ENDDO
	-C(BPK)-->
	- DO I=MAX(NP2+1,ISON(1)),ISON(2)
	-C(BPK)--<
	- IF(IDHEP(I).EQ. KFTAU.OR.IDHEP(I).EQ. KFNUE) NP2=I
	- ENDDO
	- DO I=1,4
	- P1(I)= PHEP(I,NP1) !momentum of tau+
	- P2(I)= PHEP(I,NP2) !momentum of tau-
	- Q1(I)= P1(I)+P2(I)
	- ENDDO
	-
	- POL1(3)= 0D0
	- POL2(3)= 0D0
	-
	- IF(KEYPOL.EQ.1) THEN
	-c.....include polarisation effect
	- CALL RANMAR(RRR,1)
	-
	- IF(IDHEP(IM).EQ.KFHIGGS(1).OR.IDHEP(IM).EQ.KFHIGGS(2).OR.
	- $ IDHEP(IM).EQ.KFHIGGS(3)) THEN ! case of Higgs
	- IF(RRR(1).LT.0.5) THEN
	- POL1(3)= POL
	- POL2(3)=-POL
	- ELSE
	- POL1(3)=-POL
	- POL2(3)= POL
	- ENDIF
	- ELSEIF((IDHEP(IM).EQ.KFZ0).OR.(IDHEP(IM).EQ.KFGAM)) THEN ! case of gamma/Z
	-C there is no angular dependence in gamma/Z polarization
	-C there is no s-dependence in gamma/Z polarization at all
	-C there is even no Z polarization in any form
	-C main reason is that nobody asked ...
	-C but it is prepared and longitudinal correlations
	-C can be included up to KORALZ standards
	-
	- POLZ0=PLZAPX(.true.,IM,NP1,NP2)
	- IF(RRR(1).LT.POLZ0) THEN
	- POL1(3)= POL
	- POL2(3)= POL
	- ELSE
	- POL1(3)=-POL
	- POL2(3)=-POL
	- ENDIF
	- ELSEIF(IDHEP(NP1).EQ.-IDHEP(NP2))THEN ! undef orig. only s-dep poss.
	- POLZ0=PLZAPX(.true.,IM,NP1,NP2)
	- IF(RRR(1).LT.POLZ0) THEN
	- POL1(3)= POL
	- POL2(3)= POL
	- ELSE
	- POL1(3)=-POL
	- POL2(3)=-POL
	- ENDIF
	- if(ncn.le.ncnmx) print *,
	- & " rrr(1),polz0,pol1(3),pol2(3)= ",
	- & rrr(1),polz0,pol1(3),pol2(3)
	- ELSEIF(ABS(IDHEP(IM)).EQ.KFHIGCH) THEN ! case of charged Higgs
	- POL1(3)= POL
	- POL2(3)= POL
	- ELSE ! case of W+ or W-
	- POL1(3)= -POL
	- POL2(3)= -POL
	- ENDIF
	-c.....include polarisation effect
	- ENDIF
	-
	- IF(IDHEP(IM).EQ.KFHIGGS(1).OR.IDHEP(IM).EQ.KFHIGGS(2).OR.
	- $ IDHEP(IM).EQ.KFHIGGS(3)) THEN
	- IF(IDHEP(NP1).EQ.-KFTAU .AND.
	- $ (JDAHEP(1,NP1).LE.NP1.OR.JDAHEP(1,NP1).GT.NHEP) .AND.
	- $ IDHEP(NP2).EQ. KFTAU .AND.
	- $ (JDAHEP(1,NP2).LE.NP2.OR.JDAHEP(1,NP2).GT.NHEP)
	- $ ) THEN
	- IF (IDHEP(IM).EQ.KFHIGGS(1)) THEN
	- IFPSEUDO= .FALSE.
	- ELSEIF (IDHEP(IM).EQ.KFHIGGS(2)) THEN
	- IFPSEUDO= .FALSE.
	- ELSEIF (IDHEP(IM).EQ.KFHIGGS(3)) THEN
	- IFPSEUDO= .TRUE.
	- ELSE
	- WRITE(,) 'Warning from TAUOLA:'
	- WRITE(,) 'I stop this run, wrong IDHEP(IM)=',
	- $ IDHEP(IM)
	- STOP
	- ENDIF
	- CALL SPINHIGGS(IM,NP1,NP2,IFPSEUDO,Pol1,Pol2)
	- IF (IFPHOT.EQ.1) CALL PHOTOS(IM) ! Bremsstrahlung in Higgs decay
	- ! AFTER adding taus !!
	-
	-
	- ENDIF
	- ELSE
	- IF(IDHEP(NP1).EQ.-KFTAU.AND.
	- $ (JDAHEP(1,NP1).LE.NP1.OR.JDAHEP(1,NP1).GT.NHEP)) THEN
	-C here check on if NP1 was not decayed should be verified
	- CALL DEXAY(1,POL1)
	- IF (IFPHOT.EQ.1) CALL PHOTOS(NP1)
	- CALL TAUPI0(0,1,ION)
	- ENDIF
	-
	- IF(IDHEP(NP2).EQ. KFTAU.AND.
	- $ (JDAHEP(1,NP2).LE.NP2.OR.JDAHEP(1,NP2).GT.NHEP)) THEN
	-C here check on if NP2 was not decayed should be added
	- CALL DEXAY(2,POL2)
	- IF (IFPHOT.EQ.1) CALL PHOTOS(NP2)
	- CALL TAUPI0(0,2,ION)
	- ENDIF
	- ENDIF
	- NCOUNT=NCOUNT-2
	- IF (NCOUNT.GT.0) GOTO 666
	- ENDDO
	-
	- ELSEIF(MODE.EQ.1) THEN
	-C ***********************
	-C
	- CALL DEXAY(100,POL1)
	- CALL DEKAY(100,POL1x)
	- WRITE(IOUT,7002)
	- ENDIF
	-C *****
	- 7001 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'**TAUOLA UNIVERSAL INTERFACE: ***',9X,1H,
	- $ /,' ', 25X,'**VERSION 1.21, September 2005***',9X,1H,
	- $ /,' ', 25X,'AUTHORS: P. Golonka, B. Kersevan, *',9X,1H,
	- $ /,' ', 25X,'T. Pierzchala, E. Richter-Was, ****',9X,1H,
	- $ /,' ', 25X,'*** Z. Was, M. Worek ************',9X,1H,
	- $ /,' ', 25X,'USEFUL DISCUSSIONS, IN PARTICULAR *',9X,1H,
	- $ /,' ', 25X,'WITH C. Biscarat and S. Slabospitzky*',9X,1H,
	- $ /,' ', 25X,'*** are warmly acknowledged *****',9X,1H,
	- $ /,' ', 25X,' ',9X,1H,
	- $ /,' ', 25X,'******* INITIALIZATION *********',9X,1H,
	- $ /,' ',F20.5,5X,'tau polarization switch must be 1 or 0 ',9X,1H,
	- $ /,' ',F20.5,5X,'Higs scalar/pseudo mix CERN-TH/2003-166',9X,1H,
	- $ /,' ',I10, 15X,'PI0 decay switch must be 1 or 0 ',9X,1H,
	- $ /,' ',I10, 15X,'ETA decay switch must be 1 or 0 ',9X,1H,
	- $ /,' ',I10, 15X,'K0S decay switch must be 1 or 0 ',9X,1H,
	- $ /,1X,15(5H*****)/)
	-
	- 7002 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'**TAUOLA UNIVERSAL INTERFACE: ***',9X,1H,
	- $ /,' ', 25X,'**VERSION 1.21, September2005 ***',9X,1H,
	- $ /,' ', 25X,'AUTHORS: P. Golonka, B. Kersevan, *',9X,1H,
	- $ /,' ', 25X,'T. Pierzchala, E. Richter-Was, ****',9X,1H,
	- $ /,' ', 25X,'*** Z. Was, M. Worek ************',9X,1H,
	- $ /,' ', 25X,'USEFUL DISCUSSIONS, IN PARTICULAR *',9X,1H,
	- $ /,' ', 25X,'WITH C. Biscarat and S. Slabospitzky*',9X,1H,
	- $ /,' ', 25X,'*** are warmly acknowledged *****',9X,1H,
	- $ /,' ', 25X,'*** END OF MODULE OPERATION *****',9X,1H,
	- $ /,1X,15(5H*****)/)
	-
	- END
	-
	- SUBROUTINE SPINHIGGS(IM,NP1,NP2,IFPSEUDO,Pol1,Pol2)
	- IMPLICIT double precision(A-H,O-Z)
	- LOGICAL IFPSEUDO
	- double precision HH1,HH2,wthiggs
	- DIMENSION POL1(4), POL2(4),HH1(4),HH2(4), RRR(1)
	-! CALL DEXAY(1,POL1) ! Kept for tests
	-! CALL DEXAY(2,POL2) ! Kept for tests
	- INTEGER ION(3)
	- 10 CONTINUE
	- CALL RANMAR(RRR,1)
	- CALL DEKAY(1,HH1)
	- CALL DEKAY(2,HH2)
	- wt=wthiggs(IFPSEUDO,HH1,HH2)
	- IF (RRR(1).GT.WT) GOTO 10
	- CALL DEKAY(1+10,HH1)
	- CALL TAUPI0(0,1,ION)
	- CALL DEKAY(2+10,HH2)
	- CALL TAUPI0(0,2,ION)
	- END
	- FUNCTION wthiggs(IFPSEUDO,HH1,HH2)
	- IMPLICIT double precision(A-H,O-Z)
	- LOGICAL IFPSEUDO
	- common /pseudocoup/ csc,ssc
	- double precision csc,ssc
	- save pseudocoup
	- double precision HH1(4),HH2(4),R(4,4),wthiggs
	- DO K=1,4
	- DO L=1,4
	- R(K,L)=0
	- ENDDO
	- ENDDO
	- WTHIGGS=0D0
	-
	- R(4,4)= 1D0 ! unpolarized part
	- R(3,3)=-1D0 ! longitudinal
	- ! other missing
	- IF (IFPSEUDO) THEN
	- R(1,1)=-1
	- R(2,2)= -1
	- R(1,1)=(csc2-ssc2)/(csc2+ssc2)
	- R(2,2)=(csc2-ssc2)/(csc2+ssc2)
	- R(1,2)=2cscssc/(csc2+ssc2)
	- R(2,1)=-2cscssc/(csc2+ssc2)
	- ELSE
	- R(1,1)=1
	- R(2,2)=1
	- ENDIF
	-
	-
	-
	- DO K=1,4
	- DO L=1,4
	- WTHIGGS=WTHIGGS+R(K,L)HH1(K)HH2(L)
	- ENDDO
	- ENDDO
	- WTHIGGS=WTHIGGS/4D0
	- END
	-
	- FUNCTION PLZAPX(HOPEin,IM0,NP1,NP2)
	- IMPLICIT double precision(A-H,O-Z)
	-C IM0 NP1 NP2 are the positions of Z/gamma tau tau in hepevt common block.
	-C the purpose of this routine is to calculate polarization of Z along tau direction.
	-C this is highly non-trivial due to necessity of reading infromation from hard process
	-C history in HEPEVT, which is often written not up to the gramatic rules.
	- double precision PLZAPX,PLZAP0,SVAR,COSTHE,sini,sfin,ZPROP2,
	- $ P1(4),P2(4),Q1(4),Q2(4),QQ(4),PH(4),PD1(4),PD2(4),
	- $ PQ1(4),PQ2(4),PB(4),PA(4)
	- INTEGER IM
	- LOGICAL HOPE,HOPEin
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	-
	-C(BPK)--> BROTHERS OF TAU ALREADY FOUND
	- INTEGER ISON
	- COMMON /ISONS_TAU/ISON(2)
	-C(BPK)--<
	-C >>
	-C >> STEP 1: find where are particles in hepevent and pick them up
	-C >>
	- print *, " plzapx point 001 im0,np1,np2 ",
	- & im0,np1,np2
	- HOPE=HOPEin
	-C sometimes shade Z of Z is its mother ...
	- IM=IM0
	- IM00=JMOHEP(1,IM0)
	-C to protect against check on mother of beam particles.
	- IF (IM00.GT.0) THEN
	- IF (IDHEP(IM0).EQ.IDHEP(IM00)) IM=JMOHEP(1,IM0)
	- ENDIF
	-C
	-C find (host generator-level) incoming beam-bare-particles which form Z and co.
	- IMO1=JMOHEP(1,IM)
	- IMO2=JMOHEP(2,IM)
	-
	-C(BPK)--> IN HERWIG THE POINTER MIGHT BE TO HARD CMS
	- IM00=IMO1
	- IF (ISTHEP(IM00).EQ.120) THEN
	- IMO1=JMOHEP(1,IM00)
	- IMO2=JMOHEP(2,IM00)
	- ENDIF
	-C(BPK)--<
	-
	- print *, " plzapx point 001.5 im0,im,im00,im01,im02= ",
	- & im0,im,im00,im01,im02
	- IFFULL=0
	-C case when it was like e+e- --> tau+tau- gammas and e+e- were 'first' in hepevt.
	- IF (IMO1.EQ.0.AND.IMO2.EQ.0) THEN
	- IMO1=JMOHEP(1,NP1)
	-C(BPK)-->
	- IF (IDHEP(IMO1).EQ.IDHEP(NP1)) IMO1=JMOHEP(1,IMO1) ! PROTECT AGAINST COPIES
	-C(BPK)--<
	- IMO2=JMOHEP(2,NP1)
	-C(BPK)-->
	- IF (IDHEP(IMO2).EQ.IDHEP(NP2)) IMO2=JMOHEP(1,IMO2) ! PROTECT AGAINST COPIES
	-C(BPK)--<
	- IFFULL=1
	-C case when it was like qq --> tau+tau- gammas and qq were NOT 'first' in hepevt.
	-
	- ELSEIF (IDHEP(IM).NE.22.AND.IDHEP(IM).NE.23) THEN
	- IMO1=JMOHEP(1,NP1)
	-C(BPK)-->
	- IF (IDHEP(IMO1).EQ.IDHEP(NP1)) IMO1=JMOHEP(1,IMO1) ! PROTECT AGAINST COPIES
	-C(BPK)--<
	- IMO2=JMOHEP(2,NP1)
	-C(BPK)-->
	- IF (IDHEP(IMO2).EQ.IDHEP(NP2)) IMO2=JMOHEP(1,IMO2) ! PROTECT AGAINST COPIES
	-C(BPK)--<
	- IFFULL=1
	- ENDIF
	-
	-
	-C and check if it really happened
	- IF (IMO1.EQ.0) HOPE=.FALSE.
	- IF (IMO2.EQ.0) HOPE=.FALSE.
	- IF (IMO1.EQ.IMO2) HOPE=.FALSE.
	-
	-C
	- DO I=1,4
	- Q1(I)= PHEP(I,NP1) !momentum of tau+
	- Q2(I)= PHEP(I,NP2) !momentum of tau-
	- ENDDO
	-
	-C corrections due to possible differences in 4-momentum of shadow vs true Z.
	-C(BPK)-->
	- IF (IM.EQ.JMOHEP(1,IM0).AND.
	- $ (IDHEP(IM).EQ.22.OR.IDHEP(IM).EQ.23)) THEN
	- DO K=1,4
	- PB(K)=PHEP(K,IM)
	- PA(K)=PHEP(K,IM0)
	- ENDDO
	-C(BPK)--<
	-
	- CALL BOSTDQ( 1,PA, Q1, Q1)
	- CALL BOSTDQ( 1,PA, Q2, Q2)
	- CALL BOSTDQ(-1,PB, Q1, Q1)
	- CALL BOSTDQ(-1,PB, Q2, Q2)
	-
	- ENDIF
	-
	- DO I=1,4
	- QQ(I)= Q1(I)+Q2(I) !momentum of Z
	- IF (HOPE) P1(I)=PHEP(I,IMO1) !momentum of beam1
	- IF (HOPE) P2(I)=PHEP(I,IMO2) !momentum of beam2
	- PH(I)=0D0
	- PD1(I)=0D0
	- PD2(I)=0D0
	- ENDDO
	-! These momenta correspond to quarks, gluons photons or taus
	- IDFQ1=IDHEP(NP1)
	- IDFQ2=IDHEP(NP2)
	- IF (HOPE) IDFP1=IDHEP(IMO1)
	- IF (HOPE) IDFP2=IDHEP(IMO2)
	-
	- SVAR=QQ(4)2-QQ(3)2-QQ(2)2-QQ(1)2
	- IF (.NOT.HOPE) THEN
	-C options which may be useful in some cases of two heavy boson production
	-C need individual considerations. To be developed.
	-C PLZAPX=PLZAP0(11,IDFQ1,SVAR,0D0) ! gamma/Z mixture as if produced from e beam
	-C PLZAPX=PLZAP0(12,IDFQ1,SVAR,0D0) ! pure Z
	- PLZAPX=0.5 ! pure gamma
	- print *, " plzapx point 002 svar,hope,plzapx= ",
	- & svar,hope,plzapx
	- RETURN
	- ENDIF
	-C >>
	-C >> STEP 2 look for brothers of Z which have to be included in effective incoming particles
	-C >>
	-C let us define beginning and end of particles which are produced in parallel to Z
	-C in principle following should work
	-
	-C(BPK)--> ACCOMMODATE FOR HERWIG - IM00 POINTS TO BEAM PARTICLE OR HARD CMS
	- NX1=JDAHEP(1,IM00)
	- NX2=JDAHEP(2,IM00)
	-C but ...
	- INBR=IM ! OK, HARD RECORD Z/GAMMA
	- IF (IFFULL.EQ.1) INBR=NP1 ! OK, NO Z/GAMMA
	- IF (IDHEP(JMOHEP(1,INBR)).EQ.IDHEP(INBR)) INBR=JMOHEP(1,INBR) ! FORCE HARD RECORD
	-C(BPK)--<
	- IF(NX1.EQ.0.OR.NX2.EQ.0) THEN
	- NX1=INBR
	- NX2=INBR
	- DO K=1,INBR-1
	- IF(JMOHEP(1,INBR-K).EQ.JMOHEP(1,INBR)) THEN
	- NX1=INBR-K
	- ELSE
	- GOTO 7
	- ENDIF
	- ENDDO
	- 7 CONTINUE
	-
	- DO K=INBR+1,NHEP
	- IF(JMOHEP(1,K).EQ.JMOHEP(1,INBR)) THEN
	- NX2=K
	- ELSE
	- GOTO 8
	- ENDIF
	- ENDDO
	- 8 CONTINUE
	- ENDIF
	-
	-C case of annihilation of two bosons is hopeles
	- IF (ABS(IDFP1).GE.20.AND.ABS(IDFP2).GE.20) HOPE=.FALSE.
	-C case of annihilation of non-matching flavors is hopeless
	- IF (ABS(IDFP1).LE.20.AND.ABS(IDFP2).LE.20.AND.IDFP1+IDFP2.NE.0)
	- $ HOPE=.FALSE.
	- IF (.NOT.HOPE) THEN
	-C options which may be useful in some cases of two heavy boson production
	-C need individual considerations. To be developed.
	-C PLZAPX=PLZAP0(11,IDFQ1,SVAR,0D0) ! gamma/Z mixture as if produced from e beam
	-C PLZAPX=PLZAP0(12,IDFQ1,SVAR,0D0) ! pure Z
	- PLZAPX=0.5 ! pure gamma
	- print *, " plzapx point 003 idfp1,idfp2,hope,plzapx= ",
	- & idfp1,idfp2,hope,plzapx
	- RETURN
	- ENDIF
	- IF (ABS(IDFP1).LT.20) IDE= IDFP1
	- IF (ABS(IDFP2).LT.20) IDE=-IDFP2
	-
	-
	-C >>
	-C >> STEP 3 we combine gluons, photons into incoming effective beams
	-C >>
	-
	-C in the following we will ignore the possibility of photon emission from taus
	-C however at certain moment it will be necessary to take care of
	-
	- DO L=1,4
	- PD1(L)=P1(L)
	- PD2(L)=P2(L)
	- ENDDO
	-
	- DO L=1,4
	- PQ1(L)=Q1(L)
	- PQ2(L)=Q2(L)
	- ENDDO
	-
	- IFLAV=min(ABS(IDFP1),ABS(IDFP2))
	-
	-*--------------------------------------------------------------------------
	-c IFLAV=min(ABS(IDFP1),ABS(IDFP2))
	-c that means that always quark or lepton i.e. process like
	-c f g(gamma) --> f Z0 --> tau tau
	-c we glue fermions to effective beams that is f f --> Z0 --> tau tau
	-c with gamma/g emission from initial fermion.
	-*---------------------------------------------------------------------------
	-
	- IF (ABS(IDFP1).GE.20) THEN
	- DO k=NX1,NX2
	- IDP=IDHEP(k)
	- IF (ABS(IDP).EQ.IFLAV) THEN
	- DO L=1,4
	- PD1(L)=-PHEP(L,K)
	- ENDDO
	- ENDIF
	- ENDDO
	- ENDIF
	-
	- IF (ABS(IDFP2).GE.20) THEN
	- DO k=NX1,NX2
	- IDP=IDHEP(k)
	- IF (ABS(IDP).EQ.IFLAV) THEN
	- DO L=1,4
	- PD2(L)=-PHEP(L,K)
	- ENDDO
	- ENDIF
	- ENDDO
	- ENDIF
	-
	-C if first beam was boson: gluing
	-
	- IF (ABS(IDFP1).GE.20) THEN
	- DO L=1,4
	- PH(L)=P1(L)
	- ENDDO
	- xm1=abs((PD1(4)+PH(4))2-(PD1(3)+PH(3))2
	- $ -(PD1(2)+PH(2))2-(PD1(1)+PH(1))2)
	- xm2=abs((PD2(4)+PH(4))2-(PD2(3)+PH(3))2
	- $ -(PD2(2)+PH(2))2-(PD2(1)+PH(1))2)
	- IF (XM1.LT.XM2) THEN
	- DO L=1,4
	- PD1(L)=PD1(L)+P1(L)
	- ENDDO
	- ELSE
	- DO L=1,4
	- PD2(L)=PD2(L)+P1(L)
	- ENDDO
	- ENDIF
	- ENDIF
	-
	-C if second beam was boson: gluing
	-
	-
	- IF (ABS(IDFP2).GE.20) THEN
	- DO L=1,4
	- PH(L)=P2(L)
	- ENDDO
	- xm1=abs((PD1(4)+PH(4))2-(PD1(3)+PH(3))2
	- $ -(PD1(2)+PH(2))2-(PD1(1)+PH(1))2)
	- xm2=abs((PD2(4)+PH(4))2-(PD2(3)+PH(3))2
	- $ -(PD2(2)+PH(2))2-(PD2(1)+PH(1))2)
	- IF (XM1.LT.XM2) THEN
	- DO L=1,4
	- PD1(L)=PD1(L)+P2(L)
	- ENDDO
	- ELSE
	- DO L=1,4
	- PD2(L)=PD2(L)+P2(L)
	- ENDDO
	- ENDIF
	- ENDIF
	-
	-C now spectators ...
	-
	-C(BPK)-->
	- NPH1=NP1
	- NPH2=NP2
	- IF (IDHEP(JMOHEP(1,NP1)).EQ.IDHEP(NP1)) NPH1=JMOHEP(1,NP1) ! SHOULD PUT US IN HARD REC.
	- IF (IDHEP(JMOHEP(1,NP2)).EQ.IDHEP(NP2)) NPH2=JMOHEP(1,NP2) ! SHOULD PUT US IN HARD REC.
	-C(BPK)--<
	-
	- DO k=NX1,NX2
	- IF (ABS(IDHEP(K)).NE.IFLAV.AND.K.NE.IM.AND.
	-C(BPK)-->
	- $ K.NE.NPH1.AND.K.NE.NPH2) THEN
	-C(BPK)--<
	- IF(IDHEP(K).EQ.22.AND.IFFULL.EQ.1) THEN
	- DO L=1,4
	- PH(L)=PHEP(L,K)
	- ENDDO
	- xm1=abs((PD1(4)-PH(4))2-(PD1(3)-PH(3))2
	- $ -(PD1(2)-PH(2))2-(PD1(1)-PH(1))2)
	- xm2=abs((PD2(4)-PH(4))2-(PD2(3)-PH(3))2
	- $ -(PD2(2)-PH(2))2-(PD2(1)-PH(1))2)
	- xm3=abs((PQ1(4)+PH(4))2-(PQ1(3)+PH(3))2
	- $ -(PQ1(2)+PH(2))2-(PQ1(1)+PH(1))2)
	- xm4=abs((PQ2(4)+PH(4))2-(PQ2(3)+PH(3))2
	- $ -(PQ2(2)+PH(2))2-(PQ2(1)+PH(1))2)
	-
	-
	- sini=abs((PD1(4)+PD2(4)-PH(4))2-(PD1(3)+PD2(3)-PH(3))2
	- $ -(PD1(2)+PD2(2)-PH(2))2-(PD1(1)+PD2(1)-PH(1))2)
	- sfin=abs((PD1(4)+PD2(4) )2-(PD1(3)+PD2(3) )2
	- $ -(PD1(2)+PD2(2) )2-(PD1(1)+PD2(1) )2)
	-
	- FACINI=ZPROP2(sini)
	- FACFIN=ZPROP2(sfin)
	-
	- XM1=XM1/FACINI
	- XM2=XM2/FACINI
	- XM3=XM3/FACFIN
	- XM4=XM4/FACFIN
	-
	- XM=MIN(XM1,XM2,XM3,XM4)
	- IF (XM1.EQ.XM) THEN
	- DO L=1,4
	- PD1(L)=PD1(L)-PH(L)
	- ENDDO
	- ELSEIF (XM2.EQ.XM) THEN
	- DO L=1,4
	- PD2(L)=PD2(L)-PH(L)
	- ENDDO
	- ELSEIF (XM3.EQ.XM) THEN
	- DO L=1,4
	- Q1(L)=PQ1(L)+PH(L)
	- ENDDO
	- ELSE
	- DO L=1,4
	- Q2(L)=PQ2(L)+PH(L)
	- ENDDO
	- ENDIF
	- ELSE
	- DO L=1,4
	- PH(L)=PHEP(L,K)
	- ENDDO
	- xm1=abs((PD1(4)-PH(4))2-(PD1(3)-PH(3))2
	- $ -(PD1(2)-PH(2))2-(PD1(1)-PH(1))2)
	- xm2=abs((PD2(4)-PH(4))2-(PD2(3)-PH(3))2
	- $ -(PD2(2)-PH(2))2-(PD2(1)-PH(1))2)
	- IF (XM1.LT.XM2) THEN
	- DO L=1,4
	- PD1(L)=PD1(L)-PH(L)
	- ENDDO
	- ELSE
	- DO L=1,4
	- PD2(L)=PD2(L)-PH(L)
	- ENDDO
	- ENDIF
	- ENDIF
	- ENDIF
	- ENDDO
	-
	-
	-C >>
	-C >> STEP 4 look for brothers of tau (sons of Z!) which have to be included in
	-c >> effective outcoming taus
	-C >>
	-C let us define beginning and end of particles which are produced in
	-c parallel to tau
	-
	-
	-
	-C find outcoming particles which come from Z
	-
	-
	-
	-
	-C(BPK)--> OK, IT WOULD HAVE TO BE ALONG TAUS IN HARD RECORD WITH THE SAME MOTHER
	- IF (ABS(IDHEP(IM0)).EQ.22.OR.abs(IDHEP(IM0)).EQ.23) THEN
	- DO K=ISON(1),ISON(2)
	- IF(ABS(IDHEP(K)).EQ.22) THEN
	-C(BPK)--<
	-
	- do l=1,4
	- ph(l)=phep(l,k)
	- enddo
	-
	- xm3=abs((PQ1(4)+PH(4))2-(PQ1(3)+PH(3))2
	- $ -(PQ1(2)+PH(2))2-(PQ1(1)+PH(1))2)
	- xm4=abs((PQ2(4)+PH(4))2-(PQ2(3)+PH(3))2
	- $ -(PQ2(2)+PH(2))2-(PQ2(1)+PH(1))2)
	-
	- XM=MIN(XM3,XM4)
	-
	- IF (XM3.EQ.XM) THEN
	- DO L=1,4
	- Q1(L)=PQ1(L)+PH(L)
	- ENDDO
	- ELSE
	- DO L=1,4
	- Q2(L)=PQ2(L)+PH(L)
	- ENDDO
	- ENDIF
	- endif
	- enddo
	- ENDIF
	-
	-
	-
	-*------------------------------------------------------------------------
	-
	-
	-C out of effective momenta we calculate COSTHE and later polarization
	- CALL ANGULU(PD1,PD2,Q1,Q2,COSTHE)
	-
	- PLZAPX=PLZAP0(IDE,IDFQ1,SVAR,COSTHE)
	- print *, " plzapx point 004 ide,idfq1,svar,costhe,plzapx= ",
	- & ide,idfq1,svar,costhe,plzapx
	- END
	-
	- SUBROUTINE ANGULU(PD1,PD2,Q1,Q2,COSTHE)
	- IMPLICIT double precision(A-H,O-Z)
	- double precision PD1(4),PD2(4),Q1(4),Q2(4),COSTHE,P(4),QQ(4),QT(4)
	-C take effective beam which is less massive, it should be irrelevant
	-C but in case HEPEVT is particulary dirty may help.
	-C this routine calculate reduced system transver and cosine of scattering
	-C angle.
	-
	- XM1=ABS(PD1(4)2-PD1(3)2-PD1(2)2-PD1(1)2)
	- XM2=ABS(PD2(4)2-PD2(3)2-PD2(2)2-PD2(1)2)
	- IF (XM1.LT.XM2) THEN
	- SIGN=1D0
	- DO K=1,4
	- P(K)=PD1(K)
	- ENDDO
	- ELSE
	- SIGN=-1D0
	- DO K=1,4
	- P(K)=PD2(K)
	- ENDDO
	- ENDIF
	-C calculate space like part of P (in Z restframe)
	- DO K=1,4
	- QQ(K)=Q1(k)+Q2(K)
	- QT(K)=Q1(K)-Q2(K)
	- ENDDO
	-
	- XMQQ=SQRT(QQ(4)2-QQ(3)2-QQ(2)2-QQ(1)2)
	-
	- QTXQQ=QT(4)QQ(4)-QT(3)QQ(3)-QT(2)QQ(2)-QT(1)QQ(1)
	- DO K=1,4
	- QT(K)=QT(K)-QQ(K)QTXQQ/XMQQ*2
	- ENDDO
	-
	- PXQQ=P(4)QQ(4)-P(3)QQ(3)-P(2)QQ(2)-P(1)QQ(1)
	- DO K=1,4
	- P(K)=P(K)-QQ(K)PXQQ/XMQQ*2
	- ENDDO
	-C calculate costhe
	- PXP =SQRT(p(1)2+p(2)2+p(3)2-p(4)2)
	- QTXQT=SQRT(QT(3)2+QT(2)2+QT(1)2-QT(4)2)
	- PXQT =P(3)QT(3)+P(2)QT(2)+P(1)QT(1)-P(4)QT(4)
	- COSTHE=PXQT/PXP/QTXQT
	- COSTHE=COSTHE*SIGN
	- END
	-
	- FUNCTION PLZAP0(IDE,IDF,SVAR,COSTH0)
	- IMPLICIT double precision(A-H,O-Z)
	-C this function calculates probability for the helicity +1 +1 configuration
	-C of taus for given Z/gamma transfer and COSTH0 cosine of scattering angle
	- double precision PLZAP0,SVAR,COSTHE,COSTH0
	- double precision T_BORN
	-
	- COSTHE=COSTH0
	-C >>>>> IF (IDE*IDF.LT.0) COSTHE=-COSTH0 ! this is probably not needed ID
	-C >>>>> of first beam is used by T_GIVIZ0 including sign
	- print *, " plzap0 point 001 ide,idf,svar,costh0= ",
	- & ide,idf,svar,costh0
	-
	- IF (IDF.GT.0) THEN
	- CALL INITWK(IDE,IDF,SVAR)
	- ELSE
	- CALL INITWK(-IDE,-IDF,SVAR)
	- ENDIF
	- PLZAP0=T_BORN(0,SVAR,COSTHE,1D0,1D0)
	- $ /(T_BORN(0,SVAR,COSTHE,1D0,1D0)+T_BORN(0,SVAR,COSTHE,-1D0,-1D0))
	-
	-! PLZAP0=0.5
	- END
	- FUNCTION T_BORN(MODE,SVAR,COSTHE,TA,TB)
	-C ----------------------------------------------------------------------
	-C THIS ROUTINE PROVIDES BORN CROSS SECTION. IT HAS THE SAME
	-C STRUCTURE AS FUNTIS AND FUNTIH, THUS CAN BE USED AS SIMPLER
	-C EXAMPLE OF THE METHOD APPLIED THERE
	-C INPUT PARAMETERS ARE: SVAR -- transfer
	-C COSTHE -- cosine of angle between tau+ and 1st beam
	-C TA,TB -- helicity states of tau+ tau-
	-C
	-C called by : BORNY, BORAS, BORNV, WAGA, WEIGHT
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision(A-H,O-Z)
	- COMMON / T_BEAMPM / ENE ,AMIN,AMFIN,IDE,IDF
	- double precision ENE ,AMIN,AMFIN
	- COMMON / T_GAUSPM /SS,POLN,T3E,QE,T3F,QF
	- & ,XUPGI ,XUPZI ,XUPGF ,XUPZF
	- & ,NDIAG0,NDIAGA,KEYA,KEYZ
	- & ,ITCE,JTCE,ITCF,JTCF,KOLOR
	- double precision SS,POLN,T3E,QE,T3F,QF
	- & ,XUPGI(2),XUPZI(2),XUPGF(2),XUPZF(2)
	- double precision SEPS1,SEPS2
	-C=====================================================================
	- COMMON / T_GSWPRM /SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	- double precision SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	-C SWSQ = sin2 (theta Weinberg)
	-C AMW,AMZ = W & Z boson masses respectively
	-C AMH = the Higgs mass
	-C AMTOP = the top mass
	-C GAMMZ = Z0 width
	- COMPLEX*16 ABORN(2,2),APHOT(2,2),AZETT(2,2)
	- COMPLEX*16 XUPZFP(2),XUPZIP(2)
	- COMPLEX*16 ABORNM(2,2),APHOTM(2,2),AZETTM(2,2)
	- COMPLEX*16 PROPA,PROPZ
	- COMPLEX*16 XR,XI
	- COMPLEX*16 XUPF,XUPI,XFF(4),XFEM,XFOTA,XRHO,XKE,XKF,XKEF
	- COMPLEX*16 XTHING,XVE,XVF,XVEF
	- DATA XI/(0.D0,1.D0)/,XR/(1.D0,0.D0)/
	- DATA MODE0 /-5/
	- DATA IDE0 /-55/
	- DATA SVAR0,COST0 /-5.D0,-6.D0/
	- DATA PI /3.141592653589793238462643D0/
	- DATA SEPS1,SEPS2 /0D0,0D0/
	-C
	-C MEMORIZATION =========================================================
	- IF ( MODE.NE.MODE0.OR.SVAR.NE.SVAR0.OR.COSTHE.NE.COST0
	- $ .OR.IDE0.NE.IDE)THEN
	-C
	- KEYGSW=1
	-C ** PROPAGATORS
	- IDE0=IDE
	- MODE0=MODE
	- SVAR0=SVAR
	- COST0=COSTHE
	- SINTHE=SQRT(1.D0-COSTHE**2)
	- BETA=SQRT(MAX(0D0,1D0-4D0AMFIN*2/SVAR))
	-C I MULTIPLY AXIAL COUPLING BY BETA FACTOR.
	- XUPZFP(1)=0.5D0(XUPZF(1)+XUPZF(2))+0.5BETA*(XUPZF(1)-XUPZF(2))
	- XUPZFP(2)=0.5D0(XUPZF(1)+XUPZF(2))-0.5BETA*(XUPZF(1)-XUPZF(2))
	- XUPZIP(1)=0.5D0(XUPZI(1)+XUPZI(2))+0.5(XUPZI(1)-XUPZI(2))
	- XUPZIP(2)=0.5D0(XUPZI(1)+XUPZI(2))-0.5(XUPZI(1)-XUPZI(2))
	-C FINAL STATE VECTOR COUPLING
	- XUPF =0.5D0*(XUPZF(1)+XUPZF(2))
	- XUPI =0.5D0*(XUPZI(1)+XUPZI(2))
	- XTHING =0D0
	-
	- PROPA =1D0/SVAR
	- PROPZ =1D0/DCMPLX(SVAR-AMZ*2,SVAR/AMZGAMMZ)
	- IF (KEYGSW.EQ.0) PROPZ=0.D0
	- DO 50 I=1,2
	- DO 50 J=1,2
	- REGULA= (3-2I)(3-2*J) + COSTHE
	- REGULM=-(3-2I)(3-2J) SINTHE 2.D0AMFIN/SQRT(SVAR)
	- APHOT(I,J)=PROPA(XUPGI(I)XUPGF(J)*REGULA)
	- AZETT(I,J)=PROPZ(XUPZIP(I)XUPZFP(J)+XTHING)*REGULA
	- ABORN(I,J)=APHOT(I,J)+AZETT(I,J)
	- APHOTM(I,J)=PROPADCMPLX(0D0,1D0)XUPGI(I)XUPGF(J)REGULM
	- AZETTM(I,J)=PROPZDCMPLX(0D0,1D0)(XUPZIP(I)XUPF+XTHING)REGULM
	- ABORNM(I,J)=APHOTM(I,J)+AZETTM(I,J)
	- 50 CONTINUE
	- ENDIF
	-C
	-C******************
	-C* IN CALCULATING CROSS SECTION ONLY DIAGONAL ELEMENTS
	-C* OF THE SPIN DENSITY MATRICES ENTER (LONGITUD. POL. ONLY.)
	-C* HELICITY CONSERVATION EXPLICITLY OBEYED
	- POLAR1= (SEPS1)
	- POLAR2= (-SEPS2)
	- BORN=0D0
	- DO 150 I=1,2
	- HELIC= 3-2*I
	- DO 150 J=1,2
	- HELIT=3-2*J
	- FACTOR=KOLOR(1D0+HELICPOLAR1)(1D0-HELICPOLAR2)/4D0
	- FACTOM=FACTOR(1+HELITTA)(1-HELITTB)
	- FACTOR=FACTOR(1+HELITTA)(1+HELITTB)
	-
	- BORN=BORN+CDABS(ABORN(I,J))*2FACTOR
	-C MASS TERM IN BORN
	- IF (MODE.GE.1) THEN
	- BORN=BORN+CDABS(ABORNM(I,J))*2FACTOM
	- ENDIF
	-
	- 150 CONTINUE
	-C************
	- FUNT=BORN
	- IF(FUNT.LT.0.D0) FUNT=BORN
	-
	-C
	- IF (SVAR.GT.4D0AMFIN*2) THEN
	-C PHASE SPACE THRESHOLD FACTOR
	- THRESH=SQRT(1-4D0AMFIN*2/SVAR)
	- T_BORN= FUNTSVAR2THRESH
	- ELSE
	- THRESH=0.D0
	- T_BORN=0.D0
	- ENDIF
	-C ZW HERE WAS AN ERROR 19. 05. 1989
	-! write(,) 'KKKK ',PROPA,PROPZ,XUPGI,XUPGF,XUPZI,XUPZF
	-! write(,) 'KKKK X',svar,costhe,TA,TB,T_BORN
	- END
	-
	- SUBROUTINE INITWK(IDEX,IDFX,SVAR)
	-! initialization routine coupling masses etc.
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / T_BEAMPM / ENE ,AMIN,AMFIN,IDE,IDF
	- double precision ENE ,AMIN,AMFIN
	- COMMON / T_GAUSPM /SS,POLN,T3E,QE,T3F,QF
	- & ,XUPGI ,XUPZI ,XUPGF ,XUPZF
	- & ,NDIAG0,NDIAGA,KEYA,KEYZ
	- & ,ITCE,JTCE,ITCF,JTCF,KOLOR
	- double precision SS,POLN,T3E,QE,T3F,QF
	- & ,XUPGI(2),XUPZI(2),XUPGF(2),XUPZF(2)
	- COMMON / T_GSWPRM /SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	- double precision SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	-C SWSQ = sin2 (theta Weinberg)
	-C AMW,AMZ = W & Z boson masses respectively
	-C AMH = the Higgs mass
	-C AMTOP = the top mass
	-C GAMMZ = Z0 width
	-C
	- print *, " initwk point 001 idex,idfx,svar= ", idex,idfx,svar
	- ENE=SQRT(SVAR)/2
	- AMIN=0.511D-3
	- SWSQ=0.23147
	- AMZ=91.1882
	- GAMMZ=2.4952
	- IF (IDFX.EQ. 15) then
	- IDF=2 ! denotes tau +2 tau-
	- AMFIN=1.77703 !this mass is irrelevant if small, used in ME only
	- ELSEIF (IDFX.EQ.-15) then
	- IDF=-2 ! denotes tau -2 tau-
	- AMFIN=1.77703 !this mass is irrelevant if small, used in ME only
	- ELSE
	- WRITE(,) 'INITWK: WRONG IDFX'
	- STOP
	- ENDIF
	-
	- IF (IDEX.EQ. 11) then !electron
	- IDE= 2
	- AMIN=0.511D-3
	- ELSEIF (IDEX.EQ.-11) then !positron
	- IDE=-2
	- AMIN=0.511D-3
	- ELSEIF (IDEX.EQ. 13) then !mu+
	- IDE= 2
	- AMIN=0.105659
	- ELSEIF (IDEX.EQ.-13) then !mu-
	- IDE=-2
	- AMIN=0.105659
	- ELSEIF (IDEX.EQ. 1) then !d
	- IDE= 4
	- AMIN=0.05D0
	- ELSEIF (IDEX.EQ.- 1) then !d~
	- IDE=-4
	- AMIN=0.05D0
	- ELSEIF (IDEX.EQ. 2) then !u
	- IDE= 3
	- AMIN=0.02D0
	- ELSEIF (IDEX.EQ.- 2) then !u~
	- IDE=-3
	- AMIN=0.02D0
	- ELSEIF (IDEX.EQ. 3) then !s
	- IDE= 4
	- AMIN=0.3
	- ELSEIF (IDEX.EQ.- 3) then !s~
	- IDE=-4
	- AMIN=0.3
	- ELSEIF (IDEX.EQ. 4) then !c
	- IDE= 3
	- AMIN=1.3
	- ELSEIF (IDEX.EQ.- 4) then !c~
	- IDE=-3
	- AMIN=1.3
	- ELSEIF (IDEX.EQ. 5) then !b
	- IDE= 4
	- AMIN=4.5
	- ELSEIF (IDEX.EQ.- 5) then !b~
	- IDE=-4
	- AMIN=4.5
	- ELSEIF (IDEX.EQ. 12) then !nu_e
	- IDE= 1
	- AMIN=0.1D-3
	- ELSEIF (IDEX.EQ.- 12) then !nu_e~
	- IDE=-1
	- AMIN=0.1D-3
	- ELSEIF (IDEX.EQ. 14) then !nu_mu
	- IDE= 1
	- AMIN=0.1D-3
	- ELSEIF (IDEX.EQ.- 14) then !nu_mu~
	- IDE=-1
	- AMIN=0.1D-3
	- ELSEIF (IDEX.EQ. 16) then !nu_tau
	- IDE= 1
	- AMIN=0.1D-3
	- ELSEIF (IDEX.EQ.- 16) then !nu_tau~
	- IDE=-1
	- AMIN=0.1D-3
	-
	- ELSE
	- WRITE(,) 'INITWK: WRONG IDEX'
	- STOP
	- ENDIF
	-
	-C ----------------------------------------------------------------------
	-C
	-C INITIALISATION OF COUPLING CONSTANTS AND FERMION-GAMMA / Z0 VERTEX
	-C
	-C called by : KORALZ
	-C ----------------------------------------------------------------------
	- ITCE=IDE/IABS(IDE)
	- JTCE=(1-ITCE)/2
	- ITCF=IDF/IABS(IDF)
	- JTCF=(1-ITCF)/2
	- CALL T_GIVIZO( IDE, 1,AIZOR,QE,KDUMM)
	- print *, " initwk point 002 ide,aizor,qe= ", ide,aizor,qe
	- CALL T_GIVIZO( IDE,-1,AIZOL,QE,KDUMM)
	- print *, " initwk point 003 ide,aizol,qe= ", ide,aizor,qe
	- XUPGI(1)=QE
	- XUPGI(2)=QE
	- T3E = AIZOL+AIZOR
	- XUPZI(1)=(AIZOR-QESWSQ)/SQRT(SWSQ(1-SWSQ))
	- XUPZI(2)=(AIZOL-QESWSQ)/SQRT(SWSQ(1-SWSQ))
	- CALL T_GIVIZO( IDF, 1,AIZOR,QF,KOLOR)
	- CALL T_GIVIZO( IDF,-1,AIZOL,QF,KOLOR)
	- XUPGF(1)=QF
	- XUPGF(2)=QF
	- T3F = AIZOL+AIZOR
	- XUPZF(1)=(AIZOR-QFSWSQ)/SQRT(SWSQ(1-SWSQ))
	- XUPZF(2)=(AIZOL-QFSWSQ)/SQRT(SWSQ(1-SWSQ))
	-C
	- NDIAG0=2
	- NDIAGA=11
	- KEYA = 1
	- KEYZ = 1
	-C
	-C
	- RETURN
	- END
	-
	- SUBROUTINE T_GIVIZO(IDFERM,IHELIC,SIZO3,CHARGE,KOLOR)
	-C ----------------------------------------------------------------------
	-C PROVIDES ELECTRIC CHARGE AND WEAK IZOSPIN OF A FAMILY FERMION
	-C IDFERM=1,2,3,4 DENOTES NEUTRINO, LEPTON, UP AND DOWN QUARK
	-C NEGATIVE IDFERM=-1,-2,-3,-4, DENOTES ANTIPARTICLE
	-C IHELIC=+1,-1 DENOTES RIGHT AND LEFT HANDEDNES ( CHIRALITY)
	-C SIZO3 IS THIRD PROJECTION OF WEAK IZOSPIN (PLUS MINUS HALF)
	-C AND CHARGE IS ELECTRIC CHARGE IN UNITS OF ELECTRON CHARGE
	-C KOLOR IS A QCD COLOUR, 1 FOR LEPTON, 3 FOR QUARKS
	-C
	-C called by : EVENTE, EVENTM, FUNTIH, .....
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision(A-H,O-Z)
	-C
	- IF(IDFERM.EQ.0.OR.IABS(IDFERM).GT.4) GOTO 901
	- IF(IABS(IHELIC).NE.1) GOTO 901
	- IH =IHELIC
	- IDTYPE =IABS(IDFERM)
	- IC =IDFERM/IDTYPE
	- LEPQUA=INT(IDTYPE*0.4999999D0)
	- IUPDOW=IDTYPE-2*LEPQUA-1
	- CHARGE =(-IUPDOW+2D0/3D0LEPQUA)IC
	- SIZO3 =0.25D0(IC-IH)(1-2*IUPDOW)
	- KOLOR=1+2*LEPQUA
	-C** NOTE THAT CONVENTIONALY Z0 COUPLING IS
	-C** XOUPZ=(SIZO3-CHARGESWSQ)/SQRT(SWSQ(1-SWSQ))
	- RETURN
	- 901 PRINT *,' STOP IN GIVIZO: WRONG PARAMS.'
	- STOP
	- END
	- SUBROUTINE PHYFIX(NSTOP,NSTART)
	- IMPLICIT double precision(A-H,O-Z)
	- COMMON/LUJETS/N,K(4000,5),P(4000,5),V(4000,5)
	- SAVE /LUJETS/
	-C NSTOP NSTART : when PHYTIA history ends and event starts.
	- NSTOP=0
	- NSTART=1
	- DO I=1, N
	- IF(K(I,1).NE.21) THEN
	- NSTOP = I-1
	- NSTART= I
	- GOTO 500
	- ENDIF
	- ENDDO
	- 500 CONTINUE
	- END
	- SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
	-C ----------------------------------------------------------------------
	-C this subroutine fills one entry into the HEPEVT common
	-C and updates the information for affected mother entries
	-C
	-C written by Martin W. Gruenewald (91/01/28)
	-C
	-C called by : ZTOHEP,BTOHEP,DWLUxy
	-C ----------------------------------------------------------------------
	-C
	-C this is the hepevt class in old style. No d_h_ class pre-name
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- implicit none
	- integer n, ist, id, jmo1, jmo2, jda1, jda2
	- integer ihep, i, ip
	- double precision pinv
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	-
	- LOGICAL PHFLAG
	-C
	- double precision P4(4)
	-C
	-C check address mode
	- IF (N.EQ.0) THEN
	-C
	-C append mode
	- IHEP=NHEP+1
	- ELSE IF (N.GT.0) THEN
	-C
	-C absolute position
	- IHEP=N
	- ELSE
	-C
	-C relative position
	- IHEP=NHEP+N
	- END IF
	-C
	-C check on IHEP
	- IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
	-C
	-C add entry
	- NHEP=IHEP
	- ISTHEP(IHEP)=IST
	- IDHEP(IHEP)=ID
	- JMOHEP(1,IHEP)=JMO1
	- IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
	- JMOHEP(2,IHEP)=JMO2
	- IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
	- JDAHEP(1,IHEP)=JDA1
	- JDAHEP(2,IHEP)=JDA2
	-C
	- DO I=1,4
	- PHEP(I,IHEP)=P4(I)
	-C
	-C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
	- VHEP(I,IHEP)=0.0D0
	- END DO
	- PHEP(5,IHEP)=PINV
	-C FLAG FOR PHOTOS...
	- QEDRAD(IHEP)=PHFLAG
	-C
	-C update process:
	- DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
	- IF(IP.GT.0)THEN
	-C
	-C if there is a daughter at IHEP, mother entry at IP has decayed
	- IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
	-C
	-C and daughter pointers of mother entry must be updated
	- IF(JDAHEP(1,IP).EQ.0)THEN
	- JDAHEP(1,IP)=IHEP
	- JDAHEP(2,IP)=IHEP
	- ELSE
	- JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
	- END IF
	- END IF
	- END DO
	-C
	- RETURN
	- END
	-
	-
	- FUNCTION IHEPDIM(DUM)
	- IMPLICIT double precision(A-H,O-Z)
	-C this is the hepevt class in old style. No d_h_ class pre-name
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	- IHEPDIM=NHEP
	- END
	- FUNCTION ZPROP2(S)
	- IMPLICIT double precision(A-H,O-Z)
	- COMPLEX*16 CPRZ0,CPRZ0M
	- AMZ=91.1882
	- GAMMZ=2.49
	- CPRZ0=DCMPLX((S-AMZ*2),S/AMZGAMMZ)
	- CPRZ0M=1/CPRZ0
	- ZPROP2=(ABS(CPRZ0M))**2
	- END
	-
	- SUBROUTINE TAUPI0(MODE,JAK,ION)
	- IMPLICIT double precision(A-H,O-Z)
	-C no initialization required. Must be called once after every:
	-C 1) CALL DEKAY(1+10,...)
	-C 2) CALL DEKAY(2+10,...)
	-C 3) CALL DEXAY(1,...)
	-C 4) CALL DEXAY(2,...)
	-C subroutine to decay originating from TAUOLA's taus:
	-C 1) etas (with CALL TAUETA(JAK))
	-C 2) later pi0's from taus.
	-C 3) extensions to other applications possible.
	-C this routine belongs to >tauola universal interface<, but uses
	-C routines from >tauola< utilities as well. 25.08.2005
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	-
	-C position of taus, must be defined by host program:
	- COMMON /TAUPOS/ NP1,NP2
	-c
	- double precision PHOT1(4),PHOT2(4)
	- double precision R,X(4),Y(4),PI0(4)
	- INTEGER JEZELI(3),ION(3)
	- DATA JEZELI /0,0,0/
	- SAVE JEZELI
	- IF (MODE.EQ.-1) THEN
	- JEZELI(1)=ION(1)
	- JEZELI(2)=ION(2)
	- JEZELI(3)=ION(3)
	- RETURN
	- ENDIF
	- IF (JEZELI(1).EQ.0) RETURN
	- IF (JEZELI(2).EQ.1) CALL TAUETA(JAK)
	- IF (JEZELI(3).EQ.1) CALL TAUK0S(JAK)
	-C position of decaying particle:
	- IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	- nhepM=nhep ! to avoid infinite loop
	- DO K=JDAHEP(1,NPS),nhepM ! we search for pi0's from tau till eor.
	- IF (IDHEP(K).EQ.111.AND.JDAHEP(1,K).LE.K) THEN ! IF we found pi0
	- DO L=1,4
	- PI0(L)= phep(L,K)
	- ENDDO
	-! random 3 vector on the sphere, masless
	- R=SQRT(PI0(4)2-PI0(3)2-PI0(2)2-PI0(1)2)/2D0
	- CALL SPHERD(R,X)
	- X(4)=R
	- Y(4)=R
	-
	- Y(1)=-X(1)
	- Y(2)=-X(2)
	- Y(3)=-X(3)
	-! boost to lab
	- CALL bostdq(-1,PI0,X,X)
	- CALL bostdq(-1,PI0,Y,Y)
	- DO L=1,4
	- PHOT1(L)=X(L)
	- PHOT2(L)=Y(L)
	- ENDDO
	-C to hepevt
	- CALL FILHEP(0,1,22,K,K,0,0,PHOT1,0.0D0,.TRUE.)
	- CALL FILHEP(0,1,22,K,K,0,0,PHOT2,0.0D0,.TRUE.)
	- ENDIF
	- ENDDO
	-C
	- END
	- SUBROUTINE TAUETA(JAK)
	- IMPLICIT double precision(A-H,O-Z)
	-C subroutine to decay etas's from taus.
	-C this routine belongs to tauola universal interface, but uses
	-C routines from tauola utilities. Just flat phase space, but 4 channels.
	-C it is called at the beginning of SUBR. TAUPI0(JAK)
	-C and as far as hepevt search it is basically the same as TAUPI0. 25.08.2005
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-*
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-
	-C position of taus, must be defined by host program:
	- COMMON /TAUPOS/ NP1,NP2
	-c
	- double precision RRR(1),BRSUM(3), RR(2)
	- double precision PHOT1(4),PHOT2(4),PHOT3(4)
	- double precision X(4), Y(4), Z(4)
	- double precision YM1,YM2,YM3
	- double precision R,RU,PETA(4),XM1,XM2,XM3,XM,XLAM,AM2
	- double precision a,b,c
	- XLAM(a,b,c)=SQRT(ABS((a-b-c)*2-4.0b*c))
	-C position of decaying particle:
	- IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	- nhepM=nhep ! to avoid infinite loop
	- DO K=JDAHEP(1,NPS),nhepM ! we search for etas's from tau till eor.
	- IF (IDHEP(K).EQ.221.AND.JDAHEP(1,K).LE.K) THEN ! IF we found eta
	- DO L=1,4
	- PETA(L)= phep(L,K) ! eta 4 momentum
	- ENDDO
	-C eta cumulated branching ratios:
	- BRSUM(1)=0.389 ! gamma gamma
	- BRSUM(2)=BRSUM(1)+0.319 ! 3 pi0
	- BRSUM(3)=BRSUM(2)+0.237 ! pi+ pi- pi0 rest is thus pi+pi-gamma
	- CALL RANMAR(RRR,1)
	-
	- IF (RRR(1).LT.BRSUM(1)) THEN ! gamma gamma channel exactly like pi0
	-! random 3 vector on the sphere, masless
	- R=SQRT(PETA(4)2-PETA(3)2-PETA(2)2-PETA(1)2)/2D0
	- CALL SPHERD(R,X)
	- X(4)=R
	- Y(4)=R
	-
	- Y(1)=-X(1)
	- Y(2)=-X(2)
	- Y(3)=-X(3)
	-! boost to lab
	- CALL bostdq(-1,PETA,X,X)
	- CALL bostdq(-1,PETA,Y,Y)
	- DO L=1,4
	- PHOT1(L)=X(L)
	- PHOT2(L)=Y(L)
	- ENDDO
	-C to hepevt
	- CALL FILHEP(0,1,22,K,K,0,0,PHOT1,0.0D0,.TRUE.)
	- CALL FILHEP(0,1,22,K,K,0,0,PHOT2,0.0D0,.TRUE.)
	- ELSE ! 3 body channels
	- IF(RRR(1).LT.BRSUM(2)) THEN ! 3 pi0
	- ID1= 111
	- ID2= 111
	- ID3= 111
	- XM1=AMPIZ ! masses
	- XM2=AMPIZ
	- XM3=AMPIZ
	- ELSEIF(RRR(1).LT.BRSUM(3)) THEN ! pi+ pi- pi0
	- ID1= 211
	- ID2=-211
	- ID3= 111
	- XM1=AMPI ! masses
	- XM2=AMPI
	- XM3=AMPIZ
	- ELSE ! pi+ pi- gamma
	- ID1= 211
	- ID2=-211
	- ID3= 22
	- XM1=AMPI ! masses
	- XM2=AMPI
	- XM3=0.0D0
	- ENDIF
	- 7 CONTINUE ! we generate mass of the first pair:
	- CALL RANMAR(RR,2)
	- R=SQRT(PETA(4)2-PETA(3)2-PETA(2)2-PETA(1)2)
	- AMIN=XM1+XM2
	- AMAX=R-XM3
	- AM2=SQRT(AMIN*2+RR(1)(AMAX2-AMIN2))
	-C weight for flat phase space
	- WT=XLAM(R2,AM22,XM3*2)XLAM(AM22,XM12,XM2**2)
	- & /R2 /AM22
	- IF (RR(2).GT.WT) GOTO 7
	-
	- RU=XLAM(AM22,XM12,XM2**2)/AM2/2 ! momenta of the
	- ! first two products
	- ! in the rest frame of that pair
	- CALL SPHERD(RU,X)
	- X(4)=SQRT(RU2+XM12)
	- Y(4)=SQRT(RU2+XM22)
	-
	- Y(1)=-X(1)
	- Y(2)=-X(2)
	- Y(3)=-X(3)
	-C generate momentum of that pair in rest frame of eta:
	- RU=XLAM(R2,AM22,XM3**2)/R/2
	- CALL SPHERD(RU,Z)
	- Z(4)=SQRT(RU2+AM22)
	-C and boost first two decay products to rest frame of eta.
	- CALL bostdq(-1,Z,X,X)
	- CALL bostdq(-1,Z,Y,Y)
	-C redefine Z(4) to 4-momentum of the last decay product:
	- Z(1)=-Z(1)
	- Z(2)=-Z(2)
	- Z(3)=-Z(3)
	- Z(4)=SQRT(RU2+XM32)
	-C boost all to lab; also masses
	- CALL bostdq(-1,PETA,X,X)
	- CALL bostdq(-1,PETA,Y,Y)
	- CALL bostdq(-1,PETA,Z,Z)
	- DO L=1,4
	- PHOT1(L)=X(L)
	- PHOT2(L)=Y(L)
	- PHOT3(L)=Z(L)
	- ENDDO
	- YM1=XM1
	- YM2=XM2
	- YM3=XM3
	-C to hepevt
	- CALL FILHEP(0,1,ID1,K,K,0,0,PHOT1,YM1,.TRUE.)
	- CALL FILHEP(0,1,ID2,K,K,0,0,PHOT2,YM2,.TRUE.)
	- CALL FILHEP(0,1,ID3,K,K,0,0,PHOT3,YM3,.TRUE.)
	- ENDIF
	-
	- ENDIF
	- ENDDO
	-C
	- END
	- SUBROUTINE TAUK0S(JAK)
	- IMPLICIT double precision(A-H,O-Z)
	-C subroutine to decay K0S's from taus.
	-C this routine belongs to tauola universal interface, but uses
	-C routines from tauola utilities. Just flat phase space, but 4 channels.
	-C it is called at the beginning of SUBR. TAUPI0(JAK)
	-C and as far as hepevt search it is basically the same as TAUPI0. 25.08.2005
	-C this is the hepevt class in old style. No d_h_ class pre-name
	- INTEGER NMXHEP
	- PARAMETER (NMXHEP=4000)
	- double precision phep, vhep
	- INTEGER nevhep,nhep,isthep,idhep,jmohep,
	- $ jdahep
	- COMMON /hepevt/
	- $ nevhep, ! serial number
	- $ nhep, ! number of particles
	- $ isthep(nmxhep), ! status code
	- $ idhep(nmxhep), ! particle ident KF
	- $ jmohep(2,nmxhep), ! parent particles
	- $ jdahep(2,nmxhep), ! childreen particles
	- $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	- $ vhep(4,nmxhep) ! vertex [mm]
	-* ----------------------------------------------------------------------
	- LOGICAL qedrad
	- COMMON /phoqed/
	- $ qedrad(nmxhep) ! Photos flag
	-* ----------------------------------------------------------------------
	- SAVE hepevt,phoqed
	-
	-
	-
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-*
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-
	-C position of taus, must be defined by host program:
	- COMMON /TAUPOS/ NP1,NP2
	-c
	- double precision RRR(1),BRSUM(3), RR(2)
	- double precision PHOT1(4),PHOT2(4),PHOT3(4)
	- double precision X(4), Y(4), Z(4)
	- double precision YM1,YM2,YM3
	- double precision R,RU,PETA(4),XM1,XM2,XM3,XM,XLAM
	- double precision a,b,c
	- XLAM(a,b,c)=SQRT(ABS((a-b-c)*2-4.0b*c))
	-C position of decaying particle:
	- IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	- nhepM=nhep ! to avoid infinite loop
	- DO K=JDAHEP(1,NPS),nhepM ! we search for K0S's from tau till eor.
	- IF (IDHEP(K).EQ.310.AND.JDAHEP(1,K).LE.K) THEN ! IF we found K0S
	-
	-
	- DO L=1,4
	- PETA(L)= phep(L,K) ! K0S 4 momentum (this is cloned from eta decay)
	- ENDDO
	-C K0S cumulated branching ratios:
	- BRSUM(1)=0.313 ! 2 PI0
	- BRSUM(2)=1.0 ! BRSUM(1)+0.319 ! Pi+ PI-
	- BRSUM(3)=BRSUM(2)+0.237 ! pi+ pi- pi0 rest is thus pi+pi-gamma
	- CALL RANMAR(RRR,1)
	-
	- IF(RRR(1).LT.BRSUM(1)) THEN ! 2 pi0
	- ID1= 111
	- ID2= 111
	- XM1=AMPIZ ! masses
	- XM2=AMPIZ
	- ELSEIF(RRR(1).LT.BRSUM(2)) THEN ! pi+ pi-
	- ID1= 211
	- ID2=-211
	- XM1=AMPI ! masses
	- XM2=AMPI
	- ELSE ! gamma gamma unused !!!
	- ID1= 22
	- ID2= 22
	- XM1= 0.0D0 ! masses
	- XM2= 0.0D0
	- ENDIF
	-
	-! random 3 vector on the sphere, of equal mass !!
	- R=SQRT(PETA(4)2-PETA(3)2-PETA(2)2-PETA(1)2)/2D0
	- R4=R
	- R=SQRT(ABS(R2-XM12))
	- CALL SPHERD(R,X)
	- X(4)=R4
	- Y(4)=R4
	-
	- Y(1)=-X(1)
	- Y(2)=-X(2)
	- Y(3)=-X(3)
	-! boost to lab
	- CALL bostdq(-1,PETA,X,X)
	- CALL bostdq(-1,PETA,Y,Y)
	- DO L=1,4
	- PHOT1(L)=X(L)
	- PHOT2(L)=Y(L)
	- ENDDO
	-
	- YM1=XM1
	- YM2=XM2
	-C to hepevt
	- CALL FILHEP(0,1,ID1,K,K,0,0,PHOT1,YM1,.TRUE.)
	- CALL FILHEP(0,1,ID2,K,K,0,0,PHOT2,YM2,.TRUE.)
	-
	-C
	- ENDIF
	- ENDDO
	-
	- END
	Index: trunk/tauola/Makefile.am
	===================================================================
	--- trunk/tauola/Makefile.am (revision 8888)
	+++ trunk/tauola/Makefile.am (revision 8889)
	@@ -1,80 +0,0 @@
	-## Makefile.am -- Makefile for WHIZARD
	-##
	-## Process this file with automake to produce Makefile.in
	-##
	-########################################################################
	-#
	-# Copyright (C) 1999-2023 by
	-# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	-# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	-# Juergen Reuter <juergen.reuter@desy.de>
	-# with contributions from
	-# cf. main AUTHORS file
	-#
	-# WHIZARD is free software; you can redistribute it and/or modify it
	-# under the terms of the GNU General Public License as published by
	-# the Free Software Foundation; either version 2, or (at your option)
	-# any later version.
	-#
	-# WHIZARD is distributed in the hope that it will be useful, but
	-# WITHOUT ANY WARRANTY; without even the implied warranty of
	-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	-# GNU General Public License for more details.
	-#
	-# You should have received a copy of the GNU General Public License
	-# along with this program; if not, write to the Free Software
	-# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	-#
	-########################################################################
	-
	-## The files in this directory end up in an auxiliary libtool library.
	-#AM_FFLAGS = -fno-automatic -ffixed-line-length-132 -fno-backslash -fPIC
	-AM_FFLAGS =
	-AM_FCFLAGS =
	-
	-if PYTHIA6_AVAILABLE
	-
	-if FC_IS_NAG
	-AM_FFLAGS += -dcfuns -w
	-AM_FCFLAGS += -dcfuns -w
	-endif
	-
	-noinst_LTLIBRARIES = libtauola_wo.la
	-
	-libtauola_wo_la_SOURCES = \
	- tauface-jetset.f formf.f photos.f tauola.f tauola_photos_ini.f
	-
	-else
	-
	-noinst_LTLIBRARIES = libtauola_wo_dummy.la
	-libtauola_wo_dummy_la_SOURCES = tauola_dummy.f90
	-
	-endif
	-########################################################################
	-## Default Fortran compiler options
	-
	-## Profiling
	-if FC_USE_PROFILING
	-AM_FFLAGS += $(FCFLAGS_PROFILING)
	-AM_FCFLAGS += $(FCFLAGS_PROFILING)
	-endif
	-
	-## OpenMP
	-if FC_USE_OPENMP
	-AM_FFLAGS += $(FCFLAGS_OPENMP)
	-AM_FCFLAGS += $(FCFLAGS_OPENMP)
	-endif
	-
	-########################################################################
	-## Non-standard cleanup tasks
	-
	-## Remove F90 module files
	-clean-local:
	- -rm -f *.$(FC_MODULE_EXT)
	-if FC_SUBMODULES
	- -rm -f *.smod
	-endif
	-
	-## Remove backup files
	-maintainer-clean-local:
	- -rm -f *~
	Index: trunk/tauola/tauola.f
	===================================================================
	--- trunk/tauola/tauola.f (revision 8888)
	+++ trunk/tauola/tauola.f (revision 8889)
	@@ -1,5325 +0,0 @@
	- SUBROUTINE JAKER(JAK)
	- IMPLICIT double precision (A-H,O-Z)
	-C *********************
	-C
	-C **********************************************************************
	-C *
	-
	-C *******TAUOLA LIBRARY: VERSION 2.7 ****** *
	-C ************DECEMBER 1993**************** *
	-
	-
	-
	-
	-C AUTHORS: S.JADACH, Z.WAS *** *
	-C R. DECKER, M. JEZABEK, J.H.KUEHN, *** *
	-C ******AVAILABLE FROM: WASM AT CERNVM **** *
	-C *****PUBLISHED IN COMP. PHYS. COMM.****** *
	-C * PREPRINT CERN-TH-5856 SEPTEMBER 1990 ** *
	-C * PREPRINT CERN-TH-6195 OCTOBER 1991 ** *
	-C * PREPRINT CERN-TH-6793 NOVEMBER 1992 ** *
	-C **********************************************************************
	-C
	-C ----------------------------------------------------------------------
	-c SUBROUTINE JAKER,
	-C CHOOSES DECAY MODE ACCORDING TO LIST OF BRANCHING RATIOS
	-C JAK=1 ELECTRON MODE
	-C JAK=2 MUON MODE
	-C JAK=3 PION MODE
	-C JAK=4 RHO MODE
	-C JAK=5 A1 MODE
	-C JAK=6 K MODE
	-C JAK=7 K* MODE
	-
	-C JAK=8-13 npi modes
	-C JAK=14-19 KKpi & Kpipi modes
	-C JAK=20-21 eta pi pi; gamma pi pi modes
	-
	-
	-
	-C
	-C called by : DEXAY
	-C ----------------------------------------------------------------------
	- COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
	- logical condition
	- double precision CUMUL(30),RRR(1)
	-C
	- IF(NCHAN.LE.0.OR.NCHAN.GT.30) GOTO 902
	- CALL RANMAR(RRR,1)
	- SUM=0
	- DO 20 I=1,NCHAN
	- SUM=SUM+GAMPRT(I)
	- 20 CUMUL(I)=SUM
	- DO 25 I=NCHAN,1,-1
	- if(cumul(nchan) > 0) then
	- condition = RRR(1).LT.CUMUL(I)/CUMUL(NCHAN)
	- else
	- condition = .true.
	- end if
	- IF(condition) JI=I
	- 25 CONTINUE
	- JAK=JLIST(JI)
	- RETURN
	- 902 PRINT 9020
	- 9020 FORMAT(' ----- JAKER: WRONG NCHAN')
	- STOP
	- END
	- SUBROUTINE DEKAY(KTO,HX)
	-C ***********************
	-C THIS DEKAY IS IN SPIRIT OF THE 'DECAY' WHICH
	-C WAS INCLUDED IN KORAL-B PROGRAM, COMP. PHYS. COMMUN.
	-C VOL. 36 (1985) 191, SEE COMMENTS ON GENERAL PHILOSOPHY THERE.
	-C KTO=0 INITIALISATION (OBLIGATORY)
	-C KTO=1,11 DENOTES TAU+ AND KTO=2,12 TAU-
	-C DEKAY(1,H) AND DEKAY(2,H) IS CALLED INTERNALLY BY MC GENERATOR.
	-C H DENOTES THE POLARIMETRIC VECTOR, USED BY THE HOST PROGRAM FOR
	-C CALCULATION OF THE SPIN WEIGHT.
	-C USER MAY OPTIONALLY CALL DEKAY(11,H) DEKAY(12,H) IN ORDER
	-C TO TRANSFORM DECAY PRODUCTS TO CMS AND WRITE LUND RECORD IN /LUJETS/.
	-C KTO=100, PRINT FINAL REPORT (OPTIONAL).
	-C DECAY MODES:
	-C JAK=1 ELECTRON DECAY
	-C JAK=2 MU DECAY
	-C JAK=3 PI DECAY
	-C JAK=4 RHO DECAY
	-C JAK=5 A1 DECAY
	-C JAK=6 K DECAY
	-C JAK=7 K* DECAY
	-
	-C JAK= 8-13 npi modes
	-C JAK=14-19 KKpi & Kpipi modes
	-C JAK=20-21 eta pi pi; gamma pi pi modes
	-C JAK=0 INCLUSIVE: JAK=1-21
	-
	- IMPLICIT double precision (A-H,O-Z)
	- double precision H(4)
	- double precision HX(4)
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	-
	- COMMON / IDFC / IDFF
	-
	- COMMON /TAUPOS/ NP1,NP2
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	-
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	- COMMON / INOUT / INUT,IOUT
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),
	- * PDUM4(4),PDUM5(4),HDUM(4),PDUM(4)
	- double precision PDUMX(4,9)
	- DATA IWARM/0/
	- save iwarn, nevtot, nev1, nev2
	- save h, hk
	-
	- do 51 i=1, 4
	- H(i)=0.0
	-51 continue
	- KTOM=KTO
	- IDF = IDFF
	-
	- IF(KTO.EQ.-1) THEN
	-C ==================
	-C INITIALISATION OR REINITIALISATION
	-C first or second tau positions in HEPEVT as in KORALB/Z
	- NP1=3
	- NP2=4
	- KTOM=1
	- IF (IWARM.EQ.1) X=5/(IWARM-1)
	- IWARM=1
	- WRITE(IOUT,7001) JAK1,JAK2
	- NEVTOT=0
	- NEV1=0
	- NEV2=0
	- IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	- CALL DADMEL(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DADMMU(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DADMPI(-1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DADMRO(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	- CALL DADMAA(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
	- CALL DADMKK(-1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DADMKS(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
	- CALL DADNEW(-1,IDUM,HDUM,PDUM1,PDUM2,PDUMX,JDUM)
	- ENDIF
	- DO 21 I=1,30
	- NEVDEC(I)=0
	- GAMPMC(I)=0
	- 21 GAMPER(I)=0
	- ELSEIF(KTO.EQ.1) THEN
	-C =====================
	-C DECAY OF TAU+ IN THE TAU REST FRAME
	- NEVTOT=NEVTOT+1
	- IF(IWARM.EQ.0) GOTO 902
	- ISGN= IDF/IABS(IDF)
	-
	- CALL DEKAY1(0,H,ISGN)
	- ELSEIF(KTO.EQ.2) THEN
	-C =================================
	-C DECAY OF TAU- IN THE TAU REST FRAME
	- NEVTOT=NEVTOT+1
	- IF(IWARM.EQ.0) GOTO 902
	- ISGN=-IDF/IABS(IDF)
	-
	- CALL DEKAY2(0,H,ISGN)
	- ELSEIF(KTO.EQ.11) THEN
	-C ======================
	-C REST OF DECAY PROCEDURE FOR ACCEPTED TAU+ DECAY
	- NEV1=NEV1+1
	- ISGN= IDF/IABS(IDF)
	- CALL DEKAY1(1,H,ISGN)
	- ELSEIF(KTO.EQ.12) THEN
	-C ======================
	-C REST OF DECAY PROCEDURE FOR ACCEPTED TAU- DECAY
	- NEV2=NEV2+1
	- ISGN=-IDF/IABS(IDF)
	- CALL DEKAY2(1,H,ISGN)
	- ELSEIF(KTO.EQ.100) THEN
	-C =======================
	- IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	- CALL DADMEL( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DADMMU( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DADMPI( 1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DADMRO( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	- CALL DADMAA( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
	- CALL DADMKK( 1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DADMKS( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
	- CALL DADNEW( 1,IDUM,HDUM,PDUM1,PDUM2,PDUMX,JDUM)
	- WRITE(IOUT,7010) NEV1,NEV2,NEVTOT
	- WRITE(IOUT,7011) (NEVDEC(I),GAMPMC(I),GAMPER(I),I= 1,7)
	- WRITE(IOUT,7012)
	- $ (NEVDEC(I),GAMPMC(I),GAMPER(I),NAMES(I-7),I=8,7+NMODE)
	- WRITE(IOUT,7013)
	- ENDIF
	- ELSE
	-C ====
	- GOTO 910
	- ENDIF
	-C =====
	- DO 78 K=1,4
	- 78 HX(K)=H(K)
	- RETURN
	- 7001 FORMAT(///1X,15(5H*****)
	-
	- $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	- $ /,' ', 25X,'DEC 1993; ALEPH fixes introd. dec 98 ',9X,1H,
	- $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	- $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	- $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	- $ /,' ', 25X,'Physics initialization by ALEPH collab ',9X,1H,
	- $ /,' ', 25X,'it is suggested to use this version ',9X,1H,
	- $ /,' ', 25X,' with the help of the collab. advice ',9X,1H,
	- $ /,' ', 25X,'****CERN TH-6793 NOVEMBER 1992**',9X,1H,
	- $ /,' ', 25X,'5 or more pi dec.: precision limited ',9X,1H,
	- $ /,' ', 25X,'*DEKAY ROUTINE: INITIALIZATION***',9X,1H,
	- $ /,' ',I20 ,5X,'JAK1 = DECAY MODE TAU+ ',9X,1H,
	- $ /,' ',I20 ,5X,'JAK2 = DECAY MODE TAU- ',9X,1H,
	- $ /,1X,15(5H*****)/)
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	- $ /,' ', 25X,'********DECEMBER 1993************',9X,1H,
	- $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	- $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	- $ /,' ', 25X,'AVAILABLE FROM: WASM AT CERNVM ****',9X,1H,
	- $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	- $ /,' ', 25X,'****CERN-TH-5856 SEPTEMBER 1990**',9X,1H,
	- $ /,' ', 25X,'****CERN-TH-6195 SEPTEMBER 1991**',9X,1H,
	- $ /,' ', 25X,'****CERN TH-6793 NOVEMBER 1992**',9X,1H,
	- $ /,' ', 25X,'**DEKAY ROUTINE: FINAL REPORT****',9X,1H,
	- $ /,' ',I20 ,5X,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9X,1H,
	- $ /,' ',I20 ,5X,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9X,1H,
	- $ /,' ',I20 ,5X,'NEVTOT = SUM ',9X,1H,
	- $ /,' *',' NOEVTS ',
	- $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9X,1H*)
	- 7011 FORMAT(1X,'*'
	- $ ,I10,2F12.7 ,' DADMEL ELECTRON ',9X,1H*
	- $ /,' ',I10,2F12.7 ,' DADMMU MUON ',9X,1H
	- $ /,' ',I10,2F12.7 ,' DADMPI PION ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMRO RHO (->2PI) ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMAA A1 (->3PI) ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMKK KAON ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMKS K ',9X,1H*)
	- 7012 FORMAT(1X,'*'
	- $ ,I10,2F12.7,A31 ,8X,1H*)
	- 7013 FORMAT(1X,'*'
	- $ ,20X,'THE ERROR IS RELATIVE AND PART.WIDTH ',10X,1H*
	- $ /,' ',20X,'IN UNITS GFERMI2MASS5/192/PI3 ',10X,1H*
	- $ /,1X,15(5H*****)/)
	- 902 PRINT 9020
	- 9020 FORMAT(' ----- DEKAY: LACK OF INITIALISATION')
	- STOP
	- 910 PRINT 9100
	- 9100 FORMAT(' ----- DEKAY: WRONG VALUE OF KTO ')
	- STOP
	- END
	- SUBROUTINE DEKAY1(IMOD,HH,ISGN)
	-C *******************************
	-C THIS ROUTINE SIMULATES TAU+ DECAY
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / DECP4 / PP1(4),PP2(4),KFF1,KFF2
	- double precision PP1 ,PP2
	- INTEGER KFF1,KFF2
	- double precision HH(4)
	- double precision HV(4),PNU(4),PPI(4)
	- double precision PWB(4),PMU(4),PNM(4)
	- double precision PRHO(4),PIC(4),PIZ(4)
	- double precision PAA(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PKK(4),PKS(4)
	- double precision PNPI(4,9)
	- double precision PHOT(4)
	- double precision PDUM(4)
	- DATA NEV,NPRIN/0,10/
	- save nev, nprin, kto
	- save hv, pnu, ppi, pwb, pmu, pnm
	- save prho, pic, piz, paa, pim1, pim2, pipl
	- save pkk, pks, pnpi, phot, pdum
	- save jak, imd
	-
	- KTO=1
	- IF(JAK1.EQ.-1) RETURN
	- IMD=IMOD
	- IF(IMD.EQ.0) THEN
	-C =================
	- JAK=JAK1
	- IF(JAK1.EQ.0) CALL JAKER(JAK)
	- IF(JAK.EQ.1) THEN
	- CALL DADMEL(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	- ELSEIF(JAK.EQ.2) THEN
	- CALL DADMMU(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	- ELSEIF(JAK.EQ.3) THEN
	- CALL DADMPI(0, ISGN,HV,PPI,PNU)
	- ELSEIF(JAK.EQ.4) THEN
	- CALL DADMRO(0, ISGN,HV,PNU,PRHO,PIC,PIZ)
	- ELSEIF(JAK.EQ.5) THEN
	- CALL DADMAA(0, ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- ELSEIF(JAK.EQ.6) THEN
	- CALL DADMKK(0, ISGN,HV,PKK,PNU)
	- ELSEIF(JAK.EQ.7) THEN
	- CALL DADMKS(0, ISGN,HV,PNU,PKS ,PKK,PPI,JKST)
	- ELSE
	- CALL DADNEW(0, ISGN,HV,PNU,PWB,PNPI,JAK-7)
	- ENDIF
	- DO 33 I=1,3
	- 33 HH(I)=HV(I)
	- HH(4)=1.0
	-
	- ELSEIF(IMD.EQ.1) THEN
	-C =====================
	- NEV=NEV+1
	- IF (JAK.LT.31) THEN
	- NEVDEC(JAK)=NEVDEC(JAK)+1
	- ENDIF
	- DO 34 I=1,4
	- 34 PDUM(I)=.0
	- IF(JAK.EQ.1) THEN
	- CALL DWLUEL(1,ISGN,PNU,PWB,PMU,PNM)
	- CALL DWRPH(KTOM,PHOT)
	- DO 10 I=1,4
	- 10 PP1(I)=PMU(I)
	-
	- ELSEIF(JAK.EQ.2) THEN
	- CALL DWLUMU(1,ISGN,PNU,PWB,PMU,PNM)
	- CALL DWRPH(KTOM,PHOT)
	- DO 20 I=1,4
	- 20 PP1(I)=PMU(I)
	-
	- ELSEIF(JAK.EQ.3) THEN
	- CALL DWLUPI(1,ISGN,PPI,PNU)
	- DO 30 I=1,4
	- 30 PP1(I)=PPI(I)
	-
	- ELSEIF(JAK.EQ.4) THEN
	- CALL DWLURO(1,ISGN,PNU,PRHO,PIC,PIZ)
	- DO 40 I=1,4
	- 40 PP1(I)=PRHO(I)
	-
	- ELSEIF(JAK.EQ.5) THEN
	- CALL DWLUAA(1,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- DO 50 I=1,4
	- 50 PP1(I)=PAA(I)
	- ELSEIF(JAK.EQ.6) THEN
	- CALL DWLUKK(1,ISGN,PKK,PNU)
	- DO 60 I=1,4
	- 60 PP1(I)=PKK(I)
	- ELSEIF(JAK.EQ.7) THEN
	- CALL DWLUKS(1,ISGN,PNU,PKS,PKK,PPI,JKST)
	- DO 70 I=1,4
	- 70 PP1(I)=PKS(I)
	- ELSE
	-CAM MULTIPION DECAY
	- CALL DWLNEW(1,ISGN,PNU,PWB,PNPI,JAK)
	- DO 80 I=1,4
	- 80 PP1(I)=PWB(I)
	- ENDIF
	-
	- ENDIF
	-C =====
	- END
	- SUBROUTINE DEKAY2(IMOD,HH,ISGN)
	-C *******************************
	-C THIS ROUTINE SIMULATES TAU- DECAY
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / DECP4 / PP1(4),PP2(4),KFF1,KFF2
	- double precision PP1 ,PP2
	- INTEGER KFF1,KFF2
	- double precision HH(4)
	- double precision HV(4),PNU(4),PPI(4)
	- double precision PWB(4),PMU(4),PNM(4)
	- double precision PRHO(4),PIC(4),PIZ(4)
	- double precision PAA(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PKK(4),PKS(4)
	- double precision PNPI(4,9)
	- double precision PHOT(4)
	- double precision PDUM(4)
	- DATA NEV,NPRIN/0,10/
	- save nev, nprin, kto
	- save hhm hv, pnu, ppi, pwb, pmu, pnm
	- save prho, pic, piz, paa, pim1, pim2, pipl
	- save pkk, pks, pnpi, phot, pdum
	- save jak, imd
	-
	- KTO=2
	- IF(JAK2.EQ.-1) RETURN
	- IMD=IMOD
	- IF(IMD.EQ.0) THEN
	-C =================
	- JAK=JAK2
	- IF(JAK2.EQ.0) CALL JAKER(JAK)
	- IF(JAK.EQ.1) THEN
	- CALL DADMEL(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	- ELSEIF(JAK.EQ.2) THEN
	- CALL DADMMU(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	- ELSEIF(JAK.EQ.3) THEN
	- CALL DADMPI(0, ISGN,HV,PPI,PNU)
	- ELSEIF(JAK.EQ.4) THEN
	- CALL DADMRO(0, ISGN,HV,PNU,PRHO,PIC,PIZ)
	- ELSEIF(JAK.EQ.5) THEN
	- CALL DADMAA(0, ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- ELSEIF(JAK.EQ.6) THEN
	- CALL DADMKK(0, ISGN,HV,PKK,PNU)
	- ELSEIF(JAK.EQ.7) THEN
	- CALL DADMKS(0, ISGN,HV,PNU,PKS ,PKK,PPI,JKST)
	- ELSE
	- CALL DADNEW(0, ISGN,HV,PNU,PWB,PNPI,JAK-7)
	- ENDIF
	- DO 33 I=1,3
	- 33 HH(I)=HV(I)
	- HH(4)=1.0
	- ELSEIF(IMD.EQ.1) THEN
	-C =====================
	- NEV=NEV+1
	- IF (JAK.LT.31) THEN
	- NEVDEC(JAK)=NEVDEC(JAK)+1
	- ENDIF
	- DO 34 I=1,4
	- 34 PDUM(I)=.0
	- IF(JAK.EQ.1) THEN
	- CALL DWLUEL(2,ISGN,PNU,PWB,PMU,PNM)
	- CALL DWRPH(KTOM,PHOT)
	- DO 10 I=1,4
	- 10 PP2(I)=PMU(I)
	-
	- ELSEIF(JAK.EQ.2) THEN
	- CALL DWLUMU(2,ISGN,PNU,PWB,PMU,PNM)
	- CALL DWRPH(KTOM,PHOT)
	- DO 20 I=1,4
	- 20 PP2(I)=PMU(I)
	-
	- ELSEIF(JAK.EQ.3) THEN
	- CALL DWLUPI(2,ISGN,PPI,PNU)
	- DO 30 I=1,4
	- 30 PP2(I)=PPI(I)
	-
	- ELSEIF(JAK.EQ.4) THEN
	- CALL DWLURO(2,ISGN,PNU,PRHO,PIC,PIZ)
	- DO 40 I=1,4
	- 40 PP2(I)=PRHO(I)
	-
	- ELSEIF(JAK.EQ.5) THEN
	- CALL DWLUAA(2,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- DO 50 I=1,4
	- 50 PP2(I)=PAA(I)
	- ELSEIF(JAK.EQ.6) THEN
	- CALL DWLUKK(2,ISGN,PKK,PNU)
	- DO 60 I=1,4
	- 60 PP1(I)=PKK(I)
	- ELSEIF(JAK.EQ.7) THEN
	- CALL DWLUKS(2,ISGN,PNU,PKS,PKK,PPI,JKST)
	- DO 70 I=1,4
	- 70 PP1(I)=PKS(I)
	- ELSE
	-CAM MULTIPION DECAY
	- CALL DWLNEW(2,ISGN,PNU,PWB,PNPI,JAK)
	- DO 80 I=1,4
	- 80 PP1(I)=PWB(I)
	- ENDIF
	-C
	- ENDIF
	-C =====
	- END
	- SUBROUTINE DEXAY(KTO,POL)
	-C ----------------------------------------------------------------------
	-C THIS 'DEXAY' IS A ROUTINE WHICH GENERATES DECAY OF THE SINGLE
	-C POLARIZED TAU, POL IS A POLARIZATION VECTOR (NOT A POLARIMETER
	-C VECTOR AS IN DEKAY) OF THE TAU AND IT IS AN INPUT PARAMETER.
	-C KTO=0 INITIALISATION (OBLIGATORY)
	-C KTO=1 DENOTES TAU+ AND KTO=2 TAU-
	-C DEXAY(1,POL) AND DEXAY(2,POL) ARE CALLED INTERNALLY BY MC GENERATOR.
	-C DECAY PRODUCTS ARE TRANSFORMED READILY
	-C TO CMS AND WRITEN IN THE LUND RECORD IN /LUJETS/
	-C KTO=100, PRINT FINAL REPORT (OPTIONAL).
	-C
	-C called by : KORALZ
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	- COMMON / IDFC / IDFF
	- COMMON /TAUPOS/ NP1,NP2
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4)
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	- double precision PDUM(4)
	- double precision PDUMI(4,9)
	- DATA IWARM/0/
	-
	- save iwarn
	- save pdum1, pdum2, pdum3, pdum4, pdum5
	- save pdum, pdumi
	- save nevtot, nev1, nev2
	-
	- KTOM=KTO
	-C
	- IF(KTO.EQ.-1) THEN
	-C ==================
	-
	-C INITIALISATION OR REINITIALISATION
	-C first or second tau positions in HEPEVT as in KORALB/Z
	- NP1=3
	- NP2=4
	- IWARM=1
	- WRITE(IOUT, 7001) JAK1,JAK2
	- NEVTOT=0
	- NEV1=0
	- NEV2=0
	- IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	- CALL DEXEL(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DEXMU(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DEXPI(-1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DEXRO(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	- CALL DEXAA(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
	- CALL DEXKK(-1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DEXKS(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
	- CALL DEXNEW(-1,IDUM,PDUM,PDUM1,PDUM2,PDUMI,JDUM)
	- ENDIF
	- DO 21 I=1,30
	- NEVDEC(I)=0
	- GAMPMC(I)=0
	- 21 GAMPER(I)=0
	- ELSEIF(KTO.EQ.1) THEN
	-C =====================
	-C DECAY OF TAU+ IN THE TAU REST FRAME
	- NEVTOT=NEVTOT+1
	- NEV1=NEV1+1
	- IF(IWARM.EQ.0) GOTO 902
	- ISGN=IDFF/IABS(IDFF)
	-CAM CALL DEXAY1(POL,ISGN)
	- CALL DEXAY1(KTO,JAK1,JAKP,POL,ISGN)
	- ELSEIF(KTO.EQ.2) THEN
	-C =================================
	-C DECAY OF TAU- IN THE TAU REST FRAME
	- NEVTOT=NEVTOT+1
	- NEV2=NEV2+1
	- IF(IWARM.EQ.0) GOTO 902
	- ISGN=-IDFF/IABS(IDFF)
	-CAM CALL DEXAY2(POL,ISGN)
	- CALL DEXAY1(KTO,JAK2,JAKM,POL,ISGN)
	- ELSEIF(KTO.EQ.100) THEN
	-C =======================
	- IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	- CALL DEXEL( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DEXMU( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- CALL DEXPI( 1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DEXRO( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	- CALL DEXAA( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,IDUM)
	- CALL DEXKK( 1,IDUM,PDUM,PDUM1,PDUM2)
	- CALL DEXKS( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,IDUM)
	- CALL DEXNEW( 1,IDUM,PDUM,PDUM1,PDUM2,PDUMI,IDUM)
	- WRITE(IOUT,7010) NEV1,NEV2,NEVTOT
	- WRITE(IOUT,7011) (NEVDEC(I),GAMPMC(I),GAMPER(I),I= 1,7)
	- WRITE(IOUT,7012)
	- $ (NEVDEC(I),GAMPMC(I),GAMPER(I),NAMES(I-7),I=8,7+NMODE)
	- WRITE(IOUT,7013)
	- ENDIF
	- ELSE
	- GOTO 910
	- ENDIF
	- RETURN
	- 7001 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	- $ /,' ', 25X,'DEC 1993; ALEPH fixes introd. dec 98 ',9X,1H,
	- $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	- $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	- $ /,' ', 25X,'Physics initialization by ALEPH collab ',9X,1H,
	- $ /,' ', 25X,'it is suggested to use this version ',9X,1H,
	- $ /,' ', 25X,' with the help of the collab. advice ',9X,1H,
	- $ /,' ', 25X,'AVAILABLE FROM: WASM AT CERNVM ****',9X,1H,
	- $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	- $ /,' ', 25X,'****CERN-TH-6793 NOVEMBER 1992**',9X,1H,
	- $ /,' ', 25X,'5 or more pi dec.: precision limited ',9X,1H,
	- $ /,' ', 25X,'***DEXAY ROUTINE: INITIALIZATION*',9X,1H
	- $ /,' ',I20 ,5X,'JAK1 = DECAY MODE FERMION1 (TAU+) ',9X,1H
	- $ /,' ',I20 ,5X,'JAK2 = DECAY MODE FERMION2 (TAU-) ',9X,1H
	- $ /,1X,15(5H*****)/)
	-CHBU format 7010 had more than 19 continuation lines
	-CHBU split into two
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	- $ /,' ', 25X,'********DECEMBER 1993************',9X,1H,
	- $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	- $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	- $ /,' ', 25X,'AVAILABLE FROM: WASM AT CERNVM ****',9X,1H,
	- $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	- $ /,' ', 25X,'****CERN-TH-5856 SEPTEMBER 1990**',9X,1H,
	- $ /,' ', 25X,'****CERN-TH-6195 SEPTEMBER 1991**',9X,1H,
	- $ /,' ', 25X,'****CERN-TH-6793 NOVEMBER 1992**',9X,1H,
	- $ /,' ', 25X,'***DEXAY ROUTINE: FINAL REPORT***',9X,1H
	- $ /,' ',I20 ,5X,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEVTOT = SUM ',9X,1H
	- $ /,' *',' NOEVTS ',
	- $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9X,1H*)
	- 7011 FORMAT(1X,'*'
	- $ ,I10,2F12.7 ,' DADMEL ELECTRON ',9X,1H*
	- $ /,' ',I10,2F12.7 ,' DADMMU MUON ',9X,1H
	- $ /,' ',I10,2F12.7 ,' DADMPI PION ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMRO RHO (->2PI) ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMAA A1 (->3PI) ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMKK KAON ',9X,1H
	- $ /,' ',I10,2F12.7, ' DADMKS K ',9X,1H*)
	- 7012 FORMAT(1X,'*'
	- $ ,I10,2F12.7,A31 ,8X,1H*)
	- 7013 FORMAT(1X,'*'
	- $ ,20X,'THE ERROR IS RELATIVE AND PART.WIDTH ',10X,1H*
	- $ /,' ',20X,'IN UNITS GFERMI2MASS5/192/PI3 ',10X,1H*
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DEXAY: LACK OF INITIALISATION')
	- STOP
	- 910 WRITE(IOUT, 9100)
	- 9100 FORMAT(' ----- DEXAY: WRONG VALUE OF KTO ')
	- STOP
	- END
	- SUBROUTINE DEXAY1(KTO,JAKIN,JAK,POL,ISGN)
	-C ---------------------------------------------------------------------
	-C THIS ROUTINE SIMULATES TAU+- DECAY
	-C
	-C called by : DEXAY
	-C ---------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4),POLAR(4)
	- double precision PNU(4),PPI(4)
	- double precision PRHO(4),PIC(4),PIZ(4)
	- double precision PWB(4),PMU(4),PNM(4)
	- double precision PAA(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PKK(4),PKS(4)
	- double precision PNPI(4,9)
	- double precision PHOT(4)
	- double precision PDUM(4)
	-C
	- save polar, pnu, ppi, prho, pic, piz, pwb, pmu, pnm
	- save paa, pim1, pim2, pipl, pkk, pks, pnpi, phot, pdum
	-
	- IF(JAKIN.EQ.-1) RETURN
	- DO 33 I=1,3
	- 33 POLAR(I)=POL(I)
	- POLAR(4)=0.
	- DO 34 I=1,4
	- 34 PDUM(I)=.0
	- JAK=JAKIN
	- IF(JAK.EQ.0) CALL JAKER(JAK)
	-CAM
	- IF(JAK.EQ.1) THEN
	- CALL DEXEL(0, ISGN,POLAR,PNU,PWB,PMU,PNM,PHOT)
	- CALL DWLUEL(KTO,ISGN,PNU,PWB,PMU,PNM)
	- CALL DWRPH(KTO,PHOT )
	- ELSEIF(JAK.EQ.2) THEN
	- CALL DEXMU(0, ISGN,POLAR,PNU,PWB,PMU,PNM,PHOT)
	- CALL DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
	- CALL DWRPH(KTO,PHOT )
	- ELSEIF(JAK.EQ.3) THEN
	- CALL DEXPI(0, ISGN,POLAR,PPI,PNU)
	- CALL DWLUPI(KTO,ISGN,PPI,PNU)
	- ELSEIF(JAK.EQ.4) THEN
	- CALL DEXRO(0, ISGN,POLAR,PNU,PRHO,PIC,PIZ)
	- CALL DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
	- ELSEIF(JAK.EQ.5) THEN
	- CALL DEXAA(0, ISGN,POLAR,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- CALL DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- ELSEIF(JAK.EQ.6) THEN
	- CALL DEXKK(0, ISGN,POLAR,PKK,PNU)
	- CALL DWLUKK(KTO,ISGN,PKK,PNU)
	- ELSEIF(JAK.EQ.7) THEN
	- CALL DEXKS(0, ISGN,POLAR,PNU,PKS,PKK,PPI,JKST)
	- CALL DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
	- ELSE
	- JNPI=JAK-7
	- CALL DEXNEW(0, ISGN,POLAR,PNU,PWB,PNPI,JNPI)
	- CALL DWLNEW(KTO,ISGN,PNU,PWB,PNPI,JAK)
	- ENDIF
	- NEVDEC(JAK)=NEVDEC(JAK)+1
	- END
	- SUBROUTINE DEXEL(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
	-C ----------------------------------------------------------------------
	-C THIS SIMULATES TAU DECAY IN TAU REST FRAME
	-C INTO ELECTRON AND TWO NEUTRINOS
	-C
	-C called by : DEXAY,DEXAY1
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision POL(4),HV(4),PWB(4),PNU(4),Q1(4),
	- * Q2(4),PH(4),RN(1)
	- DATA IWARM/0/
	- save iwarn
	- save hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- CALL DADMEL( -1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	-CC CALL HBOOK1(813,'WEIGHT DISTRIBUTION DEXEL $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DADMEL( 0,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(813,WT)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- CALL DADMEL( 1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	-CC CALL HPRINT(813)
	- ENDIF
	-C =====
	- RETURN
	- 902 PRINT 9020
	- 9020 FORMAT(' ----- DEXEL: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DEXMU(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
	-C ----------------------------------------------------------------------
	-C THIS SIMULATES TAU DECAY IN ITS REST FRAME
	-C INTO MUON AND TWO NEUTRINOS
	-C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-C PWB W-BOSON
	-C Q1 MUON
	-C Q2 MUON-NEUTRINO
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4),HV(4),PWB(4),PNU(4)
	- double precision Q1(4),Q2(4),PH(4),RN(1)
	- DATA IWARM/0/
	- save iwarn, hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- CALL DADMMU( -1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	-CC CALL HBOOK1(814,'WEIGHT DISTRIBUTION DEXMU $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DADMMU( 0,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(814,WT)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- CALL DADMMU( 1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	-CC CALL HPRINT(814)
	- ENDIF
	-C =====
	- RETURN
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DEXMU: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DADMEL(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
	-C ----------------------------------------------------------------------
	-C
	-C called by : DEXEL,(DEKAY,DEKAY1)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision PHX(4)
	- double precision HHV(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4)
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	- double precision RRR(3)
	- double precision SWT, SSWT
	- DATA PI /3.141592653589793238462643/
	- DATA IWARM/0/
	- save iwarn, nevraw, nevacc, nevovr, swt, sswt, wtmax
	- save hv, pdum1, pdum2, pdum3, pdum4, pdum5
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- NEVRAW=0
	- NEVACC=0
	- NEVOVR=0
	- SWT=0
	- SSWT=0
	- WTMAX=1E-20
	- DO 15 I=1,500
	- CALL DPHSEL(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	-15 CONTINUE
	-CC CALL HBOOK1(803,'WEIGHT DISTRIBUTION DADMEL $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- NEVRAW=NEVRAW+1
	- CALL DPHSEL(WT,HV,PNU,PWB,Q1,Q2,PHX)
	-CC CALL HFILL(803,WT/WTMAX)
	- SWT=SWT+WT
	- SSWT=SSWT+WT**2
	- CALL RANMAR(RRR,3)
	- RN=RRR(1)
	- IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	- IF(RN*WTMAX.GT.WT) GOTO 300
	-C ROTATIONS TO BASIC TAU REST FRAME
	- RR2=RRR(2)
	- COSTHE=-1.+2.*RR2
	- THET=ACOS(COSTHE)
	- RR3=RRR(3)
	- PHI =2PIRR3
	- CALL ROTOR2(THET,PNU,PNU)
	- CALL ROTOR3( PHI,PNU,PNU)
	- CALL ROTOR2(THET,PWB,PWB)
	- CALL ROTOR3( PHI,PWB,PWB)
	- CALL ROTOR2(THET,Q1,Q1)
	- CALL ROTOR3( PHI,Q1,Q1)
	- CALL ROTOR2(THET,Q2,Q2)
	- CALL ROTOR3( PHI,Q2,Q2)
	- CALL ROTOR2(THET,HV,HV)
	- CALL ROTOR3( PHI,HV,HV)
	- CALL ROTOR2(THET,PHX,PHX)
	- CALL ROTOR3( PHI,PHX,PHX)
	- DO 44,I=1,3
	- 44 HHV(I)=-ISGN*HV(I)
	- NEVACC=NEVACC+1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVRAW.EQ.0) RETURN
	- PARGAM=SWT/FLOAT(NEVRAW+1)
	- ERROR=0
	- IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	- RAT=PARGAM/GAMEL
	- WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	-CC CALL HPRINT(803)
	- GAMPMC(1)=RAT
	- GAMPER(1)=ERROR
	-CAM NEVDEC(1)=NEVACC
	- ENDIF
	-C =====
	- RETURN
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMEL FINAL REPORT ****** ',9X,1H*
	- $ /,' ',I20 ,5X,'NEVRAW = NO. OF EL DECAYS TOTAL ',9X,1H
	- $ /,' ',I20 ,5X,'NEVACC = NO. OF EL DECS. ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH ( ELECTRON) IN GEV UNITS ',9X,1H
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.9,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	- $ /,' ',25X, 'COMPLETE QED CORRECTIONS INCLUDED ',9X,1H
	- $ /,' ',25X, 'BUT ONLY V-A CUPLINGS ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DADMEL: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DADMMU(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision PHX(4)
	- double precision HHV(4),HV(4),PNU(4),PWB(4),Q1(4),Q2(4)
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	- double precision RRR(3)
	- double precision SWT, SSWT
	- DATA PI /3.141592653589793238462643/
	- DATA IWARM /0/
	- save iwarn, nevraw, nevacc, nevovr, swt, sswt, wtmax, hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- NEVRAW=0
	- NEVACC=0
	- NEVOVR=0
	- SWT=0
	- SSWT=0
	- WTMAX=1E-20
	- DO 15 I=1,500
	- CALL DPHSMU(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	- IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	-15 CONTINUE
	-CC CALL HBOOK1(802,'WEIGHT DISTRIBUTION DADMMU $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- NEVRAW=NEVRAW+1
	- CALL DPHSMU(WT,HV,PNU,PWB,Q1,Q2,PHX)
	-CC CALL HFILL(802,WT/WTMAX)
	- SWT=SWT+WT
	- SSWT=SSWT+WT**2
	- CALL RANMAR(RRR,3)
	- RN=RRR(1)
	- IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	- IF(RN*WTMAX.GT.WT) GOTO 300
	-C ROTATIONS TO BASIC TAU REST FRAME
	- COSTHE=-1.+2.*RRR(2)
	- THET=ACOS(COSTHE)
	- PHI =2PIRRR(3)
	- CALL ROTOR2(THET,PNU,PNU)
	- CALL ROTOR3( PHI,PNU,PNU)
	- CALL ROTOR2(THET,PWB,PWB)
	- CALL ROTOR3( PHI,PWB,PWB)
	- CALL ROTOR2(THET,Q1,Q1)
	- CALL ROTOR3( PHI,Q1,Q1)
	- CALL ROTOR2(THET,Q2,Q2)
	- CALL ROTOR3( PHI,Q2,Q2)
	- CALL ROTOR2(THET,HV,HV)
	- CALL ROTOR3( PHI,HV,HV)
	- CALL ROTOR2(THET,PHX,PHX)
	- CALL ROTOR3( PHI,PHX,PHX)
	- DO 44,I=1,3
	- 44 HHV(I)=-ISGN*HV(I)
	- NEVACC=NEVACC+1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVRAW.EQ.0) RETURN
	- PARGAM=SWT/FLOAT(NEVRAW+1)
	- ERROR=0
	- IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	- RAT=PARGAM/GAMEL
	- WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	-CC CALL HPRINT(802)
	- GAMPMC(2)=RAT
	- GAMPER(2)=ERROR
	-CAM NEVDEC(2)=NEVACC
	- ENDIF
	-C =====
	- RETURN
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMMU FINAL REPORT ****** ',9X,1H*
	- $ /,' ',I20 ,5X,'NEVRAW = NO. OF MU DECAYS TOTAL ',9X,1H
	- $ /,' ',I20 ,5X,'NEVACC = NO. OF MU DECS. ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH (MU DECAY) IN GEV UNITS ',9X,1H
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.9,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	- $ /,' ',25X, 'COMPLETE QED CORRECTIONS INCLUDED ',9X,1H
	- $ /,' ',25X, 'BUT ONLY V-A CUPLINGS ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DADMMU: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DPHSEL(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
	-C XNX,XNA was flipped in parameters of dphsel and dphsmu
	-C *********************************************************************
	-C * ELECTRON DECAY MODE *
	-C *********************************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PHX(4)
	- double precision HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
	- double precision HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
	- double precision DGAMT
	- IELMU=1
	- CALL DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
	- DO 7 K=1,4
	- HVX(K)=HV(K)
	- PHX(K)=PH(K)
	- PAAX(K)=PAA(K)
	- XAX(K)=XA(K)
	- QPX(K)=QP(K)
	- XNX(K)=XN(K)
	- 7 CONTINUE
	- DGAMX=DGAMT
	- END
	- SUBROUTINE DPHSMU(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
	-C XNX,XNA was flipped in parameters of dphsel and dphsmu
	-C *********************************************************************
	-C * MUON DECAY MODE *
	-C *********************************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PHX(4)
	- double precision HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
	- double precision HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
	- double precision DGAMT
	- IELMU=2
	- CALL DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
	- DO 7 K=1,4
	- HVX(K)=HV(K)
	- PHX(K)=PH(K)
	- PAAX(K)=PAA(K)
	- XAX(K)=XA(K)
	- QPX(K)=QP(K)
	- XNX(K)=XN(K)
	- 7 CONTINUE
	- DGAMX=DGAMT
	- END
	- SUBROUTINE DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
	- IMPLICIT double precision (A-H,O-Z)
	-C ----------------------------------------------------------------------
	-* IT SIMULATES E,MU CHANNELS OF TAU DECAY IN ITS REST FRAME WITH
	-* QED ORDER ALPHA CORRECTIONS
	-C ----------------------------------------------------------------------
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- COMMON / TAURAD / XK0DEC,ITDKRC
	- double precision XK0DEC
	- double precision HV(4),PT(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
	- double precision PR(4)
	- double precision RRR(6)
	- LOGICAL IHARD
	- DATA PI /3.141592653589793238462643D0/
	- !XLAM(X,Y,Z)=SQRT((X-Y-Z)*2-4.0Y*Z)
	-C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
	-C
	-C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	-C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	- PHSPAC=1./217/PI8
	- AMTAX=AMTAU
	-C TAU MOMENTUM
	- PT(1)=0.D0
	- PT(2)=0.D0
	- PT(3)=0.D0
	- PT(4)=AMTAX
	-C
	- CALL RANMAR(RRR,6)
	-C
	- IF (IELMU.EQ.1) THEN
	- AMU=AMEL
	- ELSE
	- AMU=AMMU
	- ENDIF
	-C
	- PRHARD=0.30D0
	- IF ( ITDKRC.EQ.0) PRHARD=0D0
	- PRSOFT=1.-PRHARD
	- IF(PRSOFT.LT.0.1) THEN
	- PRINT *, 'ERROR IN DRCMU; PRSOFT=',PRSOFT
	- STOP
	- ENDIF
	-C
	- RR5=RRR(5)
	- IHARD=(RR5.GT.PRSOFT)
	- IF (IHARD) THEN
	-C TAU DECAY TO 'TAU+photon'
	- RR1=RRR(1)
	- AMS1=(AMU+AMNUTA)**2
	- AMS2=(AMTAX)**2
	- XK1=1-AMS1/AMS2
	- XL1=LOG(XK1/2/XK0DEC)
	- XL0=LOG(2*XK0DEC)
	- XK=EXP(XL1*RR1+XL0)
	- AM3SQ=(1-XK)*AMS2
	- AM3 =SQRT(AM3SQ)
	- PHSPAC=PHSPACAMS2XL1*XK
	- PHSPAC=PHSPAC/PRHARD
	- ELSE
	- AM3=AMTAX
	- PHSPAC=PHSPAC26PI**3
	- PHSPAC=PHSPAC/PRSOFT
	- ENDIF
	-C MASS OF NEUTRINA SYSTEM
	- RR2=RRR(2)
	- AMS1=(AMNUTA)**2
	- AMS2=(AM3-AMU)**2
	-CAM
	-CAM
	-* FLAT PHASE SPACE;
	- AM2SQ=AMS1+ RR2*(AMS2-AMS1)
	- AM2 =SQRT(AM2SQ)
	- PHSPAC=PHSPAC*(AMS2-AMS1)
	-* NEUTRINA REST FRAME, DEFINE XN AND XA
	- ENQ1=(AM2SQ+AMNUTA*2)/(2AM2)
	- ENQ2=(AM2SQ-AMNUTA*2)/(2AM2)
	- PPI= ENQ12-AMNUTA2
	- PPPI=SQRT(ABS(ENQ12-AMNUTA2))
	- PHSPAC=PHSPAC(4PI)(2PPPI/AM2)
	-* NU TAU IN NUNU REST FRAME
	- CALL SPHERD(PPPI,XN)
	- XN(4)=ENQ1
	-* NU LIGHT IN NUNU REST FRAME
	- DO 30 I=1,3
	- 30 XA(I)=-XN(I)
	- XA(4)=ENQ2
	-* TAU-prim REST FRAME, DEFINE QP (muon
	-* NUNU MOMENTUM
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1.D0/(2AM3)(AM32+AM22-AMU**2)
	- PR(3)= SQRT(ABS(PR(4)2-AM22))
	- PPI = PR(4)2-AM22
	-* MUON MOMENTUM
	- QP(1)=0
	- QP(2)=0
	- QP(4)=1.D0/(2AM3)(AM32-AM22+AMU**2)
	- QP(3)=-PR(3)
	- PHSPAC=PHSPAC(4PI)(2PR(3)/AM3)
	-* NEUTRINA BOOSTED FROM THEIR FRAME TO TAU-prim REST FRAME
	- EXE=(PR(4)+PR(3))/AM2
	- CALL BOSTD3(EXE,XN,XN)
	- CALL BOSTD3(EXE,XA,XA)
	- RR3=RRR(3)
	- RR4=RRR(4)
	- IF (IHARD) THEN
	- EPS=4(AMU/AMTAX)*2
	- XL1=LOG((2+EPS)/EPS)
	- XL0=LOG(EPS)
	- ETA =EXP(XL1*RR3+XL0)
	- CTHET=1+EPS-ETA
	- THET =ACOS(CTHET)
	- PHSPAC=PHSPACXL1/2ETA
	- PHI = 2PIRR4
	- CALL ROTPOX(THET,PHI,XN)
	- CALL ROTPOX(THET,PHI,XA)
	- CALL ROTPOX(THET,PHI,QP)
	- CALL ROTPOX(THET,PHI,PR)
	-C
	-* NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
	-* tau-prim MOMENTUM
	- PAA(1)=0
	- PAA(2)=0
	- PAA(4)=1/(2AMTAX)(AMTAX2+AM32)
	- PAA(3)= SQRT(ABS(PAA(4)2-AM32))
	- PPI = PAA(4)2-AM32
	- PHSPAC=PHSPAC(4PI)(2PAA(3)/AMTAX)
	-* GAMMA MOMENTUM
	- PH(1)=0
	- PH(2)=0
	- PH(4)=PAA(3)
	- PH(3)=-PAA(3)
	-* ALL MOMENTA BOOSTED FROM TAU-prim REST FRAME TO TAU REST FRAME
	-* Z-AXIS ANTIPARALLEL TO PHOTON MOMENTUM
	- EXE=(PAA(4)+PAA(3))/AM3
	- CALL BOSTD3(EXE,XN,XN)
	- CALL BOSTD3(EXE,XA,XA)
	- CALL BOSTD3(EXE,QP,QP)
	- CALL BOSTD3(EXE,PR,PR)
	- ELSE
	- THET =ACOS(-1.+2*RR3)
	- PHI = 2PIRR4
	- CALL ROTPOX(THET,PHI,XN)
	- CALL ROTPOX(THET,PHI,XA)
	- CALL ROTPOX(THET,PHI,QP)
	- CALL ROTPOX(THET,PHI,PR)
	-C
	-* NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
	-* tau-prim MOMENTUM
	- PAA(1)=0
	- PAA(2)=0
	- PAA(4)=AMTAX
	- PAA(3)=0
	-* GAMMA MOMENTUM
	- PH(1)=0
	- PH(2)=0
	- PH(4)=0
	- PH(3)=0
	- ENDIF
	-C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
	- CALL DAMPRY(ITDKRC,XK0DEC,PH,XA,QP,XN,AMPLIT,HV)
	- DGAMT=1/(2.AMTAX)AMPLIT*PHSPAC
	- END
	- SUBROUTINE DAMPRY(ITDKRC,XK0DEC,XK,XA,QP,XN,AMPLIT,HV)
	- IMPLICIT double precision (A-H,O-Z)
	-C ----------------------------------------------------------------------
	-C IT CALCULATES MATRIX ELEMENT FOR THE
	-C TAU --> MU(E) NU NUBAR DECAY MODE
	-C INCLUDING COMPLETE ORDER ALPHA QED CORRECTIONS.
	-C ----------------------------------------------------------------------
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- double precision HV(4),QP(4),XN(4),XA(4),XK(4)
	-C
	- HV(4)=1.D0
	- AK0=XK0DEC*AMTAU
	- IF(XK(4).LT.0.1D0*AK0) THEN
	- AMPLIT=THB(ITDKRC,QP,XN,XA,AK0,HV)
	- ELSE
	- AMPLIT=SQM2(ITDKRC,QP,XN,XA,XK,AK0,HV)
	- ENDIF
	- RETURN
	- END
	- double precision FUNCTION SQM2(ITDKRC,QP,XN,XA,XK,AK0,HV)
	-C
	-C **********************************************************************
	-C REAL PHOTON MATRIX ELEMENT SQUARED *
	-C PARAMETERS: *
	-C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
	-C QP,XN,XA,XK - 4-momenta of electron (muon), NU, NUBAR and PHOTON *
	-C All four-vectors in TAU rest frame (in GeV) *
	-C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS (GEV) *
	-C SQM2 - value for S=0 *
	-C see Eqs. (2.9)-(2.10) from CJK ( Nucl.Phys.B(1991) ) *
	-C **********************************************************************
	-C
	- IMPLICIT double precision(A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / QEDPRM /ALFINV,ALFPI,XK0
	- double precision ALFINV,ALFPI,XK0
	- double precision QP(4),XN(4),XA(4),XK(4)
	- double precision R(4)
	- double precision HV(4)
	- double precision S0(3),RXA(3),RXK(3),RQP(3)
	- DATA PI /3.141592653589793238462643D0/
	-C
	- TMASS=AMTAU
	- GF=GFERMI
	- ALPHAI=ALFINV
	- TMASS2=TMASS**2
	- EMASS2=QP(4)2-QP(1)2-QP(2)2-QP(3)2
	- R(4)=TMASS
	-C SCALAR PRODUCTS OF FOUR-MOMENTA
	- DO 7 I=1,3
	- R(1)=0.D0
	- R(2)=0.D0
	- R(3)=0.D0
	- R(I)=TMASS
	- RXA(I)=R(4)XA(4)-R(1)XA(1)-R(2)XA(2)-R(3)XA(3)
	-C RXN(I)=R(4)XN(4)-R(1)XN(1)-R(2)XN(2)-R(3)XN(3)
	- RXK(I)=R(4)XK(4)-R(1)XK(1)-R(2)XK(2)-R(3)XK(3)
	- RQP(I)=R(4)QP(4)-R(1)QP(1)-R(2)QP(2)-R(3)QP(3)
	- 7 CONTINUE
	- QPXN=QP(4)XN(4)-QP(1)XN(1)-QP(2)XN(2)-QP(3)XN(3)
	- QPXA=QP(4)XA(4)-QP(1)XA(1)-QP(2)XA(2)-QP(3)XA(3)
	- QPXK=QP(4)XK(4)-QP(1)XK(1)-QP(2)XK(2)-QP(3)XK(3)
	-c XNXA=XN(4)XA(4)-XN(1)XA(1)-XN(2)XA(2)-XN(3)XA(3)
	- XNXK=XN(4)XK(4)-XN(1)XK(1)-XN(2)XK(2)-XN(3)XK(3)
	- XAXK=XA(4)XK(4)-XA(1)XK(1)-XA(2)XK(2)-XA(3)XK(3)
	- TXN=TMASS*XN(4)
	- TXA=TMASS*XA(4)
	- TQP=TMASS*QP(4)
	- TXK=TMASS*XK(4)
	-C
	- X= XNXK/QPXN
	- Z= TXK/TQP
	- A= 1+X
	- B= 1+ X*(1+Z)/2+Z/2
	- S1= QPXNTXA( -EMASS2/QPXK*2A + 2TQP/(QPXKTXK)*B-
	- $TMASS2/TXK**2) +
	- $QPXN/TXK*2 ( TMASS2XAXK - TXATXK+ XAXK*TXK) -
	- $TXATXN/TXK - QPXN/(QPXKTXK)* (TQPXAXK-TXKQPXA)
	- CONST4=256PI/ALPHAIGF**2
	- IF (ITDKRC.EQ.0) CONST4=0D0
	- SQM2=S1*CONST4
	- DO 5 I=1,3
	- S0(I) = QPXNRXA(I)(-EMASS2/QPXK*2A + 2TQP/(QPXKTXK)*B-
	- $ TMASS2/TXK**2) +
	- $ QPXN/TXK*2 (TMASS2XAXK - TXARXK(I)+ XAXK*RXK(I))-
	- $ RXA(I)TXN/TXK - QPXN/(QPXKTXK)(RQP(I)XAXK- RXK(I)*QPXA)
	- 5 HV(I)=S0(I)/S1-1.D0
	- RETURN
	- END
	- double precision FUNCTION THB(ITDKRC,QP,XN,XA,AK0,HV)
	-C
	-C **********************************************************************
	-C BORN +VIRTUAL+SOFT PHOTON MATRIX ELEMENT*2 O(ALPHA)
	-C PARAMETERS: *
	-C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
	-C QP,XN,XA - FOUR-MOMENTA OF ELECTRON (MUON), NU AND NUBAR IN GEV *
	-C ALL FOUR-VECTORS IN TAU REST FRAME *
	-C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS *
	-C THB - VALUE FOR S=0 *
	-C SEE EQS. (2.2),(2.4)-(2.5) FROM CJK (NUCL.PHYS.B351(1991)70 *
	-C AND (C.2) FROM JK (NUCL.PHYS.B320(1991)20 ) *
	-C **********************************************************************
	-C
	- IMPLICIT double precision(A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / QEDPRM /ALFINV,ALFPI,XK0
	- double precision ALFINV,ALFPI,XK0
	- DIMENSION QP(4),XN(4),XA(4)
	- double precision HV(4)
	- DIMENSION R(4)
	- double precision RXA(3),RXN(3),RQP(3)
	- double precision BORNPL(3),AM3POL(3),XM3POL(3)
	- DATA PI /3.141592653589793238462643D0/
	-C
	- TMASS=AMTAU
	- GF=GFERMI
	- ALPHAI=ALFINV
	-C
	- TMASS2=TMASS**2
	- R(4)=TMASS
	- DO 7 I=1,3
	- R(1)=0.D0
	- R(2)=0.D0
	- R(3)=0.D0
	- R(I)=TMASS
	- RXA(I)=R(4)XA(4)-R(1)XA(1)-R(2)XA(2)-R(3)XA(3)
	- RXN(I)=R(4)XN(4)-R(1)XN(1)-R(2)XN(2)-R(3)XN(3)
	-C RXK(I)=R(4)XK(4)-R(1)XK(1)-R(2)XK(2)-R(3)XK(3)
	- RQP(I)=R(4)QP(4)-R(1)QP(1)-R(2)QP(2)-R(3)QP(3)
	- 7 CONTINUE
	-C QUASI TWO-BODY VARIABLES
	- U0=QP(4)/TMASS
	- U3=SQRT(QP(1)2+QP(2)2+QP(3)**2)/TMASS
	- W3=U3
	- W0=(XN(4)+XA(4))/TMASS
	- UP=U0+U3
	- UM=U0-U3
	- WP=W0+W3
	- WM=W0-W3
	- YU=LOG(UP/UM)/2
	- YW=LOG(WP/WM)/2
	- EPS2=U02-U32
	- EPS=SQRT(EPS2)
	- Y=W02-W32
	- AL=AK0/TMASS
	-C FORMFACTORS
	- F0=2U0/U3( DILOGT(1-(UMWM/(UPWP)))- DILOGT(1-WM/WP) +
	- $DILOGT(1-UM/UP) -2YU+ 2LOG(UP)*(YW+YU) ) +
	- $1/Y* ( 2U3YU + (1-EPS2- 2Y)LOG(EPS) ) +
	- $ 2 - 4(U0/U3YU -1)* LOG(2*AL)
	- FP= YU/(2U3)(1 + (1-EPS2)/Y ) + LOG(EPS)/Y
	- FM= YU/(2U3)(1 - (1-EPS2)/Y ) - LOG(EPS)/Y
	- F3= EPS2*(FP+FM)/2
	-C SCALAR PRODUCTS OF FOUR-MOMENTA
	- QPXN=QP(4)XN(4)-QP(1)XN(1)-QP(2)XN(2)-QP(3)XN(3)
	- QPXA=QP(4)XA(4)-QP(1)XA(1)-QP(2)XA(2)-QP(3)XA(3)
	- XNXA=XN(4)XA(4)-XN(1)XA(1)-XN(2)XA(2)-XN(3)XA(3)
	- TXN=TMASS*XN(4)
	- TXA=TMASS*XA(4)
	- TQP=TMASS*QP(4)
	-C DECAY DIFFERENTIAL WIDTH WITHOUT AND WITH POLARIZATION
	- CONST3=1/(2ALPHAIPI)64GF**2
	- IF (ITDKRC.EQ.0) CONST3=0D0
	- XM3= -( F0* QPXNTXA + FPEPS2* TXN*TXA +
	- $FM* QPXNQPXA + F3 TMASS2*XNXA )
	- AM3=XM3*CONST3
	-C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
	- BRAK= (GV+GA)*2TQPXNXA+(GV-GA)2TXA*QPXN
	- & -(GV2-GA2)TMASSAMNUTA*QPXA
	- BORN= 32(GFERMI2/2.)BRAK
	- DO 5 I=1,3
	- XM3POL(I)= -( F0* QPXNRXA(I) + FPEPS2* TXN*RXA(I) +
	- $ FM* QPXN* (QPXA + (RXA(I)TQP-TXARQP(I))/TMASS2 ) +
	- $ F3* (TMASS2XNXA +TXNRXA(I) -RXN(I)*TXA) )
	- AM3POL(I)=XM3POL(I)*CONST3
	-C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
	- BORNPL(I)=BORN+(
	- & (GV+GA)*2TMASSXNXAQP(I)
	- & -(GV-GA)*2TMASSQPXNXA(I)
	- & +(GV2-GA2)AMNUTATXA*QP(I)
	- & -(GV2-GA2)AMNUTATQPXA(I) )
	- & 32(GFERMI*2/2.)
	- 5 HV(I)=(BORNPL(I)+AM3POL(I))/(BORN+AM3)-1.D0
	- THB=BORN+AM3
	- IF (THB/BORN.LT.0.1D0) THEN
	- PRINT *, 'ERROR IN THB, THB/BORN=',THB/BORN
	- STOP
	- ENDIF
	- RETURN
	- END
	- SUBROUTINE DEXPI(MODE,ISGN,POL,PPI,PNU)
	-C ----------------------------------------------------------------------
	-C TAU DECAY INTO PION AND TAU-NEUTRINO
	-C IN TAU REST FRAME
	-C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-C PPI PION CHARGED
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision POL(4),HV(4),PNU(4),PPI(4),RN(1)
	- save hv
	-CC
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- CALL DADMPI(-1,ISGN,HV,PPI,PNU)
	-CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
	-
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- CALL DADMPI( 0,ISGN,HV,PPI,PNU)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(815,WT)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- CALL DADMPI( 1,ISGN,HV,PPI,PNU)
	-CC CALL HPRINT(815)
	- ENDIF
	-C =====
	- RETURN
	- END
	- SUBROUTINE DADMPI(MODE,ISGN,HV,PPI,PNU)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision PPI(4),PNU(4),HV(4)
	- DATA PI /3.141592653589793238462643/
	- save nevtot
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- NEVTOT=0
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	- NEVTOT=NEVTOT+1
	- EPI= (AMTAU2+AMPI2-AMNUTA*2)/(2AMTAU)
	- ENU= (AMTAU2-AMPI2+AMNUTA*2)/(2AMTAU)
	- XPI= SQRT(EPI2-AMPI2)
	-C PI MOMENTUM
	- CALL SPHERA(XPI,PPI)
	- PPI(4)=EPI
	-C TAU-NEUTRINO MOMENTUM
	- DO 30 I=1,3
	-30 PNU(I)=-PPI(I)
	- PNU(4)=ENU
	- PXQ=AMTAU*EPI
	- PXN=AMTAU*ENU
	- QXN=PPI(4)PNU(4)-PPI(1)PNU(1)-PPI(2)PNU(2)-PPI(3)PNU(3)
	- BRAK=(GV2+GA2)(2PXQQXN-AMPI2PXN)
	- & +(GV2-GA2)AMTAUAMNUTAAMPI*2
	- DO 40 I=1,3
	-40 HV(I)=-ISGN2GAGVAMTAU(2PPI(I)QXN-PNU(I)AMPI**2)/BRAK
	- HV(4)=1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVTOT.EQ.0) RETURN
	- FPI=0.1284
	-C GAMM=(GFERMIFPI)2/(16.PI)AMTAU3
	-C * (BRAK/AMTAU4)2
	-CZW 7.02.93 here was an error affecting non standard model
	-C configurations only
	- GAMM=(GFERMIFPI)2/(16.PI)AMTAU3
	- $ (BRAK/AMTAU*4)
	- $ SQRT((AMTAU2-AMPI2-AMNUTA2)2
	- $ -4AMPI2AMNUTA2 )/AMTAU2
	- ERROR=0
	- RAT=GAMM/GAMEL
	- WRITE(IOUT, 7010) NEVTOT,GAMM,RAT,ERROR
	- GAMPMC(3)=RAT
	- GAMPER(3)=ERROR
	-CAM NEVDEC(3)=NEVTOT
	- ENDIF
	-C =====
	- RETURN
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMPI FINAL REPORT ****** ',9X,1H*
	- $ /,' ',I20 ,5X,'NEVTOT = NO. OF PI DECAYS TOTAL ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH ( PI DECAY) IN GEV UNITS ',9X,1H
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9X,1H
	- $ /,1X,15(5H*****)/)
	- END
	- SUBROUTINE DEXRO(MODE,ISGN,POL,PNU,PRO,PIC,PIZ)
	-C ----------------------------------------------------------------------
	-C THIS SIMULATES TAU DECAY IN TAU REST FRAME
	-C INTO NU RHO, NEXT RHO DECAYS INTO PION PAIR.
	-C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-C PRO RHO
	-C PIC PION CHARGED
	-C PIZ PION ZERO
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4),HV(4),PRO(4),PNU(4),PIC(4),PIZ(4),RN(1)
	- DATA IWARM/0/
	- save iwarn, hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- CALL DADMRO( -1,ISGN,HV,PNU,PRO,PIC,PIZ)
	-CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXRO $',100,0,2)
	-CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXRO $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DADMRO( 0,ISGN,HV,PNU,PRO,PIC,PIZ)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(816,WT)
	-CC XHELP=HV(1)2+HV(2)2+HV(3)**2
	-CC CALL HFILL(916,XHELP)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- CALL DADMRO( 1,ISGN,HV,PNU,PRO,PIC,PIZ)
	-CC CALL HPRINT(816)
	-CC CALL HPRINT(916)
	- ENDIF
	-C =====
	- RETURN
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DEXRO: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DADMRO(MODE,ISGN,HHV,PNU,PRO,PIC,PIZ)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision HHV(4)
	- double precision HV(4),PRO(4),PNU(4),PIC(4),PIZ(4)
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
	- double precision RRR(3)
	- double precision WT, SWT, SSWT
	- SAVE NEVRAW, NEVACC, NEVOVR, WT, SWT, SSWT, WTMAX
	- DATA PI /3.141592653589793238462643/
	- DATA IWARM/0/
	- save iwarn, hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- NEVRAW=0
	- NEVACC=0
	- NEVOVR=0
	- SWT=0
	- SSWT=0
	- WTMAX=1E-20
	- DO 15 I=1,500
	- CALL DPHSRO(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4)
	- IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	-15 CONTINUE
	-CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMRO $',100,0,2)
	-CC PRINT 7003,WTMAX
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DPHSRO(WT,HV,PNU,PRO,PIC,PIZ)
	-CC CALL HFILL(801,WT/WTMAX)
	- NEVRAW=NEVRAW+1
	- SWT=SWT+WT
	- SSWT=SSWT+WT**2
	- CALL RANMAR(RRR,3)
	- RN=RRR(1)
	- IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	- IF(RN*WTMAX.GT.WT) GOTO 300
	-C ROTATIONS TO BASIC TAU REST FRAME
	- COSTHE=-1.+2.*RRR(2)
	- THET=ACOS(COSTHE)
	- PHI =2PIRRR(3)
	- CALL ROTOR2(THET,PNU,PNU)
	- CALL ROTOR3( PHI,PNU,PNU)
	- CALL ROTOR2(THET,PRO,PRO)
	- CALL ROTOR3( PHI,PRO,PRO)
	- CALL ROTOR2(THET,PIC,PIC)
	- CALL ROTOR3( PHI,PIC,PIC)
	- CALL ROTOR2(THET,PIZ,PIZ)
	- CALL ROTOR3( PHI,PIZ,PIZ)
	- CALL ROTOR2(THET,HV,HV)
	- CALL ROTOR3( PHI,HV,HV)
	- DO 44 I=1,3
	- 44 HHV(I)=-ISGN*HV(I)
	- NEVACC=NEVACC+1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVRAW.EQ.0) RETURN
	- PARGAM=SWT/FLOAT(NEVRAW+1)
	- ERROR=0
	- IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	- RAT=PARGAM/GAMEL
	- WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	-CC CALL HPRINT(801)
	- GAMPMC(4)=RAT
	- GAMPER(4)=ERROR
	-CAM NEVDEC(4)=NEVACC
	- ENDIF
	-C =====
	- RETURN
	- 7003 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMRO INITIALISATION *****',9X,1H
	- $ /,' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMRO FINAL REPORT ****** ',9X,1H*
	- $ /,' ',I20 ,5X,'NEVRAW = NO. OF RHO DECAYS TOTAL ',9X,1H
	- $ /,' ',I20 ,5X,'NEVACC = NO. OF RHO DECS. ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH (RHO DECAY) IN GEV UNITS ',9X,1H
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DADMRO: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DPHSRO(DGAMT,HV,PN,PR,PIC,PIZ)
	-C ----------------------------------------------------------------------
	-C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
	-C Z-AXIS ALONG RHO MOMENTUM
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision HV(4),PT(4),PN(4),PR(4),
	- * PIC(4),PIZ(4),QQ(4),RR1(1)
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	-C
	-C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	- PHSPAC=1./211/PI5
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	-C MASS OF (REAL/VIRTUAL) RHO
	- AMS1=(AMPI+AMPIZ)**2
	- AMS2=(AMTAU-AMNUTA)**2
	-C FLAT PHASE SPACE
	-C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	-C AMX=SQRT(AMX2)
	-C PHSPAC=PHSPAC*(AMS2-AMS1)
	-C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
	- ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
	- ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
	-CAM
	- 100 CONTINUE
	- CALL RANMAR(RR1,1)
	- ALP=ALP1+RR1(1)*(ALP2-ALP1)
	- AMX2=AMRO*2+AMROGAMRO*TAN(ALP)
	- AMX=SQRT(AMX2)
	- IF(AMX.LT.2.*AMPI) GO TO 100
	-CAM
	- PHSPAC=PHSPAC((AMX2-AMRO2)2+(AMROGAMRO)*2)/(AMROGAMRO)
	- PHSPAC=PHSPAC*(ALP2-ALP1)
	-C
	-C TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	- PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	-C RHO MOMENTUM
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	- PR(3)=-PN(3)
	- PHSPAC=PHSPAC(4PI)(2PR(3)/AMTAU)
	-C
	-CAM
	- ENQ1=(AMX2+AMPI2-AMPIZ2)/(2.*AMX)
	- ENQ2=(AMX2-AMPI2+AMPIZ2)/(2.*AMX)
	- PPPI=SQRT((ENQ1-AMPI)*(ENQ1+AMPI))
	- PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	-C CHARGED PI MOMENTUM IN RHO REST FRAME
	- CALL SPHERA(PPPI,PIC)
	- PIC(4)=ENQ1
	-C NEUTRAL PI MOMENTUM IN RHO REST FRAME
	- DO 20 I=1,3
	-20 PIZ(I)=-PIC(I)
	- PIZ(4)=ENQ2
	- EXE=(PR(4)+PR(3))/AMX
	-C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
	- CALL BOSTR3(EXE,PIC,PIC)
	- CALL BOSTR3(EXE,PIZ,PIZ)
	- DO 30 I=1,4
	-30 QQ(I)=PIC(I)-PIZ(I)
	-C AMPLITUDE
	- PRODPQ=PT(4)*QQ(4)
	- PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	- PRODPN=PT(4)*PN(4)
	- QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	- BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	- & +(GV2-GA2)AMTAUAMNUTA*QQ2
	- AMPLIT=(GFERMICCABIB)2BRAK2FPIRHO(AMX)
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	- DO 40 I=1,3
	- 40 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	- RETURN
	- END
	- SUBROUTINE DEXAA(MODE,ISGN,POL,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	-C ----------------------------------------------------------------------
	-* THIS SIMULATES TAU DECAY IN TAU REST FRAME
	-* INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
	-* OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-* PAA A1
	-* PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
	-* PIM2 PION MINUS (OR PI0) 2
	-* PIPL PION PLUS (OR PI-)
	-* (PIPL,PIM1) FORM A RHO
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4),HV(4),PAA(4),PNU(4),
	- * PIM1(4),PIM2(4),PIPL(4),RN(1)
	- DATA IWARM/0/
	- save iwarn, hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- CALL DADMAA( -1,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	-CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-* =======================
	- 300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DADMAA( 0,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(816,WT)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-* =======================
	- CALL DADMAA( 1,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	-CC CALL HPRINT(816)
	- ENDIF
	-C =====
	- RETURN
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DEXAA: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DADMAA(MODE,ISGN,HHV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	-C ----------------------------------------------------------------------
	-* A1 DECAY UNWEIGHTED EVENTS
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision HHV(4)
	- double precision HV(4),PAA(4),PNU(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	- double precision RRR(3)
	- double precision SWT, SSWT
	- SAVE IWARM,NEVRAW,NEVACC,NEVOVR,SWT,SSWT,WTMAX
	- DATA PI /3.141592653589793238462643/
	- DATA IWARM/0/
	- save hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- NEVRAW=0
	- NEVACC=0
	- NEVOVR=0
	- SWT=0
	- SSWT=0
	- WTMAX=1E-20
	- DO 15 I=1,500
	- CALL DPHSAA(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JAA)
	- IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	-15 CONTINUE
	-CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMAA $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DPHSAA(WT,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	-CC CALL HFILL(801,WT/WTMAX)
	- NEVRAW=NEVRAW+1
	- SWT=SWT+WT
	- SSWT=SSWT+WT**2
	- CALL RANMAR(RRR,3)
	- RN=RRR(1)
	- IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	- IF(RN*WTMAX.GT.WT) GOTO 300
	-C ROTATIONS TO BASIC TAU REST FRAME
	- COSTHE=-1.+2.*RRR(2)
	- THET=ACOS(COSTHE)
	- PHI =2PIRRR(3)
	- CALL ROTPOL(THET,PHI,PNU)
	- CALL ROTPOL(THET,PHI,PAA)
	- CALL ROTPOL(THET,PHI,PIM1)
	- CALL ROTPOL(THET,PHI,PIM2)
	- CALL ROTPOL(THET,PHI,PIPL)
	- CALL ROTPOL(THET,PHI,HV)
	- DO 44 I=1,3
	- 44 HHV(I)=-ISGN*HV(I)
	- NEVACC=NEVACC+1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVRAW.EQ.0) RETURN
	- PARGAM=SWT/FLOAT(NEVRAW+1)
	- ERROR=0
	- IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	- RAT=PARGAM/GAMEL
	- WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	-CC CALL HPRINT(801)
	- GAMPMC(5)=RAT
	- GAMPER(5)=ERROR
	-CAM NEVDEC(5)=NEVACC
	- ENDIF
	-C =====
	- RETURN
	- 7003 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMAA INITIALISATION *****',9X,1H
	- $ /,' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMAA FINAL REPORT ****** ',9X,1H*
	- $ /,' ',I20 ,5X,'NEVRAW = NO. OF A1 DECAYS TOTAL ',9X,1H
	- $ /,' ',I20 ,5X,'NEVACC = NO. OF A1 DECS. ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH (A1 DECAY) IN GEV UNITS ',9X,1H
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DADMAA: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DPHSAA(DGAMT,HV,PN,PAA,PIM1,PIM2,PIPL,JAA)
	-C ----------------------------------------------------------------------
	-* IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
	-* Z-AXIS ALONG A1 MOMENTUM
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	- double precision BRA1,BRK0,BRK0B,BRKS
	- double precision HV(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
	-
	-
	- double precision RRR(1)
	-C MATRIX ELEMENT NUMBER:
	- MNUM=0
	-C TYPE OF THE GENERATION:
	- KEYT=1
	- CALL RANMAR(RRR,1)
	- RMOD=RRR(1)
	- IF (RMOD.LT.BRA1) THEN
	- JAA=1
	- AMP1=AMPI
	- AMP2=AMPI
	- AMP3=AMPI
	- ELSE
	- JAA=2
	- AMP1=AMPIZ
	- AMP2=AMPIZ
	- AMP3=AMPI
	- ENDIF
	- CALL
	- $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMP1,PIM2,AMP2,PIPL,AMP3,KEYT,MNUM)
	- END
	- SUBROUTINE DEXKK(MODE,ISGN,POL,PKK,PNU)
	-C ----------------------------------------------------------------------
	-C TAU DECAY INTO KAON AND TAU-NEUTRINO
	-C IN TAU REST FRAME
	-C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-C PKK KAON CHARGED
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision POL(4),HV(4),PNU(4),PKK(4),RN(1)
	- save hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- CALL DADMKK(-1,ISGN,HV,PKK,PNU)
	-CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- CALL DADMKK( 0,ISGN,HV,PKK,PNU)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(815,WT)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- CALL DADMKK( 1,ISGN,HV,PKK,PNU)
	-CC CALL HPRINT(815)
	- ENDIF
	-C =====
	- RETURN
	- END
	- SUBROUTINE DADMKK(MODE,ISGN,HV,PKK,PNU)
	-C ----------------------------------------------------------------------
	-C FZ
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / INOUT / INUT,IOUT
	- double precision PKK(4),PNU(4),HV(4)
	- DATA PI /3.141592653589793238462643/
	- save nevtot
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- NEVTOT=0
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	- NEVTOT=NEVTOT+1
	- EKK= (AMTAU2+AMK2-AMNUTA*2)/(2AMTAU)
	- ENU= (AMTAU2-AMK2+AMNUTA*2)/(2AMTAU)
	- XKK= SQRT(EKK2-AMK2)
	-C K MOMENTUM
	- CALL SPHERA(XKK,PKK)
	- PKK(4)=EKK
	-C TAU-NEUTRINO MOMENTUM
	- DO 30 I=1,3
	-30 PNU(I)=-PKK(I)
	- PNU(4)=ENU
	- PXQ=AMTAU*EKK
	- PXN=AMTAU*ENU
	- QXN=PKK(4)PNU(4)-PKK(1)PNU(1)-PKK(2)PNU(2)-PKK(3)PNU(3)
	- BRAK=(GV2+GA2)(2PXQQXN-AMK2PXN)
	- & +(GV2-GA2)AMTAUAMNUTAAMK*2
	- DO 40 I=1,3
	-40 HV(I)=-ISGN2GAGVAMTAU(2PKK(I)QXN-PNU(I)AMK**2)/BRAK
	- HV(4)=1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVTOT.EQ.0) RETURN
	- FKK=0.0354
	-CFZ THERE WAS BRAK/AMTAU**4 BEFORE
	-C GAMM=(GFERMIFKK)2/(16.PI)AMTAU3
	-C * (BRAK/AMTAU4)2
	-CZW 7.02.93 here was an error affecting non standard model
	-C configurations only
	- GAMM=(GFERMIFKK)2/(16.PI)AMTAU3
	- $ (BRAK/AMTAU*4)
	- $ SQRT((AMTAU2-AMK2-AMNUTA2)2
	- $ -4AMK2AMNUTA2 )/AMTAU2
	- ERROR=0
	-
	- ERROR=0
	- RAT=GAMM/GAMEL
	- WRITE(IOUT, 7010) NEVTOT,GAMM,RAT,ERROR
	- GAMPMC(6)=RAT
	- GAMPER(6)=ERROR
	-CAM NEVDEC(6)=NEVTOT
	- ENDIF
	-C =====
	- RETURN
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMKK FINAL REPORT *****',9X,1H
	- $ /,' ',I20 ,5X,'NEVTOT = NO. OF K DECAYS TOTAL ',9X,1H,
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH ( K DECAY) IN GEV UNITS ',9X,1H,
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9X,1H
	- $ /,1X,15(5H*****)/)
	- END
	- SUBROUTINE DEXKS(MODE,ISGN,POL,PNU,PKS,PKK,PPI,JKST)
	-C ----------------------------------------------------------------------
	-C THIS SIMULATES TAU DECAY IN TAU REST FRAME
	-C INTO NU K, THEN K DECAYS INTO PI0,K+-(JKST=20)
	-C OR PI+-,K0(JKST=10).
	-C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-C PKS K* CHARGED
	-C PK0 K ZERO
	-C PKC K CHARGED
	-C PIC PION CHARGED
	-C PIZ PION ZERO
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4),HV(4),PKS(4),PNU(4),PKK(4),PPI(4),RN(1)
	- DATA IWARM/0/
	- save iwarn, hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	-CFZ INITIALISATION DONE WITH THE GHARGED PION NEUTRAL KAON MODE(JKST=10
	- CALL DADMKS( -1,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
	-CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXKS $',100,0,2)
	-CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXKS $',100,0,2)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	-300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DADMKS( 0,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(816,WT)
	-CC XHELP=HV(1)2+HV(2)2+HV(3)**2
	-CC CALL HFILL(916,XHELP)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C ======================================
	- CALL DADMKS( 1,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
	-CC CALL HPRINT(816)
	-CC CALL HPRINT(916)
	- ENDIF
	-C =====
	- RETURN
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DEXKS: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DADMKS(MODE,ISGN,HHV,PNU,PKS,PKK,PPI,JKST)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	- double precision BRA1,BRK0,BRK0B,BRKS
	- COMMON / INOUT / INUT,IOUT
	- double precision HHV(4)
	- double precision HV(4),PKS(4),PNU(4),PKK(4),PPI(4)
	- double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
	- double precision RRR(3),RMOD(1)
	- double precision SWT, SSWT
	- DATA PI /3.141592653589793238462643/
	- DATA IWARM/0/
	- save iwarn, nevraw, nevacc, nevovr, swt, sswt, wtmax
	- save hv
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- NEVRAW=0
	- NEVACC=0
	- NEVOVR=0
	- SWT=0
	- SSWT=0
	- WTMAX=1E-20
	- DO 15 I=1,500
	-C THE INITIALISATION IS DONE WITH THE 66.7% MODE
	- JKST=10
	- CALL DPHSKS(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,JKST)
	- IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	-15 CONTINUE
	-CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMKS $',100,0,2)
	-CC PRINT 7003,WTMAX
	-CC CALL HBOOK1(112,'-------- K* MASS -------- $',100,0.,2.)
	- ELSEIF(MODE.EQ. 0) THEN
	-C =====================================
	- IF(IWARM.EQ.0) GOTO 902
	-C HERE WE CHOOSE RANDOMLY BETWEEN K0 PI+_ (66.7%)
	-C AND K+_ PI0 (33.3%)
	- DEC1=BRKS
	-400 CONTINUE
	- CALL RANMAR(RMOD,1)
	- IF(RMOD(1).LT.DEC1) THEN
	- JKST=10
	- ELSE
	- JKST=20
	- ENDIF
	- CALL DPHSKS(WT,HV,PNU,PKS,PKK,PPI,JKST)
	- CALL RANMAR(RRR,3)
	- RN=RRR(1)
	- IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	- NEVRAW=NEVRAW+1
	- SWT=SWT+WT
	- SSWT=SSWT+WT**2
	- IF(RN*WTMAX.GT.WT) GOTO 400
	-C ROTATIONS TO BASIC TAU REST FRAME
	- COSTHE=-1.+2.*RRR(2)
	- THET=ACOS(COSTHE)
	- PHI =2PIRRR(3)
	- CALL ROTOR2(THET,PNU,PNU)
	- CALL ROTOR3( PHI,PNU,PNU)
	- CALL ROTOR2(THET,PKS,PKS)
	- CALL ROTOR3( PHI,PKS,PKS)
	- CALL ROTOR2(THET,PKK,PKK)
	- CALL ROTOR3(PHI,PKK,PKK)
	- CALL ROTOR2(THET,PPI,PPI)
	- CALL ROTOR3( PHI,PPI,PPI)
	- CALL ROTOR2(THET,HV,HV)
	- CALL ROTOR3( PHI,HV,HV)
	- DO 44 I=1,3
	- 44 HHV(I)=-ISGN*HV(I)
	- NEVACC=NEVACC+1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- IF(NEVRAW.EQ.0) RETURN
	- PARGAM=SWT/FLOAT(NEVRAW+1)
	- ERROR=0
	- IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	- RAT=PARGAM/GAMEL
	- WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	-CC CALL HPRINT(801)
	- GAMPMC(7)=RAT
	- GAMPER(7)=ERROR
	-CAM NEVDEC(7)=NEVACC
	- ENDIF
	-C =====
	- RETURN
	- 7003 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMKS INITIALISATION *****',9X,1H
	- $ /,' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADMKS FINAL REPORT *****',9X,1H
	- $ /,' ',I20 ,5X,'NEVRAW = NO. OF K DECAYS TOTAL ',9X,1H*,
	- $ /,' ',I20 ,5X,'NEVACC = NO. OF K DECS. ACCEPTED ',9X,1H*,
	- $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH (K DECAY) IN GEV UNITS ',9X,1H*,
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DADMKS: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DPHSKS(DGAMT,HV,PN,PKS,PKK,PPI,JKST)
	-C ----------------------------------------------------------------------
	-C IT SIMULATES KAON* DECAY IN TAU REST FRAME WITH
	-C Z-AXIS ALONG KAON* MOMENTUM
	-C JKST=10 FOR K* --->K0 + PI+-
	-C JKST=20 FOR K* --->K+- + PI0
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision HV(4),PT(4),PN(4),PKS(4),
	- * PKK(4),PPI(4),QQ(4),RR1(1)
	-cam double complex BWIGS
	- double complex BWIGM
	- DATA PI /3.141592653589793238462643/
	-C
	- DATA ICONT /0/
	- save icont, pt, qq
	-C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	- PHSPAC=1./211/PI5
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	- CALL RANMAR(RR1,1)
	-C HERE BEGIN THE K0,PI+_ DECAY
	- IF(JKST.EQ.10)THEN
	-C ==================
	-C MASS OF (REAL/VIRTUAL) K*
	- AMS1=(AMPI+AMKZ)**2
	- AMS2=(AMTAU-AMNUTA)**2
	-C FLAT PHASE SPACE
	-C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	-C AMX=SQRT(AMX2)
	-C PHSPAC=PHSPAC*(AMS2-AMS1)
	-C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
	- ALP1=ATAN((AMS1-AMKST**2)/AMKST/GAMKST)
	- ALP2=ATAN((AMS2-AMKST**2)/AMKST/GAMKST)
	- ALP=ALP1+RR1(1)*(ALP2-ALP1)
	- AMX2=AMKST*2+AMKSTGAMKST*TAN(ALP)
	- AMX=SQRT(AMX2)
	- PHSPAC=PHSPAC((AMX2-AMKST2)2+(AMKSTGAMKST)**2)
	- & /(AMKST*GAMKST)
	- PHSPAC=PHSPAC*(ALP2-ALP1)
	-C
	-C TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	- PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	-C
	-C K* MOMENTUM
	- PKS(1)=0
	- PKS(2)=0
	- PKS(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	- PKS(3)=-PN(3)
	- PHSPAC=PHSPAC(4PI)(2PKS(3)/AMTAU)
	-C
	-CAM
	- ENPI=( AMX2+AMPI2-AMKZ*2 ) / ( 2AMX )
	- PPPI=SQRT((ENPI-AMPI)*(ENPI+AMPI))
	- PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	-C CHARGED PI MOMENTUM IN KAON* REST FRAME
	- CALL SPHERA(PPPI,PPI)
	- PPI(4)=ENPI
	-C NEUTRAL KAON MOMENTUM IN K* REST FRAME
	- DO 20 I=1,3
	-20 PKK(I)=-PPI(I)
	- PKK(4)=( AMX2+AMKZ2-AMPI*2 ) / ( 2AMX )
	- EXE=(PKS(4)+PKS(3))/AMX
	-C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
	- CALL BOSTR3(EXE,PPI,PPI)
	- CALL BOSTR3(EXE,PKK,PKK)
	- DO 30 I=1,4
	-30 QQ(I)=PPI(I)-PKK(I)
	-C QQ transverse to PKS
	- PKSD =PKS(4)PKS(4)-PKS(3)PKS(3)-PKS(2)PKS(2)-PKS(1)PKS(1)
	- QQPKS=PKS(4)* QQ(4)-PKS(3)* QQ(3)-PKS(2)* QQ(2)-PKS(1)* QQ(1)
	- DO 31 I=1,4
	-31 QQ(I)=QQ(I)-PKS(I)*QQPKS/PKSD
	-C AMPLITUDE
	- PRODPQ=PT(4)*QQ(4)
	- PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	- PRODPN=PT(4)*PN(4)
	- QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	- BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	- & +(GV2-GA2)AMTAUAMNUTA*QQ2
	-C A SIMPLE BREIT-WIGNER IS CHOSEN FOR K* RESONANCE
	-cam FKS=ABS(BWIGS(AMX2,AMKST,GAMKST))**2
	- FKS=ABS(BWIGM(AMX2,AMKST,GAMKST,AMPI,AMKZ))**2
	- AMPLIT=(GFERMISCABIB)2BRAK2FKS
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	- DO 40 I=1,3
	- 40 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	-C
	-C HERE BEGIN THE K+-,PI0 DECAY
	- ELSEIF(JKST.EQ.20)THEN
	-C ======================
	-C MASS OF (REAL/VIRTUAL) K*
	- AMS1=(AMPIZ+AMK)**2
	- AMS2=(AMTAU-AMNUTA)**2
	-C FLAT PHASE SPACE
	-C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	-C AMX=SQRT(AMX2)
	-C PHSPAC=PHSPAC*(AMS2-AMS1)
	-C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
	- ALP1=ATAN((AMS1-AMKST**2)/AMKST/GAMKST)
	- ALP2=ATAN((AMS2-AMKST**2)/AMKST/GAMKST)
	- ALP=ALP1+RR1(1)*(ALP2-ALP1)
	- AMX2=AMKST*2+AMKSTGAMKST*TAN(ALP)
	- AMX=SQRT(AMX2)
	- PHSPAC=PHSPAC((AMX2-AMKST2)2+(AMKSTGAMKST)**2)
	- & /(AMKST*GAMKST)
	- PHSPAC=PHSPAC*(ALP2-ALP1)
	-C
	-C TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	- PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	-C KAON* MOMENTUM
	- PKS(1)=0
	- PKS(2)=0
	- PKS(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	- PKS(3)=-PN(3)
	- PHSPAC=PHSPAC(4PI)(2PKS(3)/AMTAU)
	-C
	-CAM
	- ENPI=( AMX2+AMPIZ2-AMK*2 ) / ( 2AMX )
	- PPPI=SQRT((ENPI-AMPIZ)*(ENPI+AMPIZ))
	- PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	-C NEUTRAL PI MOMENTUM IN K* REST FRAME
	- CALL SPHERA(PPPI,PPI)
	- PPI(4)=ENPI
	-C CHARGED KAON MOMENTUM IN K* REST FRAME
	- DO 50 I=1,3
	-50 PKK(I)=-PPI(I)
	- PKK(4)=( AMX2+AMK2-AMPIZ*2 ) / ( 2AMX )
	- EXE=(PKS(4)+PKS(3))/AMX
	-C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
	- CALL BOSTR3(EXE,PPI,PPI)
	- CALL BOSTR3(EXE,PKK,PKK)
	- DO 60 I=1,4
	-60 QQ(I)=PKK(I)-PPI(I)
	-C QQ transverse to PKS
	- PKSD =PKS(4)PKS(4)-PKS(3)PKS(3)-PKS(2)PKS(2)-PKS(1)PKS(1)
	- QQPKS=PKS(4)* QQ(4)-PKS(3)* QQ(3)-PKS(2)* QQ(2)-PKS(1)* QQ(1)
	- DO 61 I=1,4
	-61 QQ(I)=QQ(I)-PKS(I)*QQPKS/PKSD
	-C AMPLITUDE
	- PRODPQ=PT(4)*QQ(4)
	- PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	- PRODPN=PT(4)*PN(4)
	- QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	- BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	- & +(GV2-GA2)AMTAUAMNUTA*QQ2
	-C A SIMPLE BREIT-WIGNER IS CHOSEN FOR THE K* RESONANCE
	-cam FKS=ABS(BWIGS(AMX2,AMKST,GAMKST))**2
	- FKS=ABS(BWIGM(AMX2,AMKST,GAMKST,AMK,AMPIZ))**2
	- AMPLIT=(GFERMISCABIB)2BRAK2FKS
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	- DO 70 I=1,3
	- 70 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	- ENDIF
	- RETURN
	- END
	-
	-
	-
	- SUBROUTINE DPHNPI(DGAMT,HV,PN,PR,PPI,JNPI)
	-C ----------------------------------------------------------------------
	-C IT SIMULATES MULTIPI DECAY IN TAU REST FRAME WITH
	-C Z-AXIS OPPOSITE TO NEUTRINO MOMENTUM
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	-C
	- double precision PN(4),PR(4),PPI(4,9),HV(4)
	- double precision PV(5,9),PT(4),UE(3),BE(3)
	- double precision RRR(9),RORD(9),RR1(1)
	- double precision dpar(8)
	-C
	- DATA PI /3.141592653589793238462643/
	- DATA DPAR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5/
	-C
	-C PAWT(A,B,C)=SQRT((A2-(B+C)2)(A2-(B-C)2))/(2.A)
	- PAWT(A,B,C)=SQRT(MAX(0.,(A2-(B+C)2)(A2-(B-C)2)))/(2.A)
	-C
	- AMPIK(I,J)=DCDMAS(IDFFIN(I,J))
	-C
	-C
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	-C
	-C MASS OF VIRTUAL W
	- ND=MULPIK(JNPI)
	- PS=0.
	- PHSPAC = 1./2.5 /PI2
	- DO 4 I=1,ND
	-4 PS =PS+AMPIK(I,JNPI)
	- CALL RANMAR(RR1,1)
	- AMS1=PS**2
	- AMS2=(AMTAU-AMNUTA)**2
	-C
	-C
	- AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	- AMX =SQRT(AMX2)
	- AMW =AMX
	- PHSPAC=PHSPAC * (AMS2-AMS1)
	-C
	-C TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX2)
	- PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	-C W MOMENTUM
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX2)
	- PR(3)=-PN(3)
	- PHSPAC=PHSPAC * (4.PI) (2.*PR(3)/AMTAU)
	-C
	-C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
	-C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
	-C
	- PXQ=AMTAU*PR(4)
	- PXN=AMTAU*PN(4)
	- QXN=PR(4)PN(4)-PR(1)PN(1)-PR(2)PN(2)-PR(3)PN(3)
	- BRAK=2(GV2+GA2)(2PXQQXN+AMX2*PXN)
	- & -6(GV2-GA2)AMTAUAMNUTAAMX2
	-CAM Assume neutrino mass=0. and sum over final polarisation
	-C BRAK= 2(AMTAU2-AMX2) (AMTAU*2+2.AMX2)
	- AMPLIT=CCABIB*2GFERMI*2/2. BRAK * AMX2*SIGEE(AMX2,JNPI)
	- DGAMT=1./(2.AMTAU)AMPLIT*PHSPAC
	-C
	-C ISOTROPIC W DECAY IN W REST FRAME
	- PHSPAC = 1./2.*(6ND-7) /PI*(3ND-4)
	- PHSMAX = 1./dpar(nd-2)
	- DO 200 I=1,4
	- 200 PV(I,1)=PR(I)
	- PV(5,1)=AMW
	- PV(5,ND)=AMPIK(ND,JNPI)
	-C COMPUTE MAX. PHASE SPACE FACTOR
	- PMAX=AMW-PS+AMPIK(ND,JNPI)
	- PMIN=.0
	- DO 220 IL=ND-1,1,-1
	- PMAX=PMAX+AMPIK(IL,JNPI)
	- PMIN=PMIN+AMPIK(IL+1,JNPI)
	- 220 PHSMAX=PHSMAX*PAWT(PMAX,PMIN,AMPIK(IL,JNPI))
	-CAM GENERATE ND-2 EFFECTIVE MASSES (cf LUDECY)
	- PHSPAC = 1./2.*(6ND-7) /PI*(3ND-4)
	- 240 RORD(1)=1.
	- CALL RANMAR(RRR,ND-1)
	- DO 260 IL=2,ND-1
	- RSAV=RRR(IL)
	- DO 250 JL=IL-1,1,-1
	- IF(RSAV.LE.RORD(JL)) GOTO 260
	- 250 RORD(JL+1)=RORD(JL)
	- 260 RORD(JL+1)=RSAV
	- RORD(ND)=0.
	- PHS=1.
	- DO 270 IL=ND-1,1,-1
	- PV(5,IL)=PV(5,IL+1)+AMPIK(IL,JNPI)
	- & +(RORD(IL)-RORD(IL+1))*(PV(5,1)-PS)
	- 270 PHS=PHS*PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
	- RN = RRR(1)
	- IF(PHS.LT.RN*PHSMAX) GOTO 240
	-C...PERFORM SUCCESSIVE TWO-PARTICLE DECAYS IN RESPECTIVE CM FRAME
	- 280 DO 300 IL=1,ND-1
	- PA=PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
	- CALL RANMAR(RRR,2)
	- UE(3)=2.*RRR(1)-1.
	- PHI=2.PIRRR(2)
	- UE(1)=SQRT(1.-UE(3)*2)COS(PHI)
	- UE(2)=SQRT(1.-UE(3)*2)SIN(PHI)
	- DO 290 J=1,3
	- PPI(J,IL)=PA*UE(J)
	- 290 PV(J,IL+1)=-PA*UE(J)
	- PPI(4,IL)=SQRT(PA2+AMPIK(IL,JNPI)2)
	- PV(4,IL+1)=SQRT(PA2+PV(5,IL+1)2)
	- PHSPAC=PHSPAC (4.PI)(2.PA/PV(5,IL))
	- 300 CONTINUE
	-C...LORENTZ TRANSFORM DECAY PRODUCTS TO TAU FRAME
	- DO 310 J=1,4
	- 310 PPI(J,ND)=PV(J,ND)
	- DO 340 IL=ND-1,1,-1
	- DO 320 J=1,3
	- 320 BE(J)=PV(J,IL)/PV(4,IL)
	- GAM=PV(4,IL)/PV(5,IL)
	- DO 340 I=IL,ND
	- BEP=BE(1)PPI(1,I)+BE(2)PPI(2,I)+BE(3)*PPI(3,I)
	- DO 330 J=1,3
	- 330 PPI(J,I)=PPI(J,I)+GAM(GAMBEP/(1.+GAM)+PPI(4,I))*BE(J)
	- PPI(4,I)=GAM*(PPI(4,I)+BEP)
	- 340 CONTINUE
	-C
	- HV(4)=1.
	- HV(3)=0.
	- HV(2)=0.
	- HV(1)=0.
	- RETURN
	- END
	- double precision FUNCTION SIGEE(Q2,JNP)
	-C ----------------------------------------------------------------------
	-C e+e- cross section in the (1.GEV2,AMTAU**2) region
	-C normalised to sig0 = 4/3 pi alfa2
	-C used in matrix element for multipion tau decays
	-C cf YS.Tsai Phys.Rev D4 ,2821(1971)
	-C F.Gilman et al Phys.Rev D17,1846(1978)
	-C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
	-C DATSIG(*,1) = e+e- -> pi+pi-2pi0
	-C DATSIG(*,2) = e+e- -> 2pi+2pi-
	-C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
	-C (Phys Lett 78B,623(1978)
	-C DATSIG(*,5) = e+e- -> 6pi
	-C
	-C 4- and 6-pion cross sections from data
	-C 5-pion contribution related to 4-pion cross section
	-C
	-C Called by DPHNPI
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- double precision DATSIG(17,6)
	-C
	- DATA DATSIG/
	- 1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
	- 2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
	- 3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
	- 4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
	- 5 17*.0,
	- 6 17*.0,
	- 7 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25,
	- 8 17*.0/
	- DATA SIG0 / 86.8 /
	- DATA PI /3.141592653589793238462643/
	- DATA INIT / 0 /
	- save init, jnpi, ampi2, fpi, datsig
	- save s,fact,s2,t,t2
	-C
	- JNPI=JNP
	- IF(JNP.EQ.4) JNPI=3
	- IF(JNP.EQ.3) JNPI=4
	- IF(INIT.EQ.0) THEN
	- INIT=1
	- AMPI2=AMPI**2
	- FPI = .943*AMPI
	- DO 100 I=1,17
	- DATSIG(I,2) = DATSIG(I,2)/2.
	- DATSIG(I,1) = DATSIG(I,1) + DATSIG(I,2)
	- S = 1.025+(I-1)*.05
	- FACT=0.
	- S2=S**2
	- DO 200 J=1,17
	- T= 1.025+(J-1)*.05
	- IF(T . GT. S-AMPI ) GO TO 201
	- T2=T**2
	- FACT=(T2/S2)*2SQRT((S2-T2-AMPI2)*2-4.T2AMPI2)/S2 2.T.05
	- FACT = FACT * (DATSIG(J,1)+DATSIG(J+1,1))
	- 200 DATSIG(I,3) = DATSIG(I,3) + FACT
	- 201 DATSIG(I,3) = DATSIG(I,3) /(2PIFPI)**2
	- DATSIG(I,4) = DATSIG(I,3)
	- DATSIG(I,6) = DATSIG(I,5)
	- 100 CONTINUE
	-C WRITE(6,1000) DATSIG
	- 1000 FORMAT(///1X,' EE SIGMA USED IN MULTIPI DECAYS'/
	- % (17F7.2/))
	- ENDIF
	- Q=SQRT(Q2)
	- QMIN=1.
	- IF(Q.LT.QMIN) THEN
	- SIGEE=DATSIG(1,JNPI)+
	- & (DATSIG(2,JNPI)-DATSIG(1,JNPI))*(Q-1.)/.05
	- ELSEIF(Q.LT.1.8) THEN
	- DO 1 I=1,16
	- QMAX = QMIN + .05
	- IF(Q.LT.QMAX) GO TO 2
	- QMIN = QMIN + .05
	- 1 CONTINUE
	- 2 SIGEE=DATSIG(I,JNPI)+
	- & (DATSIG(I+1,JNPI)-DATSIG(I,JNPI)) * (Q-QMIN)/.05
	- ELSEIF(Q.GT.1.8) THEN
	- SIGEE=DATSIG(17,JNPI)+
	- & (DATSIG(17,JNPI)-DATSIG(16,JNPI)) * (Q-1.8)/.05
	- ENDIF
	- IF(SIGEE.LT..0) SIGEE=0.
	-C
	- SIGEE = SIGEE/(6.PI2SIG0)
	-C
	- RETURN
	- END
	-
	- double precision FUNCTION SIGOLD(Q2,JNPI)
	-C ----------------------------------------------------------------------
	-C e+e- cross section in the (1.GEV2,AMTAU**2) region
	-C normalised to sig0 = 4/3 pi alfa2
	-C used in matrix element for multipion tau decays
	-C cf YS.Tsai Phys.Rev D4 ,2821(1971)
	-C F.Gilman et al Phys.Rev D17,1846(1978)
	-C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
	-C DATSIG(*,1) = e+e- -> pi+pi-2pi0
	-C DATSIG(*,2) = e+e- -> 2pi+2pi-
	-C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
	-C (Phys Lett 78B,623(1978)
	-C DATSIG(*,4) = e+e- -> 6pi
	-C
	-C 4- and 6-pion cross sections from data
	-C 5-pion contribution related to 4-pion cross section
	-C
	-C Called by DPHNPI
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- double precision DATSIG(17,4)
	-C
	- DATA DATSIG/
	- 1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
	- 2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
	- 3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
	- 4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
	- 5 17*.0,
	- 6 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25/
	- DATA SIG0 / 86.8 /
	- DATA PI /3.141592653589793238462643/
	- DATA INIT / 0 /
	- save init, ampi2, fpi, datsig, s, fact, s2, t, t2
	-C
	- IF(INIT.EQ.0) THEN
	- INIT=1
	- AMPI2=AMPI**2
	- FPI = .943*AMPI
	- DO 100 I=1,17
	- DATSIG(I,2) = DATSIG(I,2)/2.
	- DATSIG(I,1) = DATSIG(I,1) + DATSIG(I,2)
	- S = 1.025+(I-1)*.05
	- FACT=0.
	- S2=S**2
	- DO 200 J=1,17
	- T= 1.025+(J-1)*.05
	- IF(T . GT. S-AMPI ) GO TO 201
	- T2=T**2
	- FACT=(T2/S2)*2SQRT((S2-T2-AMPI2)*2-4.T2AMPI2)/S2 2.T.05
	- FACT = FACT * (DATSIG(J,1)+DATSIG(J+1,1))
	- 200 DATSIG(I,3) = DATSIG(I,3) + FACT
	- 201 DATSIG(I,3) = DATSIG(I,3) /(2PIFPI)**2
	- 100 CONTINUE
	-C WRITE(6,1000) DATSIG
	- 1000 FORMAT(///1X,' EE SIGMA USED IN MULTIPI DECAYS'/
	- % (17F7.2/))
	- ENDIF
	- Q=SQRT(Q2)
	- QMIN=1.
	- IF(Q.LT.QMIN) THEN
	- SIGEE=DATSIG(1,JNPI)+
	- & (DATSIG(2,JNPI)-DATSIG(1,JNPI))*(Q-1.)/.05
	- ELSEIF(Q.LT.1.8) THEN
	- DO 1 I=1,16
	- QMAX = QMIN + .05
	- IF(Q.LT.QMAX) GO TO 2
	- QMIN = QMIN + .05
	- 1 CONTINUE
	- 2 SIGEE=DATSIG(I,JNPI)+
	- & (DATSIG(I+1,JNPI)-DATSIG(I,JNPI)) * (Q-QMIN)/.05
	- ELSEIF(Q.GT.1.8) THEN
	- SIGEE=DATSIG(17,JNPI)+
	- & (DATSIG(17,JNPI)-DATSIG(16,JNPI)) * (Q-1.8)/.05
	- ENDIF
	- IF(SIGEE.LT..0) SIGEE=0.
	-C
	- SIGEE = SIGEE/(6.PI2SIG0)
	- SIGOLD=SIGEE
	-C
	- RETURN
	- END
	- SUBROUTINE DPHSPK(DGAMT,HV,PN,PAA,PNPI,JAA)
	-C ----------------------------------------------------------------------
	-* IT SIMULATES THREE PI (K) DECAY IN THE TAU REST FRAME
	-* Z-AXIS ALONG HADRONIC SYSTEM
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	-
	- double precision HV(4),PN(4),PAA(4),PIM1(4),
	- * PIM2(4),PIPL(4),PNPI(4,9)
	-C MATRIX ELEMENT NUMBER:
	- MNUM=JAA
	-C TYPE OF THE GENERATION:
	- KEYT=4
	- IF(JAA.EQ.7) KEYT=3
	-C --- MASSES OF THE DECAY PRODUCTS
	- AMP1=DCDMAS(IDFFIN(1,JAA+NM4+NM5+NM6))
	- AMP2=DCDMAS(IDFFIN(2,JAA+NM4+NM5+NM6))
	- AMP3=DCDMAS(IDFFIN(3,JAA+NM4+NM5+NM6))
	- CALL
	- $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMP1,PIM2,AMP2,PIPL,AMP3,KEYT,MNUM)
	- DO I=1,4
	- PNPI(I,1)=PIM1(I)
	- PNPI(I,2)=PIM2(I)
	- PNPI(I,3)=PIPL(I)
	- ENDDO
	- END
	-
	-
	-
	-
	- SUBROUTINE
	- $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMPA,PIM2,AMPB,PIPL,AMP3,KEYT,MNUM)
	-C ----------------------------------------------------------------------
	-* IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
	-* Z-AXIS ALONG A1 MOMENTUM
	-* it can be also used to generate K K pi and K pi pi tau decays.
	-* INPUT PARAMETERS
	-* KEYT - algorithm controlling switch
	-* 2 - flat phase space PIM1 PIM2 symmetrized statistical factor 1/2
	-* 1 - like 1 but peaked around a1 and rho (two channels) masses.
	-* 3 - peaked around omega, all particles different
	-* other- flat phase space, all particles different
	-* AMP1 - mass of first pi, etc. (1-3)
	-* MNUM - matrix element type
	-* 0 - a1 matrix element
	-* 1-6 - matrix element for K pi pi, K K pi decay modes
	-* 7 - pi- pi0 gamma matrix element
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision HV(4),PT(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PR(4)
	- double precision RRR(5)
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	-
	- save icont
	- XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)*2-4.0Y*Z))
	-C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
	-C
	-C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	-C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	- PHSPAC=1./217/PI8
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	-C
	- CALL RANMAR(RRR,5)
	- RR=RRR(5)
	-C
	- CALL CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
	- $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
	- IF (ICHAN.EQ.1) THEN
	- AMP1=AMPB
	- AMP2=AMPA
	- ELSEIF (ICHAN.EQ.2) THEN
	- AMP1=AMPA
	- AMP2=AMPB
	- ELSE
	- AMP1=AMPB
	- AMP2=AMPA
	- ENDIF
	-CAM
	- RR1=RRR(1)
	- AMS1=(AMP1+AMP2+AMP3)**2
	- AMS2=(AMTAU-AMNUTA)**2
	-C phase space with sampling for a1 resonance
	- ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	- ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	- ALP=ALP1+RR1*(ALP2-ALP1)
	- AM3SQ =AMRX*2+AMRXGAMRX*TAN(ALP)
	- AM3 =SQRT(AM3SQ)
	- PHSPAC=PHSPAC((AM3SQ-AMRX2)2+(AMRXGAMRX)*2)/(AMRXGAMRX)
	- PHSPAC=PHSPAC*(ALP2-ALP1)
	-C MASS OF (REAL/VIRTUAL) RHO -
	- RR2=RRR(2)
	- AMS1=(AMP2+AMP3)**2
	- AMS2=(AM3-AMP1)**2
	- IF (ICHAN.LE.2) THEN
	-C phase space with sampling for rho resonance,
	- ALP1=ATAN((AMS1-AMRA**2)/AMRA/GAMRA)
	- ALP2=ATAN((AMS2-AMRA**2)/AMRA/GAMRA)
	- ALP=ALP1+RR2*(ALP2-ALP1)
	- AM2SQ =AMRA*2+AMRAGAMRA*TAN(ALP)
	- AM2 =SQRT(AM2SQ)
	-C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
	-C PHSPAC=PHSPAC*(ALP2-ALP1)
	-C PHSPAC=PHSPAC((AM2SQ-AMRA2)2+(AMRAGAMRA)*2)/(AMRAGAMRA)
	-C----------------------------------------------------------------------
	- ELSE
	-C flat phase space;
	- AM2SQ=AMS1+ RR2*(AMS2-AMS1)
	- AM2 =SQRT(AM2SQ)
	- PHF0=(AMS2-AMS1)
	- ENDIF
	-C rho restframe, define pipl and pim1
	- ENQ1=(AM2SQ-AMP22+AMP32)/(2*AM2)
	- ENQ2=(AM2SQ+AMP22-AMP32)/(2*AM2)
	- PPI= ENQ12-AMP32
	- PPPI=SQRT(ABS(ENQ12-AMP32))
	-C --- this part of jacobian will be recovered later
	- PHF1=(4PI)(2*PPPI/AM2)
	-C pi minus momentum in rho rest frame
	- CALL SPHERA(PPPI,PIPL)
	- PIPL(4)=ENQ1
	-C pi0 1 momentum in rho rest frame
	- DO 30 I=1,3
	- 30 PIM1(I)=-PIPL(I)
	- PIM1(4)=ENQ2
	-C a1 rest frame, define pim2
	-* RHO MOMENTUM
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1./(2AM3)(AM32+AM22-AMP1**2)
	- PR(3)= SQRT(ABS(PR(4)2-AM22))
	- PPI = PR(4)2-AM22
	-* PI0 2 MOMENTUM
	- PIM2(1)=0
	- PIM2(2)=0
	- PIM2(4)=1./(2AM3)(AM32-AM22+AMP1**2)
	- PIM2(3)=-PR(3)
	- PHF2=(4PI)(2*PR(3)/AM3)
	-C old pions boosted from rho rest frame to a1 rest frame
	- EXE=(PR(4)+PR(3))/AM2
	- CALL BOSTR3(EXE,PIPL,PIPL)
	- CALL BOSTR3(EXE,PIM1,PIM1)
	- RR3=RRR(3)
	- RR4=RRR(4)
	- THET =ACOS(-1.+2*RR3)
	- PHI = 2PIRR4
	- CALL ROTPOL(THET,PHI,PIPL)
	- CALL ROTPOL(THET,PHI,PIM1)
	- CALL ROTPOL(THET,PHI,PIM2)
	- CALL ROTPOL(THET,PHI,PR)
	-C
	-* NOW TO THE TAU REST FRAME, DEFINE A1 AND NEUTRINO MOMENTA
	-* A1 MOMENTUM
	- PAA(1)=0
	- PAA(2)=0
	- PAA(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AM3**2)
	- PAA(3)= SQRT(ABS(PAA(4)2-AM32))
	- PPI = PAA(4)2-AM32
	- PHSPAC=PHSPAC(4PI)(2PAA(3)/AMTAU)
	-* TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AM3**2)
	- PN(3)=-PAA(3)
	-C HERE WE CORRECT FOR THE JACOBIANS OF THE TWO CHAINS
	-C ---FIRST CHANNEL ------- PIM1+PIPL
	- AMS1=(AMP2+AMP3)**2
	- AMS2=(AM3-AMP1)**2
	- ALP1=ATAN((AMS1-AMRA**2)/AMRA/GAMRA)
	- ALP2=ATAN((AMS2-AMRA**2)/AMRA/GAMRA)
	- XPRO = (PIM1(3)+PIPL(3))**2
	- $ +(PIM1(2)+PIPL(2))2+(PIM1(1)+PIPL(1))2
	- AM2SQ=-XPRO+(PIM1(4)+PIPL(4))**2
	-C JACOBIAN OF SPEEDING
	- FF1 = ((AM2SQ-AMRA2)2+(AMRAGAMRA)2)/(AMRAGAMRA)
	- FF1 =FF1 *(ALP2-ALP1)
	-C LAMBDA OF RHO DECAY
	- GG1 = (4PI)(XLAM(AM2SQ,AMP22,AMP32)/AM2SQ)
	-C LAMBDA OF A1 DECAY
	- GG1 =GG1 (4PI)SQRT(4XPRO/AM3SQ)
	- XJAJE=GG1*(AMS2-AMS1)
	-C ---SECOND CHANNEL ------ PIM2+PIPL
	- AMS1=(AMP1+AMP3)**2
	- AMS2=(AM3-AMP2)**2
	- ALP1=ATAN((AMS1-AMRB**2)/AMRB/GAMRB)
	- ALP2=ATAN((AMS2-AMRB**2)/AMRB/GAMRB)
	- XPRO = (PIM2(3)+PIPL(3))**2
	- $ +(PIM2(2)+PIPL(2))2+(PIM2(1)+PIPL(1))2
	- AM2SQ=-XPRO+(PIM2(4)+PIPL(4))**2
	- FF2 = ((AM2SQ-AMRB2)2+(AMRBGAMRB)2)/(AMRBGAMRB)
	- FF2 =FF2 *(ALP2-ALP1)
	- GG2 = (4PI)(XLAM(AM2SQ,AMP12,AMP32)/AM2SQ)
	- GG2 =GG2 (4PI)SQRT(4XPRO/AM3SQ)
	- XJADW=GG2*(AMS2-AMS1)
	-C
	- A1=0.0
	- A2=0.0
	- A3=0.0
	- XJAC1=FF1*GG1
	- XJAC2=FF2*GG2
	- IF (ICHAN.EQ.2) THEN
	- XJAC3=XJADW
	- ELSE
	- XJAC3=XJAJE
	- ENDIF
	- IF (XJAC1.NE.0.0) A1=PROB1/XJAC1
	- IF (XJAC2.NE.0.0) A2=PROB2/XJAC2
	- IF (XJAC3.NE.0.0) A3=PROB3/XJAC3
	-C
	- IF (A1+A2+A3.NE.0.0) THEN
	- PHSPAC=PHSPAC/(A1+A2+A3)
	- ELSE
	- PHSPAC=0.0
	- ENDIF
	- IF(ICHAN.EQ.2) THEN
	- DO 70 I=1,4
	- X=PIM1(I)
	- PIM1(I)=PIM2(I)
	- 70 PIM2(I)=X
	- ENDIF
	-* ALL PIONS BOOSTED FROM A1 REST FRAME TO TAU REST FRAME
	-* Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
	- EXE=(PAA(4)+PAA(3))/AM3
	- CALL BOSTR3(EXE,PIPL,PIPL)
	- CALL BOSTR3(EXE,PIM1,PIM1)
	- CALL BOSTR3(EXE,PIM2,PIM2)
	- CALL BOSTR3(EXE,PR,PR)
	-C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
	- IF (MNUM.EQ.8) THEN
	- CALL DAMPOG(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	-C ELSEIF (MNUM.EQ.0) THEN
	-C CALL DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	- ELSE
	- CALL DAMPPK(MNUM,PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	- ENDIF
	- IF (KEYT.EQ.1.OR.KEYT.EQ.2) THEN
	-C THE STATISTICAL FACTOR FOR IDENTICAL PI-S IS CANCELLED WITH
	-C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
	-Cam PHSPAC=PHSPAC*2.0
	-Cam PHSPAC=PHSPAC/2.
	- ENDIF
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	- END
	- SUBROUTINE DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	-C ----------------------------------------------------------------------
	-* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	-* FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
	-* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	-* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	-* THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
	-C
	-C called by : DPHSAA
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON /TESTA1/ KEYA1
	- double precision HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PAA(4),VEC1(4),VEC2(4)
	- double precision PIVEC(4),PIAKS(4),HVM(4)
	- double complex BWIGN,HADCUR(4),FPIK
	- DATA ICONT /1/
	- save icont
	-C
	-* F CONSTANTS FOR A1, A1-RHO-PI, AND RHO-PI-PI
	-*
	- DATA FPI /93.3E-3/
	-* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
	- BWIGN(XM,AM,GAMMA)=1./CMPLX(XM2-AM2,GAMMA*AM)
	-C
	-* FOUR MOMENTUM OF A1
	- DO 10 I=1,4
	- 10 PAA(I)=PIM1(I)+PIM2(I)+PIPL(I)
	-* MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
	- XMAA =SQRT(ABS(PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2))
	- XMRO1 =SQRT(ABS((PIPL(4)+PIM1(4))2-(PIPL(1)+PIM1(1))2
	- $ -(PIPL(2)+PIM1(2))2-(PIPL(3)+PIM1(3))2))
	- XMRO2 =SQRT(ABS((PIPL(4)+PIM2(4))2-(PIPL(1)+PIM2(1))2
	- $ -(PIPL(2)+PIM2(2))2-(PIPL(3)+PIM2(3))2))
	-* ELEMENTS OF HADRON CURRENT
	- PROD1 =PAA(4)(PIM1(4)-PIPL(4))-PAA(1)(PIM1(1)-PIPL(1))
	- $ -PAA(2)(PIM1(2)-PIPL(2))-PAA(3)(PIM1(3)-PIPL(3))
	- PROD2 =PAA(4)(PIM2(4)-PIPL(4))-PAA(1)(PIM2(1)-PIPL(1))
	- $ -PAA(2)(PIM2(2)-PIPL(2))-PAA(3)(PIM2(3)-PIPL(3))
	- DO 40 I=1,4
	- VEC1(I)= PIM1(I)-PIPL(I) -PAA(I)PROD1/XMAA*2
	- 40 VEC2(I)= PIM2(I)-PIPL(I) -PAA(I)PROD2/XMAA*2
	-* HADRON CURRENT SATURATED WITH A1 AND RHO RESONANCES
	- IF (KEYA1.EQ.1) THEN
	- FA1=9.87
	- FAROPI=1.0
	- FRO2PI=1.0
	- FNORM=FA1/SQRT(2.)FAROPIFRO2PI
	- DO 45 I=1,4
	- HADCUR(I)= CMPLX(FNORM) AMA12BWIGN(XMAA,AMA1,GAMA1)
	- $ (CMPLX(VEC1(I))AMRO*2BWIGN(XMRO1,AMRO,GAMRO)
	- $ +CMPLX(VEC2(I))AMRO2BWIGN(XMRO2,AMRO,GAMRO))
	- 45 CONTINUE
	- ELSE
	- FNORM=2.0*SQRT(2.)/3.0/FPI
	- GAMAX=GAMA1GFUN(XMAA2)/GFUN(AMA1*2)
	- DO 46 I=1,4
	- HADCUR(I)= CMPLX(FNORM) AMA12BWIGN(XMAA,AMA1,GAMAX)
	- $ (CMPLX(VEC1(I))FPIK(XMRO1)
	- $ +CMPLX(VEC2(I))*FPIK(XMRO2))
	- 46 CONTINUE
	- ENDIF
	-C
	-* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	- CALL CLVEC(HADCUR,PN,PIVEC)
	- CALL CLAXI(HADCUR,PN,PIAKS)
	- CALL CLNUT(HADCUR,BRAKM,HVM)
	-* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	- BRAK= (GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	- & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	- AMPLIT=(GFERMICCABIB)2BRAK/2.
	-C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
	-C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
	-C POLARIMETER VECTOR IN TAU REST FRAME
	- DO 90 I=1,3
	- HV(I)=-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	- & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	-C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	- HV(I)=-HV(I)/BRAK
	- 90 CONTINUE
	- END
	-
	- double precision FUNCTION GFUN(QKWA)
	-C ****************************************************************
	-C G-FUNCTION USED TO INRODUCE ENERGY DEPENDENCE IN A1 WIDTH
	-C ****************************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- IF (QKWA.LT.(AMRO+AMPI)**2) THEN
	- GFUN=4.1(QKWA-9AMPIZ2)3
	- $ (1.-3.3(QKWA-9AMPIZ2)+5.8(QKWA-9AMPIZ2)*2)
	- ELSE
	- GFUN=QKWA(1.623+10.38/QKWA-9.32/QKWA2+0.65/QKWA*3)
	- ENDIF
	- END
	- double complex FUNCTION BWIGS(S,M,G)
	-C **********************************************************
	-C P-WAVE BREIT-WIGNER FOR K*
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double precision S,M,G
	- double precision PI,PIM,QS,QM,W,GS,MK
	- SAVE PI,PIM,MK
	- DATA INIT /0/
	- P(A,B,C)=SQRT(ABS(ABS(((A+B-C)*2-4.A*B)/4./A)
	- $ +(((A+B-C)*2-4.A*B)/4./A))/2.0)
	- save init
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0) THEN
	- INIT=1
	- PI=3.141592654
	- PIM=.139
	- MK=.493667
	-C ------- BREIT-WIGNER -----------------------
	- ENDIF
	- IF (S.GT.(PIM+MK)**2) THEN
	- QS=P(S,PIM2,MK2)
	- QM=P(M2,PIM2,MK**2)
	- W=SQRT(S)
	- GS=G(M/W)(QS/QM)**3
	- ELSE
	- GS=0.0
	- ENDIF
	- BWIGS=M2/CMPLX(M2-S,-M*GS)
	- RETURN
	- END
	- double complex FUNCTION BWIG(S,M,G)
	-C **********************************************************
	-C P-WAVE BREIT-WIGNER FOR RHO
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double precision S,M,G
	- double precision PI,PIM,QS,QM,W,GS,radicand
	- DATA INIT /0/
	- SAVE PI, PIM
	- save init
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0) THEN
	- INIT=1
	- PI=3.141592654
	- PIM=.139
	-C ------- BREIT-WIGNER -----------------------
	- ENDIF
	- IF (S.GT.4.PIM*2) THEN
	- radicand = ABS(ABS(S/4.-PIM2)+(S/4.-PIM2))/2.0
	- QS=SQRT(radicand)
	- radicand = M2/4.-PIM2
	- QM=SQRT(radicand)
	- W=SQRT(S)
	- GS=G(M/W)(QS/QM)**3
	- ELSE
	- GS=0.0
	- ENDIF
	- BWIG=M2/CMPLX(M2-S,-M*GS)
	- RETURN
	- END
	- double complex FUNCTION FPIK(W)
	-C **********************************************************
	-C PION FORM FACTOR
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double complex BWIG
	- double precision ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
	- SAVE PI,PIM,ROM,ROG,ROM1,ROG1,BETA1
	- EXTERNAL BWIG
	- DATA INIT /0/
	-C
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0 ) THEN
	- INIT=1
	- PI=3.141592654
	- PIM=.140
	- ROM=0.773
	- ROG=0.145
	- ROM1=1.370
	- ROG1=0.510
	- BETA1=-0.145
	- ENDIF
	-C -----------------------------------------------
	- S=W**2
	- FPIK= (BWIG(S,ROM,ROG)+BETA1*BWIG(S,ROM1,ROG1))
	- & /(1+BETA1)
	- RETURN
	- END
	- double precision FUNCTION FPIRHO(W)
	-C **********************************************************
	-C SQUARE OF PION FORM FACTOR
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double precision :: w
	- double complex FPIK
	- FPIRHO=ABS(FPIK(W))**2
	- END
	- SUBROUTINE CLVEC(HJ,PN,PIV)
	-C ----------------------------------------------------------------------
	-* CALCULATES THE "VECTOR TYPE" PI-VECTOR PIV
	-* NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
	-C
	-C called by : DAMPAA
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PIV(4),PN(4)
	- double complex HJ(4),HN
	-C
	- HN= HJ(4)CMPLX(PN(4))-HJ(3)CMPLX(PN(3))
	- HH= REAL(HJ(4)CONJG(HJ(4))-HJ(3)CONJG(HJ(3))
	- $ -HJ(2)CONJG(HJ(2))-HJ(1)CONJG(HJ(1)))
	- DO 10 I=1,4
	- 10 PIV(I)=4.REAL(HNCONJG(HJ(I)))-2.HHPN(I)
	- RETURN
	- END
	- SUBROUTINE CLAXI(HJ,PN,PIA)
	-C ----------------------------------------------------------------------
	-* CALCULATES THE "AXIAL TYPE" PI-VECTOR PIA
	-* NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
	-C SIGN is chosen +/- for decay of TAU +/- respectively
	-C called by : DAMPAA, CLNUT
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	- COMMON / IDFC / IDFF
	- double precision PIA(4),PN(4)
	- double complex HJ(4),HJC(4)
	-C DET2(I,J)=AIMAG(HJ(I)HJC(J)-HJ(J)HJC(I))
	-C -- here was an error (ZW, 21.11.1991)
	- DET2(I,J)=AIMAG(HJC(I)HJ(J)-HJC(J)HJ(I))
	-C -- it was affecting sign of A_LR asymmetry in a1 decay.
	-C -- note also collision of notation of gamma_va as defined in
	-C -- TAUOLA paper and J.H. Kuhn and Santamaria Z. Phys C 48 (1990) 445
	-* -----------------------------------
	- IF (KTOM.EQ.1.OR.KTOM.EQ.-1) THEN
	- SIGN= IDFF/ABS(IDFF)
	- ELSEIF (KTOM.EQ.2) THEN
	- SIGN=-IDFF/ABS(IDFF)
	- ELSE
	- PRINT *, 'STOP IN CLAXI: KTOM=',KTOM
	- STOP
	- ENDIF
	-C
	- DO 10 I=1,4
	- 10 HJC(I)=CONJG(HJ(I))
	- PIA(1)= -2.PN(3)DET2(2,4)+2.PN(4)DET2(2,3)
	- PIA(2)= -2.PN(4)DET2(1,3)+2.PN(3)DET2(1,4)
	- PIA(3)= 2.PN(4)DET2(1,2)
	- PIA(4)= 2.PN(3)DET2(1,2)
	-C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
	- DO 20 I=1,4
	- 20 PIA(I)=PIA(I)*SIGN
	- END
	- SUBROUTINE CLNUT(HJ,B,HV)
	-C ----------------------------------------------------------------------
	-* CALCULATES THE CONTRIBUTION BY NEUTRINO MASS
	-* NOTE THE TAU IS ASSUMED TO BE AT REST
	-C
	-C called by : DAMPAA
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double complex HJ(4)
	- double precision HV(4),P(4)
	- DATA P /3*0.,1.0/
	-C
	- CALL CLAXI(HJ,P,HV)
	- B=REAL( HJ(4)AIMAG(HJ(4)) - HJ(3)AIMAG(HJ(3))
	- & - HJ(2)AIMAG(HJ(2)) - HJ(1)AIMAG(HJ(1)) )
	- RETURN
	- END
	- SUBROUTINE DAMPOG(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	-C ----------------------------------------------------------------------
	-* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	-* FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
	-* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	-* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	-* THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
	-C
	-C called by : DPHTRE
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON /TESTA1/ KEYA1
	- double precision HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
	- double precision PAA(4),VEC1(4),VEC2(4)
	- double precision PIVEC(4),PIAKS(4),HVM(4)
	- double complex BWIGN,HADCUR(4),FNORM,FORMOM
	- DATA ICONT /1/
	- save icont
	-* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
	- !BWIGN(XM,AM,GAMMA)=1./CMPLX(XM2-AM2,GAMMA*AM)
	-C
	-* FOUR MOMENTUM OF A1
	- DO 10 I=1,4
	- VEC1(I)=0.0
	- VEC2(I)=0.0
	- HV(I) =0.0
	- 10 PAA(I)=PIM1(I)+PIM2(I)+PIPL(I)
	- VEC1(1)=1.0
	-* MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
	- XMAA =SQRT(ABS(PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2))
	- XMOM =SQRT(ABS( (PIM2(4)+PIPL(4))2-(PIM2(3)+PIPL(3))2
	- $ -(PIM2(2)+PIPL(2))2-(PIM2(1)+PIPL(1))2 ))
	- XMRO2 =(PIPL(1))2 +(PIPL(2))2 +(PIPL(3))**2
	-* ELEMENTS OF HADRON CURRENT
	- PROD1 =VEC1(1)*PIPL(1)
	- PROD2 =VEC2(2)*PIPL(2)
	- P12 =PIM1(4)PIM2(4)-PIM1(1)PIM2(1)
	- $ -PIM1(2)PIM2(2)-PIM1(3)PIM2(3)
	- P1PL =PIM1(4)PIPL(4)-PIM1(1)PIPL(1)
	- $ -PIM1(2)PIPL(2)-PIM1(3)PIPL(3)
	- P2PL =PIPL(4)PIM2(4)-PIPL(1)PIM2(1)
	- $ -PIPL(2)PIM2(2)-PIPL(3)PIM2(3)
	- DO 40 I=1,3
	- VEC1(I)= (VEC1(I)-PROD1/XMRO2*PIPL(I))
	- 40 CONTINUE
	- GNORM=SQRT(VEC1(1)2+VEC1(2)2+VEC1(3)**2)
	- DO 41 I=1,3
	- VEC1(I)= VEC1(I)/GNORM
	- 41 CONTINUE
	- VEC2(1)=(VEC1(2)PIPL(3)-VEC1(3)PIPL(2))/SQRT(XMRO2)
	- VEC2(2)=(VEC1(3)PIPL(1)-VEC1(1)PIPL(3))/SQRT(XMRO2)
	- VEC2(3)=(VEC1(1)PIPL(2)-VEC1(2)PIPL(1))/SQRT(XMRO2)
	- P1VEC1 =PIM1(4)VEC1(4)-PIM1(1)VEC1(1)
	- $ -PIM1(2)VEC1(2)-PIM1(3)VEC1(3)
	- P2VEC1 =VEC1(4)PIM2(4)-VEC1(1)PIM2(1)
	- $ -VEC1(2)PIM2(2)-VEC1(3)PIM2(3)
	- P1VEC2 =PIM1(4)VEC2(4)-PIM1(1)VEC2(1)
	- $ -PIM1(2)VEC2(2)-PIM1(3)VEC2(3)
	- P2VEC2 =VEC2(4)PIM2(4)-VEC2(1)PIM2(1)
	- $ -VEC2(2)PIM2(2)-VEC2(3)PIM2(3)
	-* HADRON CURRENT
	- FNORM=FORMOM(XMAA,XMOM)
	- BRAK=0.0
	- DO 120 JJ=1,2
	- DO 45 I=1,4
	- IF (JJ.EQ.1) THEN
	- HADCUR(I) = FNORM *(
	- $ VEC1(I)(AMPI2P1PL-P2PL*(P12-P1PL))
	- $ -PIM2(I)(P2VEC1P1PL-P1VEC1*P2PL)
	- $ +PIPL(I)(P2VEC1P12 -P1VEC1(AMPI*2+P2PL)) )
	- ELSE
	- HADCUR(I) = FNORM *(
	- $ VEC2(I)(AMPI2P1PL-P2PL*(P12-P1PL))
	- $ -PIM2(I)(P2VEC2P1PL-P1VEC2*P2PL)
	- $ +PIPL(I)(P2VEC2P12 -P1VEC2(AMPI*2+P2PL)) )
	- ENDIF
	- 45 CONTINUE
	-C
	-* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	- CALL CLVEC(HADCUR,PN,PIVEC)
	- CALL CLAXI(HADCUR,PN,PIAKS)
	- CALL CLNUT(HADCUR,BRAKM,HVM)
	-* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	- BRAK=BRAK+(GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	- & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	- DO 90 I=1,3
	- HV(I)=HV(I)-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	- & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	- 90 CONTINUE
	-C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	- 120 CONTINUE
	- AMPLIT=(GFERMICCABIB)2BRAK/2.
	-C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
	-C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
	-C POLARIMETER VECTOR IN TAU REST FRAME
	- DO 91 I=1,3
	- HV(I)=-HV(I)/BRAK
	- 91 CONTINUE
	-
	- END
	- SUBROUTINE DAMPPK(MNUM,PT,PN,PIM1,PIM2,PIM3,AMPLIT,HV)
	-C ----------------------------------------------------------------------
	-* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	-* FOR TAU DECAY INTO K K pi, K pi pi.
	-* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	-* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	-C MNUM DECAY MODE IDENTIFIER.
	-C
	-C called by : DPHTRE
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4)
	- double precision PAA(4),VEC1(4),VEC2(4),VEC3(4),VEC4(4),VEC5(4)
	- double precision PIVEC(4),PIAKS(4),HVM(4)
	- double precision FNORM(0:7),COEF(1:5,0:7)
	- double complex HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5,UROJ
	- EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
	- SAVE UROJ,DWAPI0,FNORM,COEF
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	- save icont
	-C
	- DATA FPI /93.3E-3/
	- IF (ICONT.EQ.0) THEN
	- ICONT=1
	- UROJ=CMPLX(0.0,1.0)
	- DWAPI0=SQRT(2.0)
	- FNORM(0)=CCABIB/FPI
	- FNORM(1)=CCABIB/FPI
	- FNORM(2)=CCABIB/FPI
	- FNORM(3)=CCABIB/FPI
	- FNORM(4)=SCABIB/FPI/DWAPI0
	- FNORM(5)=SCABIB/FPI
	- FNORM(6)=SCABIB/FPI
	- FNORM(7)=CCABIB/FPI
	-C
	- COEF(1,0)= 2.0*SQRT(2.)/3.0
	- COEF(2,0)=-2.0*SQRT(2.)/3.0
	- COEF(3,0)= 0.0
	- COEF(4,0)= FPI
	- COEF(5,0)= 0.0
	-C
	- COEF(1,1)=-SQRT(2.)/3.0
	- COEF(2,1)= SQRT(2.)/3.0
	- COEF(3,1)= 0.0
	- COEF(4,1)= FPI
	- COEF(5,1)= SQRT(2.)
	-C
	- COEF(1,2)=-SQRT(2.)/3.0
	- COEF(2,2)= SQRT(2.)/3.0
	- COEF(3,2)= 0.0
	- COEF(4,2)= 0.0
	- COEF(5,2)=-SQRT(2.)
	-C
	- COEF(1,3)= 0.0
	- COEF(2,3)=-1.0
	- COEF(3,3)= 0.0
	- COEF(4,3)= 0.0
	- COEF(5,3)= 0.0
	-C
	- COEF(1,4)= 1.0/SQRT(2.)/3.0
	- COEF(2,4)=-1.0/SQRT(2.)/3.0
	- COEF(3,4)= 0.0
	- COEF(4,4)= 0.0
	- COEF(5,4)= 0.0
	-C
	- COEF(1,5)=-SQRT(2.)/3.0
	- COEF(2,5)= SQRT(2.)/3.0
	- COEF(3,5)= 0.0
	- COEF(4,5)= 0.0
	- COEF(5,5)=-SQRT(2.)
	-C
	- COEF(1,6)= 0.0
	- COEF(2,6)=-1.0
	- COEF(3,6)= 0.0
	- COEF(4,6)= 0.0
	- COEF(5,6)=-2.0
	-C
	- COEF(1,7)= 0.0
	- COEF(2,7)= 0.0
	- COEF(3,7)= 0.0
	- COEF(4,7)= 0.0
	- COEF(5,7)=-SQRT(2.0/3.0)
	-C
	- ENDIF
	-C
	- DO 10 I=1,4
	- 10 PAA(I)=PIM1(I)+PIM2(I)+PIM3(I)
	- XMAA =SQRT(ABS(PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2))
	- XMRO1 =SQRT(ABS((PIM3(4)+PIM2(4))2-(PIM3(1)+PIM2(1))2
	- $ -(PIM3(2)+PIM2(2))2-(PIM3(3)+PIM2(3))2))
	- XMRO2 =SQRT(ABS((PIM3(4)+PIM1(4))2-(PIM3(1)+PIM1(1))2
	- $ -(PIM3(2)+PIM1(2))2-(PIM3(3)+PIM1(3))2))
	- XMRO3 =SQRT(ABS((PIM1(4)+PIM2(4))2-(PIM1(1)+PIM2(1))2
	- $ -(PIM1(2)+PIM2(2))2-(PIM1(3)+PIM2(3))2))
	-* ELEMENTS OF HADRON CURRENT
	- PROD1 =PAA(4)(PIM2(4)-PIM3(4))-PAA(1)(PIM2(1)-PIM3(1))
	- $ -PAA(2)(PIM2(2)-PIM3(2))-PAA(3)(PIM2(3)-PIM3(3))
	- PROD2 =PAA(4)(PIM3(4)-PIM1(4))-PAA(1)(PIM3(1)-PIM1(1))
	- $ -PAA(2)(PIM3(2)-PIM1(2))-PAA(3)(PIM3(3)-PIM1(3))
	- PROD3 =PAA(4)(PIM1(4)-PIM2(4))-PAA(1)(PIM1(1)-PIM2(1))
	- $ -PAA(2)(PIM1(2)-PIM2(2))-PAA(3)(PIM1(3)-PIM2(3))
	- DO 40 I=1,4
	- VEC1(I)= PIM2(I)-PIM3(I) -PAA(I)PROD1/XMAA*2
	- VEC2(I)= PIM3(I)-PIM1(I) -PAA(I)PROD2/XMAA*2
	- VEC3(I)= PIM1(I)-PIM2(I) -PAA(I)PROD3/XMAA*2
	- 40 VEC4(I)= PIM1(I)+PIM2(I)+PIM3(I)
	- CALL PROD5(PIM1,PIM2,PIM3,VEC5)
	-* HADRON CURRENT
	-C be aware that sign of vec2 is opposite to sign of vec1 in a1 case
	- DO 45 I=1,4
	- HADCUR(I)= CMPLX(FNORM(MNUM)) * (
	- $CMPLX(VEC1(I)COEF(1,MNUM))FORM1(MNUM,XMAA2,XMRO12,XMRO2**2)+
	- $CMPLX(VEC2(I)COEF(2,MNUM))FORM2(MNUM,XMAA2,XMRO22,XMRO1**2)+
	- $CMPLX(VEC3(I)COEF(3,MNUM))FORM3(MNUM,XMAA2,XMRO32,XMRO1**2)+
	- (-1.0UROJ)*
	- $CMPLX(VEC4(I)COEF(4,MNUM))FORM4(MNUM,XMAA2,XMRO12,
	- $ XMRO22,XMRO32) +
	- $(-1.0)UROJ/4.0/PI2/FPI2
	- $CMPLX(VEC5(I)COEF(5,MNUM))FORM5(MNUM,XMAA2,XMRO12,XMRO2**2))
	- 45 CONTINUE
	-C
	-* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	- CALL CLVEC(HADCUR,PN,PIVEC)
	- CALL CLAXI(HADCUR,PN,PIAKS)
	- CALL CLNUT(HADCUR,BRAKM,HVM)
	-* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	- BRAK= (GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	- & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	- AMPLIT=(GFERMI)*2BRAK/2.
	- IF (MNUM.GE.9) THEN
	- PRINT *, 'MNUM=',MNUM
	- ZNAK=-1.0
	- XM1=0.0
	- XM2=0.0
	- XM3=0.0
	- DO 77 K=1,4
	- IF (K.EQ.4) ZNAK=1.0
	- XM1=ZNAKPIM1(K)*2+XM1
	- XM2=ZNAKPIM2(K)*2+XM2
	- XM3=ZNAKPIM3(K)*2+XM3
	- 77 PRINT *, 'PIM1=',PIM1(K),'PIM2=',PIM2(K),'PIM3=',PIM3(K)
	- PRINT *, 'XM1=',SQRT(XM1),'XM2=',SQRT(XM2),'XM3=',SQRT(XM3)
	- PRINT , '***********************************************'
	- ENDIF
	-C POLARIMETER VECTOR IN TAU REST FRAME
	- DO 90 I=1,3
	- HV(I)=-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	- & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	-C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	- HV(I)=-HV(I)/BRAK
	- 90 CONTINUE
	- END
	- SUBROUTINE PROD5(P1,P2,P3,PIA)
	-C ----------------------------------------------------------------------
	-C external product of P1, P2, P3 4-momenta.
	-C SIGN is chosen +/- for decay of TAU +/- respectively
	-C called by : DAMPAA, CLNUT
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	- COMMON / IDFC / IDFF
	- double precision PIA(4),P1(4),P2(4),P3(4)
	- DET2(I,J)=P1(I)P2(J)-P2(I)P1(J)
	-* -----------------------------------
	- IF (KTOM.EQ.1.OR.KTOM.EQ.-1) THEN
	- SIGN= IDFF/ABS(IDFF)
	- ELSEIF (KTOM.EQ.2) THEN
	- SIGN=-IDFF/ABS(IDFF)
	- ELSE
	- PRINT *, 'STOP IN PROD5: KTOM=',KTOM
	- STOP
	- ENDIF
	-C
	-C EPSILON( p1(1), p2(2), p3(3), (4) ) = 1
	-C
	- PIA(1)= -P3(3)DET2(2,4)+P3(4)DET2(2,3)+P3(2)*DET2(3,4)
	- PIA(2)= -P3(4)DET2(1,3)+P3(3)DET2(1,4)-P3(1)*DET2(3,4)
	- PIA(3)= P3(4)DET2(1,2)-P3(2)DET2(1,4)+P3(1)*DET2(2,4)
	- PIA(4)= P3(3)DET2(1,2)-P3(2)DET2(1,3)+P3(1)*DET2(2,3)
	-C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
	- DO 20 I=1,4
	- 20 PIA(I)=PIA(I)*SIGN
	- END
	-
	- SUBROUTINE DEXNEW(MODE,ISGN,POL,PNU,PAA,PNPI,JNPI)
	-C ----------------------------------------------------------------------
	-* THIS SIMULATES TAU DECAY IN TAU REST FRAME
	-* INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
	-* OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	-* PAA hadron 4-vector
	-* PNPI final state particles
	-* JNPI decay type
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / INOUT / INUT,IOUT
	- double precision POL(4),HV(4),PAA(4),PNU(4),PNPI(4,9),RN(1)
	- DATA IWARM/0/
	- save iwarn
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	- IWARM=1
	- CALL DADNEW( -1,ISGN,HV,PNU,PAA,PNPI,JDUMM)
	-CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXNEW $',100,-2.,2.)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-* =======================
	- 300 CONTINUE
	- IF(IWARM.EQ.0) GOTO 902
	- CALL DADNEW( 0,ISGN,HV,PNU,PAA,PNPI,JNPI)
	- WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	-CC CALL HFILL(816,WT)
	- CALL RANMAR(RN,1)
	- IF(RN(1).GT.WT) GOTO 300
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-* =======================
	- CALL DADNEW( 1,ISGN,HV,PNU,PAA,PNPI,JDUMM)
	-CC CALL HPRINT(816)
	- ENDIF
	-C =====
	- RETURN
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DEXNEW: LACK OF INITIALISATION')
	- STOP
	- END
	- SUBROUTINE DADNEW(MODE,ISGN,HV,PNU,PWB,PNPI,JNPI)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	- double precision GAMPMC ,GAMPER
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	- COMMON / INOUT / INUT,IOUT
	-
	- double precision PNU(4),PWB(4),PNPI(4,9),HV(4),HHV(4)
	- double precision PDUM1(4),PDUM2(4),PDUMI(4,9)
	- double precision RRR(3)
	- double precision WTMAX(NMODE)
	- double precision SWT(NMODE),SSWT(NMODE)
	- DIMENSION NEVRAW(NMODE),NEVOVR(NMODE),NEVACC(NMODE)
	-
	- save wtmax, nevraw, nevovr, nevacc, swt, sswt
	- save hhv, rrr, iwarn
	-
	-C
	- DATA PI /3.141592653589793238462643/
	- DATA IWARM/0/
	-C
	- IF(MODE.EQ.-1) THEN
	-C ===================
	-C -- AT THE MOMENT ONLY TWO DECAY MODES OF MULTIPIONS HAVE M. ELEM
	- NMOD=NMODE
	- IWARM=1
	-C PRINT 7003
	- DO 1 JNPI=1,NMOD
	- NEVRAW(JNPI)=0
	- NEVACC(JNPI)=0
	- NEVOVR(JNPI)=0
	- SWT(JNPI)=0
	- SSWT(JNPI)=0
	- WTMAX(JNPI)=-1.
	- DO I=1,500
	- IF (JNPI.LE.0) THEN
	- GOTO 903
	- ELSEIF(JNPI.LE.NM4) THEN
	- CALL DPH4PI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
	- ELSEIF(JNPI.LE.NM4+NM5) THEN
	- CALL DPH5PI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
	- ELSEIF(JNPI.LE.NM4+NM5+NM6) THEN
	- CALL DPHNPI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
	- ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3) THEN
	- INUM=JNPI-NM4-NM5-NM6
	- CALL DPHSPK(WT,HV,PDUM1,PDUM2,PDUMI,INUM)
	- ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3+NM2) THEN
	- INUM=JNPI-NM4-NM5-NM6-NM3
	- CALL DPHSRK(WT,HV,PDUM1,PDUM2,PDUMI,INUM)
	- ELSE
	- GOTO 903
	- ENDIF
	- IF(WT.GT.WTMAX(JNPI)/1.2) WTMAX(JNPI)=WT*1.2
	- ENDDO
	-C CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADNPI $',100,0.,2.,.0)
	-C PRINT 7004,WTMAX(JNPI)
	-1 CONTINUE
	- WRITE(IOUT,7005)
	-C
	- ELSEIF(MODE.EQ. 0) THEN
	-C =======================
	- IF(IWARM.EQ.0) GOTO 902
	-C
	-300 CONTINUE
	- IF (JNPI.LE.0) THEN
	- GOTO 903
	- ELSEIF(JNPI.LE.NM4) THEN
	- CALL DPH4PI(WT,HHV,PNU,PWB,PNPI,JNPI)
	- ELSEIF(JNPI.LE.NM4+NM5) THEN
	- CALL DPH5PI(WT,HHV,PNU,PWB,PNPI,JNPI)
	- ELSEIF(JNPI.LE.NM4+NM5+NM6) THEN
	- CALL DPHNPI(WT,HHV,PNU,PWB,PNPI,JNPI)
	- ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3) THEN
	- INUM=JNPI-NM4-NM5-NM6
	- CALL DPHSPK(WT,HHV,PNU,PWB,PNPI,INUM)
	- ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3+NM2) THEN
	- INUM=JNPI-NM4-NM5-NM6-NM3
	- CALL DPHSRK(WT,HHV,PNU,PWB,PNPI,INUM)
	- ELSE
	- GOTO 903
	- ENDIF
	- DO I=1,4
	- HV(I)=-ISGN*HHV(I)
	- ENDDO
	-C CALL HFILL(801,WT/WTMAX(JNPI))
	- NEVRAW(JNPI)=NEVRAW(JNPI)+1
	- SWT(JNPI)=SWT(JNPI)+WT
	- SSWT(JNPI)=SSWT(JNPI)+WT**2
	- CALL RANMAR(RRR,3)
	- RN=RRR(1)
	- IF(WT.GT.WTMAX(JNPI)) NEVOVR(JNPI)=NEVOVR(JNPI)+1
	- IF(RN*WTMAX(JNPI).GT.WT) GOTO 300
	-C ROTATIONS TO BASIC TAU REST FRAME
	- COSTHE=-1.+2.*RRR(2)
	- THET=ACOS(COSTHE)
	- PHI =2PIRRR(3)
	- CALL ROTOR2(THET,PNU,PNU)
	- CALL ROTOR3( PHI,PNU,PNU)
	- CALL ROTOR2(THET,PWB,PWB)
	- CALL ROTOR3( PHI,PWB,PWB)
	- CALL ROTOR2(THET,HV,HV)
	- CALL ROTOR3( PHI,HV,HV)
	- ND=MULPIK(JNPI)
	- DO 301 I=1,ND
	- CALL ROTOR2(THET,PNPI(1,I),PNPI(1,I))
	- CALL ROTOR3( PHI,PNPI(1,I),PNPI(1,I))
	-301 CONTINUE
	- NEVACC(JNPI)=NEVACC(JNPI)+1
	-C
	- ELSEIF(MODE.EQ. 1) THEN
	-C =======================
	- DO 500 JNPI=1,NMOD
	- IF(NEVRAW(JNPI).EQ.0) GOTO 500
	- PARGAM=SWT(JNPI)/FLOAT(NEVRAW(JNPI)+1)
	- ERROR=0
	- IF(NEVRAW(JNPI).NE.0)
	- & ERROR=SQRT(SSWT(JNPI)/SWT(JNPI)**2-1./FLOAT(NEVRAW(JNPI)))
	- RAT=PARGAM/GAMEL
	- WRITE(IOUT, 7010) NAMES(JNPI),
	- & NEVRAW(JNPI),NEVACC(JNPI),NEVOVR(JNPI),PARGAM,RAT,ERROR
	-CC CALL HPRINT(801)
	- GAMPMC(8+JNPI-1)=RAT
	- GAMPER(8+JNPI-1)=ERROR
	-CAM NEVDEC(8+JNPI-1)=NEVACC(JNPI)
	- 500 CONTINUE
	- ENDIF
	-C =====
	- RETURN
	- 7003 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADNEW INITIALISATION *****',9X,1H
	- $ )
	- 7004 FORMAT(' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H/)
	- 7005 FORMAT(
	- $ /,1X,15(5H*****)/)
	- 7010 FORMAT(///1X,15(5H*****)
	- $ /,' ', 25X,'***** DADNEW FINAL REPORT ****** ',9X,1H*
	- $ /,' ', 25X,'CHANNEL:',A31 ,9X,1H
	- $ /,' ',I20 ,5X,'NEVRAW = NO. OF DECAYS TOTAL ',9X,1H
	- $ /,' ',I20 ,5X,'NEVACC = NO. OF DECAYS ACCEPTED ',9X,1H
	- $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	- $ /,' ',E20.5,5X,'PARTIAL WTDTH IN GEV UNITS ',9X,1H
	- $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	- $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	- $ /,1X,15(5H*****)/)
	- 902 WRITE(IOUT, 9020)
	- 9020 FORMAT(' ----- DADNEW: LACK OF INITIALISATION')
	- STOP
	- 903 WRITE(IOUT, 9030) JNPI,MODE
	- 9030 FORMAT(' ----- DADNEW: WRONG JNPI',2I5)
	- STOP
	- END
	-
	-
	- SUBROUTINE DPH4PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
	-C ----------------------------------------------------------------------
	-* IT SIMULATES 4pi DECAY IN TAU REST FRAME WITH
	-* Z-AXIS ALONG 4pi MOMENTUM
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	- double precision HV(4),PT(4),PN(4),PAA(4),PIM1(4),
	- * PIM2(4),PIPL(4),PMULT(4,9)
	- double precision PR(4),PIZ(4)
	- double precision RRR(9)
	- double precision UU,FF,FF1,FF2,FF3,FF4,GG1,GG2,GG3,GG4,RR
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	- save icont
	- integer k
	- XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)*2-4.0Y*Z))
	-C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
	-C
	-C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	-C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	-C JRR: Initializing the polarimeter vector to zero
	- HV = 0
	- PHSPAC=1./223/PI11
	- PHSP=1./25/PI2
	-C init decay mode JNPI
	- AMP1=DCDMAS(IDFFIN(1,JNPI))
	- AMP2=DCDMAS(IDFFIN(2,JNPI))
	- AMP3=DCDMAS(IDFFIN(3,JNPI))
	- AMP4=DCDMAS(IDFFIN(4,JNPI))
	- IF (JNPI.EQ.1) THEN
	- PREZ=0.7
	- AMRX=0.782
	- GAMRX=0.0084
	- AMROP =1.2
	- GAMROP=.46
	- ELSE
	- PREZ=0.0
	- AMRX=1.4
	- GAMRX=.6
	- AMROP =AMRX
	- GAMROP=GAMRX
	-
	- ENDIF
	-! 07.06.96 here was an error in the type of variable.
	- RRDUM=0.3
	- CALL CHOICE(100+JNPI,RRDUM,ICHAN,PROB1,PROB2,PROB3,
	- $ AMROP,GAMROP,AMRX,GAMRX,AMRB,GAMRB)
	- PREZ=PROB1+PROB2
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	-C
	- CALL RANMAR(RRR,9)
	-C
	-* MASSES OF 4, 3 AND 2 PI SYSTEMS
	-C 3 PI WITH SAMPLING FOR RESONANCE
	-CAM
	- RR1=RRR(6)
	- AMS1=(AMP1+AMP2+AMP3+AMP4)**2
	- AMS2=(AMTAU-AMNUTA)**2
	- ALP1=ATAN((AMS1-AMROP**2)/AMROP/GAMROP)
	- ALP2=ATAN((AMS2-AMROP**2)/AMROP/GAMROP)
	- ALP=ALP1+RR1*(ALP2-ALP1)
	- AM4SQ =AMROP*2+AMROPGAMROP*TAN(ALP)
	- AM4 =SQRT(AM4SQ)
	- PHSPAC=PHSPAC*
	- $ ((AM4SQ-AMROP2)2+(AMROPGAMROP)2)/(AMROPGAMROP)
	- PHSPAC=PHSPAC*(ALP2-ALP1)
	-
	-C
	- RR1=RRR(1)
	- AMS1=(AMP2+AMP3+AMP4)**2
	- AMS2=(AM4-AMP1)**2
	- IF (RRR(9).GT.PREZ) THEN
	- AM3SQ=AMS1+ RR1*(AMS2-AMS1)
	- AM3 =SQRT(AM3SQ)
	-C --- this part of jacobian will be recovered later
	- FF1=AMS2-AMS1
	- ELSE
	-* PHASE SPACE WITH SAMPLING FOR OMEGA RESONANCE,
	- ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	- ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	- ALP=ALP1+RR1*(ALP2-ALP1)
	- AM3SQ =AMRX*2+AMRXGAMRX*TAN(ALP)
	- AM3 =SQRT(AM3SQ)
	-C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
	- FF1=((AM3SQ-AMRX2)2+(AMRXGAMRX)2)/(AMRXGAMRX)
	- FF1=FF1*(ALP2-ALP1)
	- ENDIF
	-C MASS OF 2
	- RR2=RRR(2)
	- AMS1=(AMP3+AMP4)**2
	- AMS2=(AM3-AMP2)**2
	-* FLAT PHASE SPACE;
	- AM2SQ=AMS1+ RR2*(AMS2-AMS1)
	- AM2 =SQRT(AM2SQ)
	-C --- this part of jacobian will be recovered later
	- FF2=(AMS2-AMS1)
	-* 2 RESTFRAME, DEFINE PIZ AND PIPL
	- ENQ1=(AM2SQ+AMP32-AMP42)/(2*AM2)
	- ENQ2=(AM2SQ-AMP32+AMP42)/(2*AM2)
	- PPI= ENQ12-AMP32
	- PPPI=SQRT(ABS(ENQ12-AMP32))
	- PHSPAC=PHSPAC(4PI)(2PPPI/AM2)
	-* PIZ momentum in 2 rest frame (PIZ is 3rd pi)
	- CALL SPHERA(PPPI,PIZ)
	- PIZ(4)=ENQ1
	-C PIPL momentum in 2 rest frame (PIPL is 4th pi)
	- DO 30 I=1,3
	- 30 PIPL(I)=-PIZ(I)
	- PIPL(4)=ENQ2
	-* 3 REST FRAME, DEFINE PIM1
	-C PR momentum
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1./(2AM3)(AM32+AM22-AMP2**2)
	- PR(3)= SQRT(ABS(PR(4)2-AM22))
	- PPI = PR(4)2-AM22
	-C PIM1 momentum
	- PIM1(1)=0
	- PIM1(2)=0
	- PIM1(4)=1./(2AM3)(AM32-AM22+AMP2**2)
	- PIM1(3)=-PR(3)
	-C --- this part of jacobian will be recovered later
	- FF3=(4PI)(2*PR(3)/AM3)
	-* OLD PIONS BOOSTED FROM 2 REST FRAME TO 3 REST FRAME
	- EXE=(PR(4)+PR(3))/AM2
	- CALL BOSTR3(EXE,PIZ,PIZ)
	- CALL BOSTR3(EXE,PIPL,PIPL)
	- RR3=RRR(3)
	- RR4=RRR(4)
	- THET =ACOS(-1.+2*RR3)
	- PHI = 2PIRR4
	- CALL ROTPOL(THET,PHI,PIPL)
	- CALL ROTPOL(THET,PHI,PIM1)
	- CALL ROTPOL(THET,PHI,PIZ)
	- CALL ROTPOL(THET,PHI,PR)
	-C 4 rest frame, define PIM2
	-C PR momentum
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1./(2AM4)(AM42+AM32-AMP1**2)
	- PR(3)= SQRT(ABS(PR(4)2-AM32))
	- PPI = PR(4)2-AM32
	-C PIM2 momentum
	- PIM2(1)=0
	- PIM2(2)=0
	- PIM2(4)=1./(2AM4)(AM42-AM32+AMP1**2)
	- PIM2(3)=-PR(3)
	-C --- this part of jacobian will be recovered later
	- FF4=(4PI)(2*PR(3)/AM4)
	-* OLD PIONS BOOSTED FROM 3 REST FRAME TO 4 REST FRAME
	- EXE=(PR(4)+PR(3))/AM3
	- CALL BOSTR3(EXE,PIZ,PIZ)
	- CALL BOSTR3(EXE,PIPL,PIPL)
	- CALL BOSTR3(EXE,PIM1,PIM1)
	- RR3=RRR(7)
	- RR4=RRR(8)
	- THET =ACOS(-1.+2*RR3)
	- PHI = 2PIRR4
	- CALL ROTPOL(THET,PHI,PIPL)
	- CALL ROTPOL(THET,PHI,PIM1)
	- CALL ROTPOL(THET,PHI,PIM2)
	- CALL ROTPOL(THET,PHI,PIZ)
	- CALL ROTPOL(THET,PHI,PR)
	-C
	-* NOW TO THE TAU REST FRAME, DEFINE PAA AND NEUTRINO MOMENTA
	-* PAA MOMENTUM
	- PAA(1)=0
	- PAA(2)=0
	- PAA(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AM4**2)
	- PAA(3)= SQRT(ABS(PAA(4)2-AM42))
	- PPI = PAA(4)2-AM42
	- PHSPAC=PHSPAC(4PI)(2PAA(3)/AMTAU)
	- PHSP=PHSP(4PI)(2PAA(3)/AMTAU)
	-* TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AM4**2)
	- PN(3)=-PAA(3)
	-C ZBW 20.12.2002 bug fix
	- IF(RRR(9).LE.0.5*PREZ) THEN
	- DO 72 I=1,4
	- X=PIM1(I)
	- PIM1(I)=PIM2(I)
	- 72 PIM2(I)=X
	- ENDIF
	-C end of bug fix
	-C WE INCLUDE REMAINING PART OF THE JACOBIAN
	-C --- FLAT CHANNEL
	- AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))2-(PIM1(3)+PIZ(3)+PIPL(3))2
	- $ -(PIM1(2)+PIZ(2)+PIPL(2))2-(PIM1(1)+PIZ(1)+PIPL(1))2
	- AMS2=(AM4-AMP2)**2
	- AMS1=(AMP1+AMP3+AMP4)**2
	- FF1=(AMS2-AMS1)
	- AMS1=(AMP3+AMP4)**2
	- AMS2=(SQRT(AM3SQ)-AMP1)**2
	- FF2=AMS2-AMS1
	- FF3=(4PI)(XLAM(AM22,AMP12,AM3SQ)/AM3SQ)
	- FF4=(4PI)(XLAM(AM3SQ,AMP22,AM42)/AM4**2)
	- UU=FF1FF2FF3*FF4
	-C --- FIRST CHANNEL
	- AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))2-(PIM1(3)+PIZ(3)+PIPL(3))2
	- $ -(PIM1(2)+PIZ(2)+PIPL(2))2-(PIM1(1)+PIZ(1)+PIPL(1))2
	- AMS2=(AM4-AMP2)**2
	- AMS1=(AMP1+AMP3+AMP4)**2
	- ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	- ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	- FF1=((AM3SQ-AMRX2)2+(AMRXGAMRX)2)/(AMRXGAMRX)
	- FF1=FF1*(ALP2-ALP1)
	- AMS1=(AMP3+AMP4)**2
	- AMS2=(SQRT(AM3SQ)-AMP1)**2
	- FF2=AMS2-AMS1
	- FF3=(4PI)(XLAM(AM22,AMP12,AM3SQ)/AM3SQ)
	- FF4=(4PI)(XLAM(AM3SQ,AMP22,AM42)/AM4**2)
	- FF=FF1FF2FF3*FF4
	-C --- SECOND CHANNEL
	- AM3SQ=(PIM2(4)+PIZ(4)+PIPL(4))2-(PIM2(3)+PIZ(3)+PIPL(3))2
	- $ -(PIM2(2)+PIZ(2)+PIPL(2))2-(PIM2(1)+PIZ(1)+PIPL(1))2
	- AMS2=(AM4-AMP1)**2
	- AMS1=(AMP2+AMP3+AMP4)**2
	- ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	- ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	- GG1=((AM3SQ-AMRX2)2+(AMRXGAMRX)2)/(AMRXGAMRX)
	- GG1=GG1*(ALP2-ALP1)
	- AMS1=(AMP3+AMP4)**2
	- AMS2=(SQRT(AM3SQ)-AMP2)**2
	- GG2=AMS2-AMS1
	- GG3=(4PI)(XLAM(AM22,AMP22,AM3SQ)/AM3SQ)
	- GG4=(4PI)(XLAM(AM3SQ,AMP12,AM42)/AM4**2)
	- GG=GG1GG2GG3*GG4
	-C --- JACOBIAN AVERAGED OVER THE TWO
	- IF ( ( (FF+GG)UU+FFGG ).GT.0.0D0) THEN
	- RR=FFGGUU/(0.5PREZ(FF+GG)UU+(1.0-PREZ)FF*GG)
	- PHSPAC=PHSPAC*RR
	- ELSE
	- PHSPAC=0.0
	- ENDIF
	-* MOMENTA OF THE TWO PI-MINUS ARE RANDOMLY SYMMETRISED
	- IF (JNPI.EQ.1) THEN
	- RR5= RRR(5)
	- IF(RR5.LE.0.5) THEN
	- DO 70 I=1,4
	- X=PIM1(I)
	- PIM1(I)=PIM2(I)
	- 70 PIM2(I)=X
	- ENDIF
	- PHSPAC=PHSPAC/2.
	- ELSE
	-C MOMENTA OF PI0-S ARE GENERATED UNIFORMLY ONLY IF PREZ=0.0
	- RR5= RRR(5)
	- IF(RR5.LE.0.5) THEN
	- DO 71 I=1,4
	- X=PIM1(I)
	- PIM1(I)=PIM2(I)
	- 71 PIM2(I)=X
	- ENDIF
	- PHSPAC=PHSPAC/6.
	- ENDIF
	-* ALL PIONS BOOSTED FROM 4 REST FRAME TO TAU REST FRAME
	-* Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
	- EXE=(PAA(4)+PAA(3))/AM4
	- CALL BOSTR3(EXE,PIZ,PIZ)
	- CALL BOSTR3(EXE,PIPL,PIPL)
	- CALL BOSTR3(EXE,PIM1,PIM1)
	- CALL BOSTR3(EXE,PIM2,PIM2)
	- CALL BOSTR3(EXE,PR,PR)
	-C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
	-C CHECK ON CONSISTENCY WITH DADNPI, THEN, CODE BREAKES UNIFORM PION
	-C DISTRIBUTION IN HADRONIC SYSTEM
	- CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIZ,PIPL,AMPLIT,HV)
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	-C PHASE SPACE CHECK
	-C DGAMT=PHSPAC
	- DO 77 K=1,4
	- PMULT(K,1) = PIM1(K)
	- PMULT(K,2) = PIM2(K)
	- PMULT(K,3) = PIZ (K)
	- PMULT(K,4) = PIPL(K)
	- 77 CONTINUE
	- END
	- SUBROUTINE DAM4PI(MNUM,PT,PN,PIM1,PIM2,PIM3,PIM4,AMPLIT,HV)
	-C ----------------------------------------------------------------------
	-* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	-* FOR TAU DECAY INTO 4 PI MODES
	-* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	-* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	-C MNUM DECAY MODE IDENTIFIER.
	-C
	-C called by : DPH4PI
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision HV(4),PT(4),PN(4),PIM1(4),
	- * PIM2(4),PIM3(4),PIM4(4)
	- double precision PIVEC(4),PIAKS(4),HVM(4)
	- double complex HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5
	- EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	-C
	- CALL CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
	-C
	-* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	- CALL CLVEC(HADCUR,PN,PIVEC)
	- CALL CLAXI(HADCUR,PN,PIAKS)
	- CALL CLNUT(HADCUR,BRAKM,HVM)
	-* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	- BRAK= (GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	- & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	- AMPLIT=(CCABIBGFERMI)2BRAK/2.
	-C POLARIMETER VECTOR IN TAU REST FRAME
	- DO 90 I=1,3
	- HV(I)=-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	- & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	-C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	- IF (BRAK.NE.0.0)
	- &HV(I)=-HV(I)/BRAK
	- 90 CONTINUE
	- END
	- SUBROUTINE DPH5PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
	-C ----------------------------------------------------------------------
	-* IT SIMULATES 5pi DECAY IN TAU REST FRAME WITH
	-* Z-AXIS ALONG 5pi MOMENTUM
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	-
	-
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- CHARACTER NAMES(NMODE)*31
	- double precision HV(4),PT(4),PN(4),PAA(4),PMULT(4,9)
	- double precision PR(4),PI1(4),PI2(4),PI3(4),PI4(4),PI5(4)
	- double precision AMP1,AMP2,AMP3,AMP4,AMP5,ams1,ams2,amom,gamom
	- double precision AM5SQ,AM4SQ,AM3SQ,AM2SQ,AM5,AM4,AM3
	- double precision RRR(10)
	- double precision gg1,gg2,gg3,ff1,ff2,ff3,ff4,alp,alp1,alp2
	- double precision XM,AM,GAMMAB
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	- data fpi /93.3e-3/
	-c
	- double complex BWIGN
	-C
	- BWIGN(XM,AM,GAMMAB)=XM2/CMPLX(XM2-AM*2,GAMMABAM)
	-
	-C
	- AMOM=.782
	- GAMOM=0.0085
	-c
	-C 6 BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	-C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	- PHSPAC=1./229/PI14
	-c PHSPAC=1./25/PI2
	-C init 5pi decay mode (JNPI)
	- AMP1=DCDMAS(IDFFIN(1,JNPI))
	- AMP2=DCDMAS(IDFFIN(2,JNPI))
	- AMP3=DCDMAS(IDFFIN(3,JNPI))
	- AMP4=DCDMAS(IDFFIN(4,JNPI))
	- AMP5=DCDMAS(IDFFIN(5,JNPI))
	-c
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	-C
	- CALL RANMAR(RRR,10)
	-C
	-c masses of 5, 4, 3 and 2 pi systems
	-c 3 pi with sampling for omega resonance
	-cam
	-c mass of 5 (12345)
	- rr1=rrr(10)
	- ams1=(amp1+amp2+amp3+amp4+amp5)**2
	- ams2=(amtau-amnuta)**2
	- am5sq=ams1+ rr1*(ams2-ams1)
	- am5 =sqrt(am5sq)
	- phspac=phspac*(ams2-ams1)
	-c
	-c mass of 4 (2345)
	-c flat phase space
	- rr1=rrr(9)
	- ams1=(amp2+amp3+amp4+amp5)**2
	- ams2=(am5-amp1)**2
	- am4sq=ams1+ rr1*(ams2-ams1)
	- am4 =sqrt(am4sq)
	- gg1=ams2-ams1
	-c
	-c mass of 3 (234)
	-C phase space with sampling for omega resonance
	- rr1=rrr(1)
	- ams1=(amp2+amp3+amp4)**2
	- ams2=(am4-amp5)**2
	- alp1=atan((ams1-amom**2)/amom/gamom)
	- alp2=atan((ams2-amom**2)/amom/gamom)
	- alp=alp1+rr1*(alp2-alp1)
	- am3sq =amom*2+amomgamom*tan(alp)
	- am3 =sqrt(am3sq)
	-c --- this part of the jacobian will be recovered later ---------------
	- gg2=((am3sq-amom2)2+(amomgamom)2)/(amomgamom)
	- gg2=gg2*(alp2-alp1)
	-c flat phase space;
	-C am3sq=ams1+ rr1*(ams2-ams1)
	-C am3 =sqrt(am3sq)
	-c --- this part of jacobian will be recovered later
	-C gg2=ams2-ams1
	-c
	-C mass of 2 (34)
	- rr2=rrr(2)
	- ams1=(amp3+amp4)**2
	- ams2=(am3-amp2)**2
	-c flat phase space;
	- am2sq=ams1+ rr2*(ams2-ams1)
	- am2 =sqrt(am2sq)
	-c --- this part of jacobian will be recovered later
	- gg3=ams2-ams1
	-c
	-c (34) restframe, define pi3 and pi4
	- enq1=(am2sq+amp32-amp42)/(2*am2)
	- enq2=(am2sq-amp32+amp42)/(2*am2)
	- ppi= enq12-amp32
	- pppi=sqrt(abs(enq12-amp32))
	- ff1=(4pi)(2*pppi/am2)
	-c pi3 momentum in (34) rest frame
	- call sphera(pppi,pi3)
	- pi3(4)=enq1
	-c pi4 momentum in (34) rest frame
	- do 30 i=1,3
	- 30 pi4(i)=-pi3(i)
	- pi4(4)=enq2
	-c
	-c (234) rest frame, define pi2
	-c pr momentum
	- pr(1)=0
	- pr(2)=0
	- pr(4)=1./(2am3)(am32+am22-amp2**2)
	- pr(3)= sqrt(abs(pr(4)2-am22))
	- ppi = pr(4)2-am22
	-c pi2 momentum
	- pi2(1)=0
	- pi2(2)=0
	- pi2(4)=1./(2am3)(am32-am22+amp2**2)
	- pi2(3)=-pr(3)
	-c --- this part of jacobian will be recovered later
	- ff2=(4pi)(2*pr(3)/am3)
	-c old pions boosted from 2 rest frame to 3 rest frame
	- exe=(pr(4)+pr(3))/am2
	- call bostr3(exe,pi3,pi3)
	- call bostr3(exe,pi4,pi4)
	- rr3=rrr(3)
	- rr4=rrr(4)
	- thet =acos(-1.+2*rr3)
	- phi = 2pirr4
	- call rotpol(thet,phi,pi2)
	- call rotpol(thet,phi,pi3)
	- call rotpol(thet,phi,pi4)
	-C
	-C (2345) rest frame, define pi5
	-c pr momentum
	- pr(1)=0
	- pr(2)=0
	- pr(4)=1./(2am4)(am42+am32-amp5**2)
	- pr(3)= sqrt(abs(pr(4)2-am32))
	- ppi = pr(4)2-am32
	-c pi5 momentum
	- pi5(1)=0
	- pi5(2)=0
	- pi5(4)=1./(2am4)(am42-am32+amp5**2)
	- pi5(3)=-pr(3)
	-c --- this part of jacobian will be recovered later
	- ff3=(4pi)(2*pr(3)/am4)
	-c old pions boosted from 3 rest frame to 4 rest frame
	- exe=(pr(4)+pr(3))/am3
	- call bostr3(exe,pi2,pi2)
	- call bostr3(exe,pi3,pi3)
	- call bostr3(exe,pi4,pi4)
	- rr3=rrr(5)
	- rr4=rrr(6)
	- thet =acos(-1.+2*rr3)
	- phi = 2pirr4
	- call rotpol(thet,phi,pi2)
	- call rotpol(thet,phi,pi3)
	- call rotpol(thet,phi,pi4)
	- call rotpol(thet,phi,pi5)
	-C
	-C (12345) rest frame, define pi1
	-c pr momentum
	- pr(1)=0
	- pr(2)=0
	- pr(4)=1./(2am5)(am52+am42-amp1**2)
	- pr(3)= sqrt(abs(pr(4)2-am42))
	- ppi = pr(4)2-am42
	-c pi1 momentum
	- pi1(1)=0
	- pi1(2)=0
	- pi1(4)=1./(2am5)(am52-am42+amp1**2)
	- pi1(3)=-pr(3)
	-c --- this part of jacobian will be recovered later
	- ff4=(4pi)(2*pr(3)/am5)
	-c old pions boosted from 4 rest frame to 5 rest frame
	- exe=(pr(4)+pr(3))/am4
	- call bostr3(exe,pi2,pi2)
	- call bostr3(exe,pi3,pi3)
	- call bostr3(exe,pi4,pi4)
	- call bostr3(exe,pi5,pi5)
	- rr3=rrr(7)
	- rr4=rrr(8)
	- thet =acos(-1.+2*rr3)
	- phi = 2pirr4
	- call rotpol(thet,phi,pi1)
	- call rotpol(thet,phi,pi2)
	- call rotpol(thet,phi,pi3)
	- call rotpol(thet,phi,pi4)
	- call rotpol(thet,phi,pi5)
	-c
	-* now to the tau rest frame, define paa and neutrino momenta
	-* paa momentum
	- paa(1)=0
	- paa(2)=0
	-c paa(4)=1./(2amtau)(amtau2-amnuta2+am5**2)
	-c paa(3)= sqrt(abs(paa(4)2-am52))
	-c ppi = paa(4)2-am52
	- paa(4)=1./(2amtau)(amtau2-amnuta2+am5sq)
	- paa(3)= sqrt(abs(paa(4)**2-am5sq))
	- ppi = paa(4)**2-am5sq
	- phspac=phspac(4pi)(2paa(3)/amtau)
	-* tau-neutrino momentum
	- pn(1)=0
	- pn(2)=0
	- pn(4)=1./(2amtau)(amtau2+amnuta2-am5**2)
	- pn(3)=-paa(3)
	-c
	- phspac=phspac * gg1gg2gg3ff1ff2ff3ff4
	-c
	-C all pions boosted from 5 rest frame to tau rest frame
	-C z-axis antiparallel to neutrino momentum
	- exe=(paa(4)+paa(3))/am5
	- call bostr3(exe,pi1,pi1)
	- call bostr3(exe,pi2,pi2)
	- call bostr3(exe,pi3,pi3)
	- call bostr3(exe,pi4,pi4)
	- call bostr3(exe,pi5,pi5)
	-c
	-C partial width consists of phase space and amplitude
	-C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
	-C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
	-C
	- PXQ=AMTAU*PAA(4)
	- PXN=AMTAU*PN(4)
	- QXN=PAA(4)PN(4)-PAA(1)PN(1)-PAA(2)PN(2)-PAA(3)PN(3)
	- BRAK=2(GV2+GA2)(2PXQQXN+AM5SQ*PXN)
	- & -6(GV2-GA2)AMTAUAMNUTAAM5SQ
	- fompp = abs(bwign(am3,amom,gamom))**2
	-c normalisation factor (to some numerical undimensioned factor;
	-c cf R.Fischer et al ZPhys C3, 313 (1980))
	- fnorm = 1/fpi**6
	-c AMPLIT=CCABIB*2GFERMI*2/2. BRAK * AM5SQ*SIGEE(AM5SQ,JNPI)
	- AMPLIT=CCABIB*2GFERMI*2/2. BRAK
	- amplit = amplit * fompp * fnorm
	-c phase space test
	-c amplit = amplit * fnorm
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	-c ignore spin terms
	- DO 40 I=1,3
	- 40 HV(I)=0.
	-c
	- do 77 k=1,4
	- pmult(k,1)=pi1(k)
	- pmult(k,2)=pi2(k)
	- pmult(k,3)=pi3(k)
	- pmult(k,4)=pi4(k)
	- pmult(k,5)=pi5(k)
	- 77 continue
	- return
	-C missing: transposition of identical particles, statistical factors
	-C for identical matrices, polarimetric vector. Matrix element rather nai
	-C flat phase space in pion system + with breit wigner for omega
	-C anyway it is better than nothing, and code is improvable.
	- end
	- SUBROUTINE DPHSRK(DGAMT,HV,PN,PR,PMULT,INUM)
	-C ----------------------------------------------------------------------
	-C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
	-C Z-AXIS ALONG RHO MOMENTUM
	-C Rho decays to K Kbar
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision HV(4),PT(4),PN(4),PR(4),PKC(4),
	- * PKZ(4),QQ(4),PMULT(4,9)
	- double precision RR1(1)
	- DATA PI /3.141592653589793238462643/
	- DATA ICONT /0/
	-C
	-C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	- PHSPAC=1./211/PI5
	-C TAU MOMENTUM
	- PT(1)=0.
	- PT(2)=0.
	- PT(3)=0.
	- PT(4)=AMTAU
	-C MASS OF (REAL/VIRTUAL) RHO
	- AMS1=(AMK+AMKZ)**2
	- AMS2=(AMTAU-AMNUTA)**2
	-C FLAT PHASE SPACE
	- CALL RANMAR(RR1,1)
	- AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	- AMX=SQRT(AMX2)
	- PHSPAC=PHSPAC*(AMS2-AMS1)
	-C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
	-c ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
	-c ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
	-CAM
	- 100 CONTINUE
	-c CALL RANMAR(RR1,1)
	-c ALP=ALP1+RR1(1)*(ALP2-ALP1)
	-c AMX2=AMRO*2+AMROGAMRO*TAN(ALP)
	-c AMX=SQRT(AMX2)
	-c IF(AMX.LT.(AMK+AMKZ)) GO TO 100
	-CAM
	-c PHSPAC=PHSPAC((AMX2-AMRO2)2+(AMROGAMRO)*2)/(AMROGAMRO)
	-c PHSPAC=PHSPAC*(ALP2-ALP1)
	-C
	-C TAU-NEUTRINO MOMENTUM
	- PN(1)=0
	- PN(2)=0
	- PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	- PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	-C RHO MOMENTUM
	- PR(1)=0
	- PR(2)=0
	- PR(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	- PR(3)=-PN(3)
	- PHSPAC=PHSPAC(4PI)(2PR(3)/AMTAU)
	-C
	-CAM
	- ENQ1=(AMX2+AMK2-AMKZ2)/(2.*AMX)
	- ENQ2=(AMX2-AMK2+AMKZ2)/(2.*AMX)
	- PPPI=SQRT((ENQ1-AMK)*(ENQ1+AMK))
	- PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	-C CHARGED PI MOMENTUM IN RHO REST FRAME
	- CALL SPHERA(PPPI,PKC)
	- PKC(4)=ENQ1
	-C NEUTRAL PI MOMENTUM IN RHO REST FRAME
	- DO 20 I=1,3
	-20 PKZ(I)=-PKC(I)
	- PKZ(4)=ENQ2
	- EXE=(PR(4)+PR(3))/AMX
	-C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
	- CALL BOSTR3(EXE,PKC,PKC)
	- CALL BOSTR3(EXE,PKZ,PKZ)
	- DO 30 I=1,4
	- 30 QQ(I)=PKC(I)-PKZ(I)
	-C QQ transverse to PR
	- PKSD =PR(4)PR(4)-PR(3)PR(3)-PR(2)PR(2)-PR(1)PR(1)
	- QQPKS=PR(4)* QQ(4)-PR(3)* QQ(3)-PR(2)* QQ(2)-PR(1)* QQ(1)
	- DO 31 I=1,4
	-31 QQ(I)=QQ(I)-PR(I)*QQPKS/PKSD
	-C AMPLITUDE
	- PRODPQ=PT(4)*QQ(4)
	- PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	- PRODPN=PT(4)*PN(4)
	- QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	- BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	- & +(GV2-GA2)AMTAUAMNUTA*QQ2
	- AMPLIT=(GFERMICCABIB)2BRAK2FPIRK(AMX)
	- DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	- DO 40 I=1,3
	- 40 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	- do 77 k=1,4
	- pmult(k,1)=pkc(k)
	- pmult(k,2)=pkz(k)
	- 77 continue
	- RETURN
	- END
	- double precision FUNCTION FPIRK(W)
	-C ----------------------------------------------------------
	-c square of pion form factor
	-C ----------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-c double complex FPIKMK
	- double complex FPIKM
	- FPIRK=ABS(FPIKM(W,AMK,AMKZ))**2
	-c FPIRK=ABS(FPIKMK(W,AMK,AMKZ))**2
	- END
	- double complex FUNCTION FPIKMK(W,XM1,XM2)
	-C **********************************************************
	-C Kaon form factor
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double complex BWIGM
	- double precision XM1, XM2
	- double precision ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
	- SAVE PI,PIM,ROM,ROG,ROM1,ROG1,BETA1
	- double complex BWIG
	- EXTERNAL BWIG
	- DATA INIT /0/
	-C
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0 ) THEN
	- INIT=1
	- PI=3.141592654
	- PIM=.140
	- ROM=0.773
	- ROG=0.145
	- ROM1=1.570
	- ROG1=0.510
	-c BETA1=-0.111
	- BETA1=-0.221
	- ENDIF
	-C -----------------------------------------------
	- S=W**2
	- FPIKMK=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
	- & /(1+BETA1)
	- RETURN
	- END
	- SUBROUTINE RESLUX
	-C ****************
	-C INITIALIZE LUND COMMON
	- IMPLICIT double precision (A-H,O-Z)
	- PARAMETER (NMXHEP=2000)
	- COMMON/HEPEVTX/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	- &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	- SAVE /HEPEVTx/
	- NHEP=0
	- END
	- SUBROUTINE DWRPH(KTO,PHX)
	-C
	-C -------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PHX(4)
	- double precision QHOT(4)
	-C
	- DO 9 K=1,4
	- QHOT(K) =0.0
	- 9 CONTINUE
	-C CASE OF TAU RADIATIVE DECAYS.
	-C FILLING OF THE LUND COMMON BLOCK.
	- DO 1002 I=1,4
	- 1002 QHOT(I)=PHX(I)
	- IF (QHOT(4).GT.1.E-5) CALL DWLUPH(KTO,QHOT)
	- RETURN
	- END
	- SUBROUTINE DWLUPH(KTO,PHOT)
	-C---------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C called by : DEXAY1,(DEKAY1,DEKAY2)
	-C
	-C used when radiative corrections in decays are generated
	-C---------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON /TAUPOS/ NP1,NP2
	- double precision PHOT(4)
	-C
	-C check energy
	- IF (PHOT(4).LE.0.0) RETURN
	-C
	-C position of decaying particle:
	- IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	- KTOS=KTO
	- IF(KTOS.GT.10) KTOS=KTOS-10
	-C boost and append photon (gamma is 22)
	- CALL TRALO4(KTOS,PHOT,PHOT,AM)
	- CALL FILHEP(0,1,22,NPS,NPS,0,0,PHOT,0.0D0,.TRUE.)
	-C
	- RETURN
	- END
	-
	- SUBROUTINE DWLUEL(KTO,ISGN,PNU,PWB,PEL,PNE)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C
	-C called by : DEXAY,(DEKAY1,DEKAY2)
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON /TAUPOS/ NP1,NP2
	- double precision PNU(4),PWB(4),PEL(4),PNE(4)
	-C
	-C position of decaying particle:
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C W boson (W+ is 24)
	- CALL TRALO4(KTO,PWB,PWB,AM)
	-C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
	-C
	-C electron (e- is 11)
	- CALL TRALO4(KTO,PEL,PEL,AM)
	- CALL FILHEP(0,1,11*ISGN,NPS,NPS,0,0,PEL,AM,.FALSE.)
	-C
	-C anti electron neutrino (nu_e is 12)
	- CALL TRALO4(KTO,PNE,PNE,AM)
	- CALL FILHEP(0,1,-12*ISGN,NPS,NPS,0,0,PNE,AM,.TRUE.)
	-C
	- RETURN
	- END
	- SUBROUTINE DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C
	-C called by : DEXAY,(DEKAY1,DEKAY2)
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON /TAUPOS/ NP1,NP2
	- double precision PNU(4),PWB(4),PMU(4),PNM(4)
	-C
	-C position of decaying particle:
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C W boson (W+ is 24)
	- CALL TRALO4(KTO,PWB,PWB,AM)
	-C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
	-C
	-C muon (mu- is 13)
	- CALL TRALO4(KTO,PMU,PMU,AM)
	- CALL FILHEP(0,1,13*ISGN,NPS,NPS,0,0,PMU,AM,.FALSE.)
	-C
	-C anti muon neutrino (nu_mu is 14)
	- CALL TRALO4(KTO,PNM,PNM,AM)
	- CALL FILHEP(0,1,-14*ISGN,NPS,NPS,0,0,PNM,AM,.TRUE.)
	-C
	- RETURN
	- END
	- SUBROUTINE DWLUPI(KTO,ISGN,PPI,PNU)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C
	-C called by : DEXAY,(DEKAY1,DEKAY2)
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PNU(4),PPI(4)
	- COMMON /TAUPOS/ NP1,NP2
	-C
	-C position of decaying particle:
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C charged pi meson (pi+ is 211)
	- CALL TRALO4(KTO,PPI,PPI,AM)
	- CALL FILHEP(0,1,-211*ISGN,NPS,NPS,0,0,PPI,AM,.TRUE.)
	-C
	- RETURN
	- END
	- SUBROUTINE DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C
	-C called by : DEXAY,(DEKAY1,DEKAY2)
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON /TAUPOS/ NP1,NP2
	- double precision PNU(4),PRHO(4),PIC(4),PIZ(4)
	-C
	-C position of decaying particle:
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C charged rho meson (rho+ is 213)
	- CALL TRALO4(KTO,PRHO,PRHO,AM)
	- CALL FILHEP(0,2,-213*ISGN,NPS,NPS,0,0,PRHO,AM,.TRUE.)
	-C
	-C charged pi meson (pi+ is 211)
	- CALL TRALO4(KTO,PIC,PIC,AM)
	- CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIC,AM,.TRUE.)
	-C
	-C pi0 meson (pi0 is 111)
	- CALL TRALO4(KTO,PIZ,PIZ,AM)
	- CALL FILHEP(0,1,111,-2,-2,0,0,PIZ,AM,.TRUE.)
	-C
	- RETURN
	- END
	- SUBROUTINE DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C JAA = 1 (2) FOR A_1- DECAY TO PI+ 2PI- (PI- 2PI0)
	-C
	-C called by : DEXAY,(DEKAY1,DEKAY2)
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON /TAUPOS/ NP1,NP2
	- double precision PNU(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
	-C
	-C position of decaying particle:
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C charged a_1 meson (a_1+ is 20213)
	- CALL TRALO4(KTO,PAA,PAA,AM)
	- CALL FILHEP(0,1,-20213*ISGN,NPS,NPS,0,0,PAA,AM,.TRUE.)
	-C
	-C two possible decays of the charged a1 meson
	- IF(JAA.EQ.1) THEN
	-C
	-C A1 --> PI+ PI- PI- (or charged conjugate)
	-C
	-C pi minus (or c.c.) (pi+ is 211)
	- CALL TRALO4(KTO,PIM2,PIM2,AM)
	- CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIM2,AM,.TRUE.)
	-C
	-C pi minus (or c.c.) (pi+ is 211)
	- CALL TRALO4(KTO,PIM1,PIM1,AM)
	- CALL FILHEP(0,1,-211*ISGN,-2,-2,0,0,PIM1,AM,.TRUE.)
	-C
	-C pi plus (or c.c.) (pi+ is 211)
	- CALL TRALO4(KTO,PIPL,PIPL,AM)
	- CALL FILHEP(0,1, 211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
	-C
	- ELSE IF (JAA.EQ.2) THEN
	-C
	-C A1 --> PI- PI0 PI0 (or charged conjugate)
	-C
	-C pi zero (pi0 is 111)
	- CALL TRALO4(KTO,PIM2,PIM2,AM)
	- CALL FILHEP(0,1,111,-1,-1,0,0,PIM2,AM,.TRUE.)
	-C
	-C pi zero (pi0 is 111)
	- CALL TRALO4(KTO,PIM1,PIM1,AM)
	- CALL FILHEP(0,1,111,-2,-2,0,0,PIM1,AM,.TRUE.)
	-C
	-C pi minus (or c.c.) (pi+ is 211)
	- CALL TRALO4(KTO,PIPL,PIPL,AM)
	- CALL FILHEP(0,1,-211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
	-C
	- ENDIF
	-C
	- RETURN
	- END
	- SUBROUTINE DWLUKK (KTO,ISGN,PKK,PNU)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PKK(4),PNU(4)
	- COMMON /TAUPOS/ NP1,NP2
	-C
	-C position of decaying particle
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4 (KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C K meson (K+ is 321)
	- CALL TRALO4 (KTO,PKK,PKK,AM)
	- CALL FILHEP(0,1,-321*ISGN,NPS,NPS,0,0,PKK,AM,.TRUE.)
	-C
	- RETURN
	- END
	- SUBROUTINE DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	- double precision BRA1,BRK0,BRK0B,BRKS
	- COMMON /TAUPOS/ NP1,NP2
	- double precision XIO(1)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C JKST=10 (20) corresponds to K0B pi- (K- pi0) decay
	-C
	-C ----------------------------------------------------------------------
	-C
	- double precision PNU(4),PKS(4),PKK(4),PPI(4)
	-C
	-C position of decaying particle
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C charged K* meson (K*+ is 323)
	- CALL TRALO4(KTO,PKS,PKS,AM)
	- CALL FILHEP(0,1,-323*ISGN,NPS,NPS,0,0,PKS,AM,.TRUE.)
	-C
	-C two possible decay modes of charged K*
	- IF(JKST.EQ.10) THEN
	-C
	-C K*- --> pi- K0B (or charged conjugate)
	-C
	-C charged pi meson (pi+ is 211)
	- CALL TRALO4(KTO,PPI,PPI,AM)
	- CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PPI,AM,.TRUE.)
	-C
	- BRAN=BRK0B
	- IF (ISGN.EQ.-1) BRAN=BRK0
	-C K0 --> K0_long (is 130) / K0_short (is 310) = 1/1
	- CALL RANMAR(XIO,1)
	- IF(XIO(1).GT.BRAN) THEN
	- K0TYPE = 130
	- ELSE
	- K0TYPE = 310
	- ENDIF
	-C
	- CALL TRALO4(KTO,PKK,PKK,AM)
	- CALL FILHEP(0,1,K0TYPE,-2,-2,0,0,PKK,AM,.TRUE.)
	-C
	- ELSE IF(JKST.EQ.20) THEN
	-C
	-C K*- --> pi0 K-
	-C
	-C pi zero (pi0 is 111)
	- CALL TRALO4(KTO,PPI,PPI,AM)
	- CALL FILHEP(0,1,111,-1,-1,0,0,PPI,AM,.TRUE.)
	-C
	-C charged K meson (K+ is 321)
	- CALL TRALO4(KTO,PKK,PKK,AM)
	- CALL FILHEP(0,1,-321*ISGN,-2,-2,0,0,PKK,AM,.TRUE.)
	-C
	- ENDIF
	-C
	- RETURN
	- END
	- SUBROUTINE DWLNEW(KTO,ISGN,PNU,PWB,PNPI,MODE)
	-C ----------------------------------------------------------------------
	-C Lorentz transformation to CMsystem and
	-C Updating of HEPEVT record
	-C
	-C ISGN = 1/-1 for tau-/tau+
	-C
	-C called by : DEXAY,(DEKAY1,DEKAY2)
	-C ----------------------------------------------------------------------
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	- COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	- & ,NAMES
	- COMMON /TAUPOS/ NP1,NP2
	- CHARACTER NAMES(NMODE)*31
	- double precision PNU(4),PWB(4),PNPI(4,9)
	- double precision PPI(4)
	-C
	- JNPI=MODE-7
	-C position of decaying particle
	- IF(KTO.EQ. 1) THEN
	- NPS=NP1
	- ELSE
	- NPS=NP2
	- ENDIF
	-C
	-C tau neutrino (nu_tau is 16)
	- CALL TRALO4(KTO,PNU,PNU,AM)
	- CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	-C
	-C W boson (W+ is 24)
	- CALL TRALO4(KTO,PWB,PWB,AM)
	- CALL FILHEP(0,1,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
	-C
	-C multi pi mode JNPI
	-C
	-C get multiplicity of mode JNPI
	- ND=MULPIK(JNPI)
	- DO I=1,ND
	-cam KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
	- KFPI=LUNPIK(IDFFIN(I,JNPI), ISGN)
	-C for charged conjugate case, change charged pions only
	-C IF(KFPI.NE.111)KFPI=KFPI*ISGN
	- DO J=1,4
	- PPI(J)=PNPI(J,I)
	- END DO
	- CALL TRALO4(KTO,PPI,PPI,AM)
	- CALL FILHEP(0,1,KFPI,-I,-I,0,0,PPI,AM,.TRUE.)
	- END DO
	-C
	- RETURN
	- END
	- double precision FUNCTION AMAST(PP)
	-C ----------------------------------------------------------------------
	-C CALCULATES MASS OF PP (DOUBLE PRECISION)
	-C
	-C USED BY : RADKOR
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PP(4)
	- AAA=PP(4)2-PP(3)2-PP(2)2-PP(1)2
	-C
	- IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
	- AMAST=AAA
	- RETURN
	- END
	- double precision FUNCTION AMAS4(PP)
	-C ******************
	-C ----------------------------------------------------------------------
	-C CALCULATES MASS OF PP
	-C
	-C USED BY :
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PP(4)
	- AAA=PP(4)2-PP(3)2-PP(2)2-PP(1)2
	- IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
	- AMAS4=AAA
	- RETURN
	- END
	- double precision FUNCTION ANGXY(X,Y)
	-C ----------------------------------------------------------------------
	-C
	-C USED BY : KORALZ RADKOR
	-C ----------------------------------------------------------------------
	- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	- DATA PI /3.141592653589793238462643D0/
	-C
	- IF(ABS(Y).LT.ABS(X)) THEN
	- THE=ATAN(ABS(Y/X))
	- IF(X.LE.0D0) THE=PI-THE
	- ELSE
	- THE=ACOS(X/SQRT(X2+Y2))
	- ENDIF
	- ANGXY=THE
	- RETURN
	- END
	- double precision FUNCTION ANGFI(X,Y)
	-C ----------------------------------------------------------------------
	-* CALCULATES ANGLE IN (0,2*PI) RANGE OUT OF X-Y
	-C
	-C USED BY : KORALZ RADKOR
	-C ----------------------------------------------------------------------
	- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	- DATA PI /3.141592653589793238462643D0/
	-C
	- IF(ABS(Y).LT.ABS(X)) THEN
	- THE=ATAN(ABS(Y/X))
	- IF(X.LE.0D0) THE=PI-THE
	- ELSE
	- THE=ACOS(X/SQRT(X2+Y2))
	- ENDIF
	- IF(Y.LT.0D0) THE=2D0*PI-THE
	- ANGFI=THE
	- END
	- SUBROUTINE ROTOD1(PH1,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C
	-C USED BY : KORALZ
	-C ----------------------------------------------------------------------
	- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	- DIMENSION PVEC(4),QVEC(4),RVEC(4)
	-C
	- PHI=PH1
	- CS=COS(PHI)
	- SN=SIN(PHI)
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- QVEC(1)=RVEC(1)
	- QVEC(2)= CSRVEC(2)-SNRVEC(3)
	- QVEC(3)= SNRVEC(2)+CSRVEC(3)
	- QVEC(4)=RVEC(4)
	- RETURN
	- END
	- SUBROUTINE ROTOD2(PH1,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C
	-C USED BY : KORALZ RADKOR
	-C ----------------------------------------------------------------------
	- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	- DIMENSION PVEC(4),QVEC(4),RVEC(4)
	-C
	- PHI=PH1
	- CS=COS(PHI)
	- SN=SIN(PHI)
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- QVEC(1)= CSRVEC(1)+SNRVEC(3)
	- QVEC(2)=RVEC(2)
	- QVEC(3)=-SNRVEC(1)+CSRVEC(3)
	- QVEC(4)=RVEC(4)
	- RETURN
	- END
	- SUBROUTINE ROTOD3(PH1,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C
	-C USED BY : KORALZ RADKOR
	-C ----------------------------------------------------------------------
	- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	-C
	- DIMENSION PVEC(4),QVEC(4),RVEC(4)
	- PHI=PH1
	- CS=COS(PHI)
	- SN=SIN(PHI)
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- QVEC(1)= CSRVEC(1)-SNRVEC(2)
	- QVEC(2)= SNRVEC(1)+CSRVEC(2)
	- QVEC(3)=RVEC(3)
	- QVEC(4)=RVEC(4)
	- END
	- SUBROUTINE BOSTR3(EXE,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
	-C
	-C USED BY : TAUOLA KORALZ (?)
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PVEC(4),QVEC(4),RVEC(4)
	-C
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- RPL=RVEC(4)+RVEC(3)
	- RMI=RVEC(4)-RVEC(3)
	- QPL=RPL*EXE
	- QMI=RMI/EXE
	- QVEC(1)=RVEC(1)
	- QVEC(2)=RVEC(2)
	- QVEC(3)=(QPL-QMI)/2
	- QVEC(4)=(QPL+QMI)/2
	- END
	- SUBROUTINE BOSTD3(EXE,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
	-C
	-C USED BY : KORALZ RADKOR
	-C ----------------------------------------------------------------------
	- IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	- DIMENSION PVEC(4),QVEC(4),RVEC(4)
	-C
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- RPL=RVEC(4)+RVEC(3)
	- RMI=RVEC(4)-RVEC(3)
	- QPL=RPL*EXE
	- QMI=RMI/EXE
	- QVEC(1)=RVEC(1)
	- QVEC(2)=RVEC(2)
	- QVEC(3)=(QPL-QMI)/2
	- QVEC(4)=(QPL+QMI)/2
	- RETURN
	- END
	- SUBROUTINE ROTOR1(PH1,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C
	-C called by :
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PVEC(4),QVEC(4),RVEC(4)
	-C
	- PHI=PH1
	- CS=COS(PHI)
	- SN=SIN(PHI)
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- QVEC(1)=RVEC(1)
	- QVEC(2)= CSRVEC(2)-SNRVEC(3)
	- QVEC(3)= SNRVEC(2)+CSRVEC(3)
	- QVEC(4)=RVEC(4)
	- END
	- SUBROUTINE ROTOR2(PH1,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C
	-C USED BY : TAUOLA
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision(A-H,O-Z)
	- double precision PVEC(4),QVEC(4),RVEC(4)
	-C
	- PHI=PH1
	- CS=COS(PHI)
	- SN=SIN(PHI)
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- QVEC(1)= CSRVEC(1)+SNRVEC(3)
	- QVEC(2)=RVEC(2)
	- QVEC(3)=-SNRVEC(1)+CSRVEC(3)
	- QVEC(4)=RVEC(4)
	- END
	- SUBROUTINE ROTOR3(PHI,PVEC,QVEC)
	-C ----------------------------------------------------------------------
	-C
	-C USED BY : TAUOLA
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PVEC(4),QVEC(4),RVEC(4)
	-C
	- CS=COS(PHI)
	- SN=SIN(PHI)
	- DO 10 I=1,4
	- 10 RVEC(I)=PVEC(I)
	- QVEC(1)= CSRVEC(1)-SNRVEC(2)
	- QVEC(2)= SNRVEC(1)+CSRVEC(2)
	- QVEC(3)=RVEC(3)
	- QVEC(4)=RVEC(4)
	- END
	- SUBROUTINE SPHERD(R,X)
	-C ----------------------------------------------------------------------
	-C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
	-C DOUBLE PRECISON VERSION OF SPHERA
	-C ----------------------------------------------------------------------
	- double precision R,X(4),PI,COSTH,SINTH
	- double precision RRR(2)
	- DATA PI /3.141592653589793238462643D0/
	-C
	- CALL RANMAR(RRR,2)
	- COSTH=-1+2*RRR(1)
	- SINTH=SQRT(1 -COSTH**2)
	- X(1)=RSINTHCOS(2PIRRR(2))
	- X(2)=RSINTHSIN(2PIRRR(2))
	- X(3)=R*COSTH
	- RETURN
	- END
	- SUBROUTINE ROTPOX(THET,PHI,PP)
	- IMPLICIT double precision (A-H,O-Z)
	-C ----------------------------------------------------------------------
	-C double precison version of ROTPOL
	-C ----------------------------------------------------------------------
	- DIMENSION PP(4)
	-C
	- CALL ROTOD2(THET,PP,PP)
	- CALL ROTOD3( PHI,PP,PP)
	- RETURN
	- END
	- SUBROUTINE SPHERA(R,X)
	-C ----------------------------------------------------------------------
	-C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
	-C
	-C called by : DPHSxx,DADMPI,DADMKK
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision R,X(4)
	- double precision RRR(2)
	- DATA PI /3.141592653589793238462643/
	-C
	- CALL RANMAR(RRR,2)
	- COSTH=-1.+2.*RRR(1)
	- SINTH=SQRT(1.-COSTH**2)
	- X(1)=RSINTHCOS(2PIRRR(2))
	- X(2)=RSINTHSIN(2PIRRR(2))
	- X(3)=R*COSTH
	- RETURN
	- END
	- SUBROUTINE ROTPOL(THET,PHI,PP)
	-C ----------------------------------------------------------------------
	-C
	-C called by : DADMAA,DPHSAA
	-C ----------------------------------------------------------------------
	- IMPLICIT double precision (A-H,O-Z)
	- double precision PP(4)
	-C
	- CALL ROTOR2(THET,PP,PP)
	- CALL ROTOR3( PHI,PP,PP)
	- RETURN
	- END
	- SUBROUTINE RMARIN(IJKLIN,NTOTIN,NTOT2N)
	- IMPLICIT NONE
	- INTEGER IJKLIN,NTOTIN,NTOT2N
	- RETURN
	- END
	- SUBROUTINE RMARUT(IJKLIN,NTOTIN,NTOT2N)
	- IMPLICIT NONE
	- INTEGER IJKLIN,NTOTIN,NTOT2N
	- RETURN
	- END
	- SUBROUTINE RANMAR(RVEC,LENV)
	- IMPLICIT NONE
	- INTEGER LENV
	- double precision RVEC
	- DIMENSION RVEC(*)
	- double precision PYR
	- INTEGER IVEC
	- DO 100 IVEC= 1, LENV
	- RVEC(IVEC) = PYR(0)
	- 100 CONTINUE
	- RETURN
	- END
	- double precision FUNCTION DILOGT(X)
	-C *****************
	- IMPLICIT double precision(A-H,O-Z)
	-CERN C304 VERSION 29/07/71 DILOG 59 C
	- Z=-1.64493406684822
	- IF(X .LT.-1.0) GO TO 1
	- IF(X .LE. 0.5) GO TO 2
	- IF(X .EQ. 1.0) GO TO 3
	- IF(X .LE. 2.0) GO TO 4
	- Z=3.2898681336964
	- 1 T=1.0/X
	- S=-0.5
	- Z=Z-0.5* LOG(ABS(X))**2
	- GO TO 5
	- 2 T=X
	- S=0.5
	- Z=0.
	- GO TO 5
	- 3 DILOGT=1.64493406684822
	- RETURN
	- 4 T=1.0-X
	- S=-0.5
	- Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
	- 5 Y=2.66666666666666 *T+0.66666666666666
	- B= 0.00000 00000 00001
	- A=Y*B +0.00000 00000 00004
	- B=Y*A-B+0.00000 00000 00011
	- A=Y*B-A+0.00000 00000 00037
	- B=Y*A-B+0.00000 00000 00121
	- A=Y*B-A+0.00000 00000 00398
	- B=Y*A-B+0.00000 00000 01312
	- A=Y*B-A+0.00000 00000 04342
	- B=Y*A-B+0.00000 00000 14437
	- A=Y*B-A+0.00000 00000 48274
	- B=Y*A-B+0.00000 00001 62421
	- A=Y*B-A+0.00000 00005 50291
	- B=Y*A-B+0.00000 00018 79117
	- A=Y*B-A+0.00000 00064 74338
	- B=Y*A-B+0.00000 00225 36705
	- A=Y*B-A+0.00000 00793 87055
	- B=Y*A-B+0.00000 02835 75385
	- A=Y*B-A+0.00000 10299 04264
	- B=Y*A-B+0.00000 38163 29463
	- A=Y*B-A+0.00001 44963 00557
	- B=Y*A-B+0.00005 68178 22718
	- A=Y*B-A+0.00023 20021 96094
	- B=Y*A-B+0.00100 16274 96164
	- A=Y*B-A+0.00468 63619 59447
	- B=Y*A-B+0.02487 93229 24228
	- A=Y*B-A+0.16607 30329 27855
	- A=Y*A-B+1.93506 43008 6996
	- DILOGT=ST(A-B)+Z
	- RETURN
	-C=======================================================================
	-C===================END OF CPC PART ====================================
	-C=======================================================================
	- END
	Index: trunk/tauola/formf.f
	===================================================================
	--- trunk/tauola/formf.f (revision 8888)
	+++ trunk/tauola/formf.f (revision 8889)
	@@ -1,601 +0,0 @@
	- FUNCTION FORMOM(XMAA,XMOM)
	- IMPLICIT double precision(A-H,O-Z)
	-C ==================================================================
	-C formfactorfor pi-pi0 gamma final state
	-C R. Decker, Z. Phys C36 (1987) 487.
	-C ==================================================================
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- COMMON /TESTA1/ KEYA1
	- double complex BWIGN,FORMOM
	- DATA ICONT /1/
	-* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
	- BWIGN(XM,AM,GAMMA)=1./CMPLX(XM2-AM2,GAMMA*AM)
	-* HADRON CURRENT
	- FRO =0.266AMRO*2
	- ELPHA=- 0.1
	- AMROP = 1.7
	- GAMROP= 0.26
	- AMOM =0.782
	- GAMOM =0.0085
	- AROMEG= 1.0
	- GCOUP=12.924
	- GCOUP=GCOUP*AROMEG
	- FQED =SQRT(4.0*3.1415926535/137.03604)
	- FORMOM=FQEDFRO2/SQRT(2.0)GCOUP*2BWIGN(XMOM,AMOM,GAMOM)
	- $ (BWIGN(XMAA,AMRO,GAMRO)+ELPHABWIGN(XMAA,AMROP,GAMROP))
	- $ (BWIGN( 0.0D0,AMRO,GAMRO)+ELPHABWIGN( 0.0D0,AMROP,GAMROP))
	- END
	- FUNCTION FORM1(MNUM,QQ,S1,SDWA)
	- IMPLICIT double precision(A-H,O-Z)
	-C ==================================================================
	-C formfactorfor F1 for 3 scalar final state
	-C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	-C H. Georgi, Weak interactions and modern particle theory,
	-C The Benjamin/Cummings Pub. Co., Inc. 1984.
	-C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	-C and erratum !!!!!!
	-C ==================================================================
	-C
	- double complex FORM1,WIGNER,WIGFOR,FPIKM,BWIGM
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- WIGNER(A,B,C)= CMPLX(1.0,0.0D0)/CMPLX(A-B*2,BC)
	- IF (MNUM.EQ.0) THEN
	-C ------------ 3 pi hadronic state (a1)
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ELSEIF (MNUM.EQ.1) THEN
	-C ------------ K- pi- K+
	- FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMKZ)
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FORM1
	- ELSEIF (MNUM.EQ.2) THEN
	-C ------------ K0 pi- K0B
	- FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMKZ)
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FORM1
	- ELSEIF (MNUM.EQ.3) THEN
	-C ------------ K- K0 pi0
	- FORM1=0.0D0
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FORM1
	- ELSEIF (MNUM.EQ.4) THEN
	-C ------------ pi0 pi0 K-
	- XM2=1.402
	- GAM2=0.174
	- FORM1=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
	- FORM1=WIGFOR(QQ,XM2,GAM2)*FORM1
	- ELSEIF (MNUM.EQ.5) THEN
	-C ------------ K- pi- pi+
	- XM2=1.402
	- GAM2=0.174
	- FORM1=WIGFOR(QQ,XM2,GAM2)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ELSEIF (MNUM.EQ.6) THEN
	- FORM1=0.0D0
	- ELSEIF (MNUM.EQ.7) THEN
	-C -------------- eta pi- pi0 final state
	- FORM1=0.0D0
	- ENDIF
	- END
	- FUNCTION FORM2(MNUM,QQ,S1,SDWA)
	- IMPLICIT double precision (A-H,O-Z)
	-C ==================================================================
	-C formfactorfor F2 for 3 scalar final state
	-C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	-C H. Georgi, Weak interactions and modern particle theory,
	-C The Benjamin/Cummings Pub. Co., Inc. 1984.
	-C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	-C and erratum !!!!!!
	-C ==================================================================
	-C
	- double complex FORM2,WIGNER,WIGFOR,FPIKM,BWIGM
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- WIGNER(A,B,C)= CMPLX(1.0,0.0D0)/CMPLX(A-B*2,BC)
	- IF (MNUM.EQ.0) THEN
	-C ------------ 3 pi hadronic state (a1)
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ELSEIF (MNUM.EQ.1) THEN
	-C ------------ K- pi- K+
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ELSEIF (MNUM.EQ.2) THEN
	-C ------------ K0 pi- K0B
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ELSEIF (MNUM.EQ.3) THEN
	-C ------------ K- K0 pi0
	- GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	- FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ELSEIF (MNUM.EQ.4) THEN
	-C ------------ pi0 pi0 K-
	- XM2=1.402
	- GAM2=0.174
	- FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
	- FORM2=WIGFOR(QQ,XM2,GAM2)*FORM2
	- ELSEIF (MNUM.EQ.5) THEN
	-C ------------ K- pi- pi+
	- XM2=1.402
	- GAM2=0.174
	- FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
	- FORM2=WIGFOR(QQ,XM2,GAM2)*FORM2
	-C
	- ELSEIF (MNUM.EQ.6) THEN
	- XM2=1.402
	- GAM2=0.174
	- FORM2=WIGFOR(QQ,XM2,GAM2)*FPIKM(SQRT(S1),AMPI,AMPI)
	-C
	- ELSEIF (MNUM.EQ.7) THEN
	-C -------------- eta pi- pi0 final state
	- FORM2=0.0D0
	- ENDIF
	-C
	- END
	- double complex FUNCTION BWIGM(S,M,G,XM1,XM2)
	- IMPLICIT double precision (A-H,O-Z)
	-C **********************************************************
	-C P-WAVE BREIT-WIGNER FOR RHO
	-C **********************************************************
	- double precision S,M,G,XM1,XM2
	- double precision PI,QS,QM,W,GS
	- SAVE PI
	- DATA INIT /0/
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0) THEN
	- INIT=1
	- PI=3.141592654
	-C ------- BREIT-WIGNER -----------------------
	- ENDIF
	- IF (S.GT.(XM1+XM2)**2) THEN
	- QS=SQRT(ABS((S -(XM1+XM2)*2)(S -(XM1-XM2)**2)))/SQRT(S)
	- QM=SQRT(ABS((M2-(XM1+XM2)2)(M2-(XM1-XM2)*2)))/M
	- W=SQRT(S)
	- GS=G(M/W)2(QS/QM)**3
	- ELSE
	- GS=0.0D0
	- ENDIF
	- BWIGM=M2/CMPLX(M2-S,-SQRT(S)*GS)
	- RETURN
	- END
	- double complex FUNCTION FPIKM(W,XM1,XM2)
	-C **********************************************************
	-C PION FORM FACTOR
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double complex BWIGM
	- double precision ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
	- SAVE PI,PIM,ROM,ROG,ROM1,ROG1,BETA1
	- EXTERNAL BWIG
	- DATA INIT /0/
	-C
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0 ) THEN
	- INIT=1
	- PI=3.141592654
	- PIM=.140
	- ROM=0.773
	- ROG=0.145
	- ROM1=1.370
	- ROG1=0.510
	- BETA1=-0.145
	- ENDIF
	-C -----------------------------------------------
	- S=W**2
	- FPIKM=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
	- & /(1+BETA1)
	- RETURN
	- END
	- double complex FUNCTION FPIKMD(W,XM1,XM2)
	-C **********************************************************
	-C PION FORM FACTOR
	-C **********************************************************
	- IMPLICIT double precision (A-H,O-Z)
	- double complex BWIGM
	- double precision ROM,ROG,ROM1,ROG1,PI,PIM,S,W
	- SAVE PI,PIM,ROM,ROG,ROM1,ROG1,ROG2,ROM2,BETA,DELTA
	- EXTERNAL BWIG
	- DATA INIT /0/
	-C
	-C ------------ PARAMETERS --------------------
	- IF (INIT.EQ.0 ) THEN
	- INIT=1
	- PI=3.141592654
	- PIM=.140
	- ROM=0.773
	- ROG=0.145
	- ROM1=1.500
	- ROG1=0.220
	- ROM2=1.750
	- ROG2=0.120
	- BETA=6.5
	- DELTA=-26.0
	- ENDIF
	-C -----------------------------------------------
	- S=W**2
	- FPIKMD=(DELTA*BWIGM(S,ROM,ROG,XM1,XM2)
	- $ +BETA*BWIGM(S,ROM1,ROG1,XM1,XM2)
	- $ + BWIGM(S,ROM2,ROG2,XM1,XM2))
	- & /(1+BETA+DELTA)
	- RETURN
	- END
	-
	- FUNCTION FORM3(MNUM,QQ,S1,SDWA)
	-C ==================================================================
	-C formfactorfor F3 for 3 scalar final state
	-C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	-C H. Georgi, Weak interactions and modern particle theory,
	-C The Benjamin/Cummings Pub. Co., Inc. 1984.
	-C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	-C and erratum !!!!!!
	-C ==================================================================
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- double complex FORM3
	- IF (MNUM.EQ.6) THEN
	- FORM3=CMPLX(0.0D0)
	- ELSE
	- FORM3=CMPLX(0.0D0)
	- ENDIF
	- FORM3=0
	-
	- END
	- FUNCTION FORM4(MNUM,QQ,S1,S2,S3)
	-C ==================================================================
	-C formfactorfor F4 for 3 scalar final state
	-C R. Decker, in preparation
	-C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	-C and erratum !!!!!!
	-C ==================================================================
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- double complex FORM4,WIGNER,FPIKM
	- double precision M
	- WIGNER(A,B,C)=CMPLX(1.0,0.0D0) /CMPLX(A-B*2,BC)
	- IF (MNUM.EQ.0) THEN
	-C ------------ 3 pi hadronic state (a1)
	- G1=5.8
	- G2=6.08
	- FPIP=0.02
	- AMPIP=1.3
	- GAMPIP=0.3
	- S=QQ
	- G=GAMPIP
	- XM1=AMPIZ
	- XM2=AMRO
	- M =AMPIP
	- W=SQRT(S)
	- IF (S.GT.(XM1+XM2)**2) THEN
	- QS=SQRT(ABS((S -(XM1+XM2)*2)(S -(XM1-XM2)**2)))/SQRT(S)
	- QM=SQRT(ABS((M2-(XM1+XM2)2)(M2-(XM1-XM2)*2)))/M
	- GS=G(M/W)2(QS/QM)**5
	- ELSE
	- GS=0.0D0
	- ENDIF
	- GAMX=GS*W/M
	- FORM4=G1G2FPIP/AMRO4/AMPIP2
	- $ AMPIP2WIGNER(QQ,AMPIP,GAMX)
	- $ ( S1(S2-S3)*FPIKM(SQRT(S1),AMPIZ,AMPIZ)
	- $ +S2(S1-S3)FPIKM(SQRT(S2),AMPIZ,AMPIZ) )
	- ELSEIF (MNUM.EQ.1) THEN
	-C ------------ K- pi- K+
	- G1=5.8
	- G2=6.08
	- FPIP=0.02
	- AMPIP=1.3
	- GAMPIP=0.3
	- S=QQ
	- G=GAMPIP
	- XM1=AMPIZ
	- XM2=AMRO
	- M =AMPIP
	- IF (S.GT.(XM1+XM2)**2) THEN
	- QS=SQRT(ABS((S -(XM1+XM2)*2)(S -(XM1-XM2)**2)))/SQRT(S)
	- QM=SQRT(ABS((M2-(XM1+XM2)2)(M2-(XM1-XM2)*2)))/M
	- W=SQRT(S)
	- GS=G(M/W)2(QS/QM)**5
	- ELSE
	- GS=0.0D0
	- ENDIF
	- GAMX=GS*W/M
	- FORM4=G1G2FPIP/AMRO4/AMPIP2
	- $ AMPIP2WIGNER(QQ,AMPIP,GAMX)
	- $ ( S1(S2-S3)*FPIKM(SQRT(S1),AMPIZ,AMPIZ)
	- $ +S2(S1-S3)FPIKM(SQRT(S2),AMPIZ,AMPIZ) )
	- ELSE
	- FORM4=CMPLX(0.0D0,0.0D0)
	- ENDIF
	-C ---- this formfactor is switched off .. .
	-cam FORM4=CMPLX(0.0D0,0.0D0)
	- END
	- FUNCTION FORM5(MNUM,QQ,S1,S2)
	-C ==================================================================
	-C formfactorfor F5 for 3 scalar final state
	-C G. Kramer, W. Palmer, S. Pinsky, Phys. Rev. D30 (1984) 89.
	-C G. Kramer, W. Palmer Z. Phys. C25 (1984) 195.
	-C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	-C and erratum !!!!!!
	-C ==================================================================
	-C
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- double complex FORM5,WIGNER,FPIKM,FPIKMD,BWIGM
	- WIGNER(A,B,C)=CMPLX(1.0,0.0D0)/CMPLX(A-B*2,BC)
	- IF (MNUM.EQ.0) THEN
	-C ------------ 3 pi hadronic state (a1)
	- FORM5=0.0D0
	- ELSEIF (MNUM.EQ.1) THEN
	-C ------------ K- pi- K+
	- ELPHA=-0.2
	- FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
	- $ *( FPIKM(SQRT(S2),AMPI,AMPI)
	- $ +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
	- ELSEIF (MNUM.EQ.2) THEN
	-C ------------ K0 pi- K0B
	- ELPHA=-0.2
	- FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
	- $ *( FPIKM(SQRT(S2),AMPI,AMPI)
	- $ +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
	- ELSEIF (MNUM.EQ.3) THEN
	-C ------------ K- K0 pi0
	- FORM5=0.0D0
	- ELSEIF (MNUM.EQ.4) THEN
	-C ------------ pi0 pi0 K-
	- FORM5=0.0D0
	- ELSEIF (MNUM.EQ.5) THEN
	-C ------------ K- pi- pi+
	- ELPHA=-0.2
	- FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMK)/(1+ELPHA)
	- $ *( FPIKM(SQRT(S1),AMPI,AMPI)
	- $ +ELPHA*BWIGM(S2,AMKST,GAMKST,AMPI,AMK))
	- ELSEIF (MNUM.EQ.6) THEN
	-C ------------ pi- K0B pi0
	- ELPHA=-0.2
	- FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMKZ)/(1+ELPHA)
	- $ *( FPIKM(SQRT(S2),AMPI,AMPI)
	- $ +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
	- ELSEIF (MNUM.EQ.7) THEN
	-C -------------- eta pi- pi0 final state
	- FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)*FPIKM(SQRT(S1),AMPI,AMPI)
	- ENDIF
	-C
	- END
	- SUBROUTINE CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
	-C ==================================================================
	-C hadronic current for 4 pi final state
	-C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	-C R. Decker Z. Phys C36 (1987) 487.
	-C M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
	-C ==================================================================
	-
	- IMPLICIT double precision (A-H,O-Z)
	- COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	-C
	- double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	- * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	- * ,AMK,AMKZ,AMKST,GAMKST
	- COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	- double precision PIM1(4),PIM2(4),PIM3(4),PIM4(4),PAA(4)
	-cam double complex HADCUR(4),FORM1,FORM2,FORM3,FPIKM
	- double complex HADCUR(4),FORM1,FORM2,FORM3,WIGFOR
	- double complex BWIGN
	- double precision PA(4),PB(4)
	- double precision AA(4,4),PP(4,4)
	- DATA PI /3.141592653589793238462643/
	- DATA FPI /93.3E-3/
	- BWIGN(A,XM,XG)=1.0/CMPLX(A-XM*2,XMXG)
	-C
	-C --- masses and constants
	-cam rho-prim taken as in Dolinsky et al (PhysLett B174 (1986) 453)
	-cam (best fit to Argus data)
	- G1=12.924
	- G2=1475.98
	- G =G1*G2
	-cam ELPHA=-.1
	-cam AMROP=1.7
	-cam GAMROP=0.26
	- ELPHA= .02
	- AMROP=1.250
	- GAMROP=0.125
	- AMOM=.782
	- GAMOM=0.0085
	-cam ARFLAT=1.0
	-cam AROMEG=1.0
	- ARFLAT=1.3
	- AROMEG=2.0
	-C
	- FRO=0.266AMRO*2
	- COEF1=2.0SQRT(3.0)/FPI2ARFLAT
	- COEF2=FROGAROMEG
	-C --- initialization of four vectors
	- DO 7 K=1,4
	- DO 8 L=1,4
	- 8 AA(K,L)=0.0D0
	- HADCUR(K)=CMPLX(0.0D0)
	- PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
	- PP(1,K)=PIM1(K)
	- PP(2,K)=PIM2(K)
	- PP(3,K)=PIM3(K)
	- 7 PP(4,K)=PIM4(K)
	-C
	- IF (MNUM.EQ.1) THEN
	-C ===================================================================
	-C pi- pi- p0 pi+ case ====
	-C ===================================================================
	- QQ=PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2
	-C --- loop over thre contribution of the non-omega current
	- DO 201 K=1,3
	- SK=(PP(K,4)+PIM4(4))2-(PP(K,3)+PIM4(3))2
	- $ -(PP(K,2)+PIM4(2))2-(PP(K,1)+PIM4(1))2
	-C -- definition of AA matrix
	-C -- cronecker delta
	- DO 202 I=1,4
	- DO 203 J=1,4
	- 203 AA(I,J)=0.0D0
	- 202 AA(I,I)=1.0
	-C ... and the rest ...
	- DO 204 L=1,3
	- IF (L.NE.K) THEN
	- DENOM=(PAA(4)-PP(L,4))2-(PAA(3)-PP(L,3))2
	- $ -(PAA(2)-PP(L,2))2-(PAA(1)-PP(L,1))2
	- DO 205 I=1,4
	- DO 205 J=1,4
	- SIG= 1.0
	- IF(J.NE.4) SIG=-SIG
	- AA(I,J)=AA(I,J)
	- $ -SIG(PAA(I)-2.0PP(L,I))*(PAA(J)-PP(L,J))/DENOM
	- 205 CONTINUE
	- ENDIF
	- 204 CONTINUE
	-C --- lets add something to HADCURR
	-cam FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
	-C FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
	- FORM1=WIGFOR(SK,AMRO,GAMRO)
	-C
	- FIX=1.0
	- IF (K.EQ.3) FIX=-2.0
	- DO 206 I=1,4
	- DO 206 J=1,4
	- HADCUR(I)=
	- $ HADCUR(I)+CMPLX(FIXCOEF1)FORM1AA(I,J)(PP(K,J)-PP(4,J))
	- 206 CONTINUE
	-C --- end of the non omega current (3 possibilities)
	- 201 CONTINUE
	-C
	-C
	-C --- there are two possibilities for omega current
	-C --- PA PB are corresponding first and second pi-s
	- DO 301 KK=1,2
	- DO 302 I=1,4
	- PA(I)=PP(KK,I)
	- PB(I)=PP(3-KK,I)
	- 302 CONTINUE
	-C --- lorentz invariants
	- QQA=0.0D0
	- SS23=0.0D0
	- SS24=0.0D0
	- SS34=0.0D0
	- QP1P2=0.0D0
	- QP1P3=0.0D0
	- QP1P4=0.0D0
	- P1P2 =0.0D0
	- P1P3 =0.0D0
	- P1P4 =0.0D0
	- DO 303 K=1,4
	- SIGN=-1.0
	- IF (K.EQ.4) SIGN= 1.0
	- QQA=QQA+SIGN(PAA(K)-PA(K))*2
	- SS23=SS23+SIGN(PB(K) +PIM3(K))*2
	- SS24=SS24+SIGN(PB(K) +PIM4(K))*2
	- SS34=SS34+SIGN(PIM3(K)+PIM4(K))*2
	- QP1P2=QP1P2+SIGN(PAA(K)-PA(K))PB(K)
	- QP1P3=QP1P3+SIGN(PAA(K)-PA(K))PIM3(K)
	- QP1P4=QP1P4+SIGN(PAA(K)-PA(K))PIM4(K)
	- P1P2=P1P2+SIGNPA(K)PB(K)
	- P1P3=P1P3+SIGNPA(K)PIM3(K)
	- P1P4=P1P4+SIGNPA(K)PIM4(K)
	- 303 CONTINUE
	-C
	- FORM2=COEF2(BWIGN(QQ,AMRO,GAMRO)+ELPHABWIGN(QQ,AMROP,GAMROP))
	-C FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
	-C $ BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
	- FORM3=BWIGN(QQA,AMOM,GAMOM)
	-C
	- DO 304 K=1,4
	- HADCUR(K)=HADCUR(K)+FORM2FORM3(
	- $ PB (K)(QP1P3P1P4-QP1P4*P1P3)
	- $ +PIM3(K)(QP1P4P1P2-QP1P2*P1P4)
	- $ +PIM4(K)(QP1P2P1P3-QP1P3*P1P2) )
	- 304 CONTINUE
	- 301 CONTINUE
	-C
	- ELSE
	-C ===================================================================
	-C pi0 pi0 p0 pi- case ====
	-C ===================================================================
	- QQ=PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2
	- DO 101 K=1,3
	-C --- loop over thre contribution of the non-omega current
	- SK=(PP(K,4)+PIM4(4))2-(PP(K,3)+PIM4(3))2
	- $ -(PP(K,2)+PIM4(2))2-(PP(K,1)+PIM4(1))2
	-C -- definition of AA matrix
	-C -- cronecker delta
	- DO 102 I=1,4
	- DO 103 J=1,4
	- 103 AA(I,J)=0.0D0
	- 102 AA(I,I)=1.0
	-C
	-C ... and the rest ...
	- DO 104 L=1,3
	- IF (L.NE.K) THEN
	- DENOM=(PAA(4)-PP(L,4))2-(PAA(3)-PP(L,3))2
	- $ -(PAA(2)-PP(L,2))2-(PAA(1)-PP(L,1))2
	- DO 105 I=1,4
	- DO 105 J=1,4
	- SIG=1.0
	- IF(J.NE.4) SIG=-SIG
	- AA(I,J)=AA(I,J)
	- $ -SIG(PAA(I)-2.0PP(L,I))*(PAA(J)-PP(L,J))/DENOM
	- 105 CONTINUE
	- ENDIF
	- 104 CONTINUE
	-C --- lets add something to HADCURR
	-cam FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
	-C FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
	- FORM1=WIGFOR(SK,AMRO,GAMRO)
	- DO 106 I=1,4
	- DO 106 J=1,4
	- HADCUR(I)=
	- $ HADCUR(I)+CMPLX(COEF1)FORM1AA(I,J)*(PP(K,J)-PP(4,J))
	- 106 CONTINUE
	-C --- end of the non omega current (3 possibilities)
	- 101 CONTINUE
	- ENDIF
	- END
	- FUNCTION WIGFOR(S,XM,XGAM)
	- IMPLICIT double precision (A-H,O-Z)
	- double complex WIGFOR,WIGNOR
	- WIGNOR=CMPLX(-XM*2,XMXGAM)
	- WIGFOR=WIGNOR/CMPLX(S-XM*2,XMXGAM)
	- END
	Index: trunk/tauola/tauola_dummy.f90
	===================================================================
	--- trunk/tauola/tauola_dummy.f90 (revision 8888)
	+++ trunk/tauola/tauola_dummy.f90 (revision 8889)
	@@ -1,92 +0,0 @@
	-subroutine dekay (kto, hx)
	- integer, intent(in) :: kto
	- double precision, dimension(4), intent(in) :: hx
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine dekay
	-
	-subroutine dexay (kto, pol)
	- integer, intent(in) :: kto
	- double precision, dimension(4), intent(in) :: pol
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine dexay
	-
	-subroutine initdk (mode, keypol)
	- integer, intent(in) :: mode, keypol
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine initdk
	-
	-subroutine inimas (mode, keypol)
	- integer, intent(in) :: mode, keypol
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine inimas
	-
	-subroutine iniphx (xk00)
	- double precision, intent(in) :: xk00
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine iniphx
	-
	-subroutine inietc (jakk1, jakk2, itd, ifpho)
	- integer, intent(in) :: jakk1, jakk2, itd, ifpho
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine inietc
	-
	-subroutine phoini ()
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine phoini
	-
	-function wthiggs (ifpseudo, hh1, hh2)
	- double precision, dimension(4), intent(in) :: hh1, hh2
	- logical, intent(in) :: ifpseudo
	- double precision :: wthiggs
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end function wthiggs
	-
	-subroutine taupi0 (mode, jak, ion)
	- integer, intent(in) :: mode, jak
	- integer, dimension(3), intent(in) :: ion
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine taupi0
	-
	-subroutine photos (id)
	- integer, intent(in) :: id
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine photos
	-
	-subroutine ranmar (rvec, lenv)
	- double precision, dimension(lenv) :: rvec
	- integer, intent(in) :: lenv
	- write (0, "(A)") "**************************************************************"
	- write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	- write (0, "(A)") "**************************************************************"
	- stop
	-end subroutine ranmar
	Index: trunk/configure.ac.in
	===================================================================
	--- trunk/configure.ac.in (revision 8888)
	+++ trunk/configure.ac.in (revision 8889)
	@@ -1,1243 +1,1248 @@
	dnl configure.ac -- Main configuration script for WHIZARD
	dnl
	dnl Process this file with autoconf to produce a configure script.
	dnl ************************************************************************
	dnl configure.ac -- Main configuration script for WHIZARD
	dnl configure.ac -- WHIZARD configuration
	dnl
	dnl Copyright (C) 1999-2023 by
	dnl Wolfgang Kilian <kilian@physik.uni-siegen.de>
	dnl Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	dnl Juergen Reuter <juergen.reuter@desy.de>
	dnl with contributions from
	dnl cf. main AUTHORS file
	dnl
	dnl WHIZARD is free software; you can redistribute it and/or modify it
	dnl under the terms of the GNU General Public License as published by
	dnl the Free Software Foundation; either version 2, or (at your option)
	dnl any later version.
	dnl
	dnl WHIZARD is distributed in the hope that it will be useful, but
	dnl WITHOUT ANY WARRANTY; without even the implied warranty of
	dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	dnl GNU General Public License for more details.
	dnl
	dnl You should have received a copy of the GNU General Public License
	dnl along with this program; if not, write to the Free Software
	dnl Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	dnl
	dnl ***********************************************************************
	dnl Environment variables that can be set by the user:
	dnl FC Fortran compiler
	dnl FCFLAGS Fortran compiler flags
	dnl ***********************************************************************
	dnl
	dnl Start configuration
	AC_INIT([XXXWHIZARDXXX],[3.1.2.1])
	AC_CONFIG_MACRO_DIR([m4])
	AM_INIT_AUTOMAKE([1.12.2 color-tests parallel-tests])
	AC_PREREQ([2.65])
	AM_MAKE_INCLUDE

	dnl Make make less verbose to improve signal/noise
	AM_SILENT_RULES([yes])

	########################################################################
	### Package-specific initialization

	AC_MSG_NOTICE([**************************************************************])
	WO_CONFIGURE_SECTION([Start of package configuration])

	### Further version information
	PACKAGE_DATE="Mar 21 2023"
	PACKAGE_STATUS="alpha"

	AC_SUBST(PACKAGE_DATE)
	AC_SUBST(PACKAGE_STATUS)

	AC_MSG_NOTICE([**************************************************************])
	AC_MSG_NOTICE([Package name: AC_PACKAGE_NAME()])
	AC_MSG_NOTICE([Version: AC_PACKAGE_VERSION()])
	AC_MSG_NOTICE([Date: $PACKAGE_DATE])
	AC_MSG_NOTICE([Status: $PACKAGE_STATUS])
	AC_MSG_NOTICE([**************************************************************])

	########################################################################
	###---------------------------------------------------------------------
	### shared library versioning (not the same as the package version!)

	LIBRARY_VERSION="-version-info 2:2:0"
	AC_SUBST([LIBRARY_VERSION])

	########################################################################
	###---------------------------------------------------------------------
	### Define the main package variables

	### Source directory, for testing purposes
	SRCDIR=`cd $srcdir && pwd`
	AC_SUBST([SRCDIR])

	### Build directory, for testing purposes
	BUILDDIR=`pwd`
	AC_SUBST([BUILDDIR])

	### Location of installed libraries and such
	eval BINDIR=$bindir
	case $BINDIR in
	NONE*) eval BINDIR=$prefix/bin ;;
	esac
	case $BINDIR in
	NONE*) BINDIR="\${prefix}/bin" ;;
	esac
	AC_SUBST([BINDIR])

	eval INCLUDEDIR=$includedir
	case $INCLUDEDIR in
	NONE*) eval INCLUDEDIR=$prefix/include ;;
	esac
	case $INCLUDEDIR in
	NONE*) INCLUDEDIR="\${prefix}/include" ;;
	esac
	AC_SUBST([INCLUDEDIR])

	eval LIBDIR=$libdir
	case $LIBDIR in
	NONE*) eval LIBDIR=$prefix/lib ;;
	esac
	case $LIBDIR in
	NONE*) eval LIBDIR=$ac_default_prefix/lib ;;
	esac
	AC_SUBST([LIBDIR])

	### Location of installed libraries and such
	eval PKGLIBDIR=$libdir/$PACKAGE
	case $PKGLIBDIR in
	NONE*) eval PKGLIBDIR=$prefix/lib/$PACKAGE ;;
	esac
	case $PKGLIBDIR in
	NONE*) PKGLIBDIR="\${prefix}/lib/$PACKAGE" ;;
	esac
	AC_SUBST([PKGLIBDIR])

	### Location of installed system-independent data
	eval PKGDATADIR=$datarootdir/$PACKAGE
	case $PKGDATADIR in
	NONE*) eval PKGDATADIR=$prefix/share/$PACKAGE ;;
	esac
	case $PKGDATADIR in
	NONE*) PKGDATADIR="\${prefix}/share/$PACKAGE" ;;
	esac
	AC_SUBST([PKGDATADIR])

	### Location of installed TeX files and such
	eval PKGTEXDIR=$datarootdir/texmf/$PACKAGE
	case $PKGTEXDIR in
	NONE*) eval PKGTEXDIR=$prefix/share/texmf/$PACKAGE ;;
	esac
	case $PKGTEXDIR in
	NONE*) PKGTEXDIR="\${prefix}/share/texmf/$PACKAGE" ;;
	esac
	AC_SUBST([PKGTEXDIR])

	### Parent location of installed .mod files
	### To be used in Fortran source
	FMODDIR=$prefix/lib/mod
	case $FMODDIR in
	NONE*) FMODDIR="\${prefix}/lib/mod" ;;
	esac
	AC_SUBST([FMODDIR])

	### To be used in Makefile.am
	### Don't use ${libdir} since lib may be changed to lib64 by configure
	fmoddir="\${prefix}/lib/mod"
	AC_SUBST([fmoddir])

	########################################################################
	###---------------------------------------------------------------------
	### Required programs and checks
	### GNU Tools

	WO_CONFIGURE_SECTION([Generic tools])

	### Initialize LIBTOOL
	LT_INIT(dlopen)

	LT_PREREQ([2.4.1b])

	AX_CHECK_GNU_MAKE()
	AC_PROG_GREP()

	AC_MSG_CHECKING([for the suffix of shared libraries])
	case $host in
	-darwin \| rhapsody*)
	SHRLIB_EXT="dylib"
	;;
	cygwin* \| mingw* \| pw32* \| cegcc* \| os2*)
	SHRLIB_EXT="dll"
	;;
	hpux9* \| hpux10* \| hpux11*)
	SHRLIB_EXT="sl"
	;;
	*)
	SHRLIB_EXT="so"
	;;
	esac
	if test "x$SHRLIB_EXT" != "x"; then
	SHRLIB_EXT=$SHRLIB_EXT
	else
	SHRLIB_EXT="so"
	fi
	AC_MSG_RESULT([.$SHRLIB_EXT])
	AC_SUBST(SHRLIB_EXT)

	### Export whether the C compiler is GNU
	AC_MSG_CHECKING([whether the C compiler is the GNU compiler])
	if test "x$ac_cv_c_compiler_gnu" = "xyes"; then
	CC_IS_GNU=".true."
	else
	CC_IS_GNU=".false."
	fi
	AC_MSG_RESULT([$ac_cv_c_compiler_gnu])
	AC_SUBST([CC_IS_GNU])

	AC_CHECK_HEADERS([quadmath.h])
	if test "x$ac_cv_header_quadmath_h" = "xyes"; then
	CC_HAS_QUADMATH=".true."
	else
	CC_HAS_QUADMATH=".false."
	fi
	AC_SUBST([CC_HAS_QUADMATH])

	########################################################################
	###---------------------------------------------------------------------
	### Host system MAC OS X check for XCode

	case $host in
	-darwin)
	WO_HLINE()
	AC_MSG_NOTICE([Host is $host, checking for XCode])
	AC_PATH_PROG(XCODE_SELECT, xcode-select)
	# locate currently selected Xcode path
	if test "x$XCODE_SELECT" != "x"; then
	AC_MSG_CHECKING(Xcode location)
	DEVELOPER_DIR=`$XCODE_SELECT -print-path`
	AC_MSG_RESULT([$DEVELOPER_DIR])
	else
	DEVELOPER_DIR=/Developer
	fi
	AC_SUBST(DEVELOPER_DIR)

	XCODEPLIST=$DEVELOPER_DIR/Applications/Xcode.app/Contents/version.plist
	if test -r "$XCODEPLIST"; then
	AC_MSG_CHECKING(Xcode version)
	if test "x$DEFAULTS" != "x"; then
	XCODE_VERSION=`$DEFAULTS read $DEVELOPER_DIR/Applications/Xcode.app/Contents/version CFBundleShortVersionString`
	else
	XCODE_VERSION=`tr -d '\r\n' < $XCODEPLIST \| sed -e 's/.<key>CFBundleShortVersionString<\/key>.<string>$[[0-9.]]$<\/string>.*/\1/'`
	fi
	AC_MSG_RESULT([$XCODE_VERSION])
	AC_SUBST(XCODE_VERSION)
	fi

	AC_MSG_NOTICE([checking for Security Integrity Protocol (SIP)])
	AC_PATH_PROG(CSRUTIL, csrutil)
	if test "x$CSRUTIL" != "x"; then
	SIP_CHECK=`$CSRUTIL status \| $SED "s/System Integrity Protection status: //"`
	if test "$SIP_CHECK" = "enabled."; then
	SIP_ACTIVE="yes"
	else
	SIP_ACTIVE="no"
	fi
	else
	SIP_ACTIVE="no"
	fi
	AC_MSG_CHECKING([Checking whether MAC OS X SIP is activated])
	AC_MSG_RESULT([$SIP_ACTIVE])
	AC_SUBST([SIP_ACTIVE])

	WO_HLINE()
	;;
	*)
	;;
	esac

	########################################################################
	###---------------------------------------------------------------------
	### Enable the distribution tools
	### (default: disabled, to speed up compilation)

	AC_ARG_ENABLE([distribution],
	[AS_HELP_STRING([--enable-distribution],
	[build the distribution incl. all docu (developers only) [[no]]])])

	AC_CACHE_CHECK([whether we want to build the distribution],
	[wo_cv_distribution],
	[dnl
	if test "$enable_distribution" = "yes"; then
	wo_cv_distribution=yes
	else
	wo_cv_distribution=no
	fi])

	AM_CONDITIONAL([DISTRIBUTION],
	[test "$enable_distribution" = "yes"])

	### ONLY_FULL {{{
	########################################################################
	###---------------------------------------------------------------------

	if test "$enable_shared" = no; then
	AC_MSG_ERROR([you've used --disable-shared which will not produce a working Whizard.])
	fi
	### ONLY_FULL }}}

	########################################################################
	###---------------------------------------------------------------------
	### We include the m4 macro tool here

	AC_PATH_PROG(M4,m4,false)
	if test "$M4" = false; then
	AM_CONDITIONAL([M4_AVAILABLE],[false])
	else
	AM_CONDITIONAL([M4_AVAILABLE],[true])
	fi

	########################################################################
	###---------------------------------------------------------------------
	### Dynamic runtime linking

	WO_CONFIGURE_SECTION([Dynamic runtime linking])

	### Look for libdl (should provide 'dlopen' and friends)
	AC_PROG_CC()
	WO_PROG_DL()

	### Define the conditional for static builds

	if test "$enable_static" = yes; then
	AM_CONDITIONAL([STATIC_AVAILABLE],[true])
	else
	AM_CONDITIONAL([STATIC_AVAILABLE],[false])
	fi

	########################################################################
	###---------------------------------------------------------------------
	### Noweb

	WO_CONFIGURE_SECTION([Checks for 'noweb' system])

	### Enable/disable noweb and determine locations of notangle, cpif, noweave
	WO_PROG_NOWEB()

	########################################################################
	###---------------------------------------------------------------------
	### LaTeX

	WO_CONFIGURE_SECTION([Checks for 'LaTeX' system])

	### Determine whether LaTeX is present
	AC_PROG_LATEX()
	AC_PROG_DVIPS()
	AC_PROG_PDFLATEX()
	AC_PROG_MAKEINDEX()
	AC_PROG_PS2PDF()
	AC_PROG_EPSPDF()
	AC_PROG_EPSTOPDF()
	if test "$EPSPDF" = "no" -a "$EPSTOPDF" = "no"; then
	AC_MSG_NOTICE([*********************************************************])
	AC_MSG_NOTICE([WARNING: eps(to)pdf n/a; O'Mega documentation will crash!])
	AC_MSG_NOTICE([WARNING: this applies only to the svn developer version!])
	AC_MSG_NOTICE([*********************************************************])
	fi
	AC_PROG_CONTEXT()
	AC_PROG_GZIP()
	AC_PATH_PROG(ACROREAD,acroread,false)
	AC_PATH_PROG(GHOSTVIEW,gv ghostview,false)
	AC_PROG_DOT()

	### Determine whether Metapost is present and whether event display is possible
	AC_PROG_MPOST()
	WO_CHECK_EVENT_ANALYSIS_METHODS()

	### We put here the check for HEVEA components as well
	WO_PROG_HEVEA()

	########################################################################
	###---------------------------------------------------------------------
	### Fortran compiler

	WO_CONFIGURE_SECTION([Fortran compiler checks])

	### Determine default compiler to use
	user_FCFLAGS="${FCFLAGS}"
	AC_PROG_FC()

	### Choose FC standard for PYTHIA6 F77 files
	AC_PROG_F77([$FC])

	### Determine compiler vendor and version
	WO_FC_GET_VENDOR_AND_VERSION()

	### Veto against old gfortran 4 versions
	WO_FC_VETO_GFORTRAN_4()

	### Veto against buggy gfortran 6.5.0 version
	WO_FC_VETO_GFORTRAN_65()

	### Veto against ifort 15/16/17/18
	WO_FC_VETO_IFORT_15_18()

	### Veto against ifort 19.0.0/1/2
	WO_FC_VETO_IFORT_190012()

	### Veto against ifort 21.0/1/2
	WO_FC_VETO_IFORT_21012()

	### Require extension '.f90' for all compiler checks
	AC_FC_SRCEXT([f90])

	### Determine flags and extensions
	WO_FC_PARAMETERS()

	### Determine flags for linking the Fortran runtime library
	WO_FC_LIBRARY_LDFLAGS()

	### Check for Fortran 95 features
	WO_FC_CHECK_F95()

	### Check for allocatable subobjects (TR15581)
	WO_FC_CHECK_TR15581()

	### Check for allocatable scalars
	WO_FC_CHECK_ALLOCATABLE_SCALARS()

	### Check for ISO C binding support
	WO_FC_CHECK_C_BINDING()

	### Check for procedures pointers and abstract interfaces
	WO_FC_CHECK_PROCEDURE_POINTERS()

	### Check for type extension and further OO features
	WO_FC_CHECK_OO_FEATURES()

	### Check for submodules (not yet used)
	WO_FC_CHECK_TR19767()

	### Check for F2003 command-line interface
	WO_FC_CHECK_CMDLINE()

	### Check for F2003-style access to environment variables
	WO_FC_CHECK_ENVVAR()

	### Check for the flush statement
	WO_FC_CHECK_FLUSH()

	### Check for iso_fortran_env
	WO_FC_CHECK_ISO_FORTRAN_ENV()
	WO_FC_CHECK_ISO_FORTRAN_ENV_2008()

	### Turn on/off master switch for debugging features
	WO_FC_SET_DEBUG()

	### OpenMP threading activated upon request
	AC_OPENMP()
	WO_FC_SET_OPENMP()

	### Profiling compilation enforced upon request
	WO_FC_SET_PROFILING()

	### Impure subroutines enforced upon request
	WO_FC_SET_OMEGA_IMPURE()

	### Find the extension of Fortran module files
	WO_FC_MODULE_FILE([FC_MODULE_NAME], [FCMOD], [$FC], [f90])

	###---------------------------------------------------------------------
	### Check for the requested precision

	WO_FC_CONFIGURE_KINDS([src/basics/kinds.f90])
	### ONLY_FULL {{{
	AC_PROG_INSTALL()
	${INSTALL} -d circe1/src
	cp -a src/basics/kinds.f90 circe1/src
	${INSTALL} -d circe2/src
	cp -a src/basics/kinds.f90 circe2/src
	${INSTALL} -d omega/src
	cp -a src/basics/kinds.f90 omega/src
	${INSTALL} -d vamp/src
	cp -a src/basics/kinds.f90 vamp/src
	### ONLY_FULL }}}

	### ONLY_VAMP_AND_FULL {{{
	########################################################################
	# VAMP Fortran options for the configure script
	########################################################################

	WO_FC_SET_MPI()

	### ONLY_VAMP_AND_FULL }}}

	########################################################################
	###---------------------------------------------------------------------
	### OCaml

	WO_CONFIGURE_SECTION([Objective Caml checks])

	### Check for ocamlc and its relatives
	AC_PROG_OCAML()
	if test "$enable_ocaml" != "no"; then
	AC_OCAML_VERSION_CHECK(405000)
	AC_PROG_OCAMLLEX()
	AC_PROG_OCAMLYACC()
	AC_PROG_OCAMLCP()
	AC_OCAML_BIGARRAY_MODULE()
	### Ocamlweb is required to be newer than v0.9
	AC_PROG_OCAMLWEB(009000)
	AC_PROG_OCAML_LABLGTK()
	AC_PATH_PROGS([OCAMLDOT],[ocamldot],[no])
	AM_CONDITIONAL([OCAMLDOT_AVAILABLE],[test "$OCAMLDOT" != "no"])
	AC_PATH_PROGS([OCAMLDEP],[ocamldep],[no])
	AM_CONDITIONAL([OCAMLDEP_AVAILABLE],[test "$OCAMLDEP" != "no"])
	AC_PATH_PROGS([OCAMLDEFUN],[ocamldefun],[no])
	else
	AC_MSG_NOTICE([WARNING: OCaml and O'Mega matrix elements disabled by request!])
	AM_CONDITIONAL([OCAMLWEB_AVAILABLE],[false])
	AM_CONDITIONAL([OCAMLDOT_AVAILABLE],[false])
	AM_CONDITIONAL([OCAMLDEP_AVAILABLE],[false])
	fi

	########################################################################
	###---------------------------------------------------------------------
	### C++

	WO_CONFIGURE_SECTION([C++ compiler checks])
	AC_PROG_CXX()
	AC_CXX_LIBRARY_LDFLAGS()

	########################################################################
	###---------------------------------------------------------------------
	### Checks for external interfaces

	WO_CONFIGURE_SECTION([Checking for PYTHON / PYTHON API])

	AX_PYTHON_DEVEL([>= '3.5'])
	WO_PROG_PYTHON_API()

	### ONLY_OMEGA_AND_FULL {{{
	########################################################################
	# O'Mega options for the configure script
	########################################################################

	########################################################################
	###---------------------------------------------------------------------
	### O'Mega UFO file paths

	WO_CONFIGURE_SECTION([O'Mega UFO file paths])

	AC_ARG_ENABLE([default-UFO-dir],
	[ --enable-default-UFO-dir=directory
	Read precomputed model tables from this directory,
	which will be populated by an administrator at
	install time [[default=$datadir/UFO, enabled]].],
	[case "$enableval" in
	no) OMEGA_DEFAULT_UFO_DIR="."
	;;
	*) OMEGA_DEFAULT_UFO_DIR="$enableval"
	;;
	esac],
	[### use eval b/c $datadir defaults to unexpanded ${datarootdir}
	case "$OMEGA_DEFAULT_UFO_DIR" in
	"") OMEGA_DEFAULT_UFO_DIR="${prefix}/omega/share/UFO"
	;;
	*) eval OMEGA_DEFAULT_UFO_DIR="$datadir/UFO"
	;;
	esac])
	AC_SUBST([OMEGA_DEFAULT_UFO_DIR])

	case "$OMEGA_DEFAULT_UFO_DIR" in
	.\|""\|NONE*) OMEGA_DEFAULT_UFO_DIR="."
	;;
	*) AC_MSG_NOTICE([Creating default UFO directory $OMEGA_DEFAULT_UFO_DIR])
	$MKDIR_P "$OMEGA_DEFAULT_UFO_DIR" 2>/dev/null
	chmod u+w "$OMEGA_DEFAULT_UFO_DIR" 2>/dev/null
	;;
	esac

	###---------------------------------------------------------------------
	### Recola

	WO_CONFIGURE_SECTION([RECOLA])

	WO_PROG_RECOLA()

	### ONLY_OMEGA_AND_FULL }}}

	### ONLY_FULL {{{
	########################################################################
	###---------------------------------------------------------------------
	### Libraries

	###---------------------------------------------------------------------
	### LHAPDF

	WO_CONFIGURE_SECTION([LHAPDF])

	WO_PROG_LHAPDF()

	###---------------------------------------------------------------------
	### ROOT

	WO_CONFIGURE_SECTION([ROOT])

	WO_ROOT_PATH(,[
	AC_DEFINE([HAVE_ROOT],,[Root library])
	AC_CHECK_LIB([dl],[dlopen],[],AC_MSG_WARN([Root libraries not linking properly]))
	],AC_MSG_RESULT([The ROOT support of HepMC might not be working properly]))

	###---------------------------------------------------------------------
	### HepMC

	WO_CONFIGURE_SECTION([HepMC])

	WO_PROG_HEPMC()

	###---------------------------------------------------------------------
	### STDHEP

	WO_CONFIGURE_SECTION([STDHEP])

	WO_PROG_TIRPC()

	AC_MSG_NOTICE([StdHEP v5.06.01 is included internally])

	###---------------------------------------------------------------------
	### LCIO

	WO_CONFIGURE_SECTION([LCIO])

	WO_PROG_LCIO()

	###---------------------------------------------------------------------
	### HDF5 (for events, grids etc.)

	WO_CONFIGURE_SECTION([HDF5])

	WO_PROG_HDF5(1.8.0,no)

	###---------------------------------------------------------------------
	### PYTHIA6, PYTHIA8 etc

	WO_CONFIGURE_SECTION([SHOWERS PYTHIA6 PYTHIA8 MPI])

	WO_PROG_QCD()

	WO_PROG_PYTHIA8()

	###---------------------------------------------------------------------
	### HOPPET

	WO_CONFIGURE_SECTION([HOPPET])

	WO_PROG_HOPPET()

	###---------------------------------------------------------------------
	### FASTJET

	WO_CONFIGURE_SECTION([FASTJET])

	WO_PROG_FASTJET()

	###---------------------------------------------------------------------
	### GoSam

	WO_CONFIGURE_SECTION([GOSAM])

	WO_PROG_GOSAM()

	###---------------------------------------------------------------------
	### OpenLoops

	WO_CONFIGURE_SECTION([OPENLOOPS])

	WO_PROG_OPENLOOPS()

	###---------------------------------------------------------------------
	### LoopTools

	WO_CONFIGURE_SECTION([LOOPTOOLS])

	WO_PROG_LOOPTOOLS()

	### ONLY_FULL }}}

	########################################################################
	###---------------------------------------------------------------------
	### Extra flags for helping the linker finding libraries

	WO_CONFIGURE_SECTION([Handle linking with C++ libraries])

	WO_PROG_STDCPP()

	### ONLY_FULL {{{
	########################################################################
	###---------------------------------------------------------------------
	### Miscellaneous

	WO_CONFIGURE_SECTION([Numerical checks])

	### Disable irrelevant optimization for parameter files
	### (default: disabled, to speed up compilation)

	AC_ARG_ENABLE([optimization-for-parameter-files],
	[AS_HELP_STRING([--enable-optimization-for-parameter-files],
	[enable (useless) optimization for parameter files [[no]]])])

	AC_CACHE_CHECK([whether we want optimization for parameter files],
	[wo_cv_optimization_for_parfiles],
	[dnl
	if test "$enable_optimization_for_parameter_files" = "yes"; then
	wo_cv_optimization_for_parfiles=yes
	else
	wo_cv_optimization_for_parfiles=no
	fi])

	AM_CONDITIONAL([OPTIMIZATION_FOR_PARFILES],
	[test "$enable_optimization_for_parameter_files" = "yes"])

	### ONLY_FULL }}}

	########################################################################
	###---------------------------------------------------------------------
	### Wrapup

	WO_CONFIGURE_SECTION([Finalize configuration])

	### Main directory

	AC_CONFIG_FILES([Makefile])

	### ONLY_FULL {{{
	###---------------------------------------------------------------------
	### Subdirectory src

	AC_CONFIG_FILES([src/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory python: WHIZARD's PYTHON/CYTHON interface

	AC_CONFIG_FILES([python/Makefile])
	AC_CONFIG_FILES([python/setup.py], [chmod u+x python/setup.py])
	AC_CONFIG_LINKS([python/whizard_python.pyx:python/whizard_python.pyx])
	AC_CONFIG_LINKS([python/cwhizard.pxd:python/cwhizard.pxd])

	###---------------------------------------------------------------------
	### Subdirectory src/hepmc

	AC_CONFIG_FILES([src/hepmc/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/lcio

	AC_CONFIG_FILES([src/lcio/Makefile])

	###---------------------------------------------------------------------
	+### Subdirectory contrib: external code shipped with WHIZARD
	+
	+AC_CONFIG_FILES([contrib/Makefile])
	+
	+###---------------------------------------------------------------------
	### Subdirectory pythia6: WHIZARD's internal PYTHIA6 version

	-AC_CONFIG_FILES([pythia6/Makefile])
	+AC_CONFIG_FILES([contrib/pythia6/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory tauola: WHIZARD's internal TAUOLA version

	-AC_CONFIG_FILES([tauola/Makefile])
	+AC_CONFIG_FILES([contrib/tauola/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory stdhep: WHIZARD's internal StdHep version

	-AC_CONFIG_FILES([mcfio/Makefile])
	-AC_CONFIG_FILES([stdhep/Makefile])
	+AC_CONFIG_FILES([contrib/mcfio/Makefile])
	+AC_CONFIG_FILES([contrib/stdhep/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/muli: multiple interactions

	AC_CONFIG_FILES([src/muli/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/lhapdf5: dummy library as LHAPDF5 replacement

	AC_CONFIG_FILES([src/lhapdf5/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/lhapdf: LHAPDF v6

	AC_CONFIG_FILES([src/lhapdf/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/pdf_builtin: Electron PDFs

	AC_CONFIG_FILES([src/qed_pdf/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/pdf_builtin: Builtin PDFs

	AC_CONFIG_FILES([src/pdf_builtin/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/tauola

	AC_CONFIG_FILES([src/tauola/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/xdr: XDR reader

	AC_CONFIG_FILES([src/xdr/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/hoppet

	AC_CONFIG_FILES([src/hoppet/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/fastjet

	AC_CONFIG_FILES([src/fastjet/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/looptools

	AC_CONFIG_FILES([src/looptools/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/shower: shower and all that

	AC_CONFIG_FILES([src/pythia8/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/shower: shower and all that

	AC_CONFIG_FILES([src/shower/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/noweb-frame: frame for whizard Noweb sources

	AC_CONFIG_FILES([src/noweb-frame/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/basics: numeric kinds, strings

	AC_CONFIG_FILES([src/basics/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/utilities: simple utilities

	AC_CONFIG_FILES([src/utilities/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/testing: unit-test support

	AC_CONFIG_FILES([src/testing/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/system: modules related to local setup and OS issues

	AC_CONFIG_FILES([src/system/Makefile])

	AC_CONFIG_FILES([src/system/system_dependencies.f90], [
	# Be cautious: Special handling of brackets due to M4!
	# 1. Configure lines containing @VARIABLE@ must be indented by exactly 7 spaces
	# to be split (^[[[:space:]]]\{7\}), the first non-space character has to
	# be an double-quote (\"). and the line has to have at least 110 characters where the
	# 111th must not be a double quote, a whitespace, a slash or an ampersand ([^\" \/&]).
	# 2. Appeand each 110-wide character block ($.\{110\}[[^\"]]$, refer to a block as \1)
	# (without a trailing double-quote) with an ampersand, a literal newline character,
	# seven white-spaces and another ampersand. Repeat with remaining pattern space (be greedy).
	# Note: The greedy options also allows us to parse the line beginning from each character
	# again with the search pattern.
	$SED "/^[[[:space:]]]\{7\}\".\{110,\}[[^\"]]/ s/$.\{110\}[[^\" \/&]]$/\1\&\\n \&/g" \
	< src/system/system_dependencies.f90 \
	> src/system/system_dependencies.tmp
	mv -f src/system/system_dependencies.tmp src/system/system_dependencies.f90
	])

	AC_CONFIG_FILES([src/system/debug_master.f90])

	###---------------------------------------------------------------------
	### Subdirectory src/combinatorics: standard algorithms

	AC_CONFIG_FILES([src/combinatorics/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/parsing: text-handling and parsing

	AC_CONFIG_FILES([src/parsing/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/rng: random-number generation

	AC_CONFIG_FILES([src/rng/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/expr_base: abstract expressions

	AC_CONFIG_FILES([src/expr_base/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/physics: particle-physics related functions

	AC_CONFIG_FILES([src/physics/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/qft: quantum (field) theory concepts as data types

	AC_CONFIG_FILES([src/qft/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/types: HEP and other types for common use

	AC_CONFIG_FILES([src/types/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/matrix_elements: process code and libraries

	AC_CONFIG_FILES([src/matrix_elements/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/me_methods: specific process code and interface

	AC_CONFIG_FILES([src/me_methods/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/particles: particle objects

	AC_CONFIG_FILES([src/particles/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/beams: beams and beam structure

	AC_CONFIG_FILES([src/beams/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/events: generic events and event I/O

	AC_CONFIG_FILES([src/events/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/vegas: VEGAS Monte Carlo adaptive integration

	AC_CONFIG_FILES([src/vegas/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/mci: multi-channel integration and event generation

	AC_CONFIG_FILES([src/mci/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/phase_space: parameterization and evaluation

	AC_CONFIG_FILES([src/phase_space/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/blha: BLHA support (NLO data record)

	AC_CONFIG_FILES([src/blha/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/gosam: GoSAM support (NLO amplitudes)

	AC_CONFIG_FILES([src/gosam/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/openloops: OpenLoops support (NLO amplitudes)

	AC_CONFIG_FILES([src/openloops/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/recola: Recola support (NLO amplitudes)

	AC_CONFIG_FILES([src/recola/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/fks: FKS subtraction algorithm

	AC_CONFIG_FILES([src/fks/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/matching: matching algorithms

	AC_CONFIG_FILES([src/matching/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/variables: Implementation of variable lists

	AC_CONFIG_FILES([src/variables/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/model_features: Model access and methods

	AC_CONFIG_FILES([src/model_features/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/models: Model-specific code

	AC_CONFIG_FILES([src/models/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/threshold

	AC_CONFIG_FILES([src/threshold/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/models/threeshl_bundle

	AC_CONFIG_FILES([src/models/threeshl_bundle/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/process_integration

	AC_CONFIG_FILES([src/process_integration/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/transforms: event transforms and event API

	AC_CONFIG_FILES([src/transforms/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/whizard-core

	AC_CONFIG_FILES([src/whizard-core/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/api

	AC_CONFIG_FILES([src/api/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/main

	AC_CONFIG_FILES([src/main/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/prebuilt

	AC_CONFIG_FILES([src/prebuilt/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/feynmf

	AC_CONFIG_FILES([src/feynmf/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory src/gamelan: WHIZARD graphics package

	AC_CONFIG_FILES([src/gamelan/Makefile])

	AC_CONFIG_FILES([src/gamelan/whizard-gml], [chmod u+x src/gamelan/whizard-gml])
	###---------------------------------------------------------------------
	### Subdirectory share

	AC_CONFIG_FILES([share/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/doc

	AC_CONFIG_FILES([share/doc/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/models

	AC_CONFIG_FILES([share/models/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/cuts

	AC_CONFIG_FILES([share/cuts/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/beam-sim

	AC_CONFIG_FILES([share/beam-sim/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/susy

	AC_CONFIG_FILES([share/susy/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/examples

	AC_CONFIG_FILES([share/examples/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/tests

	AC_CONFIG_FILES([share/tests/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/muli

	AC_CONFIG_FILES([share/muli/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/SM_tt_threshold_data

	AC_CONFIG_FILES([share/SM_tt_threshold_data/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory share/gui

	AC_CONFIG_FILES([share/gui/Makefile])

	###---------------------------------------------------------------------
	### Subdirectory tests

	AC_CONFIG_FILES([tests/Makefile])

	AC_CONFIG_FILES([tests/models/Makefile])
	AC_CONFIG_FILES([tests/models/UFO/Makefile])
	AC_CONFIG_FILES([tests/models/UFO/SM/Makefile])
	AC_CONFIG_FILES([tests/models/UFO/MSSM/Makefile])
	##_CONFIG_FILES([tests/models/UFO/SMEFTsim_top_alphaScheme/Makefile])

	AC_CONFIG_FILES([tests/unit_tests/Makefile])
	AC_CONFIG_FILES([tests/functional_tests/Makefile])
	AC_CONFIG_FILES([tests/ext_tests_mssm/Makefile])
	AC_CONFIG_FILES([tests/ext_tests_nmssm/Makefile])
	AC_CONFIG_FILES([tests/ext_tests_ilc/Makefile])
	AC_CONFIG_FILES([tests/ext_tests_shower/Makefile])
	AC_CONFIG_FILES([tests/ext_tests_nlo/Makefile])
	AC_CONFIG_FILES([tests/ext_tests_nlo_add/Makefile])

	AC_CONFIG_FILES([tests/unit_tests/run_whizard_ut.sh],
	[chmod u+x tests/unit_tests/run_whizard_ut.sh])
	AC_CONFIG_FILES([tests/unit_tests/run_whizard_ut_c.sh],
	[chmod u+x tests/unit_tests/run_whizard_ut_c.sh])
	AC_CONFIG_FILES([tests/unit_tests/run_whizard_ut_cc.sh],
	[chmod u+x tests/unit_tests/run_whizard_ut_cc.sh])
	AC_CONFIG_FILES([tests/functional_tests/run_whizard.sh],
	[chmod u+x tests/functional_tests/run_whizard.sh])
	AC_CONFIG_FILES([tests/ext_tests_mssm/run_whizard.sh],
	[chmod u+x tests/ext_tests_mssm/run_whizard.sh])
	AC_CONFIG_FILES([tests/ext_tests_nmssm/run_whizard.sh],
	[chmod u+x tests/ext_tests_nmssm/run_whizard.sh])
	AC_CONFIG_FILES([tests/ext_tests_ilc/run_whizard.sh],
	[chmod u+x tests/ext_tests_ilc/run_whizard.sh])
	AC_CONFIG_FILES([tests/ext_tests_shower/run_whizard.sh],
	[chmod u+x tests/ext_tests_shower/run_whizard.sh])
	AC_CONFIG_FILES([tests/ext_tests_nlo/run_whizard.sh],
	[chmod u+x tests/ext_tests_nlo/run_whizard.sh])
	AC_CONFIG_FILES([tests/ext_tests_nlo_add/run_whizard.sh],
	[chmod u+x tests/ext_tests_nlo_add/run_whizard.sh])

	###--------------------------------------------------------------------
	### Subdirectory scripts

	AC_CONFIG_FILES([scripts/Makefile])

	AC_CONFIG_FILES([scripts/whizard-config], [chmod u+x scripts/whizard-config])
	AC_CONFIG_FILES([scripts/whizard-setup.sh], [chmod u+x scripts/whizard-setup.sh])
	AC_CONFIG_FILES([scripts/whizard-setup.csh], [chmod u+x scripts/whizard-setup.csh])

	### ONLY_FULL }}}

	### ONLY_CIRCE1_AND_FULL {{{
	###--------------------------------------------------------------------
	### CIRCE1 subdirectory files

	AC_CONFIG_FILES([circe1/Makefile])
	AC_CONFIG_FILES([circe1/src/Makefile])
	AC_CONFIG_FILES([circe1/minuit/Makefile])
	AC_CONFIG_FILES([circe1/tools/Makefile])
	AC_CONFIG_FILES([circe1/share/Makefile])
	AC_CONFIG_FILES([circe1/share/data/Makefile])
	AC_CONFIG_FILES([circe1/share/doc/Makefile])

	### ONLY_CIRCE1_AND_FULL }}}

	### ONLY_CIRCE2_AND_FULL {{{
	###--------------------------------------------------------------------
	### CIRCE2 subdirectory files

	AC_CONFIG_FILES([circe2/Makefile])
	AC_CONFIG_FILES([circe2/src/Makefile])
	AC_CONFIG_FILES([circe2/share/Makefile])
	AC_CONFIG_FILES([circe2/share/doc/Makefile])
	AC_CONFIG_FILES([circe2/share/examples/Makefile])
	AC_CONFIG_FILES([circe2/share/data/Makefile])
	AC_CONFIG_FILES([circe2/share/tests/Makefile])
	AC_CONFIG_FILES([circe2/tests/Makefile])


	AC_CONFIG_FILES([circe2/tests/test_wrapper.sh], [chmod u+x circe2/tests/test_wrapper.sh])
	AC_CONFIG_FILES([circe2/tests/circe2_tool.sh], [chmod u+x circe2/tests/circe2_tool.sh])
	AC_CONFIG_FILES([circe2/tests/generate.sh], [chmod u+x circe2/tests/generate.sh])

	### ONLY_CIRCE2_AND_FULL }}}

	### ONLY_OMEGA_AND_FULL {{{
	###--------------------------------------------------------------------
	### OMEGA subdirectory files

	AC_CONFIG_FILES([omega/Makefile])
	AC_CONFIG_FILES([omega/bin/Makefile])
	AC_CONFIG_FILES([omega/lib/Makefile])
	AC_CONFIG_FILES([omega/models/Makefile])
	AC_CONFIG_FILES([omega/src/Makefile])
	AC_CONFIG_FILES([omega/share/Makefile])
	AC_CONFIG_FILES([omega/share/doc/Makefile])
	AC_CONFIG_FILES([omega/extensions/Makefile])
	AC_CONFIG_FILES([omega/extensions/people/Makefile])
	AC_CONFIG_FILES([omega/extensions/people/jr/Makefile])
	AC_CONFIG_FILES([omega/extensions/people/tho/Makefile])
	AC_CONFIG_FILES([omega/tests/Makefile])
	AC_CONFIG_FILES([omega/tests/UFO/Makefile])
	AC_CONFIG_FILES([omega/tests/UFO/SM/Makefile])
	AC_CONFIG_FILES([omega/tests/UFO/MSSM/Makefile])
	AC_CONFIG_FILES([omega/tests/UFO/SMEFTsim_top_alphaScheme/Makefile])
	AC_CONFIG_FILES([omega/tools/Makefile])
	AC_CONFIG_FILES([omega/scripts/Makefile])
	AC_CONFIG_FILES([omega/scripts/omega-config], [chmod u+x omega/scripts/omega-config])
	AC_CONFIG_FILES([omega/scripts/ufo-sanitizer], [chmod u+x omega/scripts/ufo-sanitizer])


	# Copy config.mli to the build directory (otherwise ocamlc and/or
	# ocamlopt would create one on their own).

	###--------------------------------------------------------------------
	AC_CONFIG_FILES([omega/src/config.ml])

	case "$srcdir" in
	.) ;;
	*) $MKDIR_P ./omega/src
	rm -f ./omega/src/config.mli
	cp $srcdir/omega/src/config.mli ./omega/src/config.mli 1>/dev/null 2>&1;;
	esac
	###--------------------------------------------------------------------

	### ONLY_OMEGA_AND_FULL }}}

	### ONLY_VAMP_AND_FULL {{{
	###--------------------------------------------------------------------
	### VAMP subdirectory files

	AC_CONFIG_FILES([vamp/Makefile])
	AC_CONFIG_FILES([vamp/src/Makefile])
	AC_CONFIG_FILES([vamp/share/Makefile])
	AC_CONFIG_FILES([vamp/share/doc/Makefile])
	AC_CONFIG_FILES([vamp/tests/Makefile])

	### ONLY_VAMP_AND_FULL }}}

	########################################################################
	###---------------------------------------------------------------------
	### Final output

	AC_OUTPUT()

	### ONLY_FULL {{{
	########################################################################
	###---------------------------------------------------------------------
	### Final output

	WO_SUMMARY()

	### ONLY_FULL }}}
	########################################################################
	Index: trunk/build_master.sh
	===================================================================
	--- trunk/build_master.sh (revision 8888)
	+++ trunk/build_master.sh (revision 8889)
	@@ -1,126 +1,126 @@
	#! /bin/sh
	# BUILD MASTER for WHIZARD (and enabling subpackages)
	########################################################################
	#
	# Copyright (C) 1999-2023 by
	# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	# Juergen Reuter <juergen.reuter@desy.de>
	# with contributions from
	# Christian Speckner <cnspeckn@googlemail.com>
	#
	# WHIZARD is free software; you can redistribute it and/or modify it
	# under the terms of the GNU General Public License as published by
	# the Free Software Foundation; either version 2, or (at your option)
	# any later version.
	#
	# WHIZARD is distributed in the hope that it will be useful, but
	# WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	# GNU General Public License for more details.
	#
	# You should have received a copy of the GNU General Public License
	# along with this program; if not, write to the Free Software
	# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	#
	########################################################################

	option=MASTER
	case "$1" in
	WHIZARD\|VAMP\|OMEGA\|CIRCE1\|CIRCE2) option=$1;;
	"") option="WHIZARD";;
	*) echo "Possible targets are: MASTER\|OMEGA\|VAMP\|CIRCE1\|CIRCE2"; exit 2
	esac

	echo "#################################################"
	echo "Deploying WHIZARD master package $option"
	echo "#################################################"

	remove_tags () {
	sed "/\#\#\# $1 {{{/,/$1 }}}/ { 1 { s/^.*//
	b
	}
	d
	}" $2 > $3
	}

	# Creating main configure.ac and Makefile.am for WHIZARD and subpackages

	case "$option" in
	WHIZARD)
	- sed -e "s/\#\#\#SUBDIRS\#\#\#/circe1 circe2 omega vamp mcfio stdhep tauola pythia6 src python share tests scripts/g" -e "/\#\#\# ONLY_FULL/d" Makefile.am.in > Makefile.am.tmp1
	+ sed -e "s/\#\#\#SUBDIRS\#\#\#/circe1 circe2 omega vamp contrib src python share tests scripts/g" -e "/\#\#\# ONLY_FULL/d" Makefile.am.in > Makefile.am.tmp1
	remove_tags ONLY_OMEGA Makefile.am.tmp1 Makefile.am.tmp2
	rm -f Makefile.am.tmp1
	mv -f Makefile.am.tmp2 Makefile.am
	sed -e "s/XXXWHIZARDXXX/WHIZARD/g" -e "/\#\#\# ONLY_/d" configure.ac.in > configure.ac.tmp
	mv -f configure.ac.tmp configure.ac;;
	CIRCE1)
	sed -e "s/\#\#\#SUBDIRS\#\#\#/circe1/g" Makefile.am.in > Makefile.am.tmp1
	remove_tags ONLY_OMEGA Makefile.am.tmp1 Makefile.am.tmp2
	rm -f Makefile.am.tmp1
	remove_tags ONLY_FULL Makefile.am.tmp2 Makefile.am.tmp3
	rm -f Makefile.am.tmp2
	mv -f Makefile.am.tmp3 Makefile.am
	sed -e "s/XXXWHIZARDXXX/WHIZARD_CIRCE1/g" -e "s/src\/basics\/kinds\.f90/circe1\/src\/kinds\.f90/g" -e "/\#\#\# ONLY_CIRCE1_AND_FULL/d" configure.ac.in > configure.ac.tmp1
	remove_tags ONLY_FULL configure.ac.tmp1 configure.ac.tmp2
	rm -f configure.ac.tmp1
	remove_tags ONLY_CIRCE2_AND_FULL configure.ac.tmp2 configure.ac.tmp3
	rm -f configure.ac.tmp2
	remove_tags ONLY_VAMP_AND_FULL configure.ac.tmp3 configure.ac.tmp4
	rm -f configure.ac.tmp3
	remove_tags ONLY_OMEGA_AND_FULL configure.ac.tmp4 configure.ac.tmp5
	rm -f configure.ac.tmp4
	mv -f configure.ac.tmp5 configure.ac;;
	CIRCE2)
	sed -e "s/\#\#\#SUBDIRS\#\#\#/circe2/g" Makefile.am.in > Makefile.am.tmp1
	remove_tags ONLY_OMEGA Makefile.am.tmp1 Makefile.am.tmp2
	rm -f Makefile.am.tmp1
	remove_tags ONLY_FULL Makefile.am.tmp2 Makefile.am.tmp3
	rm -f Makefile.am.tmp2
	mv -f Makefile.am.tmp3 Makefile.am
	sed -e "s/XXXWHIZARDXXX/WHIZARD_CIRCE2/g" -e "s/src\/basics\/kinds\.f90/circe2\/src\/kinds\.f90/g" -e "/\#\#\# ONLY_CIRCE2_AND_FULL/d" configure.ac.in > configure.ac.tmp1
	remove_tags ONLY_FULL configure.ac.tmp1 configure.ac.tmp2
	rm -f configure.ac.tmp1
	remove_tags ONLY_VAMP_AND_FULL configure.ac.tmp2 configure.ac.tmp3
	rm -f configure.ac.tmp2
	remove_tags ONLY_CIRCE1_AND_FULL configure.ac.tmp3 configure.ac.tmp4
	rm -f configure.ac.tmp3
	remove_tags ONLY_OMEGA_AND_FULL configure.ac.tmp4 configure.ac.tmp5
	rm -f configure.ac.tmp4
	mv -f configure.ac.tmp5 configure.ac;;
	OMEGA)
	sed -e "s/\#\#\#SUBDIRS\#\#\#/omega/g" -e "/\#\#\# ONLY_OMEGA/d" Makefile.am.in > Makefile.am.tmp1
	remove_tags ONLY_FULL Makefile.am.tmp1 Makefile.am.tmp2
	rm -f Makefile.am.tmp1
	mv -f Makefile.am.tmp2 Makefile.am
	sed -e "s/XXXWHIZARDXXX/WHIZARD_OMEGA/g" -e "s/src\/basics\/kinds\.f90/omega\/src\/kinds\.f90/g" -e "/\#\#\# ONLY_OMEGA_AND_FULL/d" configure.ac.in > configure.ac.tmp1
	remove_tags ONLY_FULL configure.ac.tmp1 configure.ac.tmp2
	rm -f configure.ac.tmp1
	remove_tags ONLY_VAMP_AND_FULL configure.ac.tmp2 configure.ac.tmp3
	rm -f configure.ac.tmp2
	remove_tags ONLY_CIRCE1_AND_FULL configure.ac.tmp3 configure.ac.tmp4
	rm -f configure.ac.tmp3
	remove_tags ONLY_CIRCE2_AND_FULL configure.ac.tmp4 configure.ac.tmp5
	rm -f configure.ac.tmp4
	mv -f configure.ac.tmp5 configure.ac;;
	VAMP)
	sed -e "s/\#\#\#SUBDIRS\#\#\#/vamp/g" Makefile.am.in > Makefile.am.tmp1
	remove_tags ONLY_OMEGA Makefile.am.tmp1 Makefile.am.tmp2
	rm -f Makefile.am.tmp1
	remove_tags ONLY_FULL Makefile.am.tmp2 Makefile.am.tmp3
	rm -f Makefile.am.tmp2
	mv -f Makefile.am.tmp3 Makefile.am
	sed -e "s/XXXWHIZARDXXX/WHIZARD_VAMP/g" -e "s/src\/basics\/kinds\.f90/vamp\/src\/kinds\.f90/g" configure.ac.in > configure.ac.tmp1
	remove_tags ONLY_FULL configure.ac.tmp1 configure.ac.tmp2
	rm -f configure.ac.tmp1
	remove_tags ONLY_CIRCE1_AND_FULL configure.ac.tmp2 configure.ac.tmp3
	rm -f configure.ac.tmp2
	remove_tags ONLY_CIRCE2_AND_FULL configure.ac.tmp3 configure.ac.tmp4
	rm -f configure.ac.tmp3
	remove_tags ONLY_OMEGA_AND_FULL configure.ac.tmp4 configure.ac.tmp5
	rm -f configure.ac.tmp4
	sed -e "/\#\#\# ONLY_VAMP_AND_FULL/d" configure.ac.tmp5 > configure.ac.tmp6
	rm -f configure.ac.tmp5
	mv -f configure.ac.tmp6 configure.ac;;
	esac

	Index: trunk/src/tauola/Makefile.am
	===================================================================
	--- trunk/src/tauola/Makefile.am (revision 8888)
	+++ trunk/src/tauola/Makefile.am (revision 8889)
	@@ -1,163 +1,163 @@
	## Makefile.am -- Makefile for WHIZARD
	##
	## Process this file with automake to produce Makefile.in
	#
	# Copyright (C) 1999-2023 by
	# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	# Juergen Reuter <juergen.reuter@desy.de>
	# with contributions from
	# cf. main AUTHORS file
	#
	# WHIZARD is free software; you can redistribute it and/or modify it
	# under the terms of the GNU General Public License as published by
	# the Free Software Foundation; either version 2, or (at your option)
	# any later version.
	#
	# WHIZARD is distributed in the hope that it will be useful, but
	# WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	# GNU General Public License for more details.
	#
	# You should have received a copy of the GNU General Public License
	# along with this program; if not, write to the Free Software
	# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	#
	########################################################################

	## The files in this directory end up in an auxiliary libtool library.
	noinst_LTLIBRARIES = libtauola_interface.la
	libtauola_interface_la_SOURCES = \
	$(TAUOLA_MODULES) \
	$(TAUOLA_SUBMODULES)

	TAUOLA_MODULES = \
	hepev4_aux.f90 \
	tauola_interface.f90

	TAUOLA_SUBMODULES = \
	tauola_interface_sub.f90

	# Modules and installation
	# Dump module names into file Modules
	execmoddir = $(fmoddir)/whizard
	nodist_execmod_HEADERS = \
	${TAUOLA_MODULES:.f90=.$(FCMOD)}

	libtauola_interface_Modules = ${TAUOLA_MODULES:.f90=}
	Modules: Makefile
	@for module in $(libtauola_interface_Modules); do \
	echo $$module >> $@.new; \
	done
	@if diff $@ $@.new -q >/dev/null; then \
	rm $@.new; \
	else \
	mv $@.new $@; echo "Modules updated"; \
	fi
	BUILT_SOURCES = Modules

	## Fortran module dependencies
	# Get module lists from other directories
	module_lists = \
	../basics/Modules \
	../utilities/Modules \
	../system/Modules \
	../variables/Modules \
	../qft/Modules \
	../events/Modules

	$(module_lists):
	$(MAKE) -C `dirname $@` Modules

	Module_dependencies.sed: $(libtauola_interface_la_SOURCES)
	Module_dependencies.sed: $(module_lists)
	@rm -f $@
	echo 's/, only:.//' >> $@
	echo 's/, *&//' >> $@
	echo 's/, .=>.*//' >> $@
	echo 's/$$/.lo/' >> $@
	for list in $(module_lists); do \
	dir="`dirname $$list`"; \
	for mod in `cat $$list`; do \
	echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
	done \
	done

	DISTCLEANFILES = Module_dependencies.sed

	# The following line just says
	# include Makefile.depend
	# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
	@am__include@ @am__quote@Makefile.depend@am__quote@

	Makefile.depend: Module_dependencies.sed
	Makefile.depend: $(libtauola_interface_la_SOURCES)
	@rm -f $@
	for src in $^; do \
	module="`basename $$src \| sed 's/\.f[90][0358]//'`"; \
	grep '^ *use ' $$src \
	\| grep -v '!NODEP!' \
	\| sed -e 's/^ use /'$$module'.lo: /' \
	-f Module_dependencies.sed; \
	done > $@

	DISTCLEANFILES += Makefile.depend

	SUFFIXES = .lo .$(FCMOD)
	# Fortran90 module files are generated at the same time as object files
	.lo.$(FCMOD):
	@:
	# touch $@

	if PYTHIA6_AVAILABLE
	-libtauola_interface_la_LIBADD = ../../pythia6/libpythia6_wo.la ../../tauola/libtauola_wo.la
	+libtauola_interface_la_LIBADD = ../../contrib/pythia6/libpythia6_wo.la ../../contrib/tauola/libtauola_wo.la
	else
	-libtauola_interface_la_LIBADD = ../../pythia6/libpythia6_wo_dummy.la ../../tauola/libtauola_wo_dummy.la
	+libtauola_interface_la_LIBADD = ../../contrib/pythia6/libpythia6_wo_dummy.la ../../contrib/tauola/libtauola_wo_dummy.la
	endif

	AM_FCFLAGS =

	########################################################################
	# For the moment, the submodule dependencies will be hard-coded
	tauola_interface_sub.lo: tauola_interface.lo

	########################################################################
	## Default Fortran compiler options

	## Profiling
	if FC_USE_PROFILING
	AM_FCFLAGS += $(FCFLAGS_PROFILING)
	endif

	## OpenMP
	if FC_USE_OPENMP
	AM_FCFLAGS += $(FCFLAGS_OPENMP)
	endif

	## MPI
	if FC_USE_MPI
	AM_FCFLAGS += $(FCFLAGS_MPI)
	endif

	########################################################################
	## Explicit dependencies

	AM_FCFLAGS += -I../basics -I../utilities -I../system -I../expr_base -I../combinatorics -I../parsing -I../physics -I../qft -I../types -I../fastjet -I../particles -I../events -I../variables

	MODULES= \
	tauola_interface.$(FCMOD) \
	hepev4_aux.$(FCMOD)

	########################################################################
	## Non-standard cleanup tasks

	## Remove backup files
	maintainer-clean-local:
	-rm -f *~

	## Remove module files
	clean-local:
	-rm -f $(MODULES)
	if FC_SUBMODULES
	-rm -f .smod .sub
	endif
	Index: trunk/src/shower/Makefile.am
	===================================================================
	--- trunk/src/shower/Makefile.am (revision 8888)
	+++ trunk/src/shower/Makefile.am (revision 8889)
	@@ -1,239 +1,239 @@
	## Makefile.am -- Makefile for WHIZARD
	##
	## Process this file with automake to produce Makefile.in
	#
	# Copyright (C) 1999-2023 by
	# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	# Juergen Reuter <juergen.reuter@desy.de>
	# with contributions from
	# cf. main AUTHORS file
	#
	# WHIZARD is free software; you can redistribute it and/or modify it
	# under the terms of the GNU General Public License as published by
	# the Free Software Foundation; either version 2, or (at your option)
	# any later version.
	#
	# WHIZARD is distributed in the hope that it will be useful, but
	# WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	# GNU General Public License for more details.
	#
	# You should have received a copy of the GNU General Public License
	# along with this program; if not, write to the Free Software
	# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	#
	########################################################################

	## The files in this directory make up the shower routines

	noinst_LTLIBRARIES = libshower.la
	check_LTLIBRARIES = libshower_ut.la

	libshower_la_SOURCES = \
	$(SHOWER_MODULES) \
	$(SHOWER_SUBMODULES)

	SHOWER_MODULES = \
	pythia6_up.f \
	ktclus.f90 \
	shower_base.f90 \
	shower_partons.f90 \
	shower_core.f90 \
	shower_pythia6.f90 \
	shower_pythia8.f90

	SHOWER_SUBMODULES = \
	shower_base_sub.f90 \
	shower_partons_sub.f90 \
	shower_core_sub.f90 \
	shower_pythia6_sub.f90 \
	shower_pythia8_sub.f90

	libshower_ut_la_SOURCES = \
	shower_base_uti.f90 shower_base_ut.f90

	## Omitting this would exclude it from the distribution
	dist_noinst_DATA = shower.nw

	# Modules and installation
	# Dump module names into file Modules
	execmoddir = $(fmoddir)/whizard
	nodist_execmod_HEADERS = \
	ktclus.$(FCMOD) \
	shower_base.$(FCMOD) \
	shower_core.$(FCMOD) \
	shower_partons.$(FCMOD) \
	shower_pythia6.$(FCMOD) \
	shower_pythia8.$(FCMOD)

	libshower_Modules = ${SHOWER_MODULES:.f90=} ${libshower_ut_la_SOURCES:.f90=}
	Modules: Makefile
	@for module in $(libshower_Modules); do \
	echo $$module >> $@.new; \
	done
	@if diff $@ $@.new -q >/dev/null; then \
	rm $@.new; \
	else \
	mv $@.new $@; echo "Modules updated"; \
	fi
	BUILT_SOURCES = Modules

	## Fortran module dependencies
	# Get module lists from other directories
	module_lists = \
	../basics/Modules \
	../utilities/Modules \
	../testing/Modules \
	../system/Modules \
	../combinatorics/Modules \
	../parsing/Modules \
	../rng/Modules \
	../physics/Modules \
	../qft/Modules \
	../expr_base/Modules \
	../particles/Modules \
	../types/Modules \
	../variables/Modules \
	../model_features/Modules \
	../muli/Modules \
	../events/Modules \
	../beams/Modules \
	../tauola/Modules \
	../pythia8/Modules

	include_modules_bare = ${module_lists:/Modules=}
	include_modules = ${include_modules_bare:../%=-I../%}

	$(module_lists):
	$(MAKE) -C `dirname $@` Modules

	Module_dependencies.sed: $(libshower_la_SOURCES) $(libshower_ut_la_SOURCES)
	Module_dependencies.sed: $(module_lists)
	@rm -f $@
	echo 's/, only:.//' >> $@
	echo 's/, *&//' >> $@
	echo 's/, .=>.*//' >> $@
	echo 's/$$/.lo/' >> $@
	for list in $(module_lists); do \
	dir="`dirname $$list`"; \
	for mod in `cat $$list`; do \
	echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
	done \
	done

	DISTCLEANFILES = Module_dependencies.sed

	# The following line just says
	# include Makefile.depend
	# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
	@am__include@ @am__quote@Makefile.depend@am__quote@

	Makefile.depend: Module_dependencies.sed
	Makefile.depend: $(libshower_la_SOURCES) $(libshower_ut_la_SOURCES)
	@rm -f $@
	for src in $^; do \
	module="`basename $$src \| sed 's/\.f[90][0358]//'`"; \
	grep '^ *use ' $$src \
	\| grep -v '!NODEP!' \
	\| sed -e 's/^ use /'$$module'.lo: /' \
	-f Module_dependencies.sed; \
	done > $@

	DISTCLEANFILES += Makefile.depend

	# Fortran90 module files are generated at the same time as object files
	.lo.$(FCMOD):
	@:
	# touch $@

	-AM_FCFLAGS = $(include_modules) -I../../vamp/src -I../fastjet -I../lhapdf -I ../pdf_builtin -I../tauola -I../../pythia6 -I../pythia8
	+AM_FCFLAGS = $(include_modules) -I../../vamp/src -I../fastjet -I../lhapdf -I ../pdf_builtin -I../tauola -I../../contrib/pythia6 -I../pythia8
	AM_FFLAGS =

	########################################################################
	# For the moment, the submodule dependencies will be hard-coded
	shower_base_sub.lo: shower_base.lo
	shower_partons_sub.lo: shower_partons.lo
	shower_core_sub.lo: shower_core.lo
	shower_pythia6_sub.lo: shower_pythia6.lo
	shower_pythia8_sub.lo: shower_pythia8.lo

	########################################################################
	## Default Fortran compiler options

	## Profiling
	if FC_USE_PROFILING
	AM_FFLAGS += $(FCFLAGS_PROFILING)
	AM_FCFLAGS += $(FCFLAGS_PROFILING)
	endif

	## OpenMP
	if FC_USE_OPENMP
	AM_FFLAGS += $(FCFLAGS_OPENMP)
	AM_FCFLAGS += $(FCFLAGS_OPENMP)
	endif

	## MPI
	if FC_USE_MPI
	AM_FFLAGS += $(FCFLAGS_MPI)
	AM_FCFLAGS += $(FCFLAGS_MPI)
	endif

	########################################################################
	## Non-standard targets and dependencies

	## (Re)create F90 sources from NOWEB source.

	if NOWEB_AVAILABLE

	PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
	POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw

	shower.stamp: $(PRELUDE) $(srcdir)/shower.nw $(POSTLUDE)
	@rm -f shower.tmp
	@touch shower.tmp
	for src in $(libshower_la_SOURCES) $(libshower_ut_la_SOURCES); do \
	$(NOTANGLE) -R[[$$src]] $^ \| $(CPIF) $$src; \
	done
	@mv -f shower.tmp shower.stamp

	$(libshower_la_SOURCES) $(libshower_ut_la_SOURCES): shower.stamp
	## Recover from the removal of $@
	@if test -f $@; then :; else \
	rm -f shower.stamp; \
	$(MAKE) $(AM_MAKEFLAGS) shower.stamp; \
	fi

	endif

	########################################################################
	## Non-standard cleanup tasks
	## Remove sources that can be recreated using NOWEB
	if NOWEB_AVAILABLE
	maintainer-clean-noweb:
	-rm -f .f90 .f
	endif
	.PHONY: maintainer-clean-noweb

	## Remove those sources also if builddir and srcdir are different
	if NOWEB_AVAILABLE
	clean-noweb:
	test "$(srcdir)" != "." && rm -f .f90 .f \|\| true
	endif
	.PHONY: clean-noweb

	## Remove F90 module files
	clean-local: clean-noweb
	-rm -f shower.stamp shower.tmp
	-rm -f *.$(FCMOD)
	if FC_SUBMODULES
	-rm -f .smod .sub
	endif

	## Remove backup files
	maintainer-clean-backup:
	-rm -f *~
	.PHONY: maintainer-clean-backup

	## Register additional clean targets
	maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
	Index: trunk/src/events/Makefile.am
	===================================================================
	--- trunk/src/events/Makefile.am (revision 8888)
	+++ trunk/src/events/Makefile.am (revision 8889)
	@@ -1,275 +1,275 @@
	## Makefile.am -- Makefile for WHIZARD
	##
	## Process this file with automake to produce Makefile.in
	#
	# Copyright (C) 1999-2023 by
	# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	# Juergen Reuter <juergen.reuter@desy.de>
	# with contributions from
	# cf. main AUTHORS file
	#
	# WHIZARD is free software; you can redistribute it and/or modify it
	# under the terms of the GNU General Public License as published by
	# the Free Software Foundation; either version 2, or (at your option)
	# any later version.
	#
	# WHIZARD is distributed in the hope that it will be useful, but
	# WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	# GNU General Public License for more details.
	#
	# You should have received a copy of the GNU General Public License
	# along with this program; if not, write to the Free Software
	# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	#
	########################################################################

	## The files in this directory implement quantum field theory concepts
	## such as model representation and quantum numbers.

	## We create a library which is still to be combined with auxiliary libs.
	noinst_LTLIBRARIES = libevents.la
	check_LTLIBRARIES = libevents_ut.la

	libevents_la_SOURCES = \
	$(EVENTS_MODULES) \
	$(EVENTS_SUBMODULES)

	EVENTS_MODULES = \
	event_base.f90 \
	event_handles.f90 \
	eio_data.f90 \
	eio_base.f90 \
	eio_direct.f90 \
	eio_checkpoints.f90 \
	eio_callback.f90 \
	eio_weights.f90 \
	eio_dump.f90 \
	hep_common.f90 \
	hepmc_interface.f90 \
	lcio_interface.f90 \
	hep_events.f90 \
	eio_ascii.f90 \
	eio_lhef.f90 \
	eio_stdhep.f90 \
	eio_hepmc.f90 \
	eio_lcio.f90

	EVENTS_SUBMODULES = \
	event_base_sub.f90 \
	eio_data_sub.f90 \
	eio_base_sub.f90 \
	eio_direct_sub.f90 \
	eio_checkpoints_sub.f90 \
	eio_callback_sub.f90 \
	eio_weights_sub.f90 \
	eio_dump_sub.f90 \
	hep_common_sub.f90 \
	hepmc_interface_sub.f90 \
	lcio_interface_sub.f90 \
	hep_events_sub.f90 \
	eio_ascii_sub.f90 \
	eio_lhef_sub.f90 \
	eio_stdhep_sub.f90 \
	eio_hepmc_sub.f90 \
	eio_lcio_sub.f90

	libevents_ut_la_SOURCES = \
	eio_data_uti.f90 eio_data_ut.f90 \
	eio_base_uti.f90 eio_base_ut.f90 \
	eio_direct_uti.f90 eio_direct_ut.f90 \
	eio_checkpoints_uti.f90 eio_checkpoints_ut.f90 \
	eio_weights_uti.f90 eio_weights_ut.f90 \
	eio_dump_uti.f90 eio_dump_ut.f90 \
	hepmc_interface_uti.f90 hepmc_interface_ut.f90 \
	lcio_interface_uti.f90 lcio_interface_ut.f90 \
	hep_events_uti.f90 hep_events_ut.f90 \
	eio_ascii_uti.f90 eio_ascii_ut.f90 \
	eio_lhef_uti.f90 eio_lhef_ut.f90 \
	eio_stdhep_uti.f90 eio_stdhep_ut.f90 \
	eio_hepmc_uti.f90 eio_hepmc_ut.f90 \
	eio_lcio_uti.f90 eio_lcio_ut.f90

	## Omitting this would exclude it from the distribution
	dist_noinst_DATA = events.nw

	# Modules and installation
	# Dump module names into file Modules
	execmoddir = $(fmoddir)/whizard
	nodist_execmod_HEADERS = \
	${EVENTS_MODULES:.f90=.$(FCMOD)}

	# Dump module names into file Modules
	libevents_Modules = \
	${EVENTS_MODULES:.f90=} \
	${libevents_ut_la_SOURCES:.f90=}
	Modules: Makefile
	@for module in $(libevents_Modules); do \
	echo $$module >> $@.new; \
	done
	@if diff $@ $@.new -q >/dev/null; then \
	rm $@.new; \
	else \
	mv $@.new $@; echo "Modules updated"; \
	fi
	BUILT_SOURCES = Modules

	## Fortran module dependencies
	# Get module lists from other directories
	module_lists = \
	../basics/Modules \
	../utilities/Modules \
	../testing/Modules \
	../system/Modules \
	../parsing/Modules \
	../physics/Modules \
	../qft/Modules \
	../types/Modules \
	../particles/Modules \
	../xdr/Modules

	$(module_lists):
	$(MAKE) -C `dirname $@` Modules

	Module_dependencies.sed: $(libevents_la_SOURCES) $(libevents_ut_la_SOURCES)
	Module_dependencies.sed: $(module_lists)
	@rm -f $@
	echo 's/, only:.//' >> $@
	echo 's/, *&//' >> $@
	echo 's/, .=>.*//' >> $@
	echo 's/$$/.lo/' >> $@
	for list in $(module_lists); do \
	dir="`dirname $$list`"; \
	for mod in `cat $$list`; do \
	echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
	done \
	done

	DISTCLEANFILES = Module_dependencies.sed

	# The following line just says
	# include Makefile.depend
	# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
	@am__include@ @am__quote@Makefile.depend@am__quote@

	Makefile.depend: Module_dependencies.sed
	Makefile.depend: $(libevents_la_SOURCES) $(libevents_ut_la_SOURCES)
	@rm -f $@
	for src in $^; do \
	module="`basename $$src \| sed 's/\.f[90][0358]//'`"; \
	grep '^ *use ' $$src \
	\| grep -v '!NODEP!' \
	\| sed -e 's/^ use /'$$module'.lo: /' \
	-f Module_dependencies.sed; \
	done > $@

	DISTCLEANFILES += Makefile.depend

	libevents_la_LIBADD = \
	- ../../mcfio/libwo_mcfio.la \
	- ../../stdhep/libwo_stdhep.la
	+ ../../contrib/mcfio/libwo_mcfio.la \
	+ ../../contrib/stdhep/libwo_stdhep.la

	# Fortran90 module files are generated at the same time as object files
	.lo.$(FCMOD):
	@:
	# touch $@

	AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../parsing -I../physics -I../qft -I../expr_base -I../types -I../fastjet -I../particles -I../xdr

	########################################################################
	# For the moment, the submodule dependencies will be hard-coded
	event_base_sub.lo: event_base.lo
	eio_data_sub.lo: eio_data.lo
	eio_base_sub.lo: eio_base.lo
	eio_direct_sub.lo: eio_direct.lo
	eio_checkpoints_sub.lo: eio_checkpoints.lo
	eio_callback_sub.lo: eio_callback.lo
	eio_weights_sub.lo: eio_weights.lo
	eio_dump_sub.lo: eio_dump.lo
	hep_common_sub.lo: hep_common.lo
	hepmc_interface_sub.lo: hepmc_interface.lo
	lcio_interface_sub.lo: lcio_interface.lo
	hep_events_sub.lo: hep_events.lo
	eio_ascii_sub.lo: eio_ascii.lo
	eio_lhef_sub.lo: eio_lhef.lo
	eio_stdhep_sub.lo: eio_stdhep.lo
	eio_hepmc_sub.lo: eio_hepmc.lo
	eio_lcio_sub.lo: eio_lcio.lo

	########################################################################
	## Default Fortran compiler options

	## Profiling
	if FC_USE_PROFILING
	AM_FCFLAGS += $(FCFLAGS_PROFILING)
	endif

	## OpenMP
	if FC_USE_OPENMP
	AM_FCFLAGS += $(FCFLAGS_OPENMP)
	endif

	# MPI
	if FC_USE_MPI
	AM_FCFLAGS += $(FCFLAGS_MPI)
	endif

	########################################################################
	## Non-standard targets and dependencies

	## (Re)create F90 sources from NOWEB source.
	if NOWEB_AVAILABLE

	PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
	POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw

	events.stamp: $(PRELUDE) $(srcdir)/events.nw $(POSTLUDE)
	@rm -f events.tmp
	@touch events.tmp
	for src in $(libevents_la_SOURCES) $(libevents_ut_la_SOURCES); do \
	$(NOTANGLE) -R[[$$src]] $^ \| $(CPIF) $$src; \
	done
	@mv -f events.tmp events.stamp

	$(libevents_la_SOURCES) $(libevents_ut_la_SOURCES): events.stamp
	## Recover from the removal of $@
	@if test -f $@; then :; else \
	rm -f events.stamp; \
	$(MAKE) $(AM_MAKEFLAGS) events.stamp; \
	fi

	endif


	########################################################################
	## Non-standard cleanup tasks
	## Remove sources that can be recreated using NOWEB
	if NOWEB_AVAILABLE
	maintainer-clean-noweb:
	-rm -f .f90 .c
	endif
	.PHONY: maintainer-clean-noweb

	## Remove those sources also if builddir and srcdir are different
	if NOWEB_AVAILABLE
	clean-noweb:
	test "$(srcdir)" != "." && rm -f .f90 .c \|\| true
	endif
	.PHONY: clean-noweb

	## Remove F90 module files
	clean-local: clean-noweb
	-rm -f events.stamp events.tmp
	-rm -f *.$(FCMOD)
	if FC_SUBMODULES
	-rm -f .smod .sub
	endif

	## Remove backup files
	maintainer-clean-backup:
	-rm -f *~
	.PHONY: maintainer-clean-backup

	## Register additional clean targets
	maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
	Index: trunk/synchronize.sh
	===================================================================
	--- trunk/synchronize.sh (revision 8888)
	+++ trunk/synchronize.sh (revision 8889)
	@@ -1,60 +1,60 @@
	#!/bin/sh
	### Consider it safer to explicitly mention all files that contain
	### email addresses or copyright tags.

	OLD_YEAR="Copyright (C) 1999-2022";
	NEW_YEAR="Copyright (C) 1999-2023";
	OLD_YEAR2="Copyright (C) 2001-2022";
	NEW_YEAR2="Copyright (C) 2001-2023";
	OLD_YEAR3="Copyright (C) 2019-2022";
	NEW_YEAR3="Copyright (C) 2019-2023";
	# OLD_ADDRESS="Soyoung Shim <soyoung.shim@desy.de>"
	# NEW_ADDRESS="So Young Shim <soyoung.shim@desy.de>"
	OLD_ADDRESS="Soyoung Shim"
	NEW_ADDRESS="So Young Shim"

	OLD_DATE="Mar 10 2023"
	NEW_DATE="Mar 21 2023"
	OLD_VERSION="3.1.2"
	NEW_VERSION="3.1.2.1"
	#OLD_STATUS="PACKAGE_STATUS=\"alpha\""
	#NEW_STATUS="PACKAGE_STATUS=\"beta\""
	OLD_STATUS="PACKAGE_STATUS=\"release\""
	#NEW_STATUS="PACKAGE_STATUS=\"rc1\""
	NEW_STATUS="PACKAGE_STATUS=\"alpha\""

	## We should add an option to add an author here.

	## share/doc/manual.tex should be changed manually
	## We have to discuss the entries in gamelan/manual
	## We have to discuss the entries in src/shower

	MAIN_FILES="AUTHORS BUGS Makefile.am.in README build_master.sh tests/Makefile.am tests/models/Makefile.am tests/models/UFO/Makefile.am tests/models/UFO/SM/Makefile.am tests/models/UFO/MSSM/Makefile.am tests/functional_tests/Makefile.am tests/ext_tests_mssm/Makefile.am tests/ext_tests_nmssm/Makefile.am tests/ext_tests_ilc/Makefile.am tests/ext_tests_nlo/Makefile.am tests/ext_tests_nlo_add/Makefile.am tests/ext_tests_shower/Makefile.am tests/unit_tests/Makefile.am"
	CONFIGURE_FILES="configure.ac.in src/noweb-frame/whizard-prelude.nw"
	VERSION_FILES="NEWS circe2/src/circe2.nw"
	SCRIPTS_FILES="scripts/Makefile.am scripts/whizard-config.in scripts/whizard-setup.csh.in scripts/whizard-setup.sh.in"
	SHARE_FILES="share/Makefile.am share/doc/Makefile.am share/doc/custom.hva share/examples/NLO_eettbar_GoSam.sin share/examples/NLO_eettbar_OpenLoops.sin share/examples/HERA_DIS.sin share/examples/LEP_cc10.sin share/examples/LEP_higgs.sin share/examples/W-endpoint.sin share/examples/Z-lineshape.sin share/examples/Zprime.sin share/examples/casc_dec.sin share/examples/circe1.sin share/examples/eeww_polarized.sin share/examples/DrellYanMatchingP.sin share/examples/DrellYanMatchingW.sin share/examples/DrellYanNoMatchingP.sin share/examples/DrellYanNoMatchingW.sin share/examples/EEMatching2P.sin share/examples/EEMatching2W.sin share/examples/EEMatching3P.sin share/examples/EEMatching3W.sin share/examples/EEMatching4P.sin share/examples/EEMatching4W.sin share/examples/EEMatching5P.sin share/examples/EEMatching5W.sin share/examples/EENoMatchingP.sin share/examples/EENoMatchingW.sin share/examples/LHC_VBS_likesign.sin share/tests/Makefile.am"
	-SRC_FILES="src/Makefile.am src/feynmf/Makefile.am src/hepmc/Makefile.am src/hepmc/HepMCWrap_dummy.f90 src/lcio/Makefile.am src/lcio/LCIOWrap_dummy.f90 src/tauola/Makefile.am src/lhapdf/Makefile.am src/lhapdf/lhapdf.f90 src/lhapdf5/Makefile.am src/pdf_builtin/Makefile.am src/pdf_builtin/pdf_builtin.f90 src/pdf_builtin/pdf_builtin_sub.f90 src/qed_pdf/Makefile.am src/qed_pdf/qed_pdf.nw src/fastjet/Makefile.am src/fastjet/cpp_strings.f90 src/fastjet/cpp_strings_sub.f90 src/fastjet/fastjet.f90 src/fastjet/Makefile.am src/hoppet/Makefile.am src/hoppet/hoppet.f90 pythia6/Makefile.am tauola/Makefile.am mcfio/Makefile.am stdhep/Makefile.am src/noweb-frame/Makefile.am src/noweb-frame/whizard-prelude.nw src/noweb-frame/whizard-postlude.nw src/utilities/Makefile.am src/matrix_elements/Makefile.am src/matrix_elements/matrix_elements.nw src/mci/Makefile.am src/vegas/Makefile.am src/vegas/vegas.nw src/mci/mci.nw src/utilities/utilities.nw src/testing/Makefile.am src/testing/testing.nw src/system/Makefile.am src/system/system.nw src/system/system_dependencies.f90.in src/system/debug_master.f90.in src/combinatorics/Makefile.am src/combinatorics/combinatorics.nw src/parsing/Makefile.am src/parsing/parsing.nw src/particles/Makefile.am src/particles/particles.nw src/phase_space/Makefile.am src/phase_space/phase_space.nw src/physics/Makefile.am src/physics/physics.nw src/beams/Makefile.am src/beams/beams.nw src/qft/Makefile.am src/qft/qft.nw src/rng/Makefile.am src/rng/rng.nw src/types/Makefile.am src/types/types.nw src/whizard-core/Makefile.am src/whizard-core/whizard.nw src/pythia8/Makefile.am src/shower/Makefile.am src/shower/shower.nw src/muli/Makefile.am src/muli/muli.nw src/model_features/model_features.nw src/model_features/Makefile.am src/me_methods/Makefile.am src/me_methods/me_methods.nw src/gosam/Makefile.am src/gosam/gosam.nw src/fks/Makefile.am src/fks/fks.nw src/expr_base/Makefile.am src/expr_base/expr_base.nw src/events/Makefile.am src/events/events.nw src/blha/Makefile.am src/blha/blha.nw src/variables/Makefile.am src/variables/variables.nw src/xdr/Makefile.am src/xdr/xdr_wo_stdhep.f90 src/looptools/Makefile.am src/process_integration/Makefile.am src/process_integration/process_integration.nw src/matching/Makefile.am src/matching/matching.nw src/openloops/Makefile.am src/openloops/openloops.nw src/recola/Makefile.am src/recola/recola.nw src/transforms/Makefile.am src/transforms/transforms.nw src/threshold/Makefile.am src/threshold/threshold.nw src/api/Makefile.am src/api/api.nw src/main/Makefile.am src/main/main.nw"
	+SRC_FILES="src/Makefile.am src/feynmf/Makefile.am src/hepmc/Makefile.am src/hepmc/HepMCWrap_dummy.f90 src/lcio/Makefile.am src/lcio/LCIOWrap_dummy.f90 src/tauola/Makefile.am src/lhapdf/Makefile.am src/lhapdf/lhapdf.f90 src/lhapdf5/Makefile.am src/pdf_builtin/Makefile.am src/pdf_builtin/pdf_builtin.f90 src/pdf_builtin/pdf_builtin_sub.f90 src/qed_pdf/Makefile.am src/qed_pdf/qed_pdf.nw src/fastjet/Makefile.am src/fastjet/cpp_strings.f90 src/fastjet/cpp_strings_sub.f90 src/fastjet/fastjet.f90 src/fastjet/Makefile.am src/hoppet/Makefile.am src/hoppet/hoppet.f90 contrib/Makefile.am contrib/pythia6/Makefile.am contrib/tauola/Makefile.am contrib/mcfio/Makefile.am contrib/stdhep/Makefile.am src/noweb-frame/Makefile.am src/noweb-frame/whizard-prelude.nw src/noweb-frame/whizard-postlude.nw src/utilities/Makefile.am src/matrix_elements/Makefile.am src/matrix_elements/matrix_elements.nw src/mci/Makefile.am src/vegas/Makefile.am src/vegas/vegas.nw src/mci/mci.nw src/utilities/utilities.nw src/testing/Makefile.am src/testing/testing.nw src/system/Makefile.am src/system/system.nw src/system/system_dependencies.f90.in src/system/debug_master.f90.in src/combinatorics/Makefile.am src/combinatorics/combinatorics.nw src/parsing/Makefile.am src/parsing/parsing.nw src/particles/Makefile.am src/particles/particles.nw src/phase_space/Makefile.am src/phase_space/phase_space.nw src/physics/Makefile.am src/physics/physics.nw src/beams/Makefile.am src/beams/beams.nw src/qft/Makefile.am src/qft/qft.nw src/rng/Makefile.am src/rng/rng.nw src/types/Makefile.am src/types/types.nw src/whizard-core/Makefile.am src/whizard-core/whizard.nw src/pythia8/Makefile.am src/shower/Makefile.am src/shower/shower.nw src/muli/Makefile.am src/muli/muli.nw src/model_features/model_features.nw src/model_features/Makefile.am src/me_methods/Makefile.am src/me_methods/me_methods.nw src/gosam/Makefile.am src/gosam/gosam.nw src/fks/Makefile.am src/fks/fks.nw src/expr_base/Makefile.am src/expr_base/expr_base.nw src/events/Makefile.am src/events/events.nw src/blha/Makefile.am src/blha/blha.nw src/variables/Makefile.am src/variables/variables.nw src/xdr/Makefile.am src/xdr/xdr_wo_stdhep.f90 src/looptools/Makefile.am src/process_integration/Makefile.am src/process_integration/process_integration.nw src/matching/Makefile.am src/matching/matching.nw src/openloops/Makefile.am src/openloops/openloops.nw src/recola/Makefile.am src/recola/recola.nw src/transforms/Makefile.am src/transforms/transforms.nw src/threshold/Makefile.am src/threshold/threshold.nw src/api/Makefile.am src/api/api.nw src/main/Makefile.am src/main/main.nw"
	CIRCE1_FILES="circe1/Makefile.am circe1/share/Makefile.am circe1/share/doc/Makefile.am circe1/src/Makefile.am circe1/src/circe1.nw circe1/minuit/Makefile.am circe1/src/minuit.nw circe1/tools/Makefile.am"
	CIRCE2_FILES="circe2/Makefile.am circe2/share/Makefile.am circe2/share/doc/Makefile.am circe2/src/Makefile.am circe2/src/Makefile.ocaml circe2/src/circe2.nw circe2/src/Makefile.sources circe2/src/postlude.nw circe2/tests/Makefile.am circe2/src/circe2_tool.ml circe2/src/commands.ml circe2/src/commands.mli circe2/src/diffmap.ml circe2/src/diffmap.mli circe2/src/diffmaps.ml circe2/src/diffmaps.mli circe2/src/division.ml circe2/src/division.mli circe2/src/events.ml circe2/src/events.mli circe2/src/filter.ml circe2/src/filter.mli circe2/src/float.ml circe2/src/float.mli circe2/src/grid.ml circe2/src/grid.mli circe2/src/histogram.mli circe2/src/histogram.ml circe2/src/syntax.ml circe2/src/syntax.mli circe2/src/thoArray.ml circe2/src/thoArray.mli circe2/src/thoMatrix.ml circe2/src/thoMatrix.mli circe2/src/bigarray_module.ml circe2/src/bigarray_library.ml circe2/src/bigarray_compat.mli"
	SRC_GAMELAN_FILES="src/gamelan/Makefile.am src/gamelan/whizard-gml.in"
	SRC_BASICS_FILES="src/basics/constants.f90 src/basics/io_units.f90 src/basics/Makefile.am"
	SRC_MODELS_FILES="src/models/threeshl_bundle/Makefile.am src/models/threeshl_bundle/threeshl_bundle.f90 src/models/threeshl_bundle/threeshl_bundle_lt.f90 src/models/external.Test.f90 src/models/external.Threeshl.f90 src/models/external.SM_tt_threshold.f90 src/models/Makefile.am src/models/parameters.THDM.f90 src/models/parameters.GravTest.f90 src/models/parameters.Littlest.f90 src/models/parameters.Littlest_Eta.f90 src/models/parameters.Littlest_Tpar.f90 src/models/parameters.MSSM.f90 src/models/parameters.MSSM_4.f90 src/models/parameters.MSSM_CKM.f90 src/models/parameters.MSSM_Grav.f90 src/models/parameters.MSSM_Hgg.f90 src/models/parameters.NMSSM.f90 src/models/parameters.NMSSM_CKM.f90 src/models/parameters.NMSSM_Hgg.f90 src/models/parameters.PSSSM.f90 src/models/parameters.QCD.f90 src/models/parameters.QED.f90 src/models/parameters.SM.f90 src/models/parameters.SM_CKM.f90 src/models/parameters.SM_ac.f90 src/models/parameters.SM_ac_CKM.f90 src/models/parameters.SM_dim6.f90 src/models/parameters.SM_rx.f90 src/models/parameters.SM_ul.f90 src/models/parameters.NoH_rx.f90 src/models/parameters.AltH.f90 src/models/parameters.SSC.f90 src/models/parameters.SSC_2.f90 src/models/parameters.SSC_AltT.f90 src/models/parameters.SM_top.f90 src/models/parameters.SM_top_anom.f90 src/models/parameters.SM_Higgs.f90 src/models/parameters.SM_Higgs_CKM.f90 src/models/parameters.SM_tt_threshold.f90 src/models/parameters.Simplest.f90 src/models/parameters.Simplest_univ.f90 src/models/parameters.Template.f90 src/models/parameters.HSExt.f90 src/models/parameters.Test.f90 src/models/parameters.Threeshl.f90 src/models/parameters.UED.f90 src/models/parameters.Xdim.f90 src/models/parameters.Zprime.f90 src/models/parameters.WZW.f90"
	OMEGA_FILES="omega/Makefile.am omega/share/Makefile.am omega/share/doc/Makefile.am omega/src/Makefile.am omega/src/Makefile.ocaml omega/src/Makefile.sources omega/bin/Makefile.am omega/extensions/Makefile.am omega/extensions/people/Makefile.am omega/extensions/people/jr/Makefile.am omega/extensions/people/jr/f90_SAGT.ml omega/extensions/people/jr/f90_SQED.ml omega/extensions/people/jr/f90_WZ.ml omega/extensions/people/tho/Makefile.am omega/extensions/people/tho/f90_O2.ml omega/lib/Makefile.am omega/models/Makefile.am omega/scripts/Makefile.am omega/scripts/omega-config.in omega/tools/Makefile.am omega/tests/parameters_QED.f90 omega/tests/parameters_QCD.f90 omega/tests/parameters_SM.f90 omega/tests/parameters_SM_CKM.f90 omega/tests/parameters_SM_Higgs.f90 omega/tests/parameters_SM_from_UFO.f90 omega/tests/parameters_SYM.f90 omega/tests/parameters_SM_top_anom.f90 omega/tests/parameters_HSExt.f90 omega/tests/parameters_THDM.f90 omega/tests/parameters_THDM_CKM.f90 omega/tests/parameters_Zprime.f90 omega/tests/test_openmp.f90 omega/tests/tao_random_numbers.f90 omega/tests/test_qed_eemm.f90 omega/tests/Makefile.am omega/tests/benchmark.f90 omega/tests/color_test_lib.f90 omega/tests/omega_interface.f90 omega/tests/ward_lib.f90 omega/tests/omega_unit.ml omega/tests/compare_lib.f90 omega/tests/compare_lib_recola.f90 omega/tests/benchmark_UFO_SM.f90 omega/tests/benchmark_UFO_SMEFT.f90 omega/tests/keystones_omegalib_generate.ml omega/tests/keystones_UFO_generate.ml omega/tests/keystones_omegalib_bispinors_generate.ml omega/tests/keystones_UFO_bispinors_generate.ml omega/tests/keystones.ml omega/tests/keystones.mli omega/tests/keystones_tools.f90 omega/tests/fermi_lib.f90 omega/tests/parameters_SM_Higgs_recola.f90 omega/tests/parameters_MSSM.f90 omega/tests/keystones.mli"
	OMEGA_SRC_FILES="omega/src/algebra.ml omega/src/algebra.mli omega/src/bundle.ml omega/src/bundle.mli omega/src/cache.ml omega/src/cache.mli omega/src/cascade.ml omega/src/cascade.mli omega/src/cascade_lexer.mll omega/src/cascade_parser.mly omega/src/cascade_syntax.ml omega/src/cascade_syntax.mli omega/src/charges.ml omega/src/charges.mli omega/src/color.ml omega/src/color.mli omega/src/colorize.ml omega/src/colorize.mli omega/src/combinatorics.ml omega/src/combinatorics.mli omega/src/complex.ml omega/src/complex.mli omega/src/config.ml.in omega/src/config.mli omega/src/count.ml omega/src/coupling.mli omega/src/DAG.ml omega/src/DAG.mli omega/src/fusion.ml omega/src/fusion_vintage.ml omega/src/fusion.mli omega/src/fusion_vintage.mli omega/src/linalg.ml omega/src/linalg.mli omega/src/model.mli omega/src/modellib_BSM.ml omega/src/modellib_NoH.ml omega/src/modellib_NoH.mli omega/src/modellib_BSM.mli omega/src/modellib_MSSM.ml omega/src/modellib_MSSM.mli omega/src/modellib_NMSSM.ml omega/src/modellib_NMSSM.mli omega/src/modellib_PSSSM.ml omega/src/modellib_PSSSM.mli omega/src/modellib_SM.ml omega/src/modellib_SM.mli omega/src/modellib_Zprime.mli omega/src/modellib_Zprime.ml omega/src/modellib_WZW.mli omega/src/modellib_WZW.ml omega/src/UFO.ml omega/src/UFO.mli omega/src/UFO_targets.ml omega/src/UFO_Lorentz.ml omega/src/UFO_syntax.ml omega/src/UFO_syntax.mli omega/src/UFOx.ml omega/src/UFOx.mli omega/src/UFO_lexer.mll omega/src/UFO_parser.mly omega/src/UFOx_syntax.ml omega/src/UFOx_syntax.mli omega/src/UFOx_lexer.mll omega/src/UFOx_parser.mly omega/src/omega_UFO.ml omega/src/modeltools.ml omega/src/modeltools.mli omega/src/momentum.ml omega/src/momentum.mli omega/src/OVM.ml omega/src/OVM.mli omega/src/omega.ml omega/src/omega.mli omega/src/omega_THDM.ml omega/src/omega_THDM_VM.ml omega/src/omega_THDM_CKM.ml omega/src/omega_THDM_CKM_VM.ml omega/src/omega_CQED.ml omega/src/omega_GravTest.ml omega/src/omega_Littlest.ml omega/src/omega_Littlest_Eta.ml omega/src/omega_Littlest_Tpar.ml omega/src/omega_Littlest_Zprime.ml omega/src/omega_MSSM.ml omega/src/omega_MSSM_CKM.ml omega/src/omega_MSSM_Grav.ml omega/src/omega_MSSM_Hgg.ml omega/src/omega_NMSSM.ml omega/src/omega_NMSSM_CKM.ml omega/src/omega_NMSSM_Hgg.ml omega/src/omega_PSSSM.ml omega/src/omega_Phi3.ml omega/src/omega_Phi3h.ml omega/src/omega_Phi4.ml omega/src/omega_Phi4h.ml omega/src/omega_QCD.ml omega/src/omega_QCD_VM.ml omega/src/omega_QED.ml omega/src/omega_QED_VM.ml omega/src/omega_SM.ml omega/src/omega_SM_tt_threshold.ml omega/src/omega_SM_VM.ml omega/src/omega_SM_CKM.ml omega/src/omega_SM_CKM_VM.ml omega/src/ovm_SM.ml omega/src/process.ml omega/src/process.mli omega/src/thoFilename.ml omega/src/thoFilename.mli omega/src/omega_SM_Higgs.ml omega/src/omega_SM_Higgs_CKM.ml omega/src/omega_SM_Higgs_VM.ml omega/src/omega_SM_Higgs_CKM_VM.ml omega/src/omega_SM_Rxi.ml omega/src/omega_SM_ac.ml omega/src/omega_SM_ac_CKM.ml omega/src/omega_SM_clones.ml omega/src/omega_SM_rx.ml omega/src/omega_SM_ul.ml omega/src/omega_SM_Majorana_legacy.ml omega/src/omega_SM_Majorana.ml omega/src/omega_NoH_rx.ml omega/src/omega_AltH.ml omega/src/omega_SSC.ml omega/src/omega_SSC_2.ml omega/src/omega_SM_top.ml omega/src/omega_SM_top_anom.ml omega/src/omega_SMh.ml omega/src/omega_SYM.ml omega/src/omega_Simplest.ml omega/src/omega_Simplest_univ.ml omega/src/omega_Template.ml omega/src/omega_HSExt.ml omega/src/omega_HSExt_VM.ml omega/src/omega_Threeshl.ml omega/src/omega_Threeshl_nohf.ml omega/src/omega_UED.ml omega/src/omega_Xdim.ml omega/src/omega_Zprime.ml omega/src/omega_Zprime_VM.ml omega/src/omega_logo.mp omega/src/omega_parameters_tool.nw omega/src/omegalib.nw omega/src/options.ml omega/src/options.mli omega/src/partition.ml omega/src/partition.mli omega/src/phasespace.ml omega/src/phasespace.mli omega/src/pmap.ml omega/src/pmap.mli omega/src/powSet.ml omega/src/powSet.mli omega/src/product.ml omega/src/product.mli omega/src/progress.ml omega/src/progress.mli omega/src/permutation.ml omega/src/permutation.mli omega/src/target.mli omega/src/targets.ml omega/src/targets.mli omega/src/targets_Kmatrix.ml omega/src/targets_Kmatrix.mli omega/src/test_linalg.ml omega/src/thoArray.ml omega/src/thoFilename.ml omega/src/thoArray.mli omega/src/thoList.ml omega/src/thoList.mli omega/src/thoString.ml omega/src/thoString.mli omega/src/topology.ml omega/src/topology.mli omega/src/tree.ml omega/src/tree.mli omega/src/tree2.ml omega/src/tree2.mli omega/src/trie.ml omega/src/trie.mli omega/src/tuple.ml omega/src/tuple.mli omega/src/vertex.ml omega/src/vertex.mli omega/src/vertex_lexer.mll omega/src/vertex_parser.mly omega/src/vertex_syntax.ml omega/src/vertex_syntax.mli omega/src/whizard.ml omega/src/whizard.mli omega/src/whizard_tool.ml omega/src/constants.f90 omega/src/sets.mli omega/src/sets.ml omega/src/UFO_tools.ml omega/src/UFO_tools.mli omega/src/fortran_unit.ml omega/src/format_Fortran.ml omega/src/format_Fortran.mli omega/src/omega_UFO_Majorana.ml omega/src/omega_UFO_Dirac.ml omega/src/young.mli omega/src/young.ml"
	SRC_PDF_BUILTIN_FILES="src/pdf_builtin/pdf_builtin.f90"
	VAMP_FILES="vamp/Makefile.am vamp/share/Makefile.am vamp/share/doc/Makefile.am vamp/src/Makefile.am vamp/tests/Makefile.am"
	FILES="$MAIN_FILES $CONFIGURE_FILES $VERSION_FILES $SHARE_FILES $OMEGA_FILES $SCRIPTS_FILES $SRC_FILES $CIRCE1_FILES $CIRCE2_FILES $SRC_GAMELAN_FILES $SRC_PDF_BUILTIN_FILES $VAMP_FILES $SRC_BASICS_FILES $SRC_MODELS_FILES $OMEGA_SRC_FILES"

	for f in $FILES; do
	sed -e "s/$OLD_YEAR/$NEW_YEAR/g" -e "s/$OLD_YEAR2/$NEW_YEAR2/g" -e "s/$OLD_YEAR3/$NEW_YEAR3/g" $f > $f.tmp;
	cp -f $f.tmp $f;
	rm -f $f.tmp;
	done

	CHANGE_FILES="$CONFIGURE_FILES $VERSION_FILES"
	for f in $CHANGE_FILES; do
	sed -e "s/$OLD_DATE/$NEW_DATE/g" -e "s/$OLD_VERSION/$NEW_VERSION/g" -e "s/$OLD_STATUS/$NEW_STATUS/g" $f > $f.tmp;
	cp -f $f.tmp $f;
	rm -f $f.tmp;
	done
	Index: trunk/ChangeLog
	===================================================================
	--- trunk/ChangeLog (revision 8888)
	+++ trunk/ChangeLog (revision 8889)
	@@ -1,2400 +1,2403 @@
	ChangeLog -- Summary of changes to the WHIZARD package

	Use git log/svn log to see detailed changes.

	Version 3.1.2.1

	+2023-06-01
	+ Common folder 'contrib' for external codes shipped with WHIZARD
	+
	2023-05-28
	Bug fix UFO interface:workaround for case-sensitive parameters

	2023-05-05
	Update of meson and baryon listings in SM hadrons model

	2023-03-28
	Workaround for Intel oneAPI 2022/23 regression(s)

	##################################################################

	2023-03-21
	RELEASE: version 3.1.2

	2023-03-21
	Bug fix in cyclic build dependence of WHIZARD core

	2023-03-11
	Resolve minor inconsistency in manual for NLO real partition

	##################################################################

	2023-03-10
	RELEASE: version 3.1.1

	2023-03-09
	Bug fix in UFO file parser
	Small bug fix in NLO EW infrastructure

	2023-03-01
	Bug fix: numerical mapping stability for peaked PDFs

	2023-02-28
	Bug fix UFO interface: avoid too long ME code lines

	2023-02-22
	Infrastructure for calculation of kinematic MT2 variable

	2023-02-17
	Bug fix UFO interface: correct parentheses in rational functions

	##################################################################

	2022-12-14
	RELEASE: version 3.1.0

	2022-12-12
	Bug fix Pythia8 interface: production vertices, shower history
	O'Mega support for epsilon tensor color structures

	2023-01-27
	Support for loop-induced processes

	2022-11-30
	O'Mega support for general SU(N) color representations

	2022-11-07
	Modernize configure checks for Python versions v3.10+

	2022-10-21
	General POWHEG matching
	with optional NLO real phase space partitioning

	2022-09-26
	Bug fix: accept negative scale values in SLHA block header

	2022-08-08
	Numerical stability of testsuite for Apple M1 processors

	2022-08-07
	Technically allow for muons as CIRCE2 beam spectra

	2022-06-22
	POWHEG matching for Drell-Yan and similar processes

	2022-06-12
	Add unit tests for Lorentz and phase-space modules

	2022-05-09
	Massive eikonals: Numeric robustness at ultrahigh energies

	2022-04-20
	Bug fix for VAMP2 event generation with indefinite samples

	##################################################################

	2022-04-06
	RELEASE: version 3.0.3

	2022-04-05
	POWHEG matching for single flavor hadron collisions

	2022-03-31
	NLO EW processes with massless leptons and jets (i.e.
	jet clustering and photon recombination) supported
	NLO EW for massive initial leptons validated

	2022-03-27
	Complete implementation/validation of NLL electron PDFs

	2022-02-22
	Bug fix: correct normalization for CIRCE2+EPA+polarization

	2022-02-21
	WHIZARD core now uses Fortran modules and submodules

	2022-01-27
	Infrastructure for POWHEG matching for hadron collisions

	2021-12-16
	Event files can be written/read also for decay processes
	Implementation of running QED coupling alpha

	2021-12-10
	Independent variations of renormalization/factorization scale

	##################################################################

	2021-11-23
	RELEASE: version 3.0.2

	2021-11-19
	Support for a wide class of mixed NLO QCD/EW processes

	2021-11-18
	Add pp processes for NLO EW corrections to testsuite

	2021-11-11
	Output numerically critical values with LCIO 2.17+ as double

	2021-11-05
	Minor refactoring on phase space points and kinematics

	2021-10-21
	NLO (QCD) differential distributions supported for full
	lepton collider setup: polarization, QED ISR, beamstrahlung

	2021-10-15
	SINDARIN now has a sum and product function of expressions,
	SINDARIN supports observables defined on full (sub)events
	First application: transverse mass
	Bug fix: 2HDM did not allow H+, H- as external particles

	2021-10-14
	CT18 PDFs included (NLO, NNLO)

	2021-09-30
	Bug fix: keep non-recombined photons in the event record

	2021-09-13
	Modular NLO event generation with real partition

	2021-08-20
	Bug fix: correctly reading in NLO fixed order events

	2021-08-06
	Generalize optional partitioning of the NLO real phase space

	##################################################################

	2021-07-08
	RELEASE: version 3.0.1

	2021-07-06
	MPI parallelization now comes with two incarnations:
	- standard MPI parallelization ("simple", default)
	- MPI with load balancer ("load")

	2021-07-05
	Bug fix for C++17 default compilers w/ HepMC3/ROOT interface

	2021-07-02
	Improvement for POWHEG matching:
	- implement massless recoil case
	- enable reading in existing POWHEG grids
	- support kinematic cuts at generator level

	2021-07-01
	Distinguish different cases of photons in NLO EW corrections

	2021-06-21
	Option to keep negative PDF entries or set them zero

	2021-05-31
	Full LCIO MC production files can be properly recasted

	2021-05-24
	Use defaults for UFO models without propagators.py

	2021-05-21
	Bug fix: prevent invalid code for UFO models containing hyphens

	2021-05-20
	UFO files with scientific notation float constants allowed
	UFO files: max. n-arity of vertices bound by process multiplicity

	##################################################################

	2021-04-27
	RELEASE: version 3.0.0

	2021-04-20
	Minimal required OCaml version is now 4.05.0.
	Bug fix for tau polarization from stau decays

	2021-04-19
	NLO EW splitting functions and collinear remnants completed
	Photon recombination implemented

	2021-04-14
	Bug fix for vertices/status codes with HepMC2/3 event format

	2021-04-08
	Correct Lorentz statistics for UFO model with Majorana fermions

	2021-04-06
	Bug fix for rare script failure in system_dependencies.f90.in
	Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model

	2021-04-04
	Support for UFO extensions in SMEFTSim 3.0

	2021-02-25
	Enable VAMP and VAMP2 channel equivalences for NLO integrations

	2021-02-04
	Bug fix if user does not set a prefix at configuration

	2020-12-10
	Generalize NLO calculations to non-CMS lab frames

	2020-12-08
	Bug fix in expanded p-wave form factor for top threshold

	2020-12-06
	Patch for macOS Big Sur shared library handling due to libtool;
	the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5

	2020-12-04
	O'Mega only inserts non-vanishing couplings from UFO models

	2020-11-21
	Bug fix for fractional hypercharges in UFO models

	2020-11-11
	Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)

	2020-11-09
	Correct flavor assignment for NLO fixed-order events

	2020-11-05
	Bug fix for ISR handler not working with unstable particles

	2020-10-08
	Bug fix in LHAPDF interface for photon PDFs

	2020-10-07
	Bug fix for structure function setup with asymmetric beams

	2020-10-02
	Python/Cython layer for WHIZARD API

	2020-09-30
	Allow mismatches of Python and name attributes in UFO models

	2020-09-26
	Support for negative PDG particles from certain UFO models

	2020-09-24
	Allow for QNUMBERS blocks in BSM SLHA files

	2020-09-22
	Full support for compilation with clang(++) on Darwin/macOS
	More documentation in the manual
	Minor clean-ups

	2020-09-16
	Bug fix enables reading LCIO events with LCIO v2.15+

	##################################################################

	2020-09-16
	RELEASE: version 2.8.5

	2020-09-11
	Bug fix for H->tau tau transverse polarization with PYTHIA6
	(thanks to Junping Tian / Akiya Miyamoto)

	2020-09-09
	Fix a long standing bug (since 2.0) in the calculation of color
	factors when particles of different color were combined in a
	particle class. NB: O'Mega never produced a wrong number,
	it only declared all processes as invalid.

	2020-09-08
	Enable Openloops matrix element equivalences for optimization

	2020-09-02
	Compatibility fix for PYTHIA v8.301+ interface

	2020-09-01
	Support exclusive jet clustering in ee for Fastjet interface

	##################################################################

	2020-08-30
	RELEASE: version 3.0.0_beta

	2020-08-27
	Major revision of NLO distributions and events for
	processes with structure functions:
	- Use parton momenta/flavors (instead of beams) for events
	- Bug fix for Lorentz boosts and Lorentz frames of momenta
	- Bug fix: apply cuts to virtual NLO component in correct frame
	- Correctly assign ISR radiation momenta in data structures
	- Refactoring on quantum numbers for NLO event data structures
	- Functional tests for hadron collider NLO distributions
	- many minor bug fixes regarding NLO hadron collider physics

	2020-08-11
	Bug fix for linking problem with OpenMPI

	2020-08-07
	New WHIZARD API: WHIZARD can be externally linked as a
	library, added examples for Fortran, C, C++ programs

	##################################################################

	2020-07-08
	RELEASE: version 2.8.4

	2020-07-07
	Bug fix: steering of UFO Majorana models from WHIZARD

	##################################################################

	2020-07-06
	Combined integration also for hadron collider processes at NLO

	2020-07-05
	Bug fix: correctly steer e+e- FastJet clustering algorithms
	Major revision of NLO differential distributions and events:
	- Correctly assign quantum numbers to NLO fixed-order events
	- Correctly assign weights to NLO fixed-order events for
	combined simulation
	- Cut all NLO fixed-order subevents in event groups individually
	- Only allow "sigma" normalization for NLO fixed-order events
	- Use correct PDF setup for NLO counter events
	- Several technical fixes and updates of the NLO testsuite

	##################################################################

	2020-07-03
	RELEASE: version 2.8.3

	2020-07-02
	Feature-complete UFO implementation for Majorana fermions

	2020-06-22
	Running width scheme supported for O'Mega matrix elements

	2020-06-20
	Adding H-s-s coupling to SM_Higgs(_CKM) models

	2020-06-17
	Completion of ILC 2->6 fermion extended test suite

	2020-06-15
	Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays

	2020-06-09
	Bug fix: correctly update calls for additional VAMP/2 iterations
	Bug fix: correct assignment for tau spins from PYTHIA6 interface

	2020-06-04
	Bug fix: cascades2 tree merge with empty subtree(s)

	2020-05-31
	Switch $epa_mode for different EPA implementations

	2020-05-26
	Bug fix: spin information transferred for resonance histories

	2020-04-13
	HepMC: correct weighted events for non-xsec event normalizations

	2020-04-04
	Improved HepMC3 interface: HepMC3 Root/RootTree interface

	2020-03-24
	ISR: Fix on-shell kinematics for events with ?isr_handler=true
	(set ?isr_handler_keep_mass=false for old behavior)

	2020-03-11
	Beam masses are correctly passed to hard matrix element for CIRCE2
	EPA with polarized beams: double-counting corrected

	##################################################################

	2020-03-03
	RELEASE: version 3.0.0_alpha

	2020-02-25
	Bug fix: Scale and alphas can be retrieved from internal event format to
	external formats

	2020-02-17
	Bug fix: ?keep_failed_events now forces output of actual event data
	Bug fix: particle-set reconstruction (rescanning events w/o radiation)

	2020-01-28
	Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)

	2020-01-23
	Bug fix for real components of NLO QCD 2->1 processes

	2020-01-22
	Bug fix: correct random number sequencing during parallel MPI event
	generation with rng_stream

	2020-01-21
	Consistent distribution of events during parallel MPI event generation

	2020-01-20
	Bug fix for configure setup for automake v1.16+

	2020-01-18
	General SLHA parameter files for UFO models supported

	2020-01-08
	Bug fix: correctly register RECOLA processes with flavor sums

	2019-12-19
	Support for UFO customized propagators
	O'Mega unit tests for fermion-number violating interactions

	2019-12-10
	For distribution building: check for graphviz/dot
	version 2.40 or newer

	2019-11-21
	Bug fix: alternate setups now work correctly
	Infrastructure for accessing alpha_QED event-by-event
	Guard against tiny numbers that break ASCII event output
	Enable inverse hyperbolic functions as SINDARIN observables
	Remove old compiler bug workarounds

	2019-11-20
	Allow quoted -e argument, implemented -f option

	2019-11-19
	Bug fix: resonance histories now work also with UFO models
	Fix in numerical precision of ASCII VAMP2 grids

	2019-11-06
	Add squared matrix elements to the LCIO event header

	2019-11-05
	Do not include RNG state in MD5 sum for CIRCE1/2

	2019-11-04
	Full CIRCE2 ILC 250 and 500 GeV beam spectra added
	Minor update on LCIO event header information

	2019-10-30
	NLO QCD for final states completed
	When using Openloops, v2.1.1+ mandatory

	2019-10-25
	Binary grid files for VAMP2 integrator

	##################################################################

	2019-10-24
	RELEASE: version 2.8.2

	2019-10-20
	Bug fix for HepMC linker flags

	2019-10-19
	Support for spin-2 particles from UFO files

	2019-09-27
	LCIO event format allows rescan and alternate weights

	2019-09-24
	Compatibility fix for OCaml v4.08.0+

	##################################################################

	2019-09-21
	RELEASE: version 2.8.1

	2019-09-19
	Carriage return characters in UFO models can be parsed
	Mathematica symbols in UFO models possible
	Unused/undefined parameters in UFO models handled

	2019-09-13
	New extended NLO test suite for ee and pp processes

	2019-09-09
	Photon isolation (separation of perturbative and fragmentation
	part a la Frixione)

	2019-09-05
	Major progress on NLO QCD for hadron collisions:
	- correctly assign flavor structures for alpha regions
	- fix crossing of particles for initial state splittings
	- correct assignment for PDF factors for real subtractions
	- fix kinematics for collinear splittings
	- bug fix for integrated virtual subtraction terms

	2019-09-03
	b and c jet selection in cuts and analysis

	2019-08-27
	Support for Intel MPI

	2019-08-20
	Complete (preliminary) HepMC3 support (incl.
	backwards HepMC2 write/read mode)

	2019-08-08
	Bug fix: handle carriage returns in UFO files (non-Unix OS)

	##################################################################

	2019-08-07
	RELEASE: version 2.8.0

	2019-07-31
	Complete WHIZARD UFO interface:
	- general Lorentz structures
	- matrix element support for general color factors
	- missing features: Majorana fermions and SLHA

	2019-07-20
	Make WHIZARD compatible with OCaml 4.08.0+

	2019-07-19
	Fix version testing for LHAPDF 6.2.3 and newer
	Minimal required OCaml version is now 4.02.3.

	2019-04-18
	Correctly generate ordered FKS tuples for alpha regions
	from all possible underlying Born processes

	2019-04-08
	Extended O'Mega/Recola matrix element test suite

	2019-03-29
	Correct identical particle symmetry factors for FKS subtraction

	2019-03-28
	Correct assertion of spin-correlated matrix
	elements for hadron collisions

	2019-03-27
	Bug fix for cut-off parameter delta_i for
	collinear plus/minus regions

	##################################################################

	2019-03-27
	RELEASE: version 2.7.1

	2019-02-19
	Further infrastructure for HepMC3 interface (v3.01.00)

	2019-02-07
	Explicit configure option for using debugging options
	Bug fix for performance by removing unnecessary debug operations

	2019-01-29
	Bug fix for DGLAP remnants with cut-off parameter delta_i

	2019-01-24
	Radiative decay neu2 -> neu1 A added to MSSM_Hgg model

	##################################################################

	2019-01-21
	RELEASE: version 2.7.0

	2018-12-18
	Support RECOLA for integrated und unintegrated subtractions

	2018-12-11
	FCNC top-up sector in model SM_top_anom

	2018-12-05
	Use libtirpc instead of SunRPC on Arch Linux etc.

	2018-11-30
	Display rescaling factor for weighted event samples with cuts

	2018-11-29
	Reintroduce check against different masses in flavor sums
	Bug fix for wrong couplings in the Littlest Higgs model(s)

	2018-11-22
	Bug fix for rescanning events with beam structure

	2018-11-09
	Major refactoring of internal process data

	2018-11-02
	PYTHIA8 interface

	2018-10-29
	Flat phase space parametrization with RAMBO (on diet) implemented

	2018-10-17
	Revise extended test suite

	2018-09-27
	Process container for RECOLA processes

	2018-09-15
	Fixes by M. Berggren for PYTHIA6 interface

	2018-09-14
	First fixes after HepForge modernization

	##################################################################

	2018-08-23
	RELEASE: version 2.6.4

	2018-08-09
	Infrastructure to check colored subevents

	2018-07-10
	Infrastructure for running WHIZARD in batch mode

	2018-07-04
	MPI available from distribution tarball

	2018-06-03
	Support Intel Fortran Compiler under MAC OS X

	2018-05-07
	FKS slicing parameter delta_i (initial state) implementend

	2018-05-03
	Refactor structure function assignment for NLO

	2018-05-02
	FKS slicing parameter xi_cut, delta_0 implemented

	2018-04-20
	Workspace subdirectory for process integration (grid/phs files)
	Packing/unpacking of files at job end/start
	Exporting integration results from scan loops

	2018-04-13
	Extended QCD NLO test suite

	2018-04-09
	Bug fix for Higgs Singlet Extension model

	2018-04-06
	Workspace subdirectory for process generation and compilation
	--job-id option for creating job-specific names

	2018-03-20
	Bug fix for color flow matching in hadron collisions
	with identical initial state quarks

	2018-03-08
	Structure functions quantum numbers correctly assigned for NLO

	2018-02-24
	Configure setup includes 'pgfortran' and 'flang'

	2018-02-21
	Include spin-correlated matrix elements in interactions

	2018-02-15
	Separate module for QED ISR structure functions

	##################################################################

	2018-02-10
	RELEASE: version 2.6.3

	2018-02-08
	Improvements in memory management for PS generation

	2018-01-31
	Partial refactoring: quantum number assigment NLO
	Initial-state QCD splittings for hadron collisions

	2018-01-25
	Bug fix for weighted events with VAMP2

	2018-01-17
	Generalized interface for Recola versions 1.3+ and 2.1+

	2018-01-15
	Channel equivalences also for VAMP2 integrator

	2018-01-12
	Fix for OCaml compiler 4.06 (and newer)

	2017-12-19
	RECOLA matrix elements with flavor sums can be integrated

	2017-12-18
	Bug fix for segmentation fault in empty resonance histories

	2017-12-16
	Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
	from transferral between PYTHIA and WHIZARD event records

	2017-12-15
	Event index for multiple processes in event file correct

	##################################################################

	2017-12-13
	RELEASE: version 2.6.2

	2017-12-07
	User can set offset in event numbers

	2017-11-29
	Possibility to have more than one RECOLA process in one file

	2017-11-23
	Transversal/mixed (and unitarized) dim-8 operators

	2017-11-16
	epa_q_max replaces epa_e_max (trivial factor 2)

	2017-11-15
	O'Mega matrix element compilation silent now

	2017-11-14
	Complete expanded P-wave form factor for top threshold

	2017-11-10
	Incoming particles can be accessed in SINDARIN

	2017-11-08
	Improved handling of resonance insertion, additional parameters

	2017-11-04
	Added Higgs-electron coupling (SM_Higgs)

	##################################################################

	2017-11-03
	RELEASE: version 2.6.1

	2017-10-20
	More than 5 NLO components possible at same time

	2017-10-19
	Gaussian cutoff for shower resonance matching

	2017-10-12
	Alternative (more efficient) method to generate
	phase space file

	2017-10-11
	Bug fix for shower resonance histories for processes
	with multiple components

	2017-09-25
	Bug fix for process libraries in shower resonance histories

	2017-09-21
	Correctly generate pT distribution for EPA remnants

	2017-09-20
	Set branching ratios for unstable particles also by hand

	2017-09-14
	Correctly generate pT distribution for ISR photons

	##################################################################

	2017-09-08
	RELEASE: version 2.6.0

	2017-09-05
	Bug fix for initial state NLO QCD flavor structures
	Real and virtual NLO QCD hadron collider processes
	work with internal interactions

	2017-09-04
	Fully validated MPI integration and event generation

	2017-09-01
	Resonance histories for shower: full support
	Bug fix in O'Mega model constraints
	O'Mega allows to output a parsable form of the DAG

	2017-08-24
	Resonance histories in events for transferral
	to parton shower (e.g. in ee -> jjjj)

	2017-08-01
	Alpha version of HepMC v3 interface
	(not yet really functional)

	2017-07-31
	Beta version for RECOLA OLP support

	2017-07-06
	Radiation generator fix for LHC processes

	2017-06-30
	Fix bug for NLO with structure
	functions and/or polarization

	2017-06-23
	Collinear limit for QED corrections works

	2017-06-17
	POWHEG grids generated already during integration

	2017-06-12
	Soft limit for QED corrections works

	2017-05-16
	Beta version of full MPI parallelization (VAMP2)
	Check consistency of POWHEG grid files
	Logfile config-summary.log for configure summary

	2017-05-12
	Allow polarization in top threshold

	2017-05-09
	Minimal demand automake 1.12.2
	Silent rules for make procedures

	2017-05-07
	Major fix for POWHEG damping
	Correctly initialize FKS ISR phasespace

	##################################################################

	2017-05-06
	RELEASE: version 2.5.0

	2017-05-05
	Full UFO support (SM-like models)
	Fixed-beam ISR FKS phase space

	2017-04-26
	QED splittings in radiation generator

	2017-04-10
	Retire deprecated O'Mega vertex cache files

	##################################################################

	2017-03-24
	RELEASE: version 2.4.1

	2017-03-16
	Distinguish resonance charge in phase space channels
	Keep track of resonance histories in phase space
	Complex mass scheme default for OpenLoops amplitudes

	2017-03-13
	Fix helicities for polarized OpenLoops calculations

	2017-03-09
	Possibility to advance RNG state in rng_stream

	2017-03-04
	General setup for partitioning real emission
	phase space

	2017-03-06
	Bug fix on rescan command for converting event files

	2017-02-27
	Alternative multi-channel VEGAS implementation
	VAMP2: serial backbone for MPI setup
	Smoothstep top threshold matching

	2017-02-25
	Single-beam structure function with
	s-channel mapping supported
	Safeguard against invalid process libraries

	2017-02-16
	Radiation generator for photon emission

	2017-02-10
	Fixes for NLO QCD processes (color correlations)

	2017-01-16
	LCIO variable takes precedence over LCIO_DIR

	2017-01-13
	Alternative random number generator
	rng_stream (cf. L'Ecuyer et al.)

	2017-01-01
	Fix for multi-flavor BLHA tree
	matrix elements

	2016-12-31
	Grid path option for VAMP grids

	2016-12-28
	Alpha version of Recola OLP support

	2016-12-27
	Dalitz plots for FKS phase space

	2016-12-14
	NLO multi-flavor events possible

	2016-12-09
	LCIO event header information added

	2016-12-02
	Alpha version of RECOLA interface
	Bug fix for generator status in LCIO

	##################################################################

	2016-11-28
	RELEASE: version 2.4.0

	2016-11-24
	Bug fix for OpenLoops interface: EW scheme
	is set by WHIZARD
	Bug fixes for top threshold implementation

	2016-11-11
	Refactoring of dispatching

	2016-10-18
	Bug fix for LCIO output

	2016-10-10
	First implementation for collinear soft terms

	2016-10-06
	First full WHIZARD models from UFO files

	2016-10-05
	WHIZARD does not support legacy gcc 4.7.4 any longer

	2016-09-30
	Major refactoring of process core and NLO components

	2016-09-23
	WHIZARD homogeneous entity: discarding subconfigures
	for CIRCE1/2, O'Mega, VAMP subpackages; these are
	reconstructable by script projectors

	2016-09-06
	Introduce main configure summary

	2016-08-26
	Fix memory leak in event generation

	##################################################################

	2016-08-25
	RELEASE: version 2.3.1

	2016-08-19
	Bug fix for EW-scheme dependence of gluino propagators

	2016-08-01
	Beta version of complex mass scheme support

	2016-07-26
	Fix bug in POWHEG damping for the matching

	##################################################################

	2016-07-21
	RELEASE: version 2.3.0

	2016-07-20
	UFO file support (alpha version) in O'Mega

	2016-07-13
	New (more) stable of WHIZARD GUI
	Support for EW schemes for OpenLoops
	Factorized NLO top decays for threshold model

	2016-06-15
	Passing factorization scale to PYTHIA6
	Adding charge and neutral observables

	2016-06-14
	Correcting angular distribution/tweaked kinematics in
	non-collinear structure functions splittings

	2016-05-10
	Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
	(backwards validation of LC CDR/TDR samples)

	2016-04-27
	Within OpenLoops virtuals: support for Collier library

	2016-04-25
	O'Mega vertex tables only loaded at first usage

	2016-04-21
	New CJ15 PDF parameterizations added

	2016-04-21
	Support for hadron collisions at NLO QCD

	2016-04-05
	Support for different (parameter) schemes in model files

	2016-03-31
	Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
	into the event record

	2016-03-21
	New internal implementation of polarization
	via Bloch vectors, remove pointer constructions

	2016-03-13
	Extension of cascade syntax for processes:
	exclude propagators/vertices etc. possible

	2016-02-24
	Full support for OpenLoops QCD NLO matrix
	elements, inclusion in test suite

	2016-02-12
	Substantial progress on QCD NLO support

	2016-02-02
	Automated resonance mapping for FKS subtraction

	2015-12-17
	New BSM model WZW for diphoton resonances

	##################################################################

	2015-11-22
	RELEASE: version 2.2.8

	2015-11-21
	Bug fix for fixed-order NLO events

	2015-11-20
	Anomalous FCNC top-charm vertices

	2015-11-19
	StdHEP output via HEPEVT/HEPEV4 supported

	2015-11-18
	Full set of electroweak dim-6 operators included

	2015-10-22
	Polarized one-loop amplitudes supported

	2015-10-21
	Fixes for event formats for showered events

	2015-10-14
	Callback mechanism for event output

	2015-09-22
	Bypass matrix elements in pure event sample rescans
	StdHep frozen final version v5.06.01 included internally

	2015-09-21
	configure option --with-precision to
	demand 64bit, 80bit, or 128bit Fortran
	and bind C precision types

	2015-09-07
	More extensive tests of NLO
	infrastructure and POWHEG matching

	2015-09-01
	NLO decay infrastructure
	User-defined squared matrix elements
	Inclusive FastJet algorithm plugin
	Numerical improvement for small boosts

	##################################################################

	2015-08-11
	RELEASE: version 2.2.7

	2015-08-10
	Infrastructure for damped POWHEG
	Massive emitters in POWHEG
	Born matrix elements via BLHA
	GoSam filters via SINDARIN
	Minor running coupling bug fixes
	Fixed-order NLO events

	2015-08-06
	CT14 PDFs included (LO, NLO, NNLL)

	2015-07-07
	Revalidation of ILC WHIZARD-PYTHIA event chain
	Extended test suite for showered events
	Alpha version of massive FSR for POWHEG

	2015-06-09
	Fix memory leak in interaction for long cascades
	Catch mismatch between beam definition and CIRCE2 spectrum

	2015-06-08
	Automated POWHEG matching: beta version
	Infrastructure for GKS matching
	Alpha version of fixed-order NLO events
	CIRCE2 polarization averaged spectra with
	explicitly polarized beams

	2015-05-12
	Abstract matching type: OO structure for matching/merging

	2015-05-07
	Bug fix in event record WHIZARD-PYTHIA6 transferral
	Gaussian beam spectra for lepton colliders

	##################################################################

	2015-05-02
	RELEASE: version 2.2.6

	2015-05-01
	Models for (unitarized) tensor resonances in VBS

	2015-04-28
	Bug fix in channel weights for event generation.

	2015-04-18
	Improved event record transfer WHIZARD/PYTHIA6

	2015-03-19
	POWHEG matching: alpha version

	##################################################################

	2015-02-27
	RELEASE: version 2.2.5

	2015-02-26
	Abstract types for quantum numbers

	2015-02-25
	Read-in of StdHEP events, self-tests

	2015-02-22
	Bug fix for mother-daughter relations in
	showered/hadronized events

	2015-02-20
	Projection on polarization in intermediate states

	2015-02-13
	Correct treatment of beam remnants in
	event formats (also LC remnants)

	##################################################################

	2015-02-06
	RELEASE: version 2.2.4

	2015-02-06
	Bug fix in event output

	2015-02-05
	LCIO event format supported

	2015-01-30
	Including state matrices in WHIZARD's internal IO
	Versioning for WHIZARD's internal IO
	Libtool update from 2.4.3 to 2.4.5
	LCIO event output (beta version)

	2015-01-27
	Progress on NLO integration
	Fixing a bug for multiple processes in a single
	event file when using beam event files

	2015-01-19
	Bug fix for spin correlations evaluated in the rest
	frame of the mother particle

	2015-01-17
	Regression fix for statically linked processes
	from SARAH and FeynRules

	2015-01-10
	NLO: massive FKS emitters supported (experimental)

	2015-01-06
	MMHT2014 PDF sets included

	2015-01-05
	Handling mass degeneracies in auto_decays

	2014-12-19
	Fixing bug in rescan of event files

	##################################################################

	2014-11-30
	RELEASE: version 2.2.3

	2014-11-29
	Beta version of LO continuum/NLL-threshold
	matched top threshold model for e+e- physics

	2014-11-28
	More internal refactoring: disentanglement of module
	dependencies

	2014-11-21
	OVM: O'Mega Virtual Machine, bytecode instructions
	instead of compiled Fortran code

	2014-11-01
	Higgs Singlet extension model included

	2014-10-18
	Internal restructuring of code; half-way
	WHIZARD main code file disassembled

	2014-07-09
	Alpha version of NLO infrastructure

	##################################################################

	2014-07-06
	RELEASE: version 2.2.2

	2014-07-05
	CIRCE2: correlated LC beam spectra and
	GuineaPig Interface to LC machine parameters

	2014-07-01
	Reading LHEF for decayed/factorized/showered/
	hadronized events

	2014-06-25
	Configure support for GoSAM/Ninja/Form/QGraf

	2014-06-22
	LHAPDF6 interface

	2014-06-18
	Module for automatic generation of
	radiation and loop infrastructure code

	2014-06-11
	Improved internal directory structure

	##################################################################

	2014-06-03
	RELEASE: version 2.2.1

	2014-05-30
	Extensions of internal PDG arrays

	2014-05-26
	FastJet interface

	2014-05-24
	CJ12 PDFs included

	2014-05-20
	Regression fix for external models (via SARAH
	or FeynRules)

	##################################################################

	2014-05-18
	RELEASE: version 2.2.0

	2014-04-11
	Multiple components: inclusive process definitions,
	syntax: process A + B + ...

	2014-03-13
	Improved PS mappings for e+e- ISR
	ILC TDR and CLIC spectra included in CIRCE1

	2014-02-23
	New models: AltH w\ Higgs for exclusion purposes,
	SM_rx for Dim 6-/Dim-8 operators, SSC for
	general strong interactions (w/ Higgs), and
	NoH_rx (w\ Higgs)

	2014-02-14
	Improved s-channel mapping, new on-shell
	production mapping (e.g. Drell-Yan)

	2014-02-03
	PRE-RELEASE: version 2.2.0_beta

	2014-01-26
	O'Mega: Feynman diagram generation possible (again)

	2013-12-16
	HOPPET interface for b parton matching

	2013-11-15
	PRE-RELEASE: version 2.2.0_alpha-4

	2013-10-27
	LHEF standards 1.0/2.0/3.0 implemented

	2013-10-15
	PRE-RELEASE: version 2.2.0_alpha-3

	2013-10-02
	PRE-RELEASE: version 2.2.0_alpha-2

	2013-09-25
	PRE-RELEASE: version 2.2.0_alpha-1

	2013-09-12
	PRE-RELEASE: version 2.2.0_alpha

	2013-09-03
	General 2HDM implemented

	2013-08-18
	Rescanning/recalculating events

	2013-06-07
	Reconstruction of complete event
	from 4-momenta possible

	2013-05-06
	Process library stacks

	2013-05-02
	Process stacks

	2013-04-29
	Single-particle phase space module

	2013-04-26
	Abstract interface for random
	number generator

	2013-04-24
	More object-orientation on modules
	Midpoint-rule integrator

	2013-04-05
	Object-oriented integration and
	event generation

	2013-03-12
	Processes recasted object-oriented:
	MEs, scales, structure functions
	First infrastructure for general Lorentz
	structures

	2013-01-17
	Object-orientated reworking of library and
	process core, more variable internal structure,
	unit tests

	2012-12-14
	Update Pythia version to 6.4.27

	2012-12-04
	Fix the phase in HAZ vertices

	2012-11-21
	First O'Mega unit tests, some infrastructure

	2012-11-13
	Bug fix in anom. HVV Lorentz structures

	##################################################################

	2012-09-18
	RELEASE: version 2.1.1

	2012-09-11
	Model MSSM_Hgg with Hgg and HAA vertices

	2012-09-10
	First version of implementation of multiple
	interactions in WHIZARD

	2012-09-05
	Infrastructure for internal CKKW matching

	2012-09-02
	C, C++, Python API

	2012-07-19
	Fixing particle numbering in HepMC format

	##################################################################

	2012-06-15
	RELEASE: version 2.1.0

	2012-06-14
	Analytical and kT-ordered shower officially
	released
	PYTHIA interface officially released

	2012-05-09
	Intrisince PDFs can be used for showering

	2012-05-04
	Anomalous Higgs couplings a la hep-ph/9902321

	##################################################################

	2012-03-19
	RELEASE: version 2.0.7

	2012-03-15
	Run IDs are available now
	More event variables in analysis
	Modified raw event format (compatibility mode exists)

	2012-03-12
	Bug fix in decay-integration order
	MLM matching steered completely internally now

	2012-03-09
	Special phase space mapping for narrow resonances
	decaying to 4-particle final states with far off-shell
	intermediate states
	Running alphas from PDF collaborations with
	builtin PDFs

	2012-02-16
	Bug fix in cascades decay infrastructure

	2012-02-04
	WHIZARD documentation compatible with TeXLive 2011

	2012-02-01
	Bug fix in FeynRules interface with --prefix flag

	2012-01-29
	Bug fix with name clash of O'Mega variable names

	2012-01-27
	Update internal PYTHIA to version 6.4.26
	Bug fix in LHEF output

	2012-01-21
	Catching stricter automake 1.11.2 rules

	2011-12-23
	Bug fix in decay cascade setup

	2011-12-20
	Bug fix in helicity selection rules

	2011-12-16
	Accuracy goal reimplemented

	2011-12-14
	WHIZARD compatible with TeXLive 2011

	2011-12-09
	Option --user-target added

	##################################################################

	2011-12-07
	RELEASE: version 2.0.6

	2011-12-07
	Bug fixes in SM_top_anom
	Added missing entries to HepMC format

	2011-12-06
	Allow to pass options to O'Mega
	Bug fix for HEPEVT block for showered/hadronized events

	2011-12-01
	Reenabled user plug-in for external code for
	cuts, structure functions, routines etc.

	2011-11-29
	Changed model SM_Higgs for Higgs phenomenology

	2011-11-25
	Supporting a Y, (B-L) Z' model

	2011-11-23
	Make WHIZARD compatible for MAC OS X Lion/XCode 4

	2011-09-25
	WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742

	2011-08-16
	Model SM_QCD: QCD with one EW insertion

	2011-07-19
	Explicit output channel for dvips avoids printing

	2011-07-10
	Test suite for WHIZARD unit tests

	2011-07-01
	Commands for matrix element tests
	More OpenMP parallelization of kinematics
	Added unit tests

	2011-06-23
	Conversion of CIRCE2 from F77 to F90, major
	clean-up

	2011-06-14
	Conversion of CIRCE1 from F77 to F90

	2011-06-10
	OpenMP parallelization of channel kinematics
	(by Matthias Trudewind)

	2011-05-31
	RELEASE: version 1.97

	2011-05-24
	Minor bug fixes: update grids and elsif statement.

	##################################################################

	2011-05-10
	RELEASE: version 2.0.5

	2011-05-09
	Fixed bug in final state flavor sums
	Minor improvements on phase-space setup

	2011-05-05
	Minor bug fixes

	2011-04-15
	WHIZARD as a precompiled 64-bit binary available

	2011-04-06
	Wall clock instead of cpu time for time estimates

	2011-04-05
	Major improvement on the phase space setup

	2011-04-02
	OpenMP parallelization for helicity loop in O'Mega
	matrix elements

	2011-03-31
	Tools for relocating WHIZARD and use in batch
	environments

	2011-03-29
	Completely static builds possible, profiling options

	2011-03-28
	Visualization of integration history

	2011-03-27
	Fixed broken K-matrix implementation

	2011-03-23
	Including the GAMELAN manual in the distribution

	2011-01-26
	WHIZARD analysis can handle hadronized event files

	2011-01-17
	MSTW2008 and CT10 PDF sets included

	2010-12-23
	Inclusion of NMSSM with Hgg couplings

	2010-12-21
	Advanced options for integration passes

	2010-11-16
	WHIZARD supports CTEQ6 and possibly other PDFs
	directly; data files included in the distribution

	##################################################################

	2010-10-26
	RELEASE: version 2.0.4

	2010-10-06
	Bug fix in MSSM implementation

	2010-10-01
	Update to libtool 2.4

	2010-09-29
	Support for anomalous top couplings (form factors etc.)
	Bug fix for running gauge Yukawa SUSY couplings

	2010-09-28
	RELEASE: version 1.96

	2010-09-21
	Beam remnants and pT spectra for lepton collider re-enabled
	Restructuring subevt class

	2010-09-16
	Shower and matching are disabled by default
	PYTHIA as a conditional on these two options

	2010-09-14
	Possibility to read in beam spectra re-enabled (e.g. Guinea
	Pig)

	2010-09-13
	Energy scan as (pseudo-) structure functions re-implemented

	2010-09-10
	CIRCE2 included again in WHIZARD 2 and validated

	2010-09-02
	Re-implementation of asymmetric beam energies and collision
	angles, e-p collisions work, inclusion of a HERA DIS test
	case

	##################################################################

	2010-10-18
	RELEASE: version 2.0.3

	2010-08-08
	Bug in CP-violating anomalous triple TGCs fixed

	2010-08-06
	Solving backwards compatibility problem with O'Caml 3.12.0

	2010-07-12
	Conserved quantum numbers speed up O'Mega code generation

	2010-07-07
	Attaching full ISR/FSR parton shower and MPI/ISR
	module
	Added SM model containing Hgg, HAA, HAZ vertices

	2010-07-02
	Matching output available as LHEF and STDHEP

	2010-06-30
	Various bug fixes, missing files, typos

	2010-06-26
	CIRCE1 completely re-enabled
	Chaining structure functions supported

	2010-06-25
	Partial support for conserved quantum numbers in
	O'Mega

	2010-06-21
	Major upgrade of the graphics package: error bars,
	smarter SINDARIN steering, documentation, and all that...

	2010-06-17
	MLM matching with PYTHIA shower included

	2010-06-16
	Added full CIRCE1 and CIRCE2 versions including
	full documentation and miscellanea to the trunk

	2010-06-12
	User file management supported, improved variable
	and command structure

	2010-05-24
	Improved handling of variables in local command lists

	2010-05-20
	PYTHIA interface re-enabled

	2010-05-19
	ASCII file formats for interfacing ROOT and gnuplot in
	data analysis

	##################################################################

	2010-05-18
	RELEASE: version 2.0.2

	2010-05-14
	Reimplementation of visualization of phase space
	channels
	Minor bug fixes

	2010-05-12
	Improved phase space - elimination of redundancies

	2010-05-08
	Interface for polarization completed: polarized beams etc.

	2010-05-06
	Full quantum numbers appear in process log
	Integration results are usable as user variables
	Communication with external programs

	2010-05-05
	Split module commands into commands, integration,
	simulation modules

	2010-05-04
	FSR+ISR for the first time connected to the WHIZARD 2 core

	##################################################################

	2010-04-25
	RELEASE: version 2.0.1

	2010-04-23
	Automatic compile and integrate if simulate is called
	Minor bug fixes in O'Mega

	2010-04-21
	Checkpointing for event generation
	Flush statements to use WHIZARD inside a pipe

	2010-04-20
	Reimplementation of signal handling in WGIZARD 2.0

	2010-04-19
	VAMP is now a separately configurable and installable unit of
	WHIZARD, included VAMP self-checks
	Support again compilation in quadruple precision

	2010-04-06
	Allow for logarithmic plots in GAMELAN, reimplement the
	possibility to set the number of bins

	2010-04-15
	Improvement on time estimates for event generation

	##################################################################

	2010-04-12
	RELEASE: version 2.0.0

	2010-04-09
	Per default, the code for the amplitudes is subdivided to allow
	faster compiler optimization
	More advanced and unified and straightforward command language
	syntax
	Final bug fixes

	2010-04-07
	Improvement on SINDARIN syntax; printf, sprintf function
	thorugh a C interface

	2010-04-05
	Colorizing DAGs instead of model vertices: speed boost
	in colored code generation

	2010-03-31
	Generalized options for normalization of weighted and
	unweighted events
	Grid and weight histories added again to log files
	Weights can be used in analyses

	2010-03-28
	Cascade decays completely implemented including color and
	spin correlations

	2010-03-07
	Added new WHIZARD header with logo

	2010-03-05
	Removed conflict in O'Mega amplitudes between flavour sums
	and cascades
	StdHEP interface re-implemented

	2010-03-03
	RELEASE: version 2.0.0rc3
	Several bug fixes for preventing abuse in input files
	OpenMP support for amplitudes
	Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
	FeynRules interface successfully passed MSSM test

	2010-02-26
	Eliminating ghost gluons from multi-gluon amplitudes

	2010-02-25
	RELEASE: version 1.95
	HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2

	2010-02-23
	Running alpha_s implemented in the FeynRules interface

	2010-02-19
	MSSM (semi-) automatized self-tests finalized

	2010-02-17
	RELEASE: version 1.94

	2010-02-16
	Closed memory corruption in WHIZARD 1
	Fixed problems of old MadGraph and CompHep drivers
	with modern compilers
	Uncolored vertex selection rules for colored amplitudes in
	O'Mega

	2010-02-15
	Infrastructure for color correlation computation in O'Mega
	finished
	Forbidden processes are warned about, but treated as non-fatal

	2010-02-14
	Color correlation computation in O'Mega finalized

	2010-02-10
	Improving phase space mappings for identical particles in
	initial and final states
	Introduction of more extended multi-line error message

	2010-02-08
	First O'Caml code for computation of color correlations in
	O'Mega

	2010-02-07
	First MLM matching with e+ e- -> jets

	##################################################################

	2010-02-06
	RELEASE: version 2.0.0rc2

	2010-02-05
	Reconsidered the Makefile structure and more extended tests
	Catch a crash between WHIZARD and O'Mega for forbidden processes
	Tensor products of arbitrary color structures in jet definitions

	2010-02-04
	Color correlation computation in O'Mega finalized

	##################################################################

	2010-02-03
	RELEASE: version 2.0.0rc1

	##################################################################

	2010-01-31
	Reimplemented numerical helicity selection rules
	Phase space functionality of version 1 restored and improved

	2009-12-05
	NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)

	2009-12-04
	RELEASE: version 2.0.0alpha

	##################################################################

	2009-04-16
	RELEASE: version 1.93

	2009-04-15
	Clean-up of Makefiles and configure scripts
	Reconfiguration of BSM model implementation
	extended supersymmetric models

	2008-12-23
	New model NMSSM (Felix Braam)
	SLHA2 added
	Bug in LHAPDF interface fixed

	2008-08-16
	Bug fixed in K matrix implementation
	Gravitino option in the MSSM added

	2008-03-20
	Improved color and flavor sums

	##################################################################

	2008-03-12
	RELEASE: version 1.92
	LHEF (Les Houches Event File) format added
	Fortran 2003 command-line interface (if supported by the compiler)
	Automated interface to colored models
	More bug fixes and workarounds for compiler compatibility

	##################################################################

	2008-03-06
	RELEASE: version 1.91
	New model K-matrix (resonances and anom. couplings in WW scattering)
	EWA spectrum
	Energy-scan pseudo spectrum
	Preliminary parton shower module (only from final-state quarks)
	Cleanup and improvements of configure process
	Improvements for O'Mega parameter files
	Quadruple precision works again
	More plotting options: lines, symbols, errors
	Documentation with PDF bookmarks enabled
	Various bug fixes

	2007-11-29
	New model UED

	##################################################################

	2007-11-23
	RELEASE: version 1.90
	O'Mega now part of the WHIZARD tree
	Madgraph/CompHEP disabled by default (but still usable)
	Support for LHAPDF (preliminary)
	Added new models: SMZprime, SM_km, Template
	Improved compiler recognition and compatibility
	Minor bug fixes

	##################################################################

	2006-06-15
	RELEASE: version 1.51
	Support for anomaly-type Higgs couplings (to gluon and photon/Z)
	Support for spin 3/2 and spin 2
	New models: Little Higgs (4 versions), toy models for extra dimensions
	and gravitinos
	Fixes to the whizard.nw source documentation to run through LaTeX
	Intel 9.0 bug workaround (deallocation of some arrays)

	2006-05-15
	O'Mega RELEASE: version 0.11
	merged JRR's O'Mega extensions

	##################################################################

	2006-02-07
	RELEASE: version 1.50
	To avoid confusion: Mention outdated manual example in BUGS file
	O'Mega becomes part of the WHIZARD generator

	2006-02-02 [bug fix update]
	Bug fix: spurious error when writing event files for weighted events
	Bug fix: 'r' option for omega produced garbage for some particle names
	Workaround for ifort90 bug (crash when compiling whizard_event)
	Workaround for ifort90 bug (crash when compiling hepevt_common)

	2006-01-27
	Added process definition files for MSSM 2->2 processes
	Included beam recoil for EPA (T.Barklow)
	Updated STDHEP byte counts (for STDHEP 5.04.02)
	Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
	Fixed issue with comphep requiring Xlibs on Opteron
	Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
	Fixed color-flow code: was broken for omega with option 'c' and 'w'
	Workaround hacks for g95 compatibility

	2005-11-07
	O'Mega RELEASE: version 0.10
	O'Mega, merged JRR's and WK's color hack for WHiZard
	O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
	a la JRR/WK)
	O'Mega, make JRR's MSSM official

	##################################################################

	2005-10-25
	RELEASE: version 1.43
	Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
	This should be final, since the MSSM results agree now completely
	with Madgraph and Sherpa
	User-defined lower and upper limits for split event file count
	Allow for counters (events, bytes) exceeding $2^{31}$
	Revised checksum treatment and implementation (now MD5)
	Bug fix: missing process energy scale in raw event file

	##################################################################

	2005-09-30
	RELEASE: version 1.42
	Graphical display of integration history ('make history')
	Allow for switching off signals even if supported (configure option)

	2005-09-29
	Revised phase space generation code, in particular for flavor sums
	Negative cut and histogram codes use initial beams instead of
	initial parton momenta. This allows for computing, e.g., E_miss
	Support constant-width and zero-width options for O'Mega
	Width options now denoted by w:X (X=f,c,z). f option obsolescent
	Bug fix: colorized code: flipped indices could screw up result
	Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
	Bug fix: dvips on systems where dvips defaults to lpr
	Bug fix: integer overflow if too many events are requested

	2005-07-29
	Allow for 2 -> 1 processes (if structure functions are on)

	2005-07-26
	Fixed and expanded the 'test' matrix element:
	Unit matrix element with option 'u' / default: normalized phase space

	##################################################################

	2005-07-15
	RELEASE: version 1.41
	Bug fix: no result for particle decay processes with width=0
	Bug fix: line breaks in O'Mega files with color decomposition

	2005-06-02
	New self-tests (make test-QED / test-QCD / test-SM)
	check lists of 2->2 processes
	Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)

	2005-05-25
	Revised Makefile structure
	Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)

	2005-05-19
	Support for color in O'Mega (using color flow decomposition)
	New model QCD
	Parameter file changes that correspond to replaced SM module in O'Mega
	Bug fixes in MSSM (O'Mega) parameter file

	2005-05-18
	New event file formats, useful for LHC applications:
	ATHENA and Les Houches Accord (external fragmentation)
	Naive (i.e., leading 1/N) color factor now implemented both for
	incoming and outgoing partons

	2005-01-26
	include missing HELAS files for bundle
	pgf90 compatibility issues [note: still internal error in pgf90]

	##################################################################

	2004-12-13
	RELEASE: version 1.40
	compatibility fix: preprocessor marks in helas code now commented out
	minor bug fix: format string in madgraph source

	2004-12-03
	support for arbitray beam energies and directions
	allow for pT kick in structure functions
	bug fix: rounding error could result in zero cross section
	(compiler-dependent)

	2004-10-07
	simulate decay processes
	list fraction (of total width/cross section) instead of efficiency
	in process summary
	new cut/analysis parameters AA, AAD, CTA: absolute polar angle

	2004-10-04
	Replaced Madgraph I by Madgraph II. Main improvement: model no
	longer hardcoded
	introduced parameter reset_seed_each_process (useful for debugging)
	bug fix: color initialization for some processes was undefined

	2004-09-21
	don't compile unix_args module if it is not required

	##################################################################

	2004-09-20
	RELEASE: version 1.30
	g95 compatibility issues resolved
	some (irrelevant) memory leaks closed
	removed obsolete warning in circe1
	manual update (essentially) finished

	2004-08-03
	O'Mega RELEASE: version 0.9
	O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
	the O'Caml 3.08 library (remains compatible with older
	versions). Implementation of unused functions still
	incomplete.

	2004-07-26
	minor fixes and improvements in make process

	2004-06-29
	workarounds for new Intel compiler bugs ...
	no rebuild of madgraph/comphep executables after 'make clean'
	bug fix in phase space routine:
	wrong energy for massive initial particles
	bug fix in (new) model interface: name checks for antiparticles
	pre-run checks for comphep improved
	ww-strong model file extended
	Model files particle name fixes, chep SM vertices included

	2004-06-22
	O'Mega RELEASE: version 0.8
	O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings

	2004-05-05
	Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
	NAG compiler: set number of continuation lines to 200 as default
	Extended format for cross section summary; appears now in whizard.out
	Fixed 'bundle' feature

	2004-04-28
	Fixed compatibility with revised O'Mega SM_ac model
	Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
	Fixed bug in comphep module: Vtb was overlooked

	##################################################################

	2004-04-15
	RELEASE: version 1.28
	Fixed bug: Color factor was missing for O'Mega processes with
	four quarks and more
	Manual partially updated

	2004-04-08
	Support for grid files in binary format
	New default value show_histories=F (reduce output file size)
	Revised phase space switches: removed annihilation_lines,
	removed s_channel_resonance, changed meaning of
	extra_off_shell_lines, added show_deleted_channels
	Bug fixed which lead to omission of some phase space channels
	Color flow guessed only if requested by guess_color_flow

	2004-03-10
	New model interface: Only one model name specified in whizard.prc
	All model-dependent files reside in conf/models (modellib removed)

	2004-03-03
	Support for input/output in SUSY Les Houches Accord format
	Split event files if requested
	Support for overall time limit
	Support for CIRCE and CIRCE2 generator mode
	Support for reading beam events from file

	2004-02-05
	Fixed compiler problems with Intel Fortran 7.1 and 8.0
	Support for catching signals

	##################################################################

	2003-08-06
	RELEASE: version 1.27
	User-defined PDF libraries as an alternative to the standard PDFLIB

	2003-07-23
	Revised phase space module: improved mappings for massless particles,
	equivalences of phase space channels are exploited
	Improved mapping for PDF (hadron colliders)
	Madgraph module: increased max number of color flows from 250 to 1000

	##################################################################

	2003-06-23
	RELEASE: version 1.26
	CIRCE2 support
	Fixed problem with 'TC' integer kind [Intel compiler complained]

	2003-05-28
	Support for drawing histograms of grids
	Bug fixes for MSSM definitions

	##################################################################

	2003-05-22
	RELEASE: version 1.25
	Experimental MSSM support with ISAJET interface
	Improved capabilities of generating/analyzing weighted events
	Optional drawing phase space diagrams using FeynMF

	##################################################################

	2003-01-31
	RELEASE: version 1.24
	A few more fixes and workarounds (Intel and Lahey compiler)

	2003-01-15
	Fixes and workarounds needed for WHIZARD to run with Intel compiler
	Command-line option interface for the Lahey compiler

	Bug fix: problem with reading whizard.phs

	##################################################################

	2002-12-10
	RELEASE: version 1.23

	Command-line options (on some systems)

	Allow for initial particles in the event record, ordered:
	[beams, initials] - [remnants] - outgoing partons

	Support for PYTHIA 6.2: Les Houches external process interface
	String pythia_parameters can be up to 1000 characters long
	Select color flow states in (internal) analysis
	Bug fix in color flow content of raw event files

	Support for transversal polarization of fermion beams
	Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
	'Test' matrix elements optionally respect polarization

	User-defined code can be inserted for spectra, structure functions
	and fragmentation

	Time limits can be specified for adaptation and simulation
	User-defined file names and file directory
	Initial weights in input file no longer supported

	Bug fix in MadGraph (wave function counter could overflow)

	Bug fix: Gamelan (graphical analysis) was not built if noweb absent

	##################################################################

	2002-03-16
	RELEASE: version 1.22
	Allow for beam remnants in the event record

	2002-03-01
	Handling of aliases in whizard.prc fixed (aliases are whole tokens)

	2002-02-28
	Optimized phase space handling routines
	(total execution time reduced by 20-60%, depending on process)

	##################################################################

	2002-02-26
	RELEASE: version 1.21
	Fixed ISR formula (ISR was underestimated in previous versions).
	New version includes ISR in leading-log approximation up to
	third order. Parameter ISR_sqrts renamed to ISR_scale.

	##################################################################

	2002-02-19
	RELEASE: version 1.20
	New process-generating method 'test' (dummy matrix element)
	Compatibility with autoconf 2.50 and current O'Mega version

	2002-02-05
	Prevent integration channels from being dropped (optionally)
	New internal mapping for structure functions improves performance
	Old whizard.phx file deleted after recompiling (could cause trouble)

	2002-01-24
	Support for user-defined cuts and matrix element reweighting
	STDHEP output now written by write_events_format=20 (was 3)

	2002-01-16
	Improved structure function handling; small changes in user interface:
	new parameter structured_beams in &process_input
	parameter fixed_energy in &beam_input removed
	Support for multiple initial states
	Eta-phi (cone) cut possible (hadron collider applications)
	Fixed bug: Whizard library was not always recompiled when necessary
	Fixed bug: Default cuts were insufficient in some cases
	Fixed bug: Unusable phase space mappings generated in some cases

	2001-12-06
	Reorganized document source

	2001-12-05
	Preliminary CIRCE2 support (no functionality yet)

	2001-11-27
	Intel compiler support (does not yet work because of compiler bugs)
	New cut and analysis mode cos-theta* and related
	Fixed circular jetset_interface dependency warning
	Some broadcast routines removed (parallel support disabled anyway)
	Minor shifts in cleanup targets (Makefiles)
	Modified library search, check for pdflib8*

	2001-08-06
	Fixed bug: I/O unit number could be undefined when reading phase space
	Fixed bug: Unitialized variable could cause segfault when
	event generation was disabled
	Fixed bug: Undefined subroutine in CIRCE replacement module
	Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
	(CompHEP model sm-GF #5, O'Mega model SM_ac)
	Fixed portability issue: Makefile did rely on PWD environment variable
	Fixed portability issue: PYTHIA library search ambiguity resolved

	2001-08-01
	Default whizard.prc and whizard.in depend on activated modules
	Fixed bug: TEX=latex was not properly enabled when making plots

	2001-07-20
	Fixed output settings in PERL script calls
	Cache enabled in various configure checks

	2001-07-13
	Support for multiple processes in a single WHIZARD run. The
	integrations are kept separate, but the generated events are mixed
	The whizard.evx format has changed (incompatible), including now
	the color flow information for PYTHIA fragmentation
	Output files are now process-specific, except for the event file
	Phase space file whizard.phs (if present) is used only as input,
	program-generated phase space is now in whizard.phx

	2001-07-10
	Bug fix: Undefined parameters in parameters_SM_ac.f90 removed

	2001-07-04
	Bug fix: Compiler options for the case OMEGA is disabled
	Small inconsistencies in whizard.out format fixed

	2001-07-01
	Workaround for missing PDFLIB dummy routines in PYTHIA library

	##################################################################

	2001-06-30
	RELEASE: version 1.13
	Default path /cern/pro/lib in configure script

	2001-06-20
	New fragmentation option: Interface for PYTHIA with full color flow
	information, beam remnants etc.

	2001-06-18
	Severe bug fixed in madgraph interface: 3-gluon coupling was missing
	Enabled color flow information in madgraph

	2001-06-11
	VAMP interface module rewritten
	Revised output format: Multiple VAMP iterations count as one WHIZARD
	iteration in integration passes 1 and 3
	Improved message and error handling
	Bug fix in VAMP: handle exceptional cases in rebinning_weights

	2001-05-31
	new parameters for grid adaptation: accuracy_goal and efficiency_goal

	##################################################################

	2001-05-29
	RELEASE: version 1.12
	bug fixes (compilation problems): deleted/modified unused functions

	2001-05-16
	diagram selection improved and documented

	2001-05-06
	allow for disabling packages during configuration

	2001-05-03
	slight changes in whizard.out format; manual extended

	##################################################################

	2001-04-20
	RELEASE: version 1.11
	fixed some configuration and compilation problems (PDFLIB etc.)

	2001-04-18
	linked PDFLIB: support for quark/gluon structure functions

	2001-04-05
	parameter interface written by PERL script
	SM_ac model file: fixed error in continuation line

	2001-03-13
	O'Mega, O'Caml 3.01: incompatible changes
	O'Mega, src/trie.mli: add covariance annotation to T.t
	This breaks O'Caml 3.00, but is required for O'Caml 3.01.
	O'Mega, many instances: replace `sig include Module.T end' by
	`Module.T', since the bug is fixed in O'Caml 3.01

	2001-02-28
	O'Mega, src/model.mli:
	new field Model.vertices required for model functors, will
	retire Model.fuse2, Model.fuse3, Model.fusen soon.

	##################################################################

	2001-03-27
	RELEASE: version 1.10
	reorganized the modules as libraries
	linked PYTHIA: support for parton fragmentation

	2000-12-14
	fixed some configuration problems (if noweb etc. are absent)

	##################################################################

	2000-12-01
	RELEASE of first public version: version 1.00beta
	Index: trunk/contrib/pythia6/pythia.F
	===================================================================
	--- trunk/contrib/pythia6/pythia.F (revision 0)
	+++ trunk/contrib/pythia6/pythia.F (revision 8889)
	@@ -0,0 +1,81251 @@
	+C*********************************************************************
	+C*********************************************************************
	+C* **
	+C* Dec 2012 **
	+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 xf 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 44 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 44 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 CPRO12,CVER12
	+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
	+ &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
	+ &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
	+ &/PYBINS/,/PYLH3P/,/PYLH3C/
	+
	+C...PYDAT1, containing status codes and most parameters.
	+ DATA MSTU/
	+ & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
	+ 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
	+ 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
	+ 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
	+ 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
	+ 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 7 30*0,
	+ 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
	+ & 80*0/
	+ DATA (PARU(I),I=1,100)/
	+ & 3.141592653589793D0, 6.283185307179586D0,
	+ & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
	+ 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
	+ 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
	+ 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
	+ 6 40*0D0/
	+ DATA (PARU(I),I=101,200)/
	+ & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
	+ & 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
	+ 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
	+ 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
	+ 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
	+ 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
	+ 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
	+ DATA MSTJ/
	+ & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
	+ 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
	+ 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
	+ 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
	+ 6 40*0,
	+ & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
	+ 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
	+ 2 80*0/
	+ DATA PARJ/
	+ & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
	+ & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
	+ 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
	+ 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
	+ 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
	+ 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
	+ 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
	+ 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
	+ 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
	+ 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
	+ 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
	+ 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
	+ 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
	+ 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
	+ 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
	+ 4 10*0D0,
	+ 5 10*0D0,
	+ 6 10*0D0,
	+ 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
	+ 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
	+ 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
	+ 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
	+ 9 5*0D0/
	+
	+C...PYDAT2, with particle data and flavour treatment parameters.
	+ DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
	+ &-3,0,-3,60,3,90,3,20,3,40,-1,410,2,-1,200,33,70,33,30,
	+ &33,30,33,60,33,30,33,40,-2,-3,21,20,4,23,6,2-2,2*-3,
	+ &0,21,20,23,-2,2-3,20,-3,21,20,3,0,24,23,26,3,21,20,
	+ &23,20,4,23,26,23,6,2-2,2-3,0,-3,0,21,20,23,0,3,2*-2,
	+ &2-3,20,2-3,0,21,20,23,20,23,-2,2-3,20,2-3,20,-3,2*0,
	+ &23,40,23,20,23,20,23,40,23,20,23,30,3,2*0,3,0,3,0,3,
	+ &20,3,0,3,30,-1,2,-1,2,-1,2,-3,0,-3,0,-3,40,3,20,3,0,-1,2,-1,
	+ &2,-1,2,-3,0,-3,0,-3,20,3,30,3,80,-1,2,-3,60,3,26,0,3,40,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)/81,120,2,200,1,1070,-1,0,2*-1,
	+ &20,-1,30,2-1,30,2-1,40,-1,50,2-1,40,2-1,50,2-1,6*0,
	+ &-1,70,2-1,50,2-1,60,2-1,70,2-1,80,-1,560,61,60,2,7*0,
	+ &61,90,2,30,2,0,52,21,170,6*2,
	+ &830,121,90,2,30,25*0/
	+ DATA (KCHG(I,3),I= 1, 500)/81,20,81,50,1,90,1,20,1,3*0,
	+ &21,390,1,0,21,200,31,40,61,30,91,30,121,40,1001,20,
	+ &21,20,41,20,61,20,81,30,1,0,21,0,31,0,41,30,121,30,
	+ &1,20,1,0,121,0,1,30,1,80,41,50,31,0,1,30,21,70,1,
	+ &810,211,30,1,250/
	+ 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,
	+ &2400D0,20D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
	+ &50D0,91.188D0,80.45D0,115D0,60D0,500D0,900D0,500D0,3*300D0,
	+ &30D0,5000D0,200D0,400D0,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,
	+ &21.23D0,1.282D0,21.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
	+ &25.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32500D0,
	+ &3110D0,350D0,3210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
	+ &4400D0,1000D0,3500D0,1200D0,750D0,2200D0,70D0,3*3.1D0,
	+ &39.5D0,2250D0,
	+ &81*0,
	+C...UED
	+ &586.,588.,586.,588.,586.,586.,6*598.,
	+ &3505.,6516.,640.,501.,536.,536.,25*0.D0/
	+ DATA (PMAS(I,2),I= 1, 500)/50D0,1.39816D0,160D0,2.47813D0,
	+ &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
	+ &3.3752D0,4.17669D0,30D0,417.29147D0,0.39162D0,600D0,0.151D0,
	+ &0.107D0,20D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,20D0,
	+ &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
	+ &20D0,0.023D0,20D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
	+ &20D0,0.02D0,20D0,0.02D0,20D0,0.02D0,20D0,0.02D0,5*0D0,0.12D0,
	+ &30D0,0.12D0,20D0,20.12D0,30D0,0.0394D0,4*0D0,0.036D0,0D0,
	+ &0.0358D0,20D0,0.0099D0,0D0,0.0091D0,740D0,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,
	+ &80.05D0,0D0,0.01D0,20.4D0,0.025D0,20.174D0,0.053D0,30.05D0,
	+ &0.0009D0,40.05D0,30D0,191D0,0D0,71D0,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,
	+ &70D0,60.01D0,0.25499D0,0.28446D0,131*0D0/
	+ DATA (PMAS(I,3),I= 1, 500)/50D0,13.98156D0,160D0,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,
	+ &600D0,0.4D0,0.25D0,20D0,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,
	+ &20D0,0.12D0,20D0,0.05D0,0.005D0,0D0,0.01D0,20D0,0.05D0,20D0,
	+ &0.05D0,20D0,0.05D0,20D0,0.05D0,50D0,0.14D0,30D0,0.14D0,2*0D0,
	+ &20.14D0,30D0,0.04D0,40D0,0.035D0,0D0,0.035D0,20D0,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,60.1D0,0.05D0,0.1D0,0D0,0.02D0,20.3D0,
	+ &0.05D0,20.3D0,0.02D0,20.1D0,0.03D0,0.001D0,40.1D0,30D0,
	+ &1910D0,0.00001D0,710D0,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
	+ &120.2D0,90.1D0,0.2,10.,0.07,0.3,25*0.D0/
	+ DATA (PMAS(I,4),I= 1, 500)/120D0,658654D0,0D0,0.0872D0,680D0,
	+ &0.1D0,0.387D0,160D0,0.00003D0,20D0,15500D0,7804.5D0,5*0D0,
	+ &26.762D0,30D0,3709D0,50D0,0.317D0,20D0,0.1244D0,20D0,0.14D0,
	+ &50D0,0.468D0,20D0,0.462D0,20D0,0.483D0,20D0,0.15D0,18*0D0,
	+ &44.34D0,0D0,78.88D0,40D0,23.96D0,20D0,49.1D0,0D0,87.1D0,0D0,
	+ &24.6D0,40D0,0.0618D0,0.029D0,60D0,0.106D0,60D0,0.019D0,20D0,
	+ &70.1D0,40D0,0.342D0,20.387D0,60D0,20.387D0,60D0,0.387D0,
	+ &0D0,0.387D0,20D0,80.387D0,0D0,90.387D0,1200D0,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)/50,31,60,1,0,1,50,31,60,1,0,
	+ &41,30,21,400,31,160,31,20,91,0,321,20,1,30,1,20,21,
	+ &20,31,20,41,0,51,20,41,20,51,20,61,0,71,20,51,2*0,
	+ &61,20,71,20,81,0,751,0,71,0,1,0,1,0,261,70,81,
	+ &81*0,
	+C...UED
	+ &51,0,51,0,131,250/
	+ 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,20,153,162,174,190,210,60,289,0,311,334,420,
	+ &503,30,530,539,400,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,20,1045,30,1046,2*0,
	+ &1049,1052,20,1053,1055,1058,20,1062,1063,1066,1069,0,1072,1077,
	+ &1079,1082,1084,20,1088,1089,1090,1166,20,1170,1171,1172,1173,
	+ &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
	+ &1205,1209,1213,20,1217,1218,1219,1236,1245,20,1254,1255,1256,
	+ &1257,1258,1267,20,1276,1277,1278,1279,1280,1289,1290,20,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)/58,15,210,2*0,4,2,5,2,54,2,5,3,
	+ &20,9,12,16,20,79,60,22,0,23,86,83,27,30,9,1,400,1,4,9,16*0,2,
	+ &5,29,22,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,20,1,30,3,20,3,1,20,2,
	+ &3,4,20,1,33,0,5,2,3,2,4,20,21,76,4,20,41,4,2*0,1,2,1,2,4,1,
	+ &0,74,20,21,17,29,20,41,29,20,41,9,1,9,20,89,0,99,4*1,
	+ &5,3,2,5,2,5,7,4,72,1,92,1,22,14,22,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,38,3,26,27,26,6,37,26,9,24,3,2,20,
	+ &322,15,12,27,70,61,26,30,
	+ &81*0,
	+C...UED
	+ &62,63,91,24,1,18,6,250/
	+ DATA (MDME(I,1),I= 1,8000)/61,-1,71,-1,71,-1,71,-1,7*1,-1,
	+ &71,-1,1,7-1,81,2-1,81,2-1,731,-1,21,-1,51,0,2-1,6*1,0,
	+ &2-1,31,-1,61,2-1,61,2-1,31,-1,31,-1,31,5-1,31,-1,61,
	+ &2-1,31,-1,51,621,61,2-1,61,8-1,31,-1,31,-1,31,5-1,
	+ &31,4-1,61,2-1,31,-1,121,621,61,2-1,31,-1,91,621,
	+ &31,-1,31,-1,1,181,41,2-1,21,-1,12491,2-1,3771,2-1,
	+ &19211,2-1,61,2-1,1331,2-1,61,2-1,101,-1,31,-1,31,5-1,
	+ &31,-1,161,2-1,61,2-1,161,2-1,61,2-1,131,-1,31,-1,31,
	+ &5-1,31,-1,
	+ &649*0,
	+C...UED
	+ &101,20,151,30,91,51,0,51,0,51,0,5*1,0,
	+ &1,241,29120/
	+ DATA (MDME(I,2),I= 1,8000)/43102,40,102,0,653,3102,4*0,102,
	+ &20,3102,40,102,20,6102,42,6102,242,20,841,20,36*41,
	+ &8102,0,102,0,102,20,21102,832,80,1632,40,832,90,6253,
	+ &832,140,1632,70,832,160,6253,832,130,6253,432,50,
	+ &1853,632,40,12,242,211,942,0,2,3,150,442,50,3,120,2,
	+ &30,1,0,3,160,23,150,242,23,180,23,30,1,110,2242,410,
	+ &23,90,1642,450,3,100,1042,200,213,60,12,20,12,0,12,
	+ &1442,160,48,313,242,90,1442,160,48,313,242,90,14*42,
	+ &190,48,313,242,60,211,2842,50,32,30,432,24,0,32,45*0,
	+ &1442,520,1013,242,211,40,242,211,60,242,211,0,242,
	+ &211,242,211,242,211,242,211,242,211,242,211,242,2*11,
	+ &20,342,80,48,313,2042,40,1842,40,942,0,16242,500,212,
	+ &170,232,330,12,90,32,20,12,110,432,24,50,240453,4*32,
	+ &30,632,30,432,30,5032,353,120,832,120,6651,632,9*0,
	+ &932,170,651,100,832,150,1632,140,832,180,832,180,
	+ &16*32,
	+C...UED
	+ &6530,300,90,120,370,29120/
	+ DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
	+ &0.998205D0,350D0,1D0,60D0,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,20.00205D0,20.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,20D0,0.321369D0,0.016494D0,20D0,0.016502D0,
	+ &0.320615D0,20D0,0.00001D0,0.000591D0,60D0,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,50D0,20.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,
	+ &690D0,0.000001D0,0.000072D0,0.001333D0,40D0,0.000001D0,
	+ &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
	+ &660D0,0.000014D0,0.082234D0,20D0,0.000013D0,0.003746D0,0D0,
	+ &0.913992D0,180D0,30.215119D0,0.214724D0,2*0D0,0.06996D0,
	+ &0.069959D0,0D0,21D0,20.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,20.1939D0,20.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,20.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,20.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,20.004D0,0.07D0,0.065D0,20.005D0,20.011D0,50.001D0,
	+ &0.07D0,0.065D0,20.005D0,20.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,20.003D0,20.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,20.002D0,20.004D0,2*0.002D0,0.034D0,
	+ &0.027D0,20.002D0,20.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,
	+ &20.005D0,20.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,
	+ &40.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,40.005D0,0.25D0,
	+ &0.0952D0,0.94D0,0.06D0,20.4D0,20.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,
	+ &20.005D0,0.008D0,0.012D0,0.02D0,0.055D0,20.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,20.3D0,20.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,20.3D0,20.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,20.06D0,0.516D0,0.483D0,0.001D0,0.88D0,20.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,21D0,0.018D0,20.005D0,0.003D0,0.002D0,
	+ &20.006D0,0.018D0,20.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,
	+ &40.004D0,20.002D0,20.004D0,0.003D0,0.002D0,20.003D0,
	+ &30.002D0,20.001D0,0.002D0,20.001D0,20.002D0,0.0013D0,
	+ &0.0018D0,50.001D0,40.003D0,20.005D0,20.002D0,2*0.001D0,
	+ &20.002D0,20.001D0,0.2432D0,0.057D0,20.035D0,0.15D0,20.075D0,
	+ &0.03D0,20.015D0,20.08D0,0.76D0,0.08D0,41D0,20.08D0,0.76D0,
	+ &0.08D0,1D0,20.5D0,1D0,20.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
	+ DATA (BRAT(I) ,I=1189,1381)/20.08D0,0.76D0,30.08D0,0.76D0,
	+ &30.08D0,0.76D0,30.08D0,0.76D0,30.08D0,0.76D0,30.08D0,0.76D0,
	+ &30.08D0,0.76D0,0.08D0,21D0,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,41D0,20.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,41D0,20.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,41D0,0.52D0,0.26D0,0.11D0,20.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,20.015D0,20.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,80.5D0,0.02D0,0.98D0,1D0,40.5D0,3*0.146D0,
	+ &30.05D0,0.15D0,20.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
	+ &0.667D0,0.333D0,40.25D0,0.667D0,0.333D0,0.667D0,0.333D0,20.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,60D0,1D0,60D0,1D0,4*0.013853D0,0.562703D0,
	+ &0.376702D0,0.00518D0,40.006254D0,0.974985D0,70D0,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,30.0633D0,0.063299D0,0.063295D0,0.056281D0,20D0,
	+ &60.020495D0,20D0,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,61D0,0.095602D0,20.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,
	+ &20D0,0.000011D0,0.001258D0,50D0,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,20D0,0.055332D0,20.319757D0,0.121576D0,2*0.001556D0,
	+ &40D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,30D0,
	+ &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,40D0,0.035282D0,0.001812D0,20D0,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.,
	+ &30.D0,60.08333D0,
	+ &30.D0,60.08333D0,
	+ &6*0.166667D0,
	+ &2912*0.D0/
	+ DATA (KFDP(I,1),I= 1, 377)/21,22,23,4-24,25,21,22,23,424,25,
	+ &21,22,23,4-24,25,21,22,23,424,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,424,25,237,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,
	+ &21000023,31000025,41000035,21000024,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,223,25,35,4-1,4-3,4-5,4*-7,-11,-13,
	+ &-15,-17,324,1,2,3,4,5,6,7,8,11,13,15,17,21,222,23,24,23,25,24,
	+ &37,23,25,36,1000022,21000023,31000025,41000035,21000024,
	+ &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,21000023,31000025,41000035,21000024,
	+ &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,21000022,21000023,21000025,21000035,
	+ &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,222,211,22,111,211,22,211,221,111,11,211,111,2211,
	+ &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
	+ &323,313,321,3311,-13,3211,12,14,311,2*321,311,321,313,323,313,
	+ &323,311,4321,211,111,322,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,2111,2221,2331,2113,2223,
	+ &2333,-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,2421,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,22,2431,421,411,423,413,82,11,13,82,
	+ &443,82,612,614,216,3-411,3-413,2-411,2-413,2441,2*443,
	+ &220443,22,24,2,4,511,521,511,523,513,523,513,521,511,612,
	+ &614,216,3-421,3-423,2-421,2-423,2441,2443,220443,22,
	+ &24,2,4,521,511,521,513,523,513,523,511,521,612,614,216,
	+ &3-431,3-433,2-431,2-433,3441,3443,320443,22,2*4,2,4,531/
	+ DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,24,212,2*14,
	+ &216,42,44,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,22212,2112,-12,3122,3212,3112,2212,22112,-12,2*3122,3222,
	+ &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
	+ &3312,23122,3212,3322,3312,3122,3322,3312,-12,24122,7-11,7-13,
	+ &22224,22212,22214,23122,23212,23214,53222,43224,2*3322,
	+ &3324,22224,72212,52214,22112,22114,23122,23212,23214,
	+ &23222,23224,42,3,22,1,22,-11,-13,22,44122,-11,-13,22,
	+ &34132,34232,-11,-13,22,4332,-11,-13,22,-11,-13,2*2,-11,-13,
	+ &22,-11,-13,22,-11,-13,22,-11,-13,22,-11,-13,22,25122,-12,
	+ &-14,-16,54122,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,45122,-12,-14,-16,2*-2,
	+ &2-4,-2,-4,-12,-14,-16,2-2,2-4,-2,-4,25132,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,
	+ &2311,321,311,321,313,323,321,211,111,321,130,310,2211,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,221,213,-213,113,213,10211,10111,-10211,2221,213,2*113,
	+ &-213,2321,2311,113,323,2313,323,313,-313,323,-323,423,2413,
	+ &2423,413,443,82,523,2513,2523,2513,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,
	+ &212,214,216,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,
	+ &212,214,216,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,
	+ &212,214,216,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,61000022,61000023,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,21000039,61000022,61000023,61000025,
	+ &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,22,-1,2,-1,32,-1,2*4,-3,
	+ &34,-3,26,51000039,161000022,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,
	+ &161000022,161000023,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,21000039,151000024,
	+ &61000022,61000023,61000025,61000035,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,32,-1,24,-3,34,-3,26,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,
	+ &41000011,1000012,2000012,1000012,2000012,212,214,216,3*-14,
	+ &3-16,3-2,3-4,3-6,1000039,-1000024,-1000037,1000022,1000023,
	+ &1000025,1000035,41000013,1000014,2000014,1000014,2000014,212,
	+ &214,216,3-12,3-16,3-2,3-4,3*-6,1000039,-1000024,-1000037,
	+ &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
	+ &1000016,2000016,212,214,216,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,911,9-11,11,-11,11,-11,913,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,3443,3553,2*24,
	+ &23000211,222,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
	+ &18,224,33000211,224,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,224,-24,23,222,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
	+ &14,15,16,17,18,222,23,224,23,22,224,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)/31,2,4,6,8,1,32,1,3,5,7,2,3*3,2,4,
	+ &6,8,3,34,1,3,5,7,4,35,2,4,6,8,5,36,1,3,5,7,6,5,61000006,3*7,
	+ &2,4,6,8,7,4,6,38,1,3,5,7,8,5,7,211,12,11,12,211,213,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,
	+ &215,16,15,16,15,217,18,17,218,217,-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,225,-37,-24,336,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,223,-24,225,-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,21000016,-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,1112,1114,2211,2213,
	+ &211,20213,2321,2323,211,213,211,213,211,213,211,213,211,213,
	+ &211,213,3211,213,211,2321,8211,2113,3*211,111,22,211,111,211,
	+ &111,4211,812,814,2211,2213,2111,221,2*113,223,333,20213,
	+ &211,2321,323,2311,313,-211,111,113,2211,321,2211,311,321,310,
	+ &211,-211,4211,321,4211,113,2*211,-321,111,22,-211,111,-211,111,
	+ &-211,211,-211,211,16,512,514,3211,3213,211,2111,2113,
	+ &2-311,2-313,-2112,3321,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,
	+ &4211,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,212,214,2,3,2,3,212,214,2,1,22,411,421,411,421,21,
	+ &-11,-13,-15,-1,-2,-3,-4,221,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,2111,222,111,211,-321,-211,111,
	+ &11,2-211,712,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,2111,2211,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,2111,2211,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,
	+ &2111,2211,-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,
	+ &2321,311,22,2-82,-211,111,-211,111,211,111,211,111,-321,-311,
	+ &-321,-311,411,421,411,421,22,221,-211,2211,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,221,211,111,322,1,22,41,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,21,42,224,237,2,1,3,5,1,3,5,1,3,5,-3,2-5,3,24,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,23,44,224,237,4,1,3,5,1,3,5,1,3,5,-3,
	+ &2-5,5,26,45,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,25,46,224,237,6,4,-15,
	+ &16,1,3,5,1,3,5,1,3,5,-3,2-5,11,212,411,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,211,412,224,237,11,13,15,11,13,15,1,3,5,1,3,5,1,3,5,
	+ &13,214,413,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,213,414,224,237,11,13,15,11,13,15,1,3,5,1,3,
	+ &5,1,3,5,15,216,415,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,215,416,224,237,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,22,2-3,24,2-5,26,2-11,212,2-13,214,2-15,216,-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,
	+ &24,-3,4,-3,36,-5,24,-3,36,-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,437,2-1,22,2-3,24,2-5,26,2-11,212,2-13,
	+ &214,2-15,216,-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,36,-5,24,-3,36,-5,26,1,22,41,23,25,35,36,2*-24/
	+ DATA (KFDP(I,2),I=3670,4183)/2-37,21,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,21,42,23,25,35,
	+ &36,224,237,2,1,3,5,1,3,5,1,3,5,-3,2-5,3,24,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,23,44,23,25,35,36,224,237,4,1,3,5,1,
	+ &3,5,1,3,5,-3,2-5,5,26,45,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,
	+ &25,46,23,25,35,36,224,237,6,1,3,5,1,3,5,1,3,5,-3,2*-5,11,
	+ &212,411,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,214,413,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,216,415,
	+ &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,321,31,42,1,211,
	+ &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,31,33,35,-13,13,-15,15,3-1,3-3,
	+ &3-5,31,33,35,-11,11,-15,15,3-1,3-3,3-5,31,33,35,-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,23000111,23000221,-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)/810,14,60,216,20,6*111,310,130,
	+ &20,3111,310,130,321,113,211,223,221,2113,2211,2223,2221,
	+ &2113,221,2113,2213,-213,113,2111,310,130,310,130,2*310,130,
	+ &4020,43,44,1,4,3,22,0,-11,80,-211,50,2*111,211,-211,211,
	+ &-211,100,111,40,2111,-211,-11,11,-13,22,111,30,22,3*0,111,
	+ &211,40,111,110,111,-211,60,-211,3111,70,111,-211,50,2*221,
	+ &30,111,50,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,2211,-211,-311,211,111,3211,-211,7211,70,111,-211,
	+ &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
	+ &-321,-313,-323,-211,-213,220,111,113,-311,2-211,211,-211,310,
	+ &-211,2111,211,2-211,-321,-211,2211,-211,111,-211,2211,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,160,-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,160,-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,190,-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,130,221,11*0,
	+ &2112,60,2212,120,23122,3212,100,3322,2*0,3122,3212,3214,2112,
	+ &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,520,33,1,6*0,
	+ &43,40,43,60,43,0,283,20,34122,80,4,1,4,3,22,4*4,1,4,3,
	+ &22,44,1,4,3,22,40,44,1,4,3,22,44,1,4,3,22,40,44,1,4,3,
	+ &22,0,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,2*2,
	+ &44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,4*4,1,4,
	+ &3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,2*2,
	+ &44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,44,1,4,3,22,4*4,1,4,
	+ &3,22,310,211,111,450,-211,2111,-211,3111,-211,111,211,300,
	+ &-211,111,130,221,-211,111,1990,25,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,50,-12,12,-14,14,-16,16,-2,2,-4,4,20,-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,
	+ &24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,2*4,3,-3,
	+ &26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,2*6,5,-5,
	+ &22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,2*2,1,-1/
	+ DATA (KFDP(I,3),I=2784,3354)/24,3,-3,26,5,-5,22,1,-1,24,3,-3,
	+ &26,5,-5,3,-3,5,-5,1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,70,
	+ &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
	+ &-16,-1,-3,-5,-2,-4,50,-12,12,-14,14,-16,16,-2,2,-4,4,20,-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,50,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,50,
	+ &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
	+ &-2,2,-4,4,20,-12,12,-14,14,-16,16,-2,2,-4,4,520,-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,
	+ &22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,2*2,1,-1,
	+ &24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,2*4,3,-3,
	+ &26,5,-5,22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,2*6,5,-5,
	+ &22,1,-1,24,3,-3,26,5,-5,22,1,-1,24,3,-3,26,5,-5,3,-3,5,-5,
	+ &1,3,-3,5,-5,1,3,5,-5,1,5,-5,1,3,5,-5,1,3,3510,-5,950,2,4,6,2,4,
	+ &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,29900014,29900016,2,4,6,2,4,
	+ &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,29900012,29900016,2,4,6,2,4,
	+ &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,29900012,29900014,3831*0/
	+ DATA (KFDP(I,4),I= 1,8000)/940,4111,60,111,20,-211,0,-211,
	+ &30,111,2-211,0,111,0,2111,113,221,2111,-213,-211,211,113,
	+ &6111,310,2130,4020,1381,410,-11,100,111,-211,40,111,620,
	+ &111,211,111,211,70,111,211,111,211,350,2-211,2111,211,111,
	+ &-211,2211,2-211,130,-211,111,-211,111,40,-211,111,-211,111,
	+ &340,111,-211,3111,3-211,2111,3-211,140,-321,-311,3*0,-321,
	+ &-311,200,-3,430,61,390,62,420,63,140,84,40,4-5,40,
	+ &2-5,670,-211,111,50,-211,111,520,2101,2103,22101,60,4*81,
	+ &40,481,60,481,0,2881,130,62101,1881,40,1881,40,981,0,
	+ &16281,310,-211,111,6516*0/
	+ DATA (KFDP(I,5),I= 1,8000)/960,2111,170,111,70,2*111,0,
	+ &3111,0,111,5970,-211,2111,-211,111,-211,111,650,111,-211,
	+ &3111,-211,111,71930/
	+
	+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','K0','K_20','K+','K+','K_2+','eta''','phi',
	+ &'f''_2','D+','D+','D_2+','D0','D0','D_20','D_s+','D*_s+',
	+ &'D_2s+','eta_c','J/psi','chi_2c','B0','B0','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','Sigma0','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','Z0','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','Kbar0','K_2bar0','K-','K-','K_2-',3' ','D-','D-',
	+ &'D_2-','Dbar0','Dbar0','D_2bar0','D_s-','D_s-','D*_2s-',
	+ &3' ','Bbar0','Bbar0','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',
	+ &'Sigmabar0','Sigmabar-','Sigmabar-','ss_1bar','Xibar+',
	+ &'Xibar+','Xibar0','Xibar0','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' ','dbar','ubar',
	+ &'ebar+','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','Z0','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)/160,41,40,61,50,51,0,
	+ &51,50,61,40,41,160,160,41,40,61,50,51,0,51,50,
	+ &61,40,41,160/
	+ 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, 427, 2012, 12, 12, 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, 92, 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)/50,31,80,1,50,31,60,1,0,4*1,
	+ &30,21,2540,192,0,72,0,2,0,2,0,261,70,62,2*1,
	+ &810,211,41,250/
	+
	+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 -> qDi + qSbarj', 'qi + qjbar -> qDi + qDbarj',
	+ &'qi + qj -> q_Di + q_Sj ', 'qi + qibar -> qDj + qDbarj',
	+ &21*' '/
	+ DATA (PROC(I),I=341,380)/
	+ 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
	+ 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
	+ 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
	+ 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
	+ 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
	+ 5'f + f -> f'' + f'' + H_L++/-- ',
	+ 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
	+ 5'f + fbar'' -> W_R+/- ',5*' ',
	+ 6' ', 'f + fbar -> W_L+ W_L- ',
	+ 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
	+ 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
	+ 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
	+ 6'f + fbar -> W+/- pi_T-/+ ', ' ',
	+ 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
	+ 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
	+ 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
	+ 7'f + fbar'' -> W+/- pi_T0 ',
	+ 7'f + fbar'' -> W+/- pi_T0'' ',
	+ 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
	+ 7'f + fbar -> Z0 Z0 (ETC) '/
	+ DATA (PROC(I),I=381,420)/
	+ 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
	+ 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
	+ 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
	+ 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
	+ 8' ', ' ',
	+ 9'f + fbar -> G* ', 'g + g -> G* ',
	+ 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
	+ 9'g + g -> g + G* ', ' ',
	+ 9 4*' ',
	+ &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
	+ & 18*' '/
	+ DATA (PROC(I),I=421,460)/
	+ 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
	+ 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
	+ 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
	+ 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
	+ 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
	+ 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
	+ 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
	+ 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
	+ 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
	+ 3'q + q~ -> g + cc~[3P2(1)] ',
	+ 3 21 *' '/
	+ DATA (PROC(I),I=461,500)/
	+ 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
	+ 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
	+ 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
	+ 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
	+ 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
	+ 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
	+ 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
	+ 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
	+ 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
	+ 7'q + q~ -> g + bb~[3P2(1)] ',
	+ 7 21 *' '/
	+
	+C...Cross sections and slope offsets.
	+ DATA SIGT/294*0D0/
	+
	+C...Supersymmetry switches and parameters.
	+ DATA IMSS/0,
	+ & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
	+ 1 89*0/
	+ DATA RMSS/0D0,
	+ & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
	+ 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
	+ 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
	+ 3 10*0D0,
	+ 4 0D0,1D0,8*0D0,
	+ 5 49*0D0/
	+C...Initial values for R-violating SUSY couplings.
	+C...Should not be changed here. See PYMSIN.
	+ DATA RVLAM/27*0D0/
	+ DATA RVLAMP/27*0D0/
	+ DATA RVLAMB/27*0D0/
	+
	+C...Technicolor switches and parameters
	+ DATA ITCM/0,
	+ & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 1 89*0/
	+ DATA RTCM/0D0,
	+ & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
	+ 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
	+ 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
	+ 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
	+ 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
	+ 4 200D0, 48*0D0/
	+
	+C...UED switches and parameters.
	+C... IUED(0) empty IUED vector element
	+C... IUED(1) UED ON(=1)/OFF(=0) switch
	+C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
	+C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
	+C... IUED(4) N the number of large extra dimensions
	+C... IUED(5) Selects whether the code takes Lambda (=0)
	+C... or Lambda*R (=1) as input.
	+C... IUED(6) With radiative corrections to the masses (=1)
	+C... or without (=0)
	+C...
	+C... RUED(0) empty RUED vector element
	+C... RUED(1) RINV (1/R) the curvature of the extra dimension
	+C... RUED(2) XMD the (4+N)-dimensional Planck scale
	+C... RUED(3) LAMUED (Lambda cutoff scale)
	+C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
	+C...
	+ DATA IUED/0,0,0,5,6,0,1,93*0/
	+ DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
	+
	+C...Data for histogramming routines.
	+ DATA IHIST/1000,20000,55,1/
	+ DATA INDX/1000*0/
	+
	+C...Data for SUSY Les Houches Accord.
	+ DATA CPRO/'PYTHIA ','PYTHIA '/
	+ DATA CVER/'6.4 ','6.4 '/
	+ DATA MODSEL/200*0/
	+ DATA PARMIN/100*0D0/
	+ DATA RMSOFT/101*0D0/
	+ DATA AU/9*0D0/
	+ DATA AD/9*0D0/
	+ DATA AE/9*0D0/
	+
	+ END
	+
	+C*********************************************************************
	+
	+C...PYCKBD
	+C...Check that BLOCK DATA PYDATA has been loaded.
	+C...Should not be required, except that some compilers/linkers
	+C...are pretty buggy in this respect.
	+
	+ SUBROUTINE PYCKBD
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
	+
	+C...Check a few variables to see they have been sensibly initialized.
	+ IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
	+ &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
	+ &MSTP(1).GT.5) THEN
	+C...If not, abort the run right away.
	+ WRITE(,) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
	+ WRITE(,) 'The program execution is stopped now!'
	+ CALL PYSTOP(8)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYTEST
	+C...A simple program (disguised as subroutine) to run at installation
	+C...as a check that the program works as intended.
	+
	+ SUBROUTINE PYTEST(MTEST)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
	+C...Local arrays.
	+ DIMENSION PSUM(5),PINI(6),PFIN(6)
	+
	+C...Save defaults for values that are changed.
	+ MSTJ1=MSTJ(1)
	+ MSTJ3=MSTJ(3)
	+ MSTJ11=MSTJ(11)
	+ MSTJ42=MSTJ(42)
	+ MSTJ43=MSTJ(43)
	+ MSTJ44=MSTJ(44)
	+ PARJ17=PARJ(17)
	+ PARJ22=PARJ(22)
	+ PARJ43=PARJ(43)
	+ PARJ54=PARJ(54)
	+ MST101=MSTJ(101)
	+ MST104=MSTJ(104)
	+ MST105=MSTJ(105)
	+ MST107=MSTJ(107)
	+ MST116=MSTJ(116)
	+
	+C...First part: loop over simple events to be generated.
	+ IF(MTEST.GE.1) CALL PYTABU(20)
	+ NERR=0
	+ DO 180 IEV=1,500
	+
	+C...Reset parameter values. Switch on some nonstandard features.
	+ MSTJ(1)=1
	+ MSTJ(3)=0
	+ MSTJ(11)=1
	+ MSTJ(42)=2
	+ MSTJ(43)=4
	+ MSTJ(44)=2
	+ PARJ(17)=0.1D0
	+ PARJ(22)=1.5D0
	+ PARJ(43)=1D0
	+ PARJ(54)=-0.05D0
	+ MSTJ(101)=5
	+ MSTJ(104)=5
	+ MSTJ(105)=0
	+ MSTJ(107)=1
	+ IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
	+
	+C...Ten events each for some single jets configurations.
	+ IF(IEV.LE.50) THEN
	+ ITY=(IEV+9)/10
	+ MSTJ(3)=-1
	+ IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
	+ IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
	+ IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
	+ IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
	+ IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
	+ IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
	+
	+C...Ten events each for some simple jet systems; string fragmentation.
	+ ELSEIF(IEV.LE.130) THEN
	+ ITY=(IEV-41)/10
	+ IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
	+ IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
	+ IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
	+ IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
	+ IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
	+ IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
	+ IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
	+ IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
	+ & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
	+
	+C...Seventy events with independent fragmentation and momentum cons.
	+ ELSEIF(IEV.LE.200) THEN
	+ ITY=1+(IEV-131)/16
	+ MSTJ(2)=1+MOD(IEV-131,4)
	+ MSTJ(3)=1+MOD((IEV-131)/4,4)
	+ IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
	+ IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
	+ IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
	+ & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
	+ IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
	+ & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
	+
	+C...A hundred events with random jets (check invariant mass).
	+ ELSEIF(IEV.LE.300) THEN
	+ 100 DO 110 J=1,5
	+ PSUM(J)=0D0
	+ 110 CONTINUE
	+ NJET=2D0+6D0*PYR(0)
	+ DO 130 I=1,NJET
	+ KFL=21
	+ IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
	+ IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
	+ EJET=5D0+20D0*PYR(0)
	+ THETA=ACOS(2D0*PYR(0)-1D0)
	+ PHI=6.2832D0*PYR(0)
	+ IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
	+ IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
	+ IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
	+ IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
	+ DO 120 J=1,4
	+ PSUM(J)=PSUM(J)+P(I,J)
	+ 120 CONTINUE
	+ 130 CONTINUE
	+ IF(PSUM(4)2-PSUM(1)2-PSUM(2)2-PSUM(3)2.LT.
	+ & (PSUM(5)+PARJ(32))**2) GOTO 100
	+
	+C...Fifty e+e- continuum events with matrix elements.
	+ ELSEIF(IEV.LE.350) THEN
	+ MSTJ(101)=2
	+ CALL PYEEVT(0,40D0)
	+
	+C...Fifty e+e- continuum event with varying shower options.
	+ ELSEIF(IEV.LE.400) THEN
	+ MSTJ(42)=1+MOD(IEV,2)
	+ MSTJ(43)=1+MOD(IEV/2,4)
	+ MSTJ(44)=MOD(IEV/8,3)
	+ CALL PYEEVT(0,90D0)
	+
	+C...Fifty e+e- continuum events with coherent shower.
	+ ELSEIF(IEV.LE.450) THEN
	+ CALL PYEEVT(0,500D0)
	+
	+C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
	+ ELSE
	+ CALL PYONIA(5,9.46D0)
	+ ENDIF
	+
	+C...Generate event. Find total momentum, energy and charge.
	+ DO 140 J=1,4
	+ PINI(J)=PYP(0,J)
	+ 140 CONTINUE
	+ PINI(6)=PYP(0,6)
	+ CALL PYEXEC
	+ DO 150 J=1,4
	+ PFIN(J)=PYP(0,J)
	+ 150 CONTINUE
	+ PFIN(6)=PYP(0,6)
	+
	+C...Check conservation of energy, momentum and charge;
	+C...usually exact, but only approximate for single jets.
	+ MERR=0
	+ IF(IEV.LE.50) THEN
	+ IF((PFIN(1)-PINI(1))2+(PFIN(2)-PINI(2))2.GE.10D0)
	+ & MERR=MERR+1
	+ EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
	+ IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
	+ IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
	+ ELSE
	+ DO 160 J=1,4
	+ IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
	+ 160 CONTINUE
	+ IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
	+ ENDIF
	+ IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
	+ & (PFIN(J),J=1,4),PFIN(6)
	+
	+C...Check that all KF codes are known ones, and that partons/particles
	+C...satisfy energy-momentum-mass relation. Store particle statistics.
	+ DO 170 I=1,N
	+ IF(K(I,1).GT.20) GOTO 170
	+ IF(PYCOMP(K(I,2)).EQ.0) THEN
	+ WRITE(MSTU(11),5100) I
	+ MERR=MERR+1
	+ ENDIF
	+ PD=P(I,4)2-P(I,1)2-P(I,2)2-P(I,3)2-P(I,5)**2
	+ IF(ABS(PD).GT.MAX(0.1D0,0.001D0P(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(PZSUM2+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-3PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4PESUM).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.002D0P(I,4)2,0.002D0P(I,5)**2)
	+ & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
	+ WRITE(MSTU(11),5200) I
	+ MERR=MERR+1
	+ ENDIF
	+ 210 CONTINUE
	+
	+C...Listing of erroneous events, and first event of each type.
	+ IF(MERR.GE.1) NERR=NERR+1
	+ IF(NERR.GE.10) THEN
	+ WRITE(MSTU(11),6300)
	+ CALL PYLIST(1)
	+ CALL PYSTOP(9)
	+ ENDIF
	+ IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
	+ IF(MERR.GE.1) WRITE(MSTU(11),6400)
	+ CALL PYLIST(1)
	+ ENDIF
	+ 220 CONTINUE
	+
	+C...List statistics for each process type.
	+ IF(MTEST.GE.1) CALL PYSTAT(1)
	+ 230 CONTINUE
	+
	+C...Summarize result of run.
	+ IF(NERR.EQ.0) WRITE(MSTU(11),6500)
	+ IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
	+
	+C...Format statements for output.
	+ 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
	+ &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
	+ &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
	+ &4(1X,F12.5),1X,F8.2)
	+ 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
	+ 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
	+ &'kinematics')
	+ 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
	+ &'wrong.'/5X,'Execution will be stopped after listing of event.')
	+ 6400 FORMAT(5X,'Faulty event follows:')
	+ 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
	+ 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
	+ &5X,'This should not have happened!')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYHEPC
	+C...Converts PYTHIA event record contents to or from
	+C...the standard event record commonblock.
	+
	+ SUBROUTINE PYHEPC(MCONV)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...HEPEVT commonblock.
	+ PARAMETER (NMXHEP=4000)
	+ COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ DOUBLE PRECISION PHEP,VHEP
	+ SAVE /HEPEVT/
	+
	+C...Store HEPEVT commonblock size (for interfacing issues).
	+ MSTU(8)=NMXHEP
	+
	+C...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))
	+ !!! JRR: uncolored undecayed parton
	+ if (I2 == 0) cycle
	+ 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 CHFRAM12,CHBEAM12,CHTARG12,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/200D0/,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,20.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,50.2D0/,
	+ &NFIN/20*4/
	+ DATA CHLH/'lepton','hadron'/
	+
	+C...Check that BLOCK DATA PYDATA has been loaded.
	+ CALL PYCKBD
	+
	+C...Reset MINT and VINT arrays. Write headers.
	+ MSTI(53)=0
	+ DO 100 J=1,400
	+ MINT(J)=0
	+ VINT(J)=0D0
	+ 100 CONTINUE
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
	+
	+C...Reset error counters.
	+ MSTU(23)=0
	+ MSTU(27)=0
	+ MSTU(30)=0
	+
	+C...Reset processes that should not be on.
	+ MSUB(96)=0
	+ MSUB(97)=0
	+
	+C...Select global FSR/ISR/UE parameter set = 'tune'
	+C...See routine PYTUNE for details
	+ IF (MSTP(5).NE.0) THEN
	+ MSTP5=MSTP(5)
	+ CALL PYTUNE(MSTP5)
	+ ENDIF
	+
	+C...Call user process initialization routine.
	+ IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
	+ MSEL=0
	+ CALL UPINIT
	+ MSEL=0
	+ ENDIF
	+
	+C...Maximum 4 generations; set maximum number of allowed flavours.
	+ MSTP(1)=MIN(4,MSTP(1))
	+ MSTU(114)=MIN(MSTU(114),2*MSTP(1))
	+ MSTP(58)=MIN(MSTP(58),2*MSTP(1))
	+
	+C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
	+ DO 120 I=-20,20
	+ VINT(180+I)=0D0
	+ IA=IABS(I)
	+ IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
	+ DO 110 J=1,MSTP(1)
	+ IB=2*J-1+MOD(IA,2)
	+ IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
	+ IPM=(5-ISIGN(1,I))/2
	+ IDC=J+MDCY(IA,2)+2
	+ IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
	+ & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
	+ 110 CONTINUE
	+ ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
	+ VINT(180+I)=1D0
	+ ENDIF
	+ 120 CONTINUE
	+
	+C...Initialize parton distributions: PDFLIB.
	+ IF(MSTP(52).EQ.2) THEN
	+ PARM(1)='NPTYPE'
	+ VALUE(1)=1
	+ PARM(2)='NGROUP'
	+ VALUE(2)=MSTP(51)/1000
	+ PARM(3)='NSET'
	+ VALUE(3)=MOD(MSTP(51),1000)
	+ PARM(4)='TMAS'
	+ VALUE(4)=PMAS(6,1)
	+ CALL PDFSET(PARM,VALUE)
	+ MINT(93)=1000000+MSTP(51)
	+ ENDIF
	+
	+C...Choose Lambda value to use in alpha-strong.
	+ MSTU(111)=MSTP(2)
	+ IF(MSTP(3).GE.2) THEN
	+ ALAM=0.2D0
	+ NF=4
	+ IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
	+ ALAM=ALAMIN(MSTP(51))
	+ NF=NFIN(MSTP(51))
	+ ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
	+ ALAM=QCDL5
	+ NF=5
	+ ELSEIF(MSTP(52).EQ.2) THEN
	+ ALAM=QCDL4
	+ NF=4
	+ ENDIF
	+ PARP(1)=ALAM
	+ PARP(61)=ALAM
	+ PARP(72)=ALAM
	+ PARU(112)=ALAM
	+ MSTU(112)=NF
	+ IF(MSTP(3).EQ.3) PARJ(81)=ALAM
	+ ENDIF
	+
	+C...Initialize the UED masses and widths
	+ IF (IUED(1).EQ.1) CALL PYXDIN
	+
	+C...Initialize the SUSY generation: couplings, masses,
	+C...decay modes, branching ratios, and so on.
	+ CALL PYMSIN
	+C...Initialize widths and partial widths for resonances.
	+ CALL PYINRE
	+C...Set Z0 mass and width for e+e- routines.
	+ PARJ(123)=PMAS(23,1)
	+ PARJ(124)=PMAS(23,2)
	+
	+C...Identify beam and target particles and frame of process.
	+ CHFRAM=FRAME//' '
	+ CHBEAM=BEAM//' '
	+ CHTARG=TARGET//' '
	+ CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
	+ IF(MINT(65).EQ.1) GOTO 170
	+
	+C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
	+C...For e-gamma allow 2 alternatives.
	+ MINT(121)=1
	+ IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	+ & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
	+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
	+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	+ & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
	+ ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	+ & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
	+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
	+ ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	+ & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
	+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
	+ ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
	+ IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
	+ & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
	+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
	+ ENDIF
	+ MINT(123)=MSTP(14)
	+ IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
	+ &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
	+ IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
	+ IF(MSTP(14).EQ.11) MINT(123)=0
	+ IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
	+ IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
	+ IF(MSTP(14).EQ.15) MINT(123)=2
	+ IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
	+ IF(MSTP(14).EQ.19) MINT(123)=3
	+ ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
	+ IF(MSTP(14).EQ.21) MINT(123)=0
	+ IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
	+ IF(MSTP(14).EQ.24) MINT(123)=1
	+ ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
	+ IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
	+ IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
	+ ENDIF
	+
	+C...Set up kinematics of process.
	+ CALL PYINKI(0)
	+
	+C...Set up kinematics for photons inside leptons.
	+ IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
	+
	+C...Precalculate flavour selection weights.
	+ CALL PYKFIN
	+
	+C...Loop over gamma-p or gamma-gamma alternatives.
	+ CKIN3=CKIN(3)
	+ MSAV48=0
	+ DO 160 IGA=1,MINT(121)
	+ CKIN(3)=CKIN3
	+ MINT(122)=IGA
	+
	+C...Select partonic subprocesses to be included in the simulation.
	+ CALL PYINPR
	+ MINT(101)=1
	+ MINT(102)=1
	+ MINT(103)=MINT(11)
	+ MINT(104)=MINT(12)
	+
	+C...Count number of subprocesses on.
	+ MINT(48)=0
	+ DO 130 ISUB=1,500
	+ IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
	+ & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
	+ MSUB(ISUB)=0
	+ ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
	+ & MSUB(ISUB).EQ.1) THEN
	+ WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
	+ CALL PYSTOP(1)
	+ ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
	+ WRITE(MSTU(11),5300) ISUB
	+ CALL PYSTOP(1)
	+ ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
	+ WRITE(MSTU(11),5400) ISUB
	+ CALL PYSTOP(1)
	+ ELSEIF(MSUB(ISUB).EQ.1) THEN
	+ MINT(48)=MINT(48)+1
	+ ENDIF
	+ 130 CONTINUE
	+
	+C...Stop or raise warning flag if no subprocesses on.
	+ IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
	+ IF(MSTP(127).NE.1) THEN
	+ WRITE(MSTU(11),5500)
	+ CALL PYSTOP(1)
	+ ELSE
	+ WRITE(MSTU(11),5700)
	+ MSTI(53)=1
	+ ENDIF
	+ ENDIF
	+ MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
	+ MSAV48=MSAV48+MINT(48)
	+
	+C...Reset variables for cross-section calculation.
	+ DO 150 I=0,500
	+ DO 140 J=1,3
	+ NGEN(I,J)=0
	+ XSEC(I,J)=0D0
	+ 140 CONTINUE
	+ 150 CONTINUE
	+
	+C...Find parametrized total cross-sections.
	+ CALL PYXTOT
	+ VINT(318)=VINT(317)
	+
	+C...Maxima of differential cross-sections.
	+ IF(MSTP(121).LE.1) CALL PYMAXI
	+
	+C...Initialize possibility of pileup events.
	+ IF(MINT(121).GT.1) MSTP(131)=0
	+ IF(MSTP(131).NE.0) CALL PYPILE(1)
	+
	+C...Initialize multiple interactions with variable impact parameter.
	+ IF(MINT(50).EQ.1) THEN
	+ PTMN=PARP(82)(VINT(1)/PARP(89))*PARP(90)
	+ IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
	+ & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
	+ IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
	+ MINT(35)=1
	+ CALL PYMULT(1)
	+ MINT(35)=3
	+ CALL PYMIGN(1)
	+ ENDIF
	+ ENDIF
	+
	+C...Save results for gamma-p and gamma-gamma alternatives.
	+ IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
	+ 160 CONTINUE
	+
	+C...Initialization finished.
	+ IF(MSAV48.EQ.0) THEN
	+ IF(MSTP(127).NE.1) THEN
	+ WRITE(MSTU(11),5500)
	+ CALL PYSTOP(1)
	+ ELSE
	+ WRITE(MSTU(11),5700)
	+ MSTI(53)=1
	+ ENDIF
	+ ENDIF
	+ 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
	+
	+C...Formats for initialization information.
	+ 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
	+ &'routines',1X,17('*'))
	+ 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
	+ &'-',A6,' interactions.'/1X,'Execution stopped!')
	+ 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
	+ &1X,'Execution stopped!')
	+ 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
	+ &1X,'Execution stopped!')
	+ 5500 FORMAT(1X,'Error: no subprocess switched on.'/
	+ &1X,'Execution stopped.')
	+ 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
	+ &22('*'))
	+ 5700 FORMAT(1X,'Error: no subprocess switched on.'/
	+ &1X,'Execution will stop if you try to generate events.')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYEVNT
	+C...Administers the generation of a high-pT event via calls to
	+C...a number of subroutines.
	+
	+ SUBROUTINE PYEVNT
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
	+C...Local array.
	+ DIMENSION VTX(4)
	+
	+C...Optionally let PYEVNW do the whole job.
	+ IF(MSTP(81).GE.20) THEN
	+ CALL PYEVNW
	+ RETURN
	+ ENDIF
	+
	+C...Stop if no subprocesses on.
	+ IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
	+ WRITE(MSTU(11),5100)
	+ CALL PYSTOP(1)
	+ ENDIF
	+
	+C...Initial values for some counters.
	+ MSTU(1)=0
	+ MSTU(2)=0
	+ N=0
	+ MINT(5)=MINT(5)+1
	+ MINT(7)=0
	+ MINT(8)=0
	+ MINT(30)=0
	+ MINT(83)=0
	+ MINT(84)=MSTP(126)
	+ MSTU(24)=0
	+ MSTU70=0
	+ MSTJ14=MSTJ(14)
	+C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
	+ NCT=0
	+ MINT(33)=0
	+
	+C...Let called routines know call is from PYEVNT (not PYEVNW).
	+ MINT(35)=1
	+ IF (MSTP(81).GE.10) MINT(35)=2
	+
	+C...If variable energies: redo incoming kinematics and cross-section.
	+ MSTI(61)=0
	+ IF(MSTP(171).EQ.1) THEN
	+ CALL PYINKI(1)
	+ IF(MSTI(61).EQ.1) THEN
	+ MINT(5)=MINT(5)-1
	+ RETURN
	+ ENDIF
	+ IF(MINT(121).GT.1) CALL PYSAVE(3,1)
	+ CALL PYXTOT
	+ ENDIF
	+
	+C...Loop over number of pileup events; check space left.
	+ IF(MSTP(131).LE.0) THEN
	+ NPILE=1
	+ ELSE
	+ CALL PYPILE(2)
	+ NPILE=MINT(81)
	+ ENDIF
	+ DO 270 IPILE=1,NPILE
	+ IF(MINT(84)+100.GE.MSTU(4)) THEN
	+ CALL PYERRM(11,
	+ & '(PYEVNT:) no more space in PYJETS for pileup events')
	+ IF(MSTU(21).GE.1) GOTO 280
	+ ENDIF
	+ MINT(82)=IPILE
	+
	+C...Generate variables of hard scattering.
	+ MINT(51)=0
	+ MSTI(52)=0
	+ 100 CONTINUE
	+ IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
	+ MINT(31)=0
	+ MINT(39)=0
	+ MINT(51)=0
	+ MINT(57)=0
	+ CALL PYRAND
	+ IF(MSTI(61).EQ.1) THEN
	+ MINT(5)=MINT(5)-1
	+ RETURN
	+ ENDIF
	+ IF(MINT(51).EQ.2) RETURN
	+ ISUB=MINT(1)
	+ IF(MSTP(111).EQ.-1) GOTO 260
	+
	+C...Loopback point if PYPREP fails, especially for junction topologies.
	+ NPREP=0
	+ MNT31S=MINT(31)
	+ 110 NPREP=NPREP+1
	+ MINT(31)=MNT31S
	+
	+ IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
	+C...Hard scattering (including low-pT):
	+C...reconstruct kinematics and colour flow of hard scattering.
	+ MINT31=MINT(31)
	+ 120 MINT(31)=MINT31
	+ MINT(51)=0
	+ CALL PYSCAT
	+ IF(MINT(51).EQ.1) GOTO 100
	+ IPU1=MINT(84)+1
	+ IPU2=MINT(84)+2
	+ IF(ISUB.EQ.95) GOTO 140
	+
	+C...Reset statistics on activity in event.
	+ DO 130 J=351,359
	+ MINT(J)=0
	+ VINT(J)=0D0
	+ 130 CONTINUE
	+
	+C...Showering of initial state partons (optional).
	+ NFIN=N
	+ ALAMSV=PARJ(81)
	+ PARJ(81)=PARP(72)
	+ IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
	+ & CALL PYSSPA(IPU1,IPU2)
	+ PARJ(81)=ALAMSV
	+ IF(MINT(51).EQ.1) GOTO 100
	+
	+C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
	+ IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
	+ PTMAX=0.5SQRT(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(-2D0LOG(MAX(1D-10,PYR(0))))*
	+ & SIN(PARU(2)*PYR(0))
	+ 220 CONTINUE
	+ DO 240 I=MINT(83)+1,N
	+ DO 230 J=1,4
	+ V(I,J)=V(I,J)+VTX(J)
	+ 230 CONTINUE
	+ 240 CONTINUE
	+ ENDIF
	+
	+C...Perform hadronization (if desired).
	+ IF(MSTP(111).GE.1) THEN
	+ CALL PYEXEC
	+ IF(MSTU(24).NE.0) GOTO 100
	+ ENDIF
	+ IF(MSTP(113).GE.1) THEN
	+ DO 250 I=NRECAL,N
	+ IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
	+ & P(I,2)2+P(I,3)2+P(I,5)**2)
	+ 250 CONTINUE
	+ ENDIF
	+ IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
	+
	+C...Store event information and calculate Monte Carlo estimates of
	+C...subprocess cross-sections.
	+ 260 IF(IPILE.EQ.1) CALL PYDOCU
	+
	+C...Set counters for current pileup event and loop to next one.
	+ MSTI(41)=IPILE
	+ IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
	+ IF(MSTU70.LT.10) THEN
	+ MSTU70=MSTU70+1
	+ MSTU(70+MSTU70)=N
	+ ENDIF
	+ MINT(83)=N
	+ MINT(84)=N+MSTP(126)
	+ IF(IPILE.LT.NPILE) CALL PYFRAM(2)
	+ 270 CONTINUE
	+
	+C...Generic information on pileup events. Reconstruct missing history.
	+ IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
	+ PARI(91)=VINT(132)
	+ PARI(92)=VINT(133)
	+ PARI(93)=VINT(134)
	+ IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
	+ ENDIF
	+ CALL PYEDIT(16)
	+
	+C...Transform to the desired coordinate frame.
	+ 280 CALL PYFRAM(MSTP(124))
	+ MSTU(70)=MSTU70
	+ PARU(21)=VINT(1)
	+
	+C...Error messages
	+ 5100 FORMAT(1X,'Error: no subprocess switched on.'/
	+ &1X,'Execution stopped.')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYEVNW
	+C...Administers the generation of a high-pT event via calls to
	+C...a number of subroutines for the new multiple interactions and
	+C...showering framework.
	+
	+ SUBROUTINE PYEVNW
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
	+ & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
	+C...Local arrays.
	+ DIMENSION VTX(4)
	+
	+C...Stop if no subprocesses on.
	+ IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
	+ WRITE(MSTU(11),5100)
	+ CALL PYSTOP(1)
	+ ENDIF
	+
	+C...Initial values for some counters.
	+ MSTU(1)=0
	+ MSTU(2)=0
	+ N=0
	+ MINT(5)=MINT(5)+1
	+ MINT(7)=0
	+ MINT(8)=0
	+ MINT(30)=0
	+ MINT(83)=0
	+ MINT(84)=MSTP(126)
	+ MSTU(24)=0
	+ MSTU70=0
	+ MSTJ14=MSTJ(14)
	+C...Normally, use K(I,4:5) colour info rather than /PYCT/.
	+ NCT=0
	+ MINT(33)=0
	+C...Zero counters for pT-ordered showers (failsafe)
	+ NPART=0
	+ NPARTD=0
	+
	+C...Let called routines know call is from PYEVNW (not PYEVNT).
	+ MINT(35)=3
	+
	+C...If variable energies: redo incoming kinematics and cross-section.
	+ MSTI(61)=0
	+ IF(MSTP(171).EQ.1) THEN
	+ CALL PYINKI(1)
	+ IF(MSTI(61).EQ.1) THEN
	+ MINT(5)=MINT(5)-1
	+ RETURN
	+ ENDIF
	+ IF(MINT(121).GT.1) CALL PYSAVE(3,1)
	+ CALL PYXTOT
	+ ENDIF
	+
	+C...Loop over number of pileup events; check space left.
	+ IF(MSTP(131).LE.0) THEN
	+ NPILE=1
	+ ELSE
	+ CALL PYPILE(2)
	+ NPILE=MINT(81)
	+ ENDIF
	+ DO 300 IPILE=1,NPILE
	+ IF(MINT(84)+100.GE.MSTU(4)) THEN
	+ CALL PYERRM(11,
	+ & '(PYEVNW:) no more space in PYJETS for pileup events')
	+ IF(MSTU(21).GE.1) GOTO 310
	+ ENDIF
	+ MINT(82)=IPILE
	+
	+C...Generate variables of hard scattering.
	+ MINT(51)=0
	+ MSTI(52)=0
	+ LOOPHS =0
	+ 100 CONTINUE
	+ LOOPHS = LOOPHS + 1
	+ IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
	+ IF(LOOPHS.GE.10) THEN
	+ CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
	+ & //'multiple interactions. Returning.')
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+ MINT(31)=0
	+ MINT(39)=0
	+ MINT(36)=0
	+ MINT(51)=0
	+ MINT(57)=0
	+ CALL PYRAND
	+ IF(MSTI(61).EQ.1) THEN
	+ MINT(5)=MINT(5)-1
	+ RETURN
	+ ENDIF
	+ IF(MINT(51).EQ.2) RETURN
	+ ISUB=MINT(1)
	+ IF(MSTP(111).EQ.-1) GOTO 290
	+
	+C...Loopback point if PYPREP fails, especially for junction topologies.
	+ NPREP=0
	+ MNT31S=MINT(31)
	+ 110 NPREP=NPREP+1
	+ MINT(31)=MNT31S
	+
	+ IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
	+C...Hard scattering (including low-pT):
	+C...reconstruct kinematics and colour flow of hard scattering.
	+ MINT31=MINT(31)
	+ 120 MINT(31)=MINT31
	+ MINT(51)=0
	+ CALL PYSCAT
	+ IF(MINT(51).EQ.1) GOTO 100
	+ NPARTD=N
	+ NFIN=N
	+
	+C...Intertwined initial state showers and multiple interactions.
	+C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
	+C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
	+ MSTP61=MSTP(61)
	+ IF (MINT(47).LT.2) MSTP(61)=0
	+ MSTP81=MSTP(81)
	+ IF (MINT(50).EQ.0) MSTP(81)=0
	+ IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
	+ & MINT(111).NE.12) THEN
	+C...Absolute max pT2 scale for evolution: phase space limit.
	+ PT2MXS=0.25D0*VINT(2)
	+C...Check if more constrained by ISR and MI max scales:
	+ PT2MXS=MIN(PT2MXS,MAX(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(-2D0LOG(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 PROC28, CHTMP16
	+ 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,CHAU16,CHKF16,CHD116,CHD216,CHD316,
	+ &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(2I-1),CHKIN(I),CKIN(2I)
	+ 160 CONTINUE
	+ SPRMAX=CKIN(32)
	+ IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
	+ WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
	+ WRITE(MSTU(11),7000)
	+
	+C...Status codes and parameter values.
	+ ELSEIF(MSTAT.EQ.5) THEN
	+ WRITE(MSTU(11),7100)
	+ WRITE(MSTU(11),7200)
	+ DO 170 I=1,100
	+ WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
	+ & PARP(100+I)
	+ 170 CONTINUE
	+
	+C...List of all processes implemented in the program.
	+ ELSEIF(MSTAT.EQ.6) THEN
	+ WRITE(MSTU(11),7400)
	+ WRITE(MSTU(11),7500)
	+ DO 180 I=1,500
	+ IF(ISET(I).LT.0) GOTO 180
	+ WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
	+ 180 CONTINUE
	+ WRITE(MSTU(11),7700)
	+
	+ ELSEIF(MSTAT.EQ.7) THEN
	+ WRITE (MSTU(11),8000)
	+ NMODES(0)=0
	+ NMODES(10)=0
	+ NMODES(9)=0
	+ DO 290 ILR=1,2
	+ DO 280 KFSM=1,16
	+ KFSUSY=ILR*KSUSY1+KFSM
	+ NRVDC=0
	+C...SDOWN DECAYS
	+ IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
	+ NRVDC=3
	+ DO 190 I=1,NRVDC
	+ PBRAT(I)=0D0
	+ NMODES(I)=0
	+ 190 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
	+ CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
	+ CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 200 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ IF (KFDP(IDC,3).EQ.0) THEN
	+ IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	+ & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	+ & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ NMODES(2)=NMODES(2)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	+ PBRAT(3)=PBRAT(3)+BRAT(IDC)
	+ NMODES(3)=NMODES(3)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ ENDIF
	+ 200 CONTINUE
	+ ENDIF
	+C...SUP DECAYS
	+ IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
	+ NRVDC=2
	+ DO 210 I=1,NRVDC
	+ NMODES(I)=0
	+ PBRAT(I)=0D0
	+ 210 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
	+ CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 220 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ IF (KFDP(IDC,3).EQ.0) THEN
	+ IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
	+ & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
	+ & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ NMODES(2)=NMODES(2)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ ENDIF
	+ 220 CONTINUE
	+ ENDIF
	+C...SLEPTON DECAYS
	+ IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
	+ NRVDC=2
	+ DO 230 I=1,NRVDC
	+ PBRAT(I)=0D0
	+ NMODES(I)=0
	+ 230 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
	+ CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 240 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ IF (KFDP(IDC,3).EQ.0) THEN
	+ IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	+ & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
	+ & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ NMODES(2)=NMODES(2)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ ENDIF
	+ 240 CONTINUE
	+ ENDIF
	+C...SNEUTRINO DECAYS
	+ IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
	+ & THEN
	+ NRVDC=2
	+ DO 250 I=1,NRVDC
	+ PBRAT(I)=0D0
	+ NMODES(I)=0
	+ 250 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
	+ CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 260 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ IF (KFDP(IDC,3).EQ.0) THEN
	+ IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
	+ & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
	+ & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
	+ NMODES(2)=NMODES(2)+1
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ ENDIF
	+ 260 CONTINUE
	+ ENDIF
	+ IF (NRVDC.NE.0) THEN
	+ DO 270 I=1,NRVDC
	+ WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
	+ NMODES(0)=NMODES(0)+NMODES(I)
	+ 270 CONTINUE
	+ ENDIF
	+ 280 CONTINUE
	+ 290 CONTINUE
	+ DO 370 KFSM=21,37
	+ KFSUSY=KSUSY1+KFSM
	+ NRVDC=0
	+C...NEUTRALINO DECAYS
	+ IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
	+ NRVDC=4
	+ DO 300 I=1,NRVDC
	+ PBRAT(I)=0D0
	+ NMODES(I)=0
	+ 300 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
	+ CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 310 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ ID3=IABS(KFDP(IDC,3))
	+ IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	+ & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
	+ & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
	+ & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ NMODES(2)=NMODES(2)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	+ & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
	+ & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(3)=PBRAT(3)+BRAT(IDC)
	+ NMODES(3)=NMODES(3)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
	+ & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(4)=PBRAT(4)+BRAT(IDC)
	+ NMODES(4)=NMODES(4)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ 310 CONTINUE
	+ ENDIF
	+C...CHARGINO DECAYS
	+ IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
	+ NRVDC=5
	+ DO 320 I=1,NRVDC
	+ PBRAT(I)=0D0
	+ NMODES(I)=0
	+ 320 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
	+ CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
	+ CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 330 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ ID3=IABS(KFDP(IDC,3))
	+ IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	+ & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
	+ & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	+ & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
	+ & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	+ & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
	+ & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ NMODES(2)=NMODES(2)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
	+ & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
	+ PBRAT(3)=PBRAT(3)+BRAT(IDC)
	+ NMODES(3)=NMODES(3)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
	+ & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
	+ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(3)=PBRAT(3)+BRAT(IDC)
	+ NMODES(3)=NMODES(3)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	+ & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
	+ & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
	+ PBRAT(4)=PBRAT(4)+BRAT(IDC)
	+ NMODES(4)=NMODES(4)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
	+ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(4)=PBRAT(4)+BRAT(IDC)
	+ NMODES(4)=NMODES(4)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	+ & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
	+ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(5)=PBRAT(5)+BRAT(IDC)
	+ NMODES(5)=NMODES(5)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
	+ & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(5)=PBRAT(5)+BRAT(IDC)
	+ NMODES(5)=NMODES(5)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ 330 CONTINUE
	+ ENDIF
	+C...GLUINO DECAYS
	+ IF (KFSM.EQ.21) THEN
	+ NRVDC=3
	+ DO 340 I=1,NRVDC
	+ PBRAT(I)=0D0
	+ NMODES(I)=0
	+ 340 CONTINUE
	+ CALL PYNAME(KFSUSY,CHTMP)
	+ CHD0=CHTMP//' '
	+ CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
	+ KC=PYCOMP(KFSUSY)
	+ DO 350 J=1,MDCY(KC,3)
	+ IDC=J+MDCY(KC,2)-1
	+ ID1=IABS(KFDP(IDC,1))
	+ ID2=IABS(KFDP(IDC,2))
	+ ID3=IABS(KFDP(IDC,3))
	+ IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
	+ & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
	+ & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(1)=PBRAT(1)+BRAT(IDC)
	+ NMODES(1)=NMODES(1)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
	+ & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
	+ & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(2)=PBRAT(2)+BRAT(IDC)
	+ NMODES(2)=NMODES(2)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
	+ & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
	+ & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
	+ PBRAT(3)=PBRAT(3)+BRAT(IDC)
	+ NMODES(3)=NMODES(3)+1
	+ IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
	+ IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
	+ ENDIF
	+ 350 CONTINUE
	+ ENDIF
	+
	+ IF (NRVDC.NE.0) THEN
	+ DO 360 I=1,NRVDC
	+ WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
	+ NMODES(0)=NMODES(0)+NMODES(I)
	+ 360 CONTINUE
	+ ENDIF
	+ 370 CONTINUE
	+ WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
	+
	+ IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
	+ WRITE (MSTU(11),8500)
	+ DO 400 IRV=1,3
	+ DO 390 JRV=1,3
	+ DO 380 KRV=1,3
	+ WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
	+ & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
	+ 380 CONTINUE
	+ 390 CONTINUE
	+ 400 CONTINUE
	+ WRITE (MSTU(11),8600)
	+ ENDIF
	+ ENDIF
	+
	+C...Formats for printouts.
	+ 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
	+ &'Events and Cross-sections',1X,9('*'))
	+ 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
	+ &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
	+ &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
	+ &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
	+ &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
	+ &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
	+ &'I',12X,'I')
	+ 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
	+ &D10.3,1X,'I')
	+ 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
	+ &1X,'I',34X,'I',28X,'I',12X,'I')
	+ 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
	+ &1X,'********* Total number of errors, excluding junctions =',
	+ &1X,I8,' *************'/
	+ &1X,'********* Total number of errors, including junctions =',
	+ &1X,I8,' *************'/
	+ &1X,'********* Total number of warnings = ',
	+ &1X,I8,' *************'/
	+ &1X,'********* Fraction of events that fail fragmentation ',
	+ &'cuts =',1X,F8.5,' *********'/)
	+ 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
	+ &'Ratios',1X,27('*'))
	+ 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
	+ &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
	+ &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
	+ &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
	+ &1X,98('='))
	+ 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
	+ &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
	+ &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
	+ 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
	+ &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
	+ &1P,D10.3,0P,1X,'I')
	+ 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
	+ &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
	+ &1P,D10.3,0P,1X,'I')
	+ 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
	+ 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
	+ &'Particles at Hard Interaction',1X,7('*'))
	+ 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
	+ &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
	+ &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
	+ &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
	+ &78('=')/1X,'I',38X,'I',37X,'I')
	+ 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
	+ 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
	+ 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
	+ &'Kinematical Variables',1X,12('*'))
	+ 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
	+ 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
	+ &16X,'I')
	+ 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
	+ &1X,'<',1X,1P,D10.3,0P,16X,'I')
	+ 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
	+ 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
	+ 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
	+ &'Parameter Values',1X,12('*'))
	+ 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
	+ &'PARP(I)'/)
	+ 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
	+ 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
	+ &1X,13('*'))
	+ 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
	+ &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
	+ &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
	+ 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
	+ 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
	+ 8000 FORMAT(1X/ 1X/
	+ & 17X,'Sums over R-Violating branching ratios',1X/ 1X
	+ & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
	+ & ,'Mother --> Sum over final state flavours',4X,'I',2X
	+ & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
	+ & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
	+ 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
	+ & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
	+ & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
	+ & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
	+ & /1X,70('='))
	+ 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
	+ & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
	+ 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
	+ 8500 FORMAT(1X/ 1X/
	+ & 1X,'R-Violating couplings',1X/ 1X /
	+ & 1X,55('=')/
	+ & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
	+ & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
	+ & ,'I',15X,'I',15X,'I',15X,'I')
	+ 8600 FORMAT(1X,55('='))
	+ 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
	+ & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYUPEV
	+C...Administers the hard-process generation required for output to the
	+C...Les Houches event record.
	+
	+ SUBROUTINE PYUPEV
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/,/PYINT4/
	+
	+C...HEPEUP for output.
	+ INTEGER MAXNUP
	+ PARAMETER (MAXNUP=500)
	+ INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	+ DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	+ COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	+ &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	+ &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	+ SAVE /HEPEUP/
	+
	+C...Stop if no subprocesses on.
	+ IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
	+ WRITE(MSTU(11),5100)
	+ STOP
	+ ENDIF
	+
	+C...Special flags for hard-process generation only.
	+ MSTP71=MSTP(71)
	+ MSTP(71)=0
	+ MST128=MSTP(128)
	+ MSTP(128)=1
	+
	+C...Initial values for some counters.
	+ N=0
	+ MINT(5)=MINT(5)+1
	+ MINT(7)=0
	+ MINT(8)=0
	+ MINT(30)=0
	+ MINT(83)=0
	+ MINT(84)=MSTP(126)
	+ MSTU(24)=0
	+ MSTU70=0
	+ MSTJ14=MSTJ(14)
	+C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
	+ MINT(33)=0
	+
	+C...If variable energies: redo incoming kinematics and cross-section.
	+ MSTI(61)=0
	+ IF(MSTP(171).EQ.1) THEN
	+ CALL PYINKI(1)
	+ IF(MSTI(61).EQ.1) THEN
	+ MINT(5)=MINT(5)-1
	+ RETURN
	+ ENDIF
	+ IF(MINT(121).GT.1) CALL PYSAVE(3,1)
	+ CALL PYXTOT
	+ ENDIF
	+
	+C...Do not allow pileup events.
	+ MINT(82)=1
	+
	+C...Generate variables of hard scattering.
	+ MINT(51)=0
	+ MSTI(52)=0
	+ 100 CONTINUE
	+ IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
	+ MINT(31)=0
	+ MINT(51)=0
	+ MINT(57)=0
	+ CALL PYRAND
	+ IF(MSTI(61).EQ.1) THEN
	+ MINT(5)=MINT(5)-1
	+ RETURN
	+ ENDIF
	+ IF(MINT(51).EQ.2) RETURN
	+ ISUB=MINT(1)
	+
	+ IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
	+C...Hard scattering (including low-pT):
	+C...reconstruct kinematics and colour flow of hard scattering.
	+ MINT31=MINT(31)
	+ 110 MINT(31)=MINT31
	+ MINT(51)=0
	+ CALL PYSCAT
	+ IF(MINT(51).EQ.1) GOTO 100
	+ IPU1=MINT(84)+1
	+ IPU2=MINT(84)+2
	+
	+C...Decay of final state resonances.
	+ MINT(32)=0
	+ IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
	+ & CALL PYRESD(0)
	+ IF(MINT(51).EQ.1) GOTO 100
	+ MINT(52)=N
	+
	+C...Longitudinal boost of hard scattering.
	+ BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
	+ CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
	+
	+ ELSEIF(ISUB.NE.99) THEN
	+C...Diffractive and elastic scattering.
	+ CALL PYDIFF
	+
	+ ELSE
	+C...DIS scattering (photon flux external).
	+ CALL PYDISG
	+ IF(MINT(51).EQ.1) GOTO 100
	+ ENDIF
	+
	+C...Check that no odd resonance left undecayed.
	+ MINT(54)=N
	+ NFIX=N
	+ DO 120 I=MINT(84)+1,NFIX
	+ IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
	+ & K(I,2).NE.22) THEN
	+ KCA=PYCOMP(K(I,2))
	+ IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
	+ CALL PYRESD(I)
	+ IF(MINT(51).EQ.1) GOTO 100
	+ ENDIF
	+ ENDIF
	+ 120 CONTINUE
	+
	+C...Boost hadronic subsystem to overall rest frame.
	+C..(Only relevant when photon inside lepton beam.)
	+ IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
	+
	+C...Store event information and calculate Monte Carlo estimates of
	+C...subprocess cross-sections.
	+ 130 CALL PYDOCU
	+
	+C...Transform to the desired coordinate frame.
	+ 140 CALL PYFRAM(MSTP(124))
	+ MSTU(70)=MSTU70
	+ PARU(21)=VINT(1)
	+
	+C...Restore special flags for hard-process generation only.
	+ MSTP(71)=MSTP71
	+ MSTP(128)=MST128
	+
	+C...Trace colour tags; convert to LHA style labels.
	+ NCT=100
	+ DO 150 I=MINT(84)+1,N
	+ MCT(I,1)=0
	+ MCT(I,2)=0
	+ 150 CONTINUE
	+ DO 160 I=MINT(84)+1,N
	+ KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
	+ IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
	+ IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
	+ & THEN
	+ IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
	+ IDA=MOD(K(I,4),MSTU(5))
	+ IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
	+ & MCT(IMO,2).NE.0) THEN
	+ MCT(I,1)=MCT(IMO,2)
	+ ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
	+ & MCT(IMO,1).NE.0) THEN
	+ MCT(I,1)=MCT(IMO,1)
	+ ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
	+ & MCT(IDA,2).NE.0) THEN
	+ MCT(I,1)=MCT(IDA,2)
	+ ELSE
	+ NCT=NCT+1
	+ MCT(I,1)=NCT
	+ ENDIF
	+ ENDIF
	+ IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
	+ & THEN
	+ IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
	+ IDA=MOD(K(I,5),MSTU(5))
	+ IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
	+ & MCT(IMO,1).NE.0) THEN
	+ MCT(I,2)=MCT(IMO,1)
	+ ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
	+ & MCT(IMO,2).NE.0) THEN
	+ MCT(I,2)=MCT(IMO,2)
	+ ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
	+ & MCT(IDA,1).NE.0) THEN
	+ MCT(I,2)=MCT(IDA,1)
	+ ELSE
	+ NCT=NCT+1
	+ MCT(I,2)=NCT
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 160 CONTINUE
	+
	+C...Put event in HEPEUP commonblock.
	+ NUP=N-MINT(84)
	+ IDPRUP=MINT(1)
	+ XWGTUP=1D0
	+ SCALUP=VINT(53)
	+ AQEDUP=VINT(57)
	+ AQCDUP=VINT(58)
	+ DO 180 I=1,NUP
	+ IDUP(I)=K(I+MINT(84),2)
	+ IF(I.LE.2) THEN
	+ ISTUP(I)=-1
	+ MOTHUP(1,I)=0
	+ MOTHUP(2,I)=0
	+ ELSEIF(K(I+4,3).EQ.0) THEN
	+ ISTUP(I)=1
	+ MOTHUP(1,I)=1
	+ MOTHUP(2,I)=2
	+ ELSE
	+ ISTUP(I)=1
	+ MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
	+ MOTHUP(2,I)=0
	+ ENDIF
	+ IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
	+ & ISTUP(K(I+MINT(84),3)-MINT(84))=2
	+ ICOLUP(1,I)=MCT(I+MINT(84),1)
	+ ICOLUP(2,I)=MCT(I+MINT(84),2)
	+ DO 170 J=1,5
	+ PUP(J,I)=P(I+MINT(84),J)
	+ 170 CONTINUE
	+ VTIMUP(I)=V(I,5)
	+ SPINUP(I)=9D0
	+ 180 CONTINUE
	+
	+C...Optionally write out event to disk. Minimal size for time/spin fields.
	+ IF(MSTP(162).GT.0) THEN
	+ WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
	+ DO 190 I=1,NUP
	+ IF(VTIMUP(I).EQ.0D0) THEN
	+ WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
	+ & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
	+ & ' 0. 9.'
	+ ELSE
	+ WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
	+ & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
	+ & VTIMUP(I),' 9.'
	+ ENDIF
	+ 190 CONTINUE
	+
	+C...Optional extra line with parton-density information.
	+ IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
	+ & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
	+ ENDIF
	+
	+C...Error messages and other print formats.
	+ 5100 FORMAT(1X,'Error: no subprocess switched on.'/
	+ &1X,'Execution stopped.')
	+ 5200 FORMAT(1P,2I6,4E14.6)
	+ 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
	+ 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
	+ 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYUPIN
	+C...Fills the HEPRUP commonblock with info on incoming beams and allowed
	+C...processes, and optionally stores that information on file.
	+
	+ SUBROUTINE PYUPIN
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
	+
	+C...User process initialization commonblock.
	+ INTEGER MAXPUP
	+ PARAMETER (MAXPUP=100)
	+ INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	+ DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	+ COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	+ &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	+ &LPRUP(MAXPUP)
	+ SAVE /HEPRUP/
	+
	+C...Store info on incoming beams.
	+ IDBMUP(1)=K(1,2)
	+ IDBMUP(2)=K(2,2)
	+ EBMUP(1)=P(1,4)
	+ EBMUP(2)=P(2,4)
	+ PDFGUP(1)=0
	+ PDFGUP(2)=0
	+ PDFSUP(1)=MSTP(51)
	+ PDFSUP(2)=MSTP(51)
	+
	+C...Event weighting strategy.
	+ IDWTUP=3
	+
	+C...Info on individual processes.
	+ NPRUP=0
	+ DO 100 ISUB=1,500
	+ IF(MSUB(ISUB).EQ.1) THEN
	+ NPRUP=NPRUP+1
	+ XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
	+ XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
	+ XMAXUP(NPRUP)=1D0
	+ LPRUP(NPRUP)=ISUB
	+ ENDIF
	+ 100 CONTINUE
	+
	+C...Write info to file.
	+ IF(MSTP(161).GT.0) THEN
	+ WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
	+ & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	+ DO 110 IPR=1,NPRUP
	+ WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
	+ & LPRUP(IPR)
	+ 110 CONTINUE
	+ ENDIF
	+
	+C...Formats for printout.
	+ 5100 FORMAT(1P,2I8,2E14.6,6I6)
	+ 5200 FORMAT(1P,3E14.6,I6)
	+
	+ RETURN
	+ END
	+
	+
	+C*********************************************************************
	+
	+C...Combine the two old-style Pythia initialization and event files
	+C...into a single Les Houches Event File.
	+
	+ SUBROUTINE PYLHEF
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+
	+C...PYTHIA commonblock: only used to provide read/write units and version.
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ SAVE /PYPARS/
	+
	+C...User process initialization commonblock.
	+ INTEGER MAXPUP
	+ PARAMETER (MAXPUP=100)
	+ INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	+ DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	+ COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	+ &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	+ &LPRUP(MAXPUP)
	+ SAVE /HEPRUP/
	+
	+C...User process event common block.
	+ INTEGER MAXNUP
	+ PARAMETER (MAXNUP=500)
	+ INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	+ DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	+ COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	+ &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	+ &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	+ SAVE /HEPEUP/
	+
	+C...Lines to read in assumed never longer than 200 characters.
	+ PARAMETER (MAXLEN=200)
	+ CHARACTER*(MAXLEN) STRING
	+
	+C...Format for reading lines.
	+ CHARACTER*6 STRFMT
	+ STRFMT='(A000)'
	+ WRITE(STRFMT(3:5),'(I3)') MAXLEN
	+
	+C...Rewind initialization and event files.
	+ REWIND MSTP(161)
	+ REWIND MSTP(162)
	+
	+C...Write header info.
	+ WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
	+ WRITE(MSTP(163),'(A)') '<!--'
	+ WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
	+ &MSTP(181),'.',MSTP(182)
	+ WRITE(MSTP(163),'(A)') '-->'
	+
	+C...Read first line of initialization info and get number of processes.
	+ READ(MSTP(161),'(A)',END=400,ERR=400) STRING
	+ READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
	+ &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	+
	+C...Copy initialization lines, omitting trailing blanks.
	+C...Embed in <init> ... </init> block.
	+ WRITE(MSTP(163),'(A)') '<init>'
	+ DO 140 IPR=0,NPRUP
	+ IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
	+ LEN=MAXLEN+1
	+ 120 LEN=LEN-1
	+ IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
	+ WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
	+ 140 CONTINUE
	+ WRITE(MSTP(163),'(A)') '</init>'
	+
	+C...Begin event loop. Read first line of event info or already done.
	+ READ(MSTP(162),'(A)',END=320,ERR=400) STRING
	+ 200 CONTINUE
	+
	+C...Look at first line to know number of particles in event.
	+ READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
	+
	+C...Begin an <event> block. Copy event lines, omitting trailing blanks.
	+ WRITE(MSTP(163),'(A)') '<event>'
	+ DO 240 I=0,NUP
	+ IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
	+ LEN=MAXLEN+1
	+ 220 LEN=LEN-1
	+ IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
	+ WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
	+ 240 CONTINUE
	+
	+C...Copy trailing comment lines - with a # in the first column - as is.
	+ 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
	+ IF(STRING(1:1).EQ.'#') THEN
	+ LEN=MAXLEN+1
	+ 280 LEN=LEN-1
	+ IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
	+ WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
	+ GOTO 260
	+ ENDIF
	+
	+C..End the <event> block. Loop back to look for next event.
	+ WRITE(MSTP(163),'(A)') '</event>'
	+ GOTO 200
	+
	+C...Successfully reached end of event loop: write closing tag
	+C...and remove temporary intermediate files (unless asked not to).
	+ 300 WRITE(MSTP(163),'(A)') '</event>'
	+ 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
	+ IF(MSTP(164).EQ.1) RETURN
	+ CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
	+ CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
	+ RETURN
	+
	+C...Error exit.
	+ 400 WRITE(,) ' PYLHEF file joining failed!'
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYINRE
	+C...Calculates full and effective widths of gauge bosons, stores
	+C...masses and widths, rescales coefficients to be used for
	+C...resonance production generation.
	+
	+ SUBROUTINE PYINRE
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYDAT4/CHAF(500,2)
	+ CHARACTER CHAF*16
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYINT6/PROC(0:500)
	+ CHARACTER PROC*28
	+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
	+C...Local arrays and data.
	+ 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-TANBE2)/(1D0+TANBE2))**2
	+ SQMZ=PMAS(23,1)**2
	+ SQMW=PMAS(24,1)**2
	+ SQMH=PMAS(25,1)**2
	+ SQMA=SQMH(SQMZ-SQMH)/(SQMZRATBE-SQMH)
	+ SQMHP=0.5D0(SQMA+SQMZ+SQRT((SQMA+SQMZ)2-4D0SQMASQMZRATBE))
	+ 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.5D0ATAN(2D0TANBE(SQMA+SQMZ)/((1D0-TANBE2)
	+ & (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.5D0COS(2D0BESU)*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(2D0ALSU)COS(BESU+ALSU)-2D0SIN(2D0ALSU)*
	+ & SIN(BESU+ALSU)
	+ PARU(177)=COS(2D0BESU)COS(BESU+ALSU)
	+ PARU(178)=COS(BESU-ALSU)-0.5D0COS(2D0BESU)*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))+
	+ & 2D0WDTE(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))+
	+ & 2D0WDTE(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))+
	+ & 2D0WDTEM(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.9D0PMAS(KC,1),10D0PMAS(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(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
	+
	+C...Local arrays, character variables and data.
	+ CHARACTER CHFRAM12,CHBEAM12,CHTARG12,CHCOM(3)12,CHALP(2)*26,
	+ &CHIDNT(3)12,CHTEMP12,CHCDE(39)12,CHINIT76,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+2D0PM(2)SQRT(PM(1)2+WIN2)
	+ IF(MSTP(122).GE.1) THEN
	+ LOFFS=(29-(LEN(2)+LEN(3)))/2
	+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	+ & ' fixed target'//' '
	+ WRITE(MSTU(11),5200) CHINIT
	+ WRITE(MSTU(11),5400) WIN
	+ WRITE(MSTU(11),5500) SQRT(S)
	+ ENDIF
	+
	+C...Frame defined by user three-vectors.
	+ ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
	+ MINT(111)=3
	+ P(1,5)=PM(1)
	+ P(2,5)=PM(2)
	+ P(1,4)=SQRT(P(1,1)2+P(1,2)2+P(1,3)2+P(1,5)2)
	+ P(2,4)=SQRT(P(2,1)2+P(2,2)2+P(2,3)2+P(2,5)2)
	+ S=(P(1,4)+P(2,4))2-(P(1,1)+P(2,1))2-(P(1,2)+P(2,2))**2-
	+ & (P(1,3)+P(2,3))**2
	+ IF(MSTP(122).GE.1) THEN
	+ LOFFS=(22-(LEN(2)+LEN(3)))/2
	+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	+ & ' user configuration'//' '
	+ WRITE(MSTU(11),5200) CHINIT
	+ WRITE(MSTU(11),5600)
	+ WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
	+ WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
	+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	+ ENDIF
	+
	+C...Frame defined by user four-vectors.
	+ ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
	+ MINT(111)=4
	+ PMS1=P(1,4)2-P(1,1)2-P(1,2)2-P(1,3)2
	+ P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
	+ PMS2=P(2,4)2-P(2,1)2-P(2,2)2-P(2,3)2
	+ P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
	+ S=(P(1,4)+P(2,4))2-(P(1,1)+P(2,1))2-(P(1,2)+P(2,2))**2-
	+ & (P(1,3)+P(2,3))**2
	+ IF(MSTP(122).GE.1) THEN
	+ LOFFS=(22-(LEN(2)+LEN(3)))/2
	+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	+ & ' user configuration'//' '
	+ WRITE(MSTU(11),5200) CHINIT
	+ WRITE(MSTU(11),5600)
	+ WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
	+ WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
	+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	+ ENDIF
	+
	+C...Frame defined by user five-vectors.
	+ ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
	+ MINT(111)=5
	+ S=(P(1,4)+P(2,4))2-(P(1,1)+P(2,1))2-(P(1,2)+P(2,2))**2-
	+ & (P(1,3)+P(2,3))**2
	+ IF(MSTP(122).GE.1) THEN
	+ LOFFS=(22-(LEN(2)+LEN(3)))/2
	+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	+ & ' user configuration'//' '
	+ WRITE(MSTU(11),5200) CHINIT
	+ WRITE(MSTU(11),5600)
	+ WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
	+ WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
	+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	+ ENDIF
	+
	+C...Frame defined by HEPRUP common block.
	+ ELSEIF(MINT(111).GE.11) THEN
	+ S=(EBMUP(1)+EBMUP(2))2-(SQRT(MAX(0D0,EBMUP(1)2-PM(1)**2))-
	+ & SQRT(MAX(0D0,EBMUP(2)2-PM(2)2)))**2
	+ IF(MSTP(122).GE.1) THEN
	+ LOFFS=(22-(LEN(2)+LEN(3)))/2
	+ CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
	+ & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
	+ & ' user configuration'//' '
	+ WRITE(MSTU(11),5200) CHINIT
	+ WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
	+ WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
	+ ENDIF
	+
	+C...Unknown frame. Error for too low CM energy.
	+ ELSE
	+ WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
	+ CALL PYSTOP(7)
	+ ENDIF
	+ IF(S.LT.PARP(2)**2) THEN
	+ WRITE(MSTU(11),5900) SQRT(S)
	+ CALL PYSTOP(7)
	+ ENDIF
	+
	+C...Formats for initialization and error information.
	+ 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
	+ &1X,'Execution stopped!')
	+ 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
	+ &1X,'Execution stopped!')
	+ 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
	+ 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
	+ &19X,'I'/1X,'I',76X,'I'/1X,78('='))
	+ 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
	+ 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
	+ &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
	+ 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
	+ &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
	+ 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
	+ 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
	+ &1X,'Execution stopped!')
	+ 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
	+ &'generation.'/1X,'Execution stopped!')
	+ 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
	+ &'GeV beam energies',13X,'I')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYINKI
	+C...Sets up kinematics, including rotations and boosts to/from CM frame.
	+
	+ SUBROUTINE PYINKI(MODKI)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+
	+C...User process initialization commonblock.
	+ INTEGER MAXPUP
	+ PARAMETER (MAXPUP=100)
	+ INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	+ DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	+ COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	+ &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	+ &LPRUP(MAXPUP)
	+ SAVE /HEPRUP/
	+
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
	+
	+C...Set initial flavour state.
	+ N=2
	+ DO 100 I=1,2
	+ K(I,1)=1
	+ K(I,2)=MINT(10+I)
	+ IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
	+ 100 CONTINUE
	+
	+C...Reset boost. Do kinematics for various cases.
	+ DO 110 J=6,10
	+ VINT(J)=0D0
	+ 110 CONTINUE
	+
	+C...Set up kinematics for events defined in CM frame.
	+ IF(MINT(111).EQ.1) THEN
	+ WIN=VINT(290)
	+ IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
	+ S=WIN**2
	+ P(1,5)=VINT(3)
	+ P(2,5)=VINT(4)
	+ IF(MINT(141).NE.0) P(1,5)=VINT(303)
	+ IF(MINT(142).NE.0) P(2,5)=VINT(304)
	+ P(1,1)=0D0
	+ P(1,2)=0D0
	+ P(2,1)=0D0
	+ P(2,2)=0D0
	+ P(1,3)=SQRT(((S-P(1,5)2-P(2,5)2)*2-(2D0P(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+2D0P(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)=4D0PTMN*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.125D0LOG(1D0+0.10D0VINT(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/71,30,61,40,43,26,4*0/
	+C...X and Y parameters of sigmatot = X * s*epsilon + Y s**(-eta).
	+ DATA XPAR/221.70D0,313.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/21,32,3,4,30,32,23,4,40/
	+ DATA IHADB/71,30,2,3,4,3,24,40/
	+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/21,32,3,4,30,5,6,7,8,9,10,40/
	+ DATA IFITDD/21,32,3,4,30,5,6,7,8,9,10,40/
	+ 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=2D0BHA+2D0BHB+4D0*SEPS-4.2D0
	+ SIGTMP(I,1)=FACELSIGTMP(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+2D0ALPLOG(S/SQML))/
	+ & (BSD+2D0ALPLOG(S/SQMU)))/(2D0*ALP)
	+ BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
	+ SUM2=CRESLOG(1D0+((PMA+PMRC)/(PMA+PMTH))*2)/
	+ & (BSD+2D0ALPLOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
	+ SIGTMP(I,2)=FACSDXPAR(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+2D0ALPLOG(S/SQML))/
	+ & (BSD+2D0ALPLOG(S/SQMU)))/(2D0*ALP)
	+ BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
	+ SUM2=CRESLOG(1D0+((PMB+PMRC)/(PMB+PMTH))*2)/
	+ & (BSD+2D0ALPLOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
	+ SIGTMP(I,3)=FACSDXPAR(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(SSMP/((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))/(2D0ALP)
	+ 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/(ALPSQMU(PMB+PMTH)*(PMB+PMRC))))
	+ SUM2=CRESLOG(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/(ALPSQMU(PMA+PMTH)*(PMA+PMRC))))
	+ SUM3=CRESLOG(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*2LOG(1D0+((PMA+PMRC)/(PMA+PMTH))*2)
	+ & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))*2)/MAX(0.1D0,2D0ALP*SLRR+BXX)
	+ SIGTMP(I,4)=FACDDXPAR(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)=16D0PARP(15)2VINT(154)**2/
	+ & ((4D0PARP(15)2+VINT(307))(4D0VINT(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)2PARP(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)=16D0PARP(15)2VINT(154)**2/
	+ & ((4D0PARP(15)2+VINT(308))(4D0VINT(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)2PARP(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)=16D0PARP(15)2VINT(154)**2/
	+ & ((4D0PARP(15)2+VINT(307))(4D0VINT(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)16D0PARP(15)*2VINT(154)**2/
	+ & ((4D0PARP(15)2+VINT(308))(4D0VINT(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)2PARP(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)*2PARP(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/(96D0PARU(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.08D0PARP(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+GAMR12)
	+ 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+GAMR22)
	+ ENDIF
	+ IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
	+ WTMAT(IBIN,3+2MINT(72))=WTMAT(IBIN,3+2MINT(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,2D0SQM3SQM4/(VINTPT(IACC,11)VINT(2))*2)
	+ RSQM=1D0+RM34
	+ CTHMAX=SQRT(1D0-4D0VINT(71)2/(TAUMAXVINT(2)))
	+ CTHMIN=-CTHMAX
	+ IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0VINT(71)*2/
	+ & (TAUMAX*VINT(2)))
	+ ACTH1=CTHMAX-CTHMIN
	+ ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
	+ ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
	+ ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
	+ ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
	+ CTH=VINTPT(IACC,13)
	+ WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
	+ WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
	+ & MAX(RM34,RSQM-CTH)
	+ WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
	+ & MAX(RM34,RSQM+CTH)
	+ WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
	+ & MAX(RM34,RSQM-CTH)**2
	+ WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
	+ & MAX(RM34,RSQM+CTH)**2
	+ ENDIF
	+ 180 CONTINUE
	+
	+C...Check that equation system solvable.
	+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
	+ MSOLV=1
	+ WTRELS=0D0
	+ DO 190 IBIN=1,NBIN
	+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
	+ & IRED=1,NBIN),WTREL(IBIN)
	+ IF(NAREL(IBIN).EQ.0) MSOLV=0
	+ WTRELS=WTRELS+WTREL(IBIN)
	+ 190 CONTINUE
	+ IF(ABS(WTRELS).LT.1D-20) MSOLV=0
	+
	+C...Solve to find relative importance of cross-section pieces.
	+ IF(MSOLV.EQ.1) THEN
	+ DO 200 IBIN=1,NBIN
	+ WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
	+ WTRSAV(IBIN)=WTREL(IBIN)
	+ 200 CONTINUE
	+C...Auxiliary vectors to record order of permutations
	+ DO I=1,NBIN
	+ IP(I) = I
	+ IQ(I) = I
	+ ENDDO
	+ DO 230 IRED=1,NBIN-1
	+ MROW=IRED
	+ RESMAX=ABS(WTREL(MROW))
	+C...Find row with largest residual
	+ DO JBIN=IRED+1,NBIN
	+ IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
	+ MROW=JBIN
	+ RESMAX=ABS(WTREL(MROW))
	+ ENDIF
	+ ENDDO
	+ IF(RESMAX.LT.1D-20) THEN
	+ MSOLV=0
	+ GOTO 260
	+ ENDIF
	+ MCOL = IRED
	+ AMAX = ABS(WTMAT(MROW,MCOL))
	+C...Find column with largest entry
	+ DO JBIN=IRED+1,NBIN
	+ IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
	+ MCOL = JBIN
	+ AMAX = ABS(WTMAT(MROW,MCOL))
	+ ENDIF
	+ ENDDO
	+C...Swap rows if necessary
	+ IF(MROW.NE.IRED) THEN
	+ DO JBIN=1,NBIN
	+ TMPE=WTMAT(IRED,JBIN)
	+ WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
	+ WTMAT(MROW,JBIN)=TMPE
	+ ENDDO
	+ TMPE=WTREL(IRED)
	+ WTREL(IRED)=WTREL(MROW)
	+ WTREL(MROW)=TMPE
	+ MTMP=IQ(IRED)
	+ IQ(IRED)=IQ(MROW)
	+ IQ(MROW)=MTMP
	+ ENDIF
	+C...Swap columns if necessary
	+ IF(MCOL.NE.IRED) THEN
	+ DO JBIN=1,NBIN
	+ TMPE=WTMAT(JBIN,IRED)
	+ WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
	+ WTMAT(JBIN,MCOL)=TMPE
	+ ENDDO
	+ MTMP=IP(IRED)
	+ IP(IRED)=IP(MCOL)
	+ IP(MCOL)=MTMP
	+ ENDIF
	+C...Begin eliminating equations
	+ DO 220 IBIN=IRED+1,NBIN
	+ IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
	+ MSOLV=0
	+ GOTO 260
	+ ENDIF
	+C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
	+ RQTU=WTMAT(IBIN,IRED)
	+ RQTL=WTMAT(IRED,IRED)
	+C...Switch order of operations
	+ WTREL(IBIN)=WTREL(IBIN)-RQTU*
	+ $ (WTREL(IRED)/RQTL)
	+ DO 210 ICOE=IRED,NBIN
	+ WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
	+ $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
	+ 210 CONTINUE
	+ 220 CONTINUE
	+ 230 CONTINUE
	+ DO 250 IRED=NBIN,1,-1
	+ DO 240 ICOE=IRED+1,NBIN
	+ WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
	+ 240 CONTINUE
	+ IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
	+ MSOLV=0
	+ GOTO 260
	+ ENDIF
	+ COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
	+ TEMPC(IRED)=COEFU(IRED)
	+ 250 CONTINUE
	+C...Return to original order
	+ DO IBIN=1,NBIN
	+ MTMP=IP(IBIN)
	+ COEFU(MTMP)=TEMPC(IBIN)
	+ ENDDO
	+ ENDIF
	+
	+C...Share evenly if failure.
	+ 260 IF(MSOLV.EQ.0) THEN
	+ DO 270 IBIN=1,NBIN
	+ COEFU(IBIN)=1D0
	+ WTRELN(IBIN)=0.1D0
	+ IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
	+ & WTRSAV(IBIN)/WTRELS)
	+ 270 CONTINUE
	+ ENDIF
	+
	+C...Normalize coefficients, with piece shared democratically.
	+ COEFSU=0D0
	+ WTRELS=0D0
	+ DO 280 IBIN=1,NBIN
	+ COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
	+ COEFSU=COEFSU+COEFU(IBIN)
	+ WTRELS=WTRELS+WTRELN(IBIN)
	+ 280 CONTINUE
	+ IF(COEFSU.GT.0D0) THEN
	+ DO 290 IBIN=1,NBIN
	+ COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))0.5D0
	+ & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
	+ 290 CONTINUE
	+ ELSE
	+ DO 300 IBIN=1,NBIN
	+ COEFO(IBIN)=1D0/NBIN
	+ 300 CONTINUE
	+ ENDIF
	+ IF(IVAR.EQ.1) IOFF=0
	+ IF(IVAR.EQ.2) IOFF=17
	+ IF(IVAR.EQ.3) IOFF=7
	+ IF(IVAR.EQ.4) IOFF=12
	+ DO 310 IBIN=1,NBIN
	+ ICOF=IOFF+IBIN
	+ IF(IVAR.EQ.1) THEN
	+ IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
	+ ICOF=7
	+ ENDIF
	+ ENDIF
	+ IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
	+ IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
	+ COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
	+ ELSE
	+ COEF(ISUB,ICOF)=COEFO(IBIN)
	+ ENDIF
	+ 310 CONTINUE
	+
	+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
	+ & (COEFO(IBIN),IBIN=1,NBIN)
	+
	+ 320 CONTINUE
	+
	+C...Find two most promising maxima among points previously determined.
	+ DO 330 J=1,4
	+ IACCMX(J)=0
	+ SIGSMX(J)=0D0
	+ 330 CONTINUE
	+ NMAX=0
	+ DO 390 IACC=1,NACC
	+ DO 340 J=1,30
	+ VINT(10+J)=VINTPT(IACC,J)
	+ 340 CONTINUE
	+ IF(ISTSB.NE.5) THEN
	+ CALL PYSIGH(NCHN,SIGS)
	+ IF(MWTXS.EQ.1) THEN
	+ CALL PYEVWT(WTXS)
	+ SIGS=WTXS*SIGS
	+ ENDIF
	+ ELSE
	+ SIGS=0D0
	+ DO 350 IKIN3=1,MSTP(129)
	+ CALL PYKMAP(5,0,0D0)
	+ IF(MINT(51).EQ.1) GOTO 350
	+ CALL PYSIGH(NCHN,SIGTMP)
	+ IF(MWTXS.EQ.1) THEN
	+ CALL PYEVWT(WTXS)
	+ SIGTMP=WTXS*SIGTMP
	+ ENDIF
	+ IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
	+ 350 CONTINUE
	+ ENDIF
	+ IEQ=0
	+ DO 360 IMV=1,NMAX
	+ IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
	+ 360 CONTINUE
	+ IF(IEQ.EQ.0) THEN
	+ DO 370 IMV=NMAX,1,-1
	+ IIN=IMV+1
	+ IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
	+ IACCMX(IMV+1)=IACCMX(IMV)
	+ SIGSMX(IMV+1)=SIGSMX(IMV)
	+ 370 CONTINUE
	+ IIN=1
	+ 380 IACCMX(IIN)=IACC
	+ SIGSMX(IIN)=SIGS
	+ IF(NMAX.LE.1) NMAX=NMAX+1
	+ ENDIF
	+ 390 CONTINUE
	+
	+C...Read out starting position for search.
	+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
	+ SIGSAM=SIGSMX(1)
	+ DO 440 IMAX=1,NMAX
	+ IACC=IACCMX(IMAX)
	+ MTAU=MVARPT(IACC,1)
	+ MTAUP=MVARPT(IACC,2)
	+ MYST=MVARPT(IACC,3)
	+ MCTH=MVARPT(IACC,4)
	+ VTAU=0.5D0
	+ VYST=0.5D0
	+ VCTH=0.5D0
	+ VTAUP=0.5D0
	+
	+C...Starting point and step size in parameter space.
	+ DO 430 IRPT=1,2
	+ DO 420 IVAR=1,4
	+ IF(NPTS(IVAR).EQ.1) GOTO 420
	+ IF(IVAR.EQ.1) VVAR=VTAU
	+ IF(IVAR.EQ.2) VVAR=VTAUP
	+ IF(IVAR.EQ.3) VVAR=VYST
	+ IF(IVAR.EQ.4) VVAR=VCTH
	+ IF(IVAR.EQ.1) MVAR=MTAU
	+ IF(IVAR.EQ.2) MVAR=MTAUP
	+ IF(IVAR.EQ.3) MVAR=MYST
	+ IF(IVAR.EQ.4) MVAR=MCTH
	+ IF(IRPT.EQ.1) VDEL=0.1D0
	+ IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
	+ & 0.98D0-VVAR))
	+ IF(IRPT.EQ.1) VMAR=0.02D0
	+ IF(IRPT.EQ.2) VMAR=0.002D0
	+ IMOV0=1
	+ IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
	+ DO 410 IMOV=IMOV0,8
	+
	+C...Define new point in parameter space.
	+ IF(IMOV.EQ.0) THEN
	+ INEW=2
	+ VNEW=VVAR
	+ ELSEIF(IMOV.EQ.1) THEN
	+ INEW=3
	+ VNEW=VVAR+VDEL
	+ ELSEIF(IMOV.EQ.2) THEN
	+ INEW=1
	+ VNEW=VVAR-VDEL
	+ ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
	+ & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
	+ VVAR=VVAR+VDEL
	+ SIGSSM(1)=SIGSSM(2)
	+ SIGSSM(2)=SIGSSM(3)
	+ INEW=3
	+ VNEW=VVAR+VDEL
	+ ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
	+ & VVAR-2D0*VDEL.GT.VMAR) THEN
	+ VVAR=VVAR-VDEL
	+ SIGSSM(3)=SIGSSM(2)
	+ SIGSSM(2)=SIGSSM(1)
	+ INEW=1
	+ VNEW=VVAR-VDEL
	+ ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
	+ VDEL=0.5D0*VDEL
	+ VVAR=VVAR+VDEL
	+ SIGSSM(1)=SIGSSM(2)
	+ INEW=2
	+ VNEW=VVAR
	+ ELSE
	+ VDEL=0.5D0*VDEL
	+ VVAR=VVAR-VDEL
	+ SIGSSM(3)=SIGSSM(2)
	+ INEW=2
	+ VNEW=VVAR
	+ ENDIF
	+
	+C...Convert to relevant variables and find derived new limits.
	+ ILERR=0
	+ IF(IVAR.EQ.1) THEN
	+ VTAU=VNEW
	+ CALL PYKMAP(1,MTAU,VTAU)
	+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
	+ CALL PYKLIM(4)
	+ IF(MINT(51).EQ.1) ILERR=1
	+ ENDIF
	+ ENDIF
	+ IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
	+ & ILERR.EQ.0) THEN
	+ IF(IVAR.EQ.2) VTAUP=VNEW
	+ CALL PYKMAP(4,MTAUP,VTAUP)
	+ ENDIF
	+ IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
	+ CALL PYKLIM(2)
	+ IF(MINT(51).EQ.1) ILERR=1
	+ ENDIF
	+ IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
	+ IF(IVAR.EQ.3) VYST=VNEW
	+ CALL PYKMAP(2,MYST,VYST)
	+ CALL PYKLIM(3)
	+ IF(MINT(51).EQ.1) ILERR=1
	+ ENDIF
	+ IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
	+ & ILERR.EQ.0) THEN
	+ IF(IVAR.EQ.4) VCTH=VNEW
	+ CALL PYKMAP(3,MCTH,VCTH)
	+ ENDIF
	+ IF(ISUB.EQ.96) VINT(25)=VINT(21)(1.-VINT(23)*2)
	+
	+C...Evaluate cross-section. Save new maximum. Final maximum.
	+ IF(ILERR.NE.0) THEN
	+ SIGS=0.
	+ ELSEIF(ISTSB.NE.5) THEN
	+ CALL PYSIGH(NCHN,SIGS)
	+ IF(MWTXS.EQ.1) THEN
	+ CALL PYEVWT(WTXS)
	+ SIGS=WTXS*SIGS
	+ ENDIF
	+ ELSE
	+ SIGS=0D0
	+ DO 400 IKIN3=1,MSTP(129)
	+ CALL PYKMAP(5,0,0D0)
	+ IF(MINT(51).EQ.1) GOTO 400
	+ CALL PYSIGH(NCHN,SIGTMP)
	+ IF(MWTXS.EQ.1) THEN
	+ CALL PYEVWT(WTXS)
	+ SIGTMP=WTXS*SIGTMP
	+ ENDIF
	+ IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
	+ 400 CONTINUE
	+ ENDIF
	+ SIGSSM(INEW)=SIGS
	+ IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
	+ IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
	+ & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
	+ 410 CONTINUE
	+ 420 CONTINUE
	+ 430 CONTINUE
	+ 440 CONTINUE
	+ IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
	+ XSEC(ISUB,1)=1.05D0*SIGSAM
	+C...Add extra headroom for UED
	+ IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
	+ IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
	+ & WTGAGA*XSEC(ISUB,1)
	+ 450 CONTINUE
	+ IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
	+ & PARP(174)*XSEC(ISUB,1)
	+ IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
	+ 460 CONTINUE
	+ MINT(51)=0
	+
	+C...Print summary table.
	+ IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
	+ IF(MSTP(127).NE.1) THEN
	+ WRITE(MSTU(11),5900)
	+ CALL PYSTOP(1)
	+ ELSE
	+ WRITE(MSTU(11),6400)
	+ MSTI(53)=1
	+ ENDIF
	+ ENDIF
	+ IF(MSTP(122).GE.1) THEN
	+ WRITE(MSTU(11),6000)
	+ WRITE(MSTU(11),6100)
	+ DO 470 ISUB=1,500
	+ IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
	+ IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
	+ IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
	+ & GOTO 470
	+ IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
	+ IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
	+ & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
	+ IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
	+ WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
	+ 470 CONTINUE
	+ WRITE(MSTU(11),6300)
	+ ENDIF
	+
	+C...Format statements for maximization results.
	+ 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
	+ &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
	+ &'cth',9X,'tau''',7X,'sigma')
	+ 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
	+ &'phase space.'/1X,'Process switched off!')
	+ 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
	+ 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
	+ &'cross-section.'/1X,'Process switched off!')
	+ 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
	+ 5500 FORMAT(1X,1P,10D11.3)
	+ 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
	+ 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
	+ &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
	+ 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
	+ 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
	+ &'cross-section.'/1X,'Execution stopped!')
	+ 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
	+ &'cross-section maximum search',1X,8('*'))
	+ 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
	+ &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
	+ &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
	+ 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
	+ 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
	+ 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
	+ &'cross-section.'/
	+ &1X,'Execution will stop if you try to generate events.')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYPILE
	+C...Initializes multiplicity distribution and selects mutliplicity
	+C...of pileup events, i.e. several events occuring at the same
	+C...beam crossing.
	+
	+ SUBROUTINE PYPILE(MPILE)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
	+C...Local arrays and saved variables.
	+ DIMENSION WTI(0:200)
	+ SAVE IMIN,IMAX,WTI,WTS
	+
	+C...Sum of allowed cross-sections for pileup events.
	+ IF(MPILE.EQ.1) THEN
	+ VINT(131)=SIGT(0,0,5)
	+ IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
	+ IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
	+ IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
	+ IF(MSTP(133).LE.0) RETURN
	+
	+C...Initialize multiplicity distribution at maximum.
	+ XNAVE=VINT(131)*PARP(131)
	+ IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
	+ INAVE=MAX(1,MIN(200,NINT(XNAVE)))
	+ WTI(INAVE)=1D0
	+ WTS=WTI(INAVE)
	+ WTN=WTI(INAVE)*INAVE
	+
	+C...Find shape of multiplicity distribution below maximum.
	+ IMIN=INAVE
	+ DO 100 I=INAVE-1,1,-1
	+ IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
	+ IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
	+ IF(WTI(I).LT.1D-6) GOTO 110
	+ WTS=WTS+WTI(I)
	+ WTN=WTN+WTI(I)*I
	+ IMIN=I
	+ 100 CONTINUE
	+
	+C...Find shape of multiplicity distribution above maximum.
	+ 110 IMAX=INAVE
	+ DO 120 I=INAVE+1,200
	+ IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
	+ IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
	+ IF(WTI(I).LT.1D-6) GOTO 130
	+ WTS=WTS+WTI(I)
	+ WTN=WTN+WTI(I)*I
	+ IMAX=I
	+ 120 CONTINUE
	+ 130 VINT(132)=XNAVE
	+ VINT(133)=WTN/WTS
	+ IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
	+ & WTS/(WTS+WTI(1)/XNAVE)
	+ IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
	+ IF(MSTP(133).GE.2) VINT(134)=XNAVE
	+
	+C...Pick multiplicity of pileup events.
	+ ELSE
	+ IF(MSTP(133).LE.0) THEN
	+ MINT(81)=MAX(1,MSTP(134))
	+ ELSE
	+ WTR=WTS*PYR(0)
	+ DO 140 I=IMIN,IMAX
	+ MINT(81)=I
	+ WTR=WTR-WTI(I)
	+ IF(WTR.LE.0D0) GOTO 150
	+ 140 CONTINUE
	+ 150 CONTINUE
	+ ENDIF
	+ ENDIF
	+
	+C...Format statement for error message.
	+ 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
	+ &'crossing too large, ',1P,D12.4)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYSAVE
	+C...Saves and restores parameter and cross section values for the
	+C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
	+C...Also makes random choice between alternatives.
	+
	+ SUBROUTINE PYSAVE(ISAVE,IGA)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
	+C...Local arrays and saved variables.
	+ DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
	+ &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
	+ &INTCP(15,20),RECP(15,20)
	+ SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
	+
	+C...Save list of subprocesses and cross-section information.
	+ IF(ISAVE.EQ.1) THEN
	+ ICP=0
	+ DO 120 I=1,500
	+ IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
	+ ICP=ICP+1
	+ NSUBCP(IGA,ICP)=I
	+ MSUBCP(IGA,ICP)=MSUB(I)
	+ DO 100 J=1,20
	+ COEFCP(IGA,ICP,J)=COEF(I,J)
	+ 100 CONTINUE
	+ DO 110 J=1,3
	+ NGENCP(IGA,ICP,J)=NGEN(I,J)
	+ XSECCP(IGA,ICP,J)=XSEC(I,J)
	+ 110 CONTINUE
	+ 120 CONTINUE
	+ NCP(IGA)=ICP
	+ DO 130 J=1,3
	+ NGENCP(IGA,0,J)=NGEN(0,J)
	+ XSECCP(IGA,0,J)=XSEC(0,J)
	+ 130 CONTINUE
	+ DO 160 I1=0,6
	+ DO 150 I2=0,6
	+ DO 140 J=0,5
	+ SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
	+ 140 CONTINUE
	+ 150 CONTINUE
	+ 160 CONTINUE
	+
	+C...Save various common process variables.
	+ DO 170 J=1,10
	+ INTCP(IGA,J)=MINT(40+J)
	+ 170 CONTINUE
	+ INTCP(IGA,11)=MINT(101)
	+ INTCP(IGA,12)=MINT(102)
	+ INTCP(IGA,13)=MINT(107)
	+ INTCP(IGA,14)=MINT(108)
	+ INTCP(IGA,15)=MINT(123)
	+ RECP(IGA,1)=CKIN(3)
	+ RECP(IGA,2)=VINT(318)
	+
	+C...Save cross-section information only.
	+ ELSEIF(ISAVE.EQ.2) THEN
	+ DO 190 ICP=1,NCP(IGA)
	+ I=NSUBCP(IGA,ICP)
	+ DO 180 J=1,3
	+ NGENCP(IGA,ICP,J)=NGEN(I,J)
	+ XSECCP(IGA,ICP,J)=XSEC(I,J)
	+ 180 CONTINUE
	+ 190 CONTINUE
	+ DO 200 J=1,3
	+ NGENCP(IGA,0,J)=NGEN(0,J)
	+ XSECCP(IGA,0,J)=XSEC(0,J)
	+ 200 CONTINUE
	+
	+C...Choose between allowed alternatives.
	+ ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
	+ IF(ISAVE.EQ.4) THEN
	+ XSUMCP=0D0
	+ DO 210 IG=1,MINT(121)
	+ XSUMCP=XSUMCP+XSECCP(IG,0,1)
	+ 210 CONTINUE
	+ XSUMCP=XSUMCP*PYR(0)
	+ DO 220 IG=1,MINT(121)
	+ IGA=IG
	+ XSUMCP=XSUMCP-XSECCP(IG,0,1)
	+ IF(XSUMCP.LE.0D0) GOTO 230
	+ 220 CONTINUE
	+ 230 CONTINUE
	+ ENDIF
	+
	+C...Restore cross-section information.
	+ DO 240 I=1,500
	+ MSUB(I)=0
	+ 240 CONTINUE
	+ DO 270 ICP=1,NCP(IGA)
	+ I=NSUBCP(IGA,ICP)
	+ MSUB(I)=MSUBCP(IGA,ICP)
	+ DO 250 J=1,20
	+ COEF(I,J)=COEFCP(IGA,ICP,J)
	+ 250 CONTINUE
	+ DO 260 J=1,3
	+ NGEN(I,J)=NGENCP(IGA,ICP,J)
	+ XSEC(I,J)=XSECCP(IGA,ICP,J)
	+ 260 CONTINUE
	+ 270 CONTINUE
	+ DO 280 J=1,3
	+ NGEN(0,J)=NGENCP(IGA,0,J)
	+ XSEC(0,J)=XSECCP(IGA,0,J)
	+ 280 CONTINUE
	+ DO 310 I1=0,6
	+ DO 300 I2=0,6
	+ DO 290 J=0,5
	+ SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
	+ 290 CONTINUE
	+ 300 CONTINUE
	+ 310 CONTINUE
	+
	+C...Restore various common process variables.
	+ DO 320 J=1,10
	+ MINT(40+J)=INTCP(IGA,J)
	+ 320 CONTINUE
	+ MINT(101)=INTCP(IGA,11)
	+ MINT(102)=INTCP(IGA,12)
	+ MINT(107)=INTCP(IGA,13)
	+ MINT(108)=INTCP(IGA,14)
	+ MINT(123)=INTCP(IGA,15)
	+ CKIN(3)=RECP(IGA,1)
	+ CKIN(1)=2D0*CKIN(3)
	+ VINT(318)=RECP(IGA,2)
	+
	+C...Sum up cross-section info (for PYSTAT).
	+ ELSEIF(ISAVE.EQ.5) THEN
	+ DO 330 I=1,500
	+ MSUB(I)=0
	+ NGEN(I,1)=0
	+ NGEN(I,3)=0
	+ XSEC(I,3)=0D0
	+ 330 CONTINUE
	+ NGEN(0,1)=0
	+ NGEN(0,2)=0
	+ NGEN(0,3)=0
	+ XSEC(0,3)=0
	+ DO 350 IG=1,MINT(121)
	+ DO 340 ICP=1,NCP(IG)
	+ I=NSUBCP(IG,ICP)
	+ IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
	+ NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
	+ NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
	+ XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
	+ 340 CONTINUE
	+ NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
	+ NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
	+ NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
	+ XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
	+ 350 CONTINUE
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYGAGA
	+C...For lepton beams it gives photon-hadron or photon-photon systems
	+C...to be treated with the ordinary machinery and combines this with a
	+C...description of the lepton -> lepton + photon branching.
	+
	+ SUBROUTINE PYGAGA(IGAGA,WTGAGA)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
	+ &/PYINT5/
	+C...Local variables and data statement.
	+ DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
	+ &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
	+ SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
	+ DATA EPS/1D-4/
	+
	+C...Initialize generation of photons inside leptons.
	+ IF(IGAGA.EQ.1) THEN
	+
	+C...Save quantities on incoming lepton system.
	+ VINT(301)=VINT(1)
	+ VINT(302)=VINT(2)
	+ PMS(1)=VINT(303)**2
	+ IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
	+ PMS(2)=VINT(304)**2
	+ IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
	+ PMC(3)=VINT(302)-PMS(1)-PMS(2)
	+ W2MIN=MAX(CKIN(77),2D0CKIN(3),2D0CKIN(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+2I),1D0-2D0VINT(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),
	+ & (YMINPMC(3)-CKIN(64+2I))/PMC(I))
	+ XMAX(I)=MIN(XMAX(I),(YMAXPMC(3)-CKIN(63+2I))/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+2I),XMIN(I)2PMS(I)/(1D0-XMIN(I))+
	+ & ((1D0-XMAX(I))(VINT(302)-2D0PMS(3-I))-
	+ & 2D0PMS(I)/(1D0-XMAX(I)))SIN(THEMIN/2D0)**2,0D0)
	+ Q2MAX(I)=XMAX(I)*2PMS(I)/(1D0-XMAX(I))+
	+ & ((1D0-XMIN(I))(VINT(302)-2D0PMS(3-I))-
	+ & 2D0PMS(I)/(1D0-XMIN(I)))SIN(THEMAX/2D0)**2
	+ IF(CKIN(64+2I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2I),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,12D0MAX(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=WTGAGA2D0(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),2D0CKIN(3),2D0CKIN(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)=4D0PTMN*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)*2PMS(I)/(1D0-X(I))) GOTO 120
	+ IF(Q2(I).GT.(1D0-X(I))(VINT(302)-2D0PMS(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+2I).OR.Y(I).GT.CKIN(72+2I)) GOTO 120
	+ RAT=((1D0-X(I))Q2(I)-X(I)2PMS(I))/
	+ & ((1D0-X(I))*2(VINT(302)-2D0PMS(3-I)-2D0PMS(I)))
	+ THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
	+ IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
	+ IF(CKIN(68+2I).GT.0D0.AND.THETA(I).GT.CKIN(68+2I))
	+ & GOTO 120
	+
	+C...Phi angle isotropic. Reconstruct pT.
	+ PHI(I)=PARU(2)*PYR(0)
	+ PT(I)=SQRT(((1D0-X(I))PMC(I))2/(4D0VINT(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.5D0X(1)PMC(1)X(2)PMC(2)/VINT(302)-
	+ & 2D0PT(1)PT(2)COS(PHI(1)-PHI(2))+2D0
	+ & SQRT((0.5D0X(1)PMC(1)/VINT(301))2+Q2(1)-PT(1)2)*
	+ & SQRT((0.5D0X(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.5D0SQRT((W2-PMS1-PMS2)2-4D0PMS1*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=WTGAGA2D0(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)=4D0PTMN*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.5D0SQRT((PMC(3)2-4D0PMS(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.
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
	+ & MSTP(14).LE.10) THEN
	+ IF(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
	+ 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/(96D0PARU(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=4D0PARP(15)*2
	+ Q1S=4D0VINT(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=2D0BHAD(IHA)+2D0BHAD(IHB)+4D0SH*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=2D0ALP4D0
	+ ENDIF
	+
	+C...Determine maximum possible t range and coefficient of generation.
	+ SQLA12=(SH-SQM1-SQM2)*2-4D0SQM1*SQM2
	+ SQLA34=(SH-SQM3-SQM4)*2-4D0SQM3*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)
	+ & (SQM1SQM4-SQM2SQM3)/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+CRESSMRES1/(SMRES1+SQM3))
	+ IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
	+ ELSEIF(ISUB.EQ.93) THEN
	+ FSD=(1D0-SQM4/SH)(1D0+CRESSMRES2/(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/
	+ & (SHSMP+SQM3SQM4))(1D0+CRESSMRES1/(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=2D0ALPLOG(SH/SQM3)
	+ IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
	+ ELSEIF(ISUB.EQ.93) THEN
	+ BADD=2D0ALPLOG(SH/SQM4)
	+ IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
	+ ELSEIF(ISUB.EQ.94) THEN
	+ BADD=2D0ALP(LOG(EXP(4D0)+SH/(ALPSQM3SQM4))-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-4D0SQM3*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)
	+ & (SQM1SQM4-SQM2SQM3)/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)=2D0SQRT(MAX(0D0,-(THC+THATH+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/I2c21/tau + I1/I3c31/(tau+tau_R) +
	+C...I1/I4c4tau/((stau-m^2)^2+(mGamma)^2) +
	+C...I1/I5c51/(tau+tau_R') +
	+C...I1/I6c6tau/((stau-m'^2)^2+(m'Gamma')^2) +
	+C...I1/I7c7tau/(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/I2c2(1 - tau/tau')^3/tau' +
	+C...I1/I3c31/(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/I1c1(y-ymin) + I0/I2c2(ymax-y*) +
	+C...I0/I3c31/cosh(y) + I0/I4c41/(1-exp(y-y*max)) +
	+C...I0/I5c51/(1-exp(-y-ymin)), I0 = ymax-ymin,
	+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/I1c11/(A - cth) + I0/I2c21/(A + cth) +
	+C...I0/I3c31/(A - cth)^2 + I0/I4c41/(A + cth)^2,
	+C...A = 1 + 2(m3m4/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)
	+ !!! BCN: Relaxing the Pythia warnings that are frequent for beam events
	+ IF (VINT(41).GT.1.1.OR.VINT(42).GT.1.1) 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.25D0XT2GMXVINT(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=WTMXLOG(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=WTLOG(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.25D0VINT(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.25D0VINT(4)*2
	+ VINT(284)=(Q0S+PS)*(Q1S+PS)/
	+ & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
	+ ENDIF
	+ ENDIF
	+ IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
	+
	+C...Format statements for differential cross-section maximum violations.
	+ 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
	+ &'in event',1X,I7,'D0'/1X,'Execution stopped!')
	+ 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
	+ &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
	+ 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
	+ &'in event',1X,I7)
	+ 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
	+ &'in event',1X,I7,'D0'/1X,'Execution stopped!')
	+ 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
	+ &'in event',1X,I7)
	+ 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
	+ 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
	+ 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
	+ 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
	+ 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
	+ 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYSCAT
	+C...Finds outgoing flavours and event type; sets up the kinematics
	+C...and colour flow of the hard scattering
	+
	+ SUBROUTINE PYSCAT
	+
	+C...Double precision and integer declarations
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+
	+C...User process event common block.
	+ INTEGER MAXNUP
	+ PARAMETER (MAXNUP=500)
	+ INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	+ DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	+ COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	+ &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	+ &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	+ SAVE /HEPEUP/
	+
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
	+ &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
	+ COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	+ COMMON/PYPUED/IUED(0:99),RUED(0:99)
	+ SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
	+ &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
	+ &/PYTCSM/,/PYPUED/
	+C...Local arrays and saved variables
	+ DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
	+ &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
	+ INTEGER IOKFLA(6),IIFLAV
	+C...UED related declarations:
	+C...equivalences between ordered particles (451->475)
	+C...and UED particle code (5 000 000 + id)
	+ DIMENSION IUEDEQ(475),MUED(2)
	+ DATA (IUEDEQ(I),I=451,475)/
	+ & 6100001,6100002,6100003,6100004,6100005,6100006,
	+ & 5100001,5100002,5100003,5100004,5100005,5100006,
	+ & 6100011,6100013,6100015,
	+ & 5100012,5100011,5100014,5100013,5100016,5100015,
	+ & 5100021,5100022,5100023,5100024/
	+ SAVE VINTSV
	+
	+C...Read out process
	+ ISUB=MINT(1)
	+ ISUBSV=ISUB
	+
	+C...Restore information for low-pT processes
	+ IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
	+ DO 100 J=41,66
	+ 100 VINT(J)=VINTSV(J)
	+ ENDIF
	+
	+C...Convert H' or A process into equivalent H one
	+ IHIGG=1
	+ KFHIGG=25
	+ IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
	+ &ISUB.LE.190)) THEN
	+ IHIGG=2
	+ IF(MOD(ISUB-1,10).GE.5) IHIGG=3
	+ KFHIGG=33+IHIGG
	+ IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
	+ IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
	+ IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
	+ IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
	+ IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
	+ IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
	+ IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
	+ IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
	+ IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
	+ IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
	+ IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
	+ IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
	+ ENDIF
	+
	+ IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
	+
	+C...Convert bottomonium process into equivalent charmonium ones.
	+ IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
	+
	+C...Choice of subprocess, number of documentation lines
	+ IDOC=6+ISET(ISUB)
	+ IF(ISUB.EQ.95) IDOC=8
	+ IF(ISET(ISUB).EQ.5) IDOC=9
	+ IF(ISET(ISUB).EQ.11) IDOC=4+NUP
	+ MINT(3)=IDOC-6
	+ IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
	+ MINT(4)=IDOC
	+ IPU1=MINT(84)+1
	+ IPU2=MINT(84)+2
	+ IPU3=MINT(84)+3
	+ IPU4=MINT(84)+4
	+ IPU5=MINT(84)+5
	+ IPU6=MINT(84)+6
	+
	+C...Reset K, P and V vectors. Store incoming particles
	+ DO 120 JT=1,MSTP(126)+100
	+ I=MINT(83)+JT
	+ IF(I.GT.MSTU(4)) GOTO 120
	+ DO 110 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=0D0
	+ 110 CONTINUE
	+ 120 CONTINUE
	+ DO 140 JT=1,2
	+ I=MINT(83)+JT
	+ K(I,1)=21
	+ K(I,2)=MINT(10+JT)
	+ DO 130 J=1,5
	+ P(I,J)=VINT(285+5*JT+J)
	+ 130 CONTINUE
	+ 140 CONTINUE
	+ MINT(6)=2
	+ KFRES=0
	+
	+C...Store incoming partons in their CM-frame. Save pdf value.
	+ SH=VINT(44)
	+ SHR=SQRT(SH)
	+ SHP=VINT(26)*VINT(2)
	+ SHPR=SQRT(SHP)
	+ SHUSER=SHR
	+ IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
	+ DO 150 JT=1,2
	+ I=MINT(84)+JT
	+ K(I,1)=14
	+ K(I,2)=MINT(14+JT)
	+ K(I,3)=MINT(83)+2+JT
	+ P(I,3)=0.5D0SHUSER(-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)*24D0/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/(4D0XH)*PYR(0)) GOTO 220
	+ SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
	+ SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	+ Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	+ Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	+ & 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/(4D0XH)*PYR(0)) GOTO 230
	+ SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
	+ SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	+ Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	+ Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	+ & 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/(4D0XH)*PYR(0)) GOTO 330
	+ SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
	+ SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	+ Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	+ Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	+ & 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/(4D0XH)*PYR(0)) GOTO 340
	+ SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
	+ SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	+ Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	+ Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	+ & 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/(4D0XH)*PYR(0)) GOTO 370
	+ SQC1=1D0-4D0PMQ(JT)2/(Z(JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(0)-1D0)C1))/C1
	+ CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
	+ Z(3-JT)=1D0-XH/(1D0-Z(JT))
	+ SQC1=1D0-4D0PMQ(3-JT)2/(Z(3-JT)2SHP)
	+ 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-(C22-C12)/(C2+(2D0PYR(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=ANGSQRT(Z(JT)2-4D0PMQ(JT)**2/SHP)
	+ Z3=1D0-Z(JT)-XH+(PMQ(1)2+PMQ(2)2)/SHP
	+ Z(3-JT)=2D0/(Z12-Z22)(Z1Z3+Z2SQRT(Z32-(Z12-Z22)
	+ & 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+5JTA)-P(I,5)2+VINT(196+5JTA)**2))
	+ P(I,1)=PTCOS(VINT(198+5JTA))
	+ P(I,2)=PTSIN(VINT(198+5JTA))
	+ 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-4D0PMS1*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.5D0SHPRZ(JT).LE.P(I,5)) THEN
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+ PABS=SQRT(MAX(0D0,(0.5D0SHPRZ(JT))2-P(I,5)2))
	+ PTABS=PABSSQRT(MAX(0D0,1D0-CTHE(JT)*2))
	+ P(I,1)=PTABS*COS(PHI(JT))
	+ P(I,2)=PTABS*SIN(PHI(JT))
	+ P(I,3)=PABSCTHE(JT)(-1)**(JT+1)
	+ P(I,4)=0.5D0SHPRZ(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.5D0SHPR-PABSCTHE(JT))(-1)*(JT+1)
	+ P(IZW,4)=0.5D0SHPR(1D0-Z(JT))
	+ P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)2+PTABS2-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.5D0SHPRZ(JT).LE.P(I,5)) P(I,5)=0D0
	+ PABS=SQRT(MAX(0D0,(0.5D0SHPRZ(JT))2-P(I,5)2))
	+ PTABS=PABSSQRT(MAX(0D0,1D0-CTHE(JT)*2))
	+ P(I,1)=PTABS*COS(PHI(JT))
	+ P(I,2)=PTABS*SIN(PHI(JT))
	+ P(I,3)=PABSCTHE(JT)(-1)**(JT+1)
	+ P(I,4)=0.5D0SHPRZ(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.5D0SHPR-PABSCTHE(JT))(-1)*(JT+1)
	+ P(IZW,4)=0.5D0SHPR(1D0-Z(JT))
	+ P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)2+PTABS2-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=BEXCMP(I1,1)+BEYCMP(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(PX2+PY2))
	+ PHICM=PYANGL(PX,PY)
	+C...Store hard scattering subsystem. Rotate and boost it
	+ SQLAM=(SH-P(IPU5,5)2-P(IPU6,5)2)*2-4D0P(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)=PABSSTHWZCOS(PHIWZ)
	+ P(IPU5,2)=PABSSTHWZSIN(PHIWZ)
	+ P(IPU5,3)=PABS*CTHWZ
	+ P(IPU5,4)=SQRT(PABS2+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(PABS2+P(IPU6,5)2)
	+ CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
	+ DO 620 JT=1,2
	+ I1=MINT(83)+8+JT
	+ I2=MINT(84)+4+JT
	+ K(I1,1)=21
	+ K(I1,2)=K(I2,2)
	+ DO 610 J=1,5
	+ P(I1,J)=P(I2,J)
	+ 610 CONTINUE
	+ 620 CONTINUE
	+ N=IPU6
	+ MINT(7)=MINT(83)+9
	+ MINT(8)=MINT(83)+10
	+ ENDIF
	+
	+ IF(ISET(ISUB).EQ.11) THEN
	+ ELSEIF(IDOC.GE.8) THEN
	+C...Store colour connection indices
	+ DO 630 J=1,2
	+ JC=J
	+ IF(KCS.EQ.-1) JC=3-J
	+ IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
	+ & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
	+ IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
	+ & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
	+ IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
	+ & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
	+ IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
	+ & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
	+ 630 CONTINUE
	+
	+C...Copy outgoing partons to documentation lines
	+ IMAX=2
	+ IF(IDOC.EQ.9) IMAX=3
	+ DO 650 I=1,IMAX
	+ I1=MINT(83)+IDOC-IMAX+I
	+ I2=MINT(84)+2+I
	+ K(I1,1)=21
	+ K(I1,2)=K(I2,2)
	+ IF(IDOC.LE.9) K(I1,3)=0
	+ IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
	+ DO 640 J=1,5
	+ P(I1,J)=P(I2,J)
	+ 640 CONTINUE
	+ 650 CONTINUE
	+
	+ ELSEIF(IDOC.EQ.9) THEN
	+C...Store colour connection indices
	+ DO 660 J=1,2
	+ JC=J
	+ IF(KCS.EQ.-1) JC=3-J
	+ IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
	+ & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
	+ & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
	+ IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
	+ & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
	+ & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
	+ IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
	+ & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
	+ IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
	+ & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
	+ 660 CONTINUE
	+
	+C...Copy outgoing partons to documentation lines
	+ DO 680 I=1,3
	+ I1=MINT(83)+IDOC-3+I
	+ I2=MINT(84)+2+I
	+ K(I1,1)=21
	+ K(I1,2)=K(I2,2)
	+ K(I1,3)=0
	+ DO 670 J=1,5
	+ P(I1,J)=P(I2,J)
	+ 670 CONTINUE
	+ 680 CONTINUE
	+ ENDIF
	+
	+C...Copy outgoing partons to list of allowed radiators.
	+ NPART=0
	+ IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
	+ DO 690 I=MINT(84)+3,N
	+ NPART=NPART+1
	+ IPART(NPART)=I
	+ PTPART(NPART)=SQRT(P(I,5)2+P(I,1)2+P(I,2)**2)
	+ 690 CONTINUE
	+ ENDIF
	+
	+C...Low-pT events: remove gluons used for string drawing purposes
	+ IF(ISUB.EQ.95) THEN
	+ IF(MINT(35).LE.1) THEN
	+ K(IPU3,1)=K(IPU3,1)+10
	+ K(IPU4,1)=K(IPU4,1)+10
	+ ENDIF
	+ DO 700 J=41,66
	+ VINTSV(J)=VINT(J)
	+ VINT(J)=0D0
	+ 700 CONTINUE
	+ DO 720 I=MINT(83)+5,MINT(83)+8
	+ DO 710 J=1,5
	+ P(I,J)=0D0
	+ 710 CONTINUE
	+ 720 CONTINUE
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C***********************************************************************
	+
	+C...PYEVOL
	+C...Handles intertwined pT-ordered spacelike initial-state parton
	+C...and multiple interactions.
	+
	+ SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
	+C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
	+C...MODE = 0 : (Re-)initialize ISR/MI evolution.
	+C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...External
	+ EXTERNAL PYALPS
	+ DOUBLE PRECISION PYALPS
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
	+ & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
	+ COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
	+C...Max size of hard system = HEPEUP size
	+ INTEGER MAXNUP
	+ PARAMETER (MAXNUP=500)
	+C...Local arrays and saved variables.
	+ DIMENSION VINTSV(11:80),KSAV(MAXNUP,5),PSAV(MAXNUP,5),
	+ & VSAV(MAXNUP,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,NSAV-MINT(84)
	+ 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,NSAV-MINT(84)
	+ 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.1D0ALAM3)*2)
	+ IF (MSTP(70).EQ.2) THEN
	+C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
	+ VINT(18)=(PARP(82)(VINT(1)/PARP(89))PARP(90))*2
	+ ELSEIF (MSTP(70).EQ.3) THEN
	+C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
	+ ALPHA0 = MAX(1D-6,PARP(73))
	+ Q20 = ALAM3**2/PARP(64)
	+ IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
	+ VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
	+ ENDIF
	+C...Also store PT2MIN in VINT(17).
	+ 180 VINT(17)=PT2MIN
	+
	+C...Set FS masses zero now.
	+ VINT(63)=0D0
	+ VINT(64)=0D0
	+
	+C...Initialize IS showers with VINT(56) as max scale.
	+ PT2ISR=VINT(56)
	+ PT20=PT2MIN
	+ IF (MSTP(70).EQ.0) THEN
	+ PT20=MAX(PT2MIN,PARP(62)**2)
	+ ELSEIF (MSTP(70).EQ.1) THEN
	+ PT20=MAX(PT2MIN,(PARP(81)(VINT(1)/PARP(89))PARP(90))*2)
	+ ENDIF
	+ CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
	+ IF(MINT(51).NE.0) RETURN
	+
	+ RETURN
	+
	+C----------------------------------------------------------------------
	+C...MODE= 1: Evolve event from PTMAX to PTMIN.
	+ ELSEIF (MODE.EQ.1) THEN
	+
	+C...Skip if no phase space.
	+ 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
	+
	+C...Starting pT2 max scale (to be udpated successively).
	+ PT2CMX=PT2MAX
	+
	+C...Evolve two sides of the event to find which branches at highest pT.
	+ 200 JSMX=-1
	+ MIMX=0
	+ PT2MX=0D0
	+
	+C...Loop over current shower initiators.
	+ IF (MSTP(61).GE.1) THEN
	+ DO 230 MI=1,MINT(31)
	+ IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
	+ ISUB=96
	+ IF (MI.EQ.1) ISUB=ISUBHD
	+ MINT(1)=ISUB
	+ MINT(36)=MI
	+C...Set up shat, initiator x values, and x remaining in BR.
	+ VINT(44)=SHAT(MI)
	+ VINT(141)=XMI(1,MI)
	+ VINT(142)=XMI(2,MI)
	+ VINT(143)=1D0
	+ VINT(144)=1D0
	+ DO 210 JI=1,MINT(31)
	+ IF (JI.EQ.MINT(36)) GOTO 210
	+ VINT(143)=VINT(143)-XMI(1,JI)
	+ VINT(144)=VINT(144)-XMI(2,JI)
	+ 210 CONTINUE
	+C...Loop over sides.
	+C...Generate trial branchings for this interaction. The hardest
	+C...branching so far is automatically updated if necessary in /PYISMX/.
	+ DO 220 JS=1,2
	+ MINT(30)=JS
	+ PT20=PT2MIN
	+ IF (MSTP(70).EQ.0) THEN
	+ PT20=MAX(PT2MIN,PARP(62)**2)
	+ ELSEIF (MSTP(70).EQ.1) THEN
	+ PT20=MAX(PT2MIN,
	+ & (PARP(81)(VINT(1)/PARP(89))PARP(90))*2)
	+ ENDIF
	+ CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
	+ IF (MINT(51).NE.0) RETURN
	+ 220 CONTINUE
	+ 230 CONTINUE
	+ ENDIF
	+
	+C...Generate trial additional interaction.
	+ MINT(36)=MINT(31)+1
	+ 240 IF (MOD(MSTP(81),10).GE.1) THEN
	+ MINT(1)=96
	+C...Set up X remaining in BR.
	+ VINT(143)=1D0
	+ VINT(144)=1D0
	+ DO 250 JI=1,MINT(31)
	+ VINT(143)=VINT(143)-XMI(1,JI)
	+ VINT(144)=VINT(144)-XMI(2,JI)
	+ 250 CONTINUE
	+C...Generate trial interaction
	+ 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
	+ IF (MINT(51).EQ.1) RETURN
	+ ENDIF
	+
	+C...And the winner is:
	+ IF (PT2MX.LT.PT2MIN) THEN
	+ GOTO 330
	+ ELSEIF (JSMX.EQ.0) THEN
	+C...Accept additional interaction (may still fail).
	+ CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
	+ IF(MINT(51).NE.0) RETURN
	+ IF (IFAIL.EQ.0) THEN
	+ SHAT(MINT(36))=VINT(44)
	+C...Decide on flavours (valence/sea/companion).
	+ DO 270 JS=1,2
	+ MINT(30)=JS
	+ CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
	+ IF(MINT(51).NE.0) RETURN
	+ 270 CONTINUE
	+ ENDIF
	+ ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
	+C...Reconstruct kinematics of acceptable ISR branching.
	+C...Set up shat, initiator x values, and x remaining in BR.
	+ MINT(30)=JSMX
	+ MINT(36)=MIMX
	+ VINT(44)=SHAT(MINT(36))
	+ VINT(141)=XMI(1,MINT(36))
	+ VINT(142)=XMI(2,MINT(36))
	+ VINT(143)=1D0
	+ VINT(144)=1D0
	+ DO 280 JI=1,MINT(31)
	+ IF (JI.EQ.MINT(36)) GOTO 280
	+ VINT(143)=VINT(143)-XMI(1,JI)
	+ VINT(144)=VINT(144)-XMI(2,JI)
	+ 280 CONTINUE
	+ PT2NEW=PT2MX
	+ CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
	+ IF (MINT(51).EQ.1) RETURN
	+ ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
	+C...Bookeep joining. Cannot (yet) be constructed kinematically.
	+ MINT(354)=MINT(354)+1
	+ VINT(354)=VINT(354)+SQRT(PT2MX)
	+ IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
	+ MJOIND(JSMX-2,MJN1MX)=MJN2MX
	+ MJOIND(JSMX-2,MJN2MX)=MJN1MX
	+ ENDIF
	+
	+C...Update PT2 iteration scale.
	+ PT2CMX=PT2MX
	+
	+C...Loop back to continue evolution.
	+ IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	+ CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
	+ ELSE
	+ IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
	+ ENDIF
	+
	+C----------------------------------------------------------------------
	+C...MODE= 2: (Re-)store user information on hardest interaction etc.
	+ ELSEIF (MODE.EQ.2) THEN
	+
	+C...Revert to "ordinary" meanings of some parameters.
	+ 290 DO 310 JS=1,2
	+ MINT(12+JS)=K(IMI(JS,1,1),2)
	+ VINT(140+JS)=XMI(JS,1)
	+ IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
	+ VINT(142+JS)=1D0
	+ DO 300 MI=1,MINT(31)
	+ VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
	+ 300 CONTINUE
	+ 310 CONTINUE
	+
	+C...Restore saved quantities for hardest interaction.
	+ MINT(1)=ISUBHD
	+ MINT(15)=M15SV
	+ MINT(16)=M16SV
	+ MINT(21)=M21SV
	+ MINT(22)=M22SV
	+ DO 320 J=11,80
	+ VINT(J)=VINTSV(J)
	+ 320 CONTINUE
	+
	+ ENDIF
	+
	+ 330 RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYSSPA
	+C...Generates spacelike parton showers.
	+
	+ SUBROUTINE PYSSPA(IPU1,IPU2)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
	+C...Local arrays and data.
	+ DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
	+ &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
	+ &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
	+ &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
	+ &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
	+ DATA IS/2*0/
	+
	+C...Read out basic information; set global Q^2 scale.
	+ IPUS1=IPU1
	+ IPUS2=IPU2
	+ ISUB=MINT(1)
	+ Q2MX=VINT(56)
	+ VINT2R=VINT(2)VINT(143)VINT(144)
	+ IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
	+ &MIN(VINT2R,PARP(67)*VINT(56))
	+ FCQ2MX=1D0
	+
	+C...Define which processes ME corrections have been implemented for.
	+ MECOR=0
	+ IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
	+ IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
	+ & ISUB.EQ.144) MECOR=1
	+ IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
	+ IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
	+ ENDIF
	+
	+C...Initialize QCD evolution and check phase space.
	+ Q2MNC=PARP(62)**2
	+ Q2MNCS(1)=Q2MNC
	+ Q2MNCS(2)=Q2MNC
	+ IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
	+ Q0S=PARP(15)**2
	+ PS=VINT(3)**2
	+ Q2EFF=VINT(54)((Q0S+PS)/(VINT(54)+PS))
	+ & EXP(PS(VINT(54)-Q0S)/((VINT(54)+PS)(Q0S+PS)))
	+ Q2INT=SQRT(Q0S*Q2EFF)
	+ Q2MNCS(1)=MAX(Q2MNC,Q2INT)
	+ ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
	+ Q2MNCS(1)=MAX(Q2MNC,VINT(283))
	+ ENDIF
	+ IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
	+ Q0S=PARP(15)**2
	+ PS=VINT(4)**2
	+ Q2EFF=VINT(54)((Q0S+PS)/(VINT(54)+PS))
	+ & EXP(PS(VINT(54)-Q0S)/((VINT(54)+PS)(Q0S+PS)))
	+ Q2INT=SQRT(Q0S*Q2EFF)
	+ Q2MNCS(2)=MAX(Q2MNC,Q2INT)
	+ ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
	+ Q2MNCS(2)=MAX(Q2MNC,VINT(284))
	+ ENDIF
	+ MCEV=0
	+ ALAMS=PARU(112)
	+ PARU(112)=PARP(61)
	+ FQ2C=1D0
	+ TCMX=0D0
	+ IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
	+ MCEV=1
	+ IF(MSTP(64).EQ.1) FQ2C=PARP(63)
	+ IF(MSTP(64).EQ.2) FQ2C=PARP(64)
	+ TCMX=LOG(FQ2CQ2MX/PARP(61)*2)
	+ IF(Q2MX.LT.MAX(Q2MNC,2D0PARP(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,2D0SPME)
	+ 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.9D0Q2S(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+
	+ & 8D0Q2S(1)Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
	+ ENDIF
	+ IF(MCEV.EQ.1) TEVCB=LOG(FQ2CQ2B/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.EQ2LOG((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/(4D0PARU(102))LOG((1D0-XEE-XB)*(1D0-XEE)/
	+ & (XEE*(XB+XEE)))/XB
	+ ELSEIF(KFLB.EQ.-24) THEN
	+ WTAPE(11)=1D0/(4D0PARU(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=TEVCBEXP(MAX(-50D0,LOG(PYR(0))B0/WTSUMC))
	+ ELSE
	+ TEVCB=TEVCBEXP(MAX(-50D0,LOG(PYR(0))B0/(5D0*WTSUMC)))
	+ ENDIF
	+ ENDIF
	+ IF(MEEV.EQ.1) THEN
	+ TEVEB=TEVEBEXP(MAX(-50D0,LOG(PYR(0))PARU(2)/
	+ & (PARU(101)FWTEWTSUME*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)*2EXP(MAX(-50D0,TEVCB))/FQ2C
	+ IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
	+ IF(MEEV.EQ.2) Q2EB=ALAM(JT)*2EXP(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.1D0PMAS(KFLCB,1)*2
	+ TEVCB=LOG(FQ2CQ2B/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(FQ2CQ2B/ALAM(JT)*2)
	+ ELSE
	+ Q2B=Q2EB
	+ Q2REF=Q2B
	+ IF(MCEV.EQ.1) TEVCB=LOG(FQ2CQ2B/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+Z2)(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-2D0Z(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-2D0Z(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))(RSOFTXEC/((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=(4D0Q2B)/(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=(4D0Z2Q2B)/(4D0Z2Q2B+(1D0-Z)XB2VINT2R)
	+ 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(WTZXFAN/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-4D0DQ2(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-4D0DQ2(JR)*DQ2(JT))
	+ DPD(4)=SQRT(DPD(2)*2-4D0DQ2(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.5D0DPD(1)DPD(2)+0.5D0DPD(3)*
	+ & DPD(4)-DQ2(JR)(DQ2(JT)+DQ2(3)))/(4D0DSHDPC(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.5D0DPD(1)*DPD(2)+
	+ & 0.5D0DPD(3)DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
	+ & (4D0DSHDPC(3)**2)
	+ IF(DPT2.LT.0D0) GOTO 100
	+ DPB(1)=(0.5D0DPD(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.
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ ELSEIF(K(IT,2).LT.0) THEN
	+ ID1=IS(JT)
	+ ID2=IT
	+ ELSEIF(K(IT,2).EQ.21) THEN
	+ IF(PYR(0).GT.0.5D0) THEN
	+ ID1=IS(JT)
	+ ID2=IT
	+ ELSE
	+ ID1=IT
	+ ID2=IS(JT)
	+ ENDIF
	+ 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(DBSVX2+DBSVZ2.GE.1D0) GOTO 100
	+ CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
	+ IR=N+(JT-1)*(IS(1)-N)
	+ CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
	+ & 0D0,0D0,0D0)
	+
	+C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
	+ IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
	+ NPART=NPART+1
	+ IPART(NPART)=IT
	+ PTPART(NPART)=SQRT(PARP(71)*DPT2)
	+ ENDIF
	+
	+C...Global statistics.
	+ MINT(352)=MINT(352)+1
	+ VINT(352)=VINT(352)+SQRT(P(IT,1)2+P(IT,2)2)
	+ IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)2+P(IT,2)2)
	+
	+ ENDIF
	+
	+C...Update kinematics variables.
	+ IS(JT)=N
	+ DQ2(JT)=Q2B
	+ IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
	+ DSH=DSHZ
	+
	+C...Save quantities; loop back.
	+ Q2S(JT)=Q2B
	+ DPHI(JT)=PHIBR
	+ MCESV(JT)=MCE
	+ IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
	+ &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
	+ KFLS(JT+2)=KFLS(JT)
	+ KFLS(JT)=KFLA
	+ XS(JT)=XA
	+ ZS(JT)=Z
	+ DO 310 KFL=-25,25
	+ XFS(JT,KFL)=XFA(KFL)
	+ 310 CONTINUE
	+ TEVCSV(JT)=TEVCB
	+ TEVESV(JT)=TEVEB
	+ ELSE
	+ MORE(JT)=0
	+ IF(JT.EQ.1) IPU1=N
	+ IF(JT.EQ.2) IPU2=N
	+ ENDIF
	+ IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	+ CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
	+ IF(MSTU(21).GE.1) N=NS
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
	+
	+C...Boost hard scattering partons to frame of shower initiators.
	+ DO 320 J=1,3
	+ ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
	+ 320 CONTINUE
	+ K(N+2,1)=1
	+ DO 330 J=1,5
	+ P(N+2,J)=P(NS+1,J)
	+ 330 CONTINUE
	+ CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
	+ ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
	+ ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)2+P(N+2,2)2))
	+ IMIN=MINT(83)+5
	+ IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
	+ CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
	+ CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
	+
	+C...Store user information. Reset Lambda value.
	+ IF(MINT(31).LE.1) THEN
	+ K(IPU1,3)=MINT(83)+3
	+ K(IPU2,3)=MINT(83)+4
	+ ELSE
	+ K(IPU1,3)=MINT(83)+1
	+ K(IPU2,3)=MINT(83)+2
	+ ENDIF
	+ DO 340 JT=1,2
	+ MINT(12+JT)=KFLS(JT)
	+ VINT(140+JT)=XS(JT)
	+ IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
	+ IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
	+ 340 CONTINUE
	+ PARU(112)=ALAMS
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYPTIS
	+C...Generates pT-ordered spacelike initial-state parton showers and
	+C...trial joinings.
	+C...MODE=-1: Initialize ISR from scratch, starting from the hardest
	+C... interaction initiators at PT2NOW.
	+C...MODE= 0: Generate a trial branching on interaction MINT(36), side
	+C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
	+C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
	+C... is below PT2CUT.
	+C... (Also generate test joinings if MSTP(96)=1.)
	+C...MODE= 1: Accept stored shower branching. Update event record etc.
	+C...PT2NOW : Starting (max) PT2 scale for evolution.
	+C...PT2CUT : Lower limit for evolution.
	+C...PT2 : Result of evolution. Generated PT2 for trial emission.
	+C...IFAIL : Status return code. IFAIL=0 when all is well.
	+
	+ SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
	+ & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
	+ SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
	+ & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
	+C...Local variables
	+ DIMENSION ZSAV(2,240),PT2SAV(2,240),
	+ & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
	+ & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
	+ & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
	+ SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
	+ & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
	+C...For check on excessive weights.
	+ CHARACTER CHWT*12
	+
	+C...Only give errors for very large weights, otherwise just warnings
	+ DATA WTEMAX /1.5D0/
	+C...Only give errors for large pT, otherwise just warnings
	+ DATA PTEMAX /5D0/
	+
	+ IFAIL=-1
	+
	+C----------------------------------------------------------------------
	+C...MODE=-1: Initialize initial state showers from scratch, i.e.
	+C...starting from the hardest interaction initiators.
	+ IF (MODE.EQ.-1) THEN
	+C...Set hard scattering SHAT.
	+ SHTNOW(1)=VINT(44)
	+C...Mass thresholds and Lambda for QCD evolution.
	+ AEM2PI=PARU(101)/PARU(2)
	+ RMB=PMAS(5,1)
	+ RMC=PMAS(4,1)
	+ ALAM4=PARP(61)
	+ IF(MSTU(112).LT.4) ALAM4=PARP(61)(PARP(61)/RMC)*(2D0/25D0)
	+ IF(MSTU(112).GT.4) ALAM4=PARP(61)(RMB/PARP(61))*(2D0/25D0)
	+ ALAM5=ALAM4(ALAM4/RMB)*(2D0/23D0)
	+ ALAM3=ALAM4(RMC/ALAM4)*(2D0/27D0)
	+C...Optionally use Lambda_MC = Lambda_CMW
	+ IF (MSTP(64).EQ.3) THEN
	+ ALAM5 = ALAM5 * 1.569
	+ ALAM4 = ALAM4 * 1.618
	+ ALAM3 = ALAM3 * 1.661
	+ ENDIF
	+ RMB2=RMB**2
	+ RMC2=RMC**2
	+C...Massive quark forced creation threshold (in M**2).
	+ TMIN=1.01D0
	+C...Set upper limit for X (ensures some X left for beam remnant).
	+ XMXC=1D0-2D0*PARP(111)/VINT(1)
	+
	+ IF (MSTP(61).GE.1) THEN
	+C...Initial values: flavours, momenta, virtualities.
	+ DO 100 JS=1,2
	+ NISGEN(JS,1)=0
	+
	+C...Special kinematics check for c/b quarks (that g -> c cbar or
	+C...b bbar kinematically possible).
	+ KFLB=K(IMI(JS,1,1),2)
	+ KFLCB=IABS(KFLB)
	+ IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
	+C...Check PT2MAX > mQ^2
	+ IF (VINT(56).LT.1.05D0PMAS(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(Z2+(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(Z2+(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)=6D0LOG(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(Z2+(1D0-Z)*2)
	+ ELSE
	+ WTAPJ(MJ)=Z4D0/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/(AEM2PIWTAPE))-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/(TPLPYR(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
	+C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
	+C...picked up by ISR (necessary since intertwining not implemented)
	+C...Here simply kill backwards-evolution probability.
	+ IF (KFLB.EQ.21.AND.(IABS(KFLA).EQ.4.OR.IABS(KFLA).EQ.5)) THEN
	+ IF (KSVCA.GE.1) WTVETO = 0D0
	+ ENDIF
	+ WTVETO=WTVETO*XFJ(KFLA)
	+C...Monte Carlo veto to accept trial joining
	+ 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)2RMQ2/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=Z2+(1D0-Z)2
	+C...Massive correction
	+ IF (MQMASS.NE.0) THEN
	+ WTZ=WTZ+2D0Z(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
	+C...(prevent infinite loop by limiting number of NTRY)
	+ IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0.AND.NTRY.LE.200) 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 last if several)
	+ DO 260 IFS=1,NPART
	+ MCJ = MCT(IPART(IFS),MSIDE)
	+ IF (MCJ.NE.MCTAG) GOTO 260
	+C...Pick last matching final-state partner if several
	+C...(if no matching final-state partner, defaults back to annihilation)
	+ KSJ = K(IPART(IFS),1)
	+ IF (KSJ.GE.1.AND.KSJ.LT.10) 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 (4D0PT2.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 (4D0PT2PYR(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))))2PT2SAV(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=WTZXFAN/XFBNWTPDFA
	+ ELSEIF(MCRQQ.EQ.1) THEN
	+ WTPDFA=TPM/WPDF0
	+ WTTOT=WTCRQQWTZXFAN/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)=KT1MSTU(5)2+IM1MSTU(5)+ID1
	+ K(I,5)=KT2MSTU(5)2+IM2MSTU(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.5D0SQRT(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(BETAX2+BETAZ2.GE.1D0) THEN
	+ CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
	+ MINT(51)=1
	+ IFAIL=-1
	+ RETURN
	+ ENDIF
	+ CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
	+ I1=IMI(1,MI,1)
	+ THETA=PYANGL(P(I1,3),P(I1,1))
	+ CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
	+
	+C...Global statistics.
	+ MINT(352)=MINT(352)+1
	+ VINT(352)=VINT(352)+SQRT(P(IT,1)2+P(IT,2)2)
	+ IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)2+P(IT,2)2)
	+
	+C...Add parton with relevant pT scale for timelike shower.
	+ IF (K(IT,2).NE.22) THEN
	+ NPART=NPART+1
	+ IPART(NPART)=IT
	+ PTPART(NPART)=SQRT(PT2AMX)
	+ ENDIF
	+
	+C...Update saved variables.
	+ SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
	+ NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
	+ XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
	+ PT2SAV(JSMX,MIMX)=PT2MX
	+ ZSAV(JS,MIMX)=ZMX
	+
	+ KSA=IABS(K(IS,2))
	+ KMA=IABS(K(IM,2))
	+ IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
	+C...Gluon reconstructs to quark.
	+C...Decide whether newly created quark is valence or sea:
	+ MINT(30)=JS
	+ CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
	+ IF(MINT(51).NE.0) RETURN
	+ ENDIF
	+ IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
	+C...Quark reconstructs to gluon.
	+C...Now some guy may have lost his companion. Check.
	+ ICMP=IMI(JS,MI,2)
	+ IF (ICMP.GT.0) THEN
	+ CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
	+ & //' away. Cannot handle that yet. Giving up.')
	+ MINT(51)=1
	+ RETURN
	+ ELSEIF(ICMP.LT.0) THEN
	+C...A sea quark with companion still in BR was reconstructed to a gluon.
	+C...Companion should now be removed from the beam remnant.
	+C...(Momentum integral is automatically updated in next call to PYPDFU.)
	+ ICMP=-ICMP
	+ IFL=-K(IS,2)
	+ DO 380 JCMP=ICMP,NVC(JS,IFL)-1
	+ XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
	+ DO 370 JI=1,MINT(31)
	+ KMI=-IMI(JS,JI,2)
	+ JFL=-K(IMI(JS,JI,1),2)
	+ IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
	+ & ,2)+1
	+ 370 CONTINUE
	+ 380 CONTINUE
	+ NVC(JS,IFL)=NVC(JS,IFL)-1
	+ ENDIF
	+C...Set gluon IMI(JS,MI,2) = 0.
	+ IMI(JS,MI,2)=0
	+ ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
	+C...Quark reconstructing to quark. If sea with companion still in BR
	+C...then update associated x value.
	+C...(Momentum integral is automatically updated in next call to PYPDFU.)
	+ IF (IMI(JS,MI,2).LT.0) THEN
	+ ICMP=-IMI(JS,MI,2)
	+ IFL=-K(IS,2)
	+ XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
	+ ENDIF
	+ ENDIF
	+
	+ ENDIF
	+
	+C...If reached this point, normal exit.
	+ 390 IFAIL=0
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYMEMX
	+C...Generates maximum ME weight in some initial-state showers.
	+C...Inparameter MECOR: kind of hard scattering process
	+C...Outparameter WTFF: maximum weight for fermion -> fermion
	+C... WTGF: maximum weight for gluon/photon -> fermion
	+C... WTFG: maximum weight for fermion -> gluon/photon
	+C... WTGG: maximum weight for gluon -> gluon
	+
	+ SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
	+
	+C...Default maximum weight.
	+ WTFF=1D0
	+ WTGF=1D0
	+ WTFG=1D0
	+ WTGG=1D0
	+
	+C...Select maximum weight by process.
	+ IF(MECOR.EQ.1) THEN
	+ WTFF=1D0
	+ WTGF=3D0
	+ ELSEIF(MECOR.EQ.2) THEN
	+ WTFG=1D0
	+ WTGG=1D0
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYMEWT
	+C...Calculates actual ME weight in some initial-state showers.
	+C...Inparameter MECOR: kind of hard scattering process
	+C... IFLCB: flavour combination of branching,
	+C... 1 for fermion -> fermion,
	+C... 2 for gluon/photon -> fermion
	+C... 3 for fermion -> gluon/photon,
	+C... 4 for gluon -> gluon
	+C... Q2: Q2 value of shower branching
	+C... Z: Z value of branching
	+C...In+outparameter PHIBR: azimuthal angle of branching
	+C...Outparameter WTME: actual ME weight
	+
	+ SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
	+
	+C...Default output.
	+ WTME=1D0
	+
	+C...Define kinematics of shower branching in Mandelstam variables.
	+ SQM=VINT(44)
	+ SH=SQM/Z
	+ TH=-Q2
	+ UH=Q2-SQM*(1D0-Z)/Z
	+
	+C...Matrix-element corrections for f + fbar -> s-channel vector boson.
	+ IF(MECOR.EQ.1) THEN
	+ IF(IFLCB.EQ.1) THEN
	+ WTME=(TH2+UH2+2D0SQMSH)/(SH2+SQM2)
	+ ELSEIF(IFLCB.EQ.2) THEN
	+ WTME=(SH2+TH2+2D0SQMUH)/((SH-SQM)2+SQM2)
	+ ENDIF
	+
	+C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
	+ ELSEIF(MECOR.EQ.2) THEN
	+ IF(IFLCB.EQ.3) THEN
	+ WTME=(SH2+UH2)/(SH2+(SH-SQM)2)
	+ ELSEIF(IFLCB.EQ.4) THEN
	+ WTME=0.5D0(SH4+UH4+TH4+SQM4)/(SH2-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=(SH2+TH2+2D0(SQM-TH)(SQM-SH))/
	+ 1 (SH*2+2D0SQM*(SQM-SH))
	+ ENDIF
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYPTMI
	+C...Handles the generation of additional interactions in the new
	+C...multiple interactions framework.
	+C...MODE=-1 : Initalize MI from scratch.
	+C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
	+C... Sudakov for PT2, abort if below PT2CUT.
	+C...MODE= 1 : Accept interaction at PT2NOW and store variables.
	+C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
	+C...PT2NOW : Starting (max) PT2 scale for evolution.
	+C...PT2CUT : Lower limit for evolution.
	+C...PT2 : Result of evolution. Generated PT2 for trial interaction.
	+C...IFAIL : Status return code.
	+C... = 0: All is well.
	+C... < 0: Phase space exhausted, generation to be terminated.
	+C... > 0: Additional interaction vetoed, but continue evolution.
	+
	+ SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
	+ & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+C...Local arrays and saved variables.
	+ DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
	+
	+ SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
	+ & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
	+ & /PYISMX/,/PYCTAG/
	+ SAVE 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=XT2FACXT2/(XT2FAC-XT2LOG(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.25D0VINT(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.25D0VINT(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/(4D0TAUT)
	+ 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.5D0VINT(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
	+C...PS 05 Aug 2012: bug fix to prevent heavy companion quarks from being
	+C...picked up by MPI (necessary since intertwining not implemented)
	+C...Here simply reclassify companions as ordinary SEA. Will give
	+C...additional spurious companions, but is simplest solution.
	+ IF (IABS(IFL).EQ.4.OR.IABS(IFL).EQ.5) THEN
	+ SEA = SEA + CMP
	+ CMP = 0D0
	+ ENDIF
	+
	+ 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=3D0XCXS(XC2+XS2)/(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+XS2(-3D0+XS)+3D0XSLOG(XS))
	+ ELSEIF (NPOW.EQ.2) THEN
	+ PYFCMP=FAC(1D0-Y)2/(2D0((1D0-XS)(1D0+XS(4D0+XS))
	+ & +3D0XS(1D0+XS)*LOG(XS)))
	+ ELSEIF (NPOW.EQ.3) THEN
	+ PYFCMP=FAC(1D0-Y)32D0/(4D0+27D0XS-31D0XS**3
	+ & +6D0XSLOG(XS)(3D0+2D0XS*(3D0+XS)))
	+ ELSEIF (NPOW.GE.4) THEN
	+ PYFCMP=FAC(1D0-Y)4/(2D0(1D0+2D0XS)((1D0-XS)*(1D0+
	+ & XS(10D0+XS))+6D0XSLOG(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-2D0XS(-3D0+XS))+3D0*LOG(XS))
	+ PYPCMP=PYPCMP/((-1D0+XS)(2D0+XS(-1D0+2D0*XS)))
	+ ELSEIF (NPOW.EQ.1) THEN
	+ PYPCMP=-1D0-3D0XS+(2D0(-1D0+XS)*2(1D0+XS+XS**2))
	+ & /(2D0+XS*2(XS-3D0)+3D0XSLOG(XS))
	+ ELSEIF (NPOW.EQ.2) THEN
	+ PYPCMP=XS((1D0-XS)(19D0+XS(43D0+4D0XS))
	+ & +6D0LOG(XS)(1D0+6D0XS+4D0XS**2))
	+ PYPCMP=PYPCMP/(4D0((XS-1D0)(1D0+XS*(4D0+XS))
	+ & -3D0XSLOG(XS)*(1+XS)))
	+ ELSEIF (NPOW.EQ.3) THEN
	+ PYPCMP=3D0XS((XS-1)(7D0+XS(28D0+13D0*XS))
	+ & -2D0LOG(XS)(1D0+XS(9D0+2D0XS*(6D0+XS))))
	+ PYPCMP=PYPCMP/(4D0+27D0XS-31D0XS**3
	+ & +6D0XSLOG(XS)(3D0+2D0XS*(3D0+XS)))
	+ ELSE
	+ PYPCMP=(-9D0XS(XS*2-1D0)(5D0+XS(24D0+XS))+12D0XS*LOG(XS)
	+ & (1D0+2D0XS)(1D0+2D0XS(5D0+2D0XS)))
	+ PYPCMP=PYPCMP/(8D0(1D0+2D0XS)((XS-1D0)(1D0+XS*(10D0+XS))
	+ & -6D0XSLOG(XS)*(1D0+XS)))
	+ ENDIF
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYUPRE
	+C...Rearranges contents of the HEPEUP commonblock so that
	+C...mothers precede daughters and daughters of a decay are
	+C...listed consecutively.
	+
	+ SUBROUTINE PYUPRE
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+
	+C...User process event common block.
	+ INTEGER MAXNUP
	+ PARAMETER (MAXNUP=500)
	+ INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	+ DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	+ COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	+ &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	+ &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	+ SAVE /HEPEUP/
	+
	+C...Local arrays.
	+ DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
	+ &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
	+ &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
	+
	+C...Check whether a rearrangement is required.
	+ NEED=0
	+ DO 100 IUP=1,NUP
	+ IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
	+ 100 CONTINUE
	+ DO 110 IUP=2,NUP
	+ IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
	+ 110 CONTINUE
	+
	+ IF(NEED.NE.0) THEN
	+C...Find the new order that particles should have.
	+ NEWPOS(0)=0
	+ NNEW=0
	+ INEW=-1
	+ 120 INEW=INEW+1
	+ DO 130 IUP=1,NUP
	+ IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
	+ NNEW=NNEW+1
	+ NEWPOS(NNEW)=IUP
	+ ENDIF
	+ 130 CONTINUE
	+ IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
	+ IF(NNEW.NE.NUP) THEN
	+ CALL PYERRM(2,
	+ & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
	+ RETURN
	+ ENDIF
	+
	+C...Copy old info into temporary storage.
	+ DO 150 I=1,NUP
	+ IDUPT(I)=IDUP(I)
	+ ISTUPT(I)=ISTUP(I)
	+ MOTUPT(1,I)=MOTHUP(1,I)
	+ MOTUPT(2,I)=MOTHUP(2,I)
	+ ICOUPT(1,I)=ICOLUP(1,I)
	+ ICOUPT(2,I)=ICOLUP(2,I)
	+ DO 140 J=1,5
	+ PUPT(J,I)=PUP(J,I)
	+ 140 CONTINUE
	+ VTIUPT(I)=VTIMUP(I)
	+ SPIUPT(I)=SPINUP(I)
	+ 150 CONTINUE
	+
	+C...Copy info back into HEPEUP in right order.
	+ DO 180 I=1,NUP
	+ IOLD=NEWPOS(I)
	+ IDUP(I)=IDUPT(IOLD)
	+ ISTUP(I)=ISTUPT(IOLD)
	+ MOTHUP(1,I)=0
	+ MOTHUP(2,I)=0
	+ DO 160 IMOT=1,I-1
	+ IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
	+ IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
	+ 160 CONTINUE
	+ IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
	+ MOTHSW=MOTHUP(1,I)
	+ MOTHUP(1,I)=MOTHUP(2,I)
	+ MOTHUP(2,I)=MOTHSW
	+ ENDIF
	+ ICOLUP(1,I)=ICOUPT(1,IOLD)
	+ ICOLUP(2,I)=ICOUPT(2,IOLD)
	+ DO 170 J=1,5
	+ PUP(J,I)=PUPT(J,IOLD)
	+ 170 CONTINUE
	+ VTIMUP(I)=VTIUPT(IOLD)
	+ SPINUP(I)=SPIUPT(IOLD)
	+ 180 CONTINUE
	+ ENDIF
	+
	+c...If incoming particles are massive recalculate to put them massless.
	+ IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
	+ PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
	+ PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
	+ PUP(4,1)=0.5D0*PPLUS
	+ PUP(3,1)=PUP(4,1)
	+ PUP(5,1)=0D0
	+ PUP(4,2)=0.5D0*PMINUS
	+ PUP(3,2)=-PUP(4,2)
	+ PUP(5,2)=0D0
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYADSH
	+C...Administers the generation of successive final-state showers
	+C...in external processes.
	+
	+ SUBROUTINE PYADSH(NFIN)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
	+C...Local array.
	+ DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
	+
	+C...Set primary vertex.
	+ DO 100 J=1,5
	+ V(MINT(83)+5,J)=0D0
	+ V(MINT(83)+6,J)=0D0
	+ V(MINT(84)+1,J)=0D0
	+ V(MINT(84)+2,J)=0D0
	+ 100 CONTINUE
	+
	+C...Isolate systems of particles with the same mother.
	+ NSYS=0
	+ IMS=-1
	+ DO 140 I=MINT(84)+3,NFIN
	+ IM=K(I,3)
	+ IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
	+ IF(IM.NE.IMS) THEN
	+ NSYS=NSYS+1
	+ IBEG(NSYS)=I
	+ IMS=IM
	+ ENDIF
	+
	+C...Set production vertices.
	+ IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
	+ & THEN
	+ DO 110 J=1,4
	+ V(I,J)=0D0
	+ 110 CONTINUE
	+ ELSE
	+ DO 120 J=1,4
	+ V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
	+ 120 CONTINUE
	+ ENDIF
	+ IF(MSTP(125).GE.1) THEN
	+ IDOC=I-MSTP(126)+4
	+ DO 130 J=1,5
	+ V(IDOC,J)=V(I,J)
	+ 130 CONTINUE
	+ ENDIF
	+ 140 CONTINUE
	+
	+C...End loop over systems. Return if no showers to be performed.
	+ IBEG(NSYS+1)=NFIN+1
	+ IF(MSTP(71).LE.0) RETURN
	+
	+C...Loop through systems of particles; check that sensible size.
	+ DO 270 ISYS=1,NSYS
	+ NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
	+ IF(MINT(35).LE.2) THEN
	+ IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
	+ GOTO 270
	+ ELSEIF(NSIZ.LE.1) THEN
	+ CALL PYERRM(2,'(PYADSH:) only one particle in system')
	+ GOTO 270
	+ ELSEIF(NSIZ.GT.80) THEN
	+ CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
	+ GOTO 270
	+ ENDIF
	+ ENDIF
	+
	+C...Save status codes and daughters of showering particles; reset them.
	+ DO 150 J=1,4
	+ PSUM(J)=0D0
	+ 150 CONTINUE
	+ DO 170 II=1,NSIZ
	+ I=IBEG(ISYS)-1+II
	+ KSAV(II,1)=K(I,1)
	+ IF(K(I,1).GT.10) THEN
	+ K(I,1)=1
	+ IF(KSAV(II,1).EQ.14) K(I,1)=3
	+ ENDIF
	+ IF(KSAV(II,1).LE.10) THEN
	+ ELSEIF(K(I,1).EQ.1) THEN
	+ KSAV(II,4)=K(I,4)
	+ KSAV(II,5)=K(I,5)
	+ K(I,4)=0
	+ K(I,5)=0
	+ ELSE
	+ KSAV(II,4)=MOD(K(I,4),MSTU(5))
	+ KSAV(II,5)=MOD(K(I,5),MSTU(5))
	+ K(I,4)=K(I,4)-KSAV(II,4)
	+ K(I,5)=K(I,5)-KSAV(II,5)
	+ ENDIF
	+ DO 160 J=1,4
	+ PSUM(J)=PSUM(J)+P(I,J)
	+ 160 CONTINUE
	+ 170 CONTINUE
	+
	+C...Perform shower.
	+ QMAX=SQRT(MAX(0D0,PSUM(4)2-PSUM(1)2-PSUM(2)**2-
	+ & PSUM(3)**2))
	+ IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
	+ NSAV=N
	+ IF(MINT(35).LE.2) THEN
	+ IF(NSIZ.EQ.2) THEN
	+ CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
	+ ELSE
	+ CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
	+ ENDIF
	+
	+C...For external processes, first call, also ISR partons radiate.
	+C...Can use existing PYPART list, removing partons that radiate later.
	+ ELSEIF(ISYS.EQ.1) THEN
	+ NPARTN=0
	+ DO 175 II=1,NPART
	+ IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
	+ NPARTN=NPARTN+1
	+ IPART(NPARTN)=IPART(II)
	+ PTPART(NPARTN)=PTPART(II)
	+ ENDIF
	+ 175 CONTINUE
	+ NPART=NPARTN
	+ CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
	+ ELSE
	+C...For subsequent calls use the systems excluded above.
	+ NPART=NSIZ
	+ NPARTD=0
	+ DO 180 II=1,NSIZ
	+ I=IBEG(ISYS)-1+II
	+ IPART(II)=I
	+ PTPART(II)=0.5D0*QMAX
	+ 180 CONTINUE
	+ CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
	+ ENDIF
	+
	+C...Look up showered copies of original showering particles.
	+ DO 260 II=1,NSIZ
	+ I=IBEG(ISYS)-1+II
	+ IMV=I
	+C...Particles without daughters need not be studied.
	+ IF(KSAV(II,1).LE.10) GOTO 260
	+ IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
	+ ELSEIF(K(I,1).EQ.11) THEN
	+ 190 IMV=MOD(K(IMV,4),MSTU(5))
	+ IF(K(IMV,1).EQ.11) GOTO 190
	+ ELSE
	+ KDA1=MOD(K(I,4),MSTU(5))
	+ IF(KDA1.GT.0) THEN
	+ IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
	+ ENDIF
	+ KDA2=MOD(K(I,5),MSTU(5))
	+ IF(KDA2.GT.0) THEN
	+ IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
	+ ENDIF
	+ DO 200 I3=I+1,N
	+ IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
	+ & THEN
	+ IMV=I3
	+ KDA1=MOD(K(I3,4),MSTU(5))
	+ IF(KDA1.GT.0) THEN
	+ IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
	+ ENDIF
	+ KDA2=MOD(K(I3,5),MSTU(5))
	+ IF(KDA2.GT.0) THEN
	+ IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
	+ ENDIF
	+ ENDIF
	+ 200 CONTINUE
	+ ENDIF
	+
	+C...Restore daughter info of original partons to showered copies.
	+ IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
	+ IF(KSAV(II,1).LE.10) THEN
	+ ELSEIF(K(I,1).EQ.1) THEN
	+ K(IMV,4)=KSAV(II,4)
	+ K(IMV,5)=KSAV(II,5)
	+ ELSE
	+ K(IMV,4)=K(IMV,4)+KSAV(II,4)
	+ K(IMV,5)=K(IMV,5)+KSAV(II,5)
	+ ENDIF
	+
	+C...Reset mother info of existing daughters to showered copies.
	+ DO 210 I3=IBEG(ISYS+1),NFIN
	+ IF(K(I3,3).EQ.I) K(I3,3)=IMV
	+ IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
	+ IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
	+ IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
	+ ENDIF
	+ 210 CONTINUE
	+
	+C...Boost all original daughters to new frame of showered copy.
	+C...Also update their colour tags.
	+ IF(IMV.NE.I) THEN
	+ DO 220 J=1,3
	+ BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
	+ 220 CONTINUE
	+ FAC=2D0/(1D0+BETA(1)2+BETA(2)2+BETA(3)**2)
	+ DO 230 J=1,3
	+ BETA(J)=FAC*BETA(J)
	+ 230 CONTINUE
	+ DO 250 I3=IBEG(ISYS+1),NFIN
	+ IMO=I3
	+ 240 IMO=K(IMO,3)
	+ IF(MSTP(128).LE.0) THEN
	+ IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
	+ IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
	+ & THEN
	+ CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
	+ IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
	+ ENDIF
	+ ELSE
	+ IF(IMO.EQ.IMV) THEN
	+ CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
	+ IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
	+ ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
	+ GOTO 240
	+ ENDIF
	+ ENDIF
	+ 250 CONTINUE
	+ ENDIF
	+ 260 CONTINUE
	+
	+C...End of loop over showering systems
	+ 270 CONTINUE
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYVETO
	+C...Interface to UPVETO, which allows user to veto event generation
	+C...on the parton level, after parton showers but before multiple
	+C...interactions, beam remnants and hadronization is added.
	+
	+ SUBROUTINE PYVETO(IVETO)
	+
	+C...All real arithmetic in double precision.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+C...Three Pythia functions return integers, so need declaring.
	+ INTEGER PYK,PYCHGE,PYCOMP
	+
	+C...PYTHIA commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYPARS/,/PYINT1/
	+C...HEPEVT commonblock.
	+ PARAMETER (NMXHEP=4000)
	+ COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ DOUBLE PRECISION PHEP,VHEP
	+ SAVE /HEPEVT/
	+C...Local array.
	+ DIMENSION IRESO(100)
	+
	+C...Define longitudinal boost from initiator rest frame to cm frame.
	+ GAMMA=0.5D0(VINT(141)+VINT(142))/SQRT(VINT(141)VINT(142))
	+ GABEZ=0.5D0(VINT(141)-VINT(142))/SQRT(VINT(141)VINT(142))
	+
	+C...Presentation is different if using pT-ordered shower
	+ IF(MINT(35).EQ.3) THEN
	+ GAMMA=1D0
	+ GABEZ=0D0
	+ ENDIF
	+
	+C... Reset counters.
	+ NEVHEP=0
	+ NHEP=0
	+ NRESO=0
	+
	+C...Oth pass: identify beam and incoming partons
	+ DO 140 I=MINT(83)+1,MINT(83)+6
	+ ISTORE=0
	+ IF(K(I,2).EQ.94) THEN
	+
	+ ELSE
	+ NRESO=NRESO+1
	+ IRESO(NRESO)=I
	+ IMOTH=K(I,3)
	+ ENDIF
	+ 140 CONTINUE
	+
	+C...First pass: identify final locations of resonances
	+C...and of their daughters before showering.
	+ DO 150 I=MINT(84)+3,N
	+ ISTORE=0
	+ IMOTH=0
	+
	+C...Skip shower CM frame documentation lines.
	+ IF(K(I,2).EQ.94) THEN
	+
	+C... Store a new intermediate product, when mother in documentation.
	+ ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
	+ & K(I,3).LE.MINT(84)) THEN
	+ ISTORE=1
	+ NHEP=NHEP+1
	+ II=NHEP
	+ NRESO=NRESO+1
	+ IRESO(NRESO)=I
	+ IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
	+
	+C... Store a new intermediate product, when mother in main section.
	+ ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
	+ & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
	+ ISTORE=1
	+ NHEP=NHEP+1
	+ II=NHEP
	+ NRESO=NRESO+1
	+ IRESO(NRESO)=I
	+ IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
	+ ENDIF
	+
	+ IF(ISTORE.EQ.1) THEN
	+C...Copy parton info, boosting momenta along z axis to cm frame.
	+ ISTHEP(II)=2
	+ IDHEP(II)=K(I,2)
	+ PHEP(1,II)=P(I,1)
	+ PHEP(2,II)=P(I,2)
	+ PHEP(3,II)=GAMMAP(I,3)+GABEZP(I,4)
	+ PHEP(4,II)=GAMMAP(I,4)+GABEZP(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)=GAMMAP(I,3)+GABEZP(I,4)
	+ PHEP(4,II)=GAMMAP(I,4)+GABEZP(I,3)
	+ PHEP(5,II)=P(I,5)
	+C...Store one mother. Rest of history and vertex info zeroed.
	+ JMOHEP(1,II)=IMOTH
	+ JMOHEP(2,II)=0
	+ JDAHEP(1,II)=0
	+ JDAHEP(2,II)=0
	+ VHEP(1,II)=0D0
	+ VHEP(2,II)=0D0
	+ VHEP(3,II)=0D0
	+ VHEP(4,II)=0D0
	+ ENDIF
	+ 200 CONTINUE
	+C...Call user-written routine to decide whether to keep events.
	+ CALL UPVETO(IVETO)
	+ RETURN
	+ END
	+C*********************************************************************
	+
	+C...PYRESD
	+C...Allows resonances to decay (including parton showers for hadronic
	+C...channels).
	+
	+ SUBROUTINE PYRESD(IRES)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYPUED/IUED(0:99),RUED(0:99)
	+ SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
	+ &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
	+C...Local arrays and complex and character variables.
	+ DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
	+ &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(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 CODE9,MASS9
	+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((A2-(B+C)2)(A2-(B-C)2))/(2D0A)
	+
	+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)=-4D0D34D56+DT(3D0DT+4D0DU)+DT2(DT*DU/
	+ &(D34D56)-2D0(1D0/D34+1D0/D56)(DT+DU)+2D0(D34/D56+D56/D34))
	+ DJGK(DT,DU)=8D0(D34+D56)2-8D0(D34+D56)(DT+DU)-6D0DT*DU-
	+ &2D0DTDU(DTDU/(D34D56)-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(PA2+P(N+IL,5)2)
	+ PV(IL+1,4)=SQRT(PA2+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(GABEP/(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
	+
	+CXXX 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=RMGLU2+RMQ12-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-RMRES2)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/(16D0XWXW1)
	+ 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=SFISFF(VE*POLL+PARJ(132)-PARJ(131))
	+ HF1W=SFWSFF2((VE*2+1D0)POLL+2D0VE
	+ & (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-(2D0PMQ/P(ID,5))*2))
	+ VF=SIGN(1D0,QF)-4D0QFXW
	+ RFV=0.5D0VQ(3D0-VQ*2)(QF*2POLL-2D0QFVF*HF1I+
	+ & VF*2HF1W)+VQ*3HF1W
	+ IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ*3HF1W/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)=-2D0COUP(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)*2HGZ(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)*2HGZ(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+2JT-1,3)=0.5D0P(ID,5)
	+ P(N+2JT-1,4)=0.5D0P(ID,5)
	+ P(N+2JT,3)=-0.5D0P(ID,5)
	+ P(N+2JT,4)=0.5D0P(ID,5)
	+ CALL PYROBO(N+2JT-1,N+2JT,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=P10P21P32P43-P10P21P33P42-P10P22P31P43+P10P22*
	+ & P33P41+P10P23P31P42-P10P23P32P41-P11P20P32P43+P11*
	+ & P20P33P42+P11P22P30P43-P11P22P33P40-P11P23P30*P42+
	+ & P11P23P32P40+P12P20P31P43-P12P20P33P41-P12P21P30
	+ & P43+P12P21P33P40+P12P23P30P41-P12P23P31P40-P13P20*
	+ & P31P42+P13P20P32P41+P13P21P30P42-P13P21P32P40-P13*
	+ & P22P30P41+P13P22P31*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-4D0EF1XWV
	+ KFLF2A=IABS(KFL1(2))
	+ EF2=KCHG(KFLF2A,1)/3D0
	+ AF2=SIGN(1D0,EF2+0.1D0)
	+ VF2=AF2-4D0EF2XWV
	+ VA12AS=4D0VF1AF1VF2AF2/((VF12+AF12)(VF22+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
	+ & -2PKK(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.5D0ETA/XMV2EPSI((1D0+VA12AS)(PKK(3,5)+PKK(4,6))
	+ & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
	+ & +6.25D-2ETA2/XMV4(-2D0PKK(3,4)2PKK(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)
	+ & +VA12ASPKK(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 +2D0ETAXMAXMB/XMV*2
	+ & +2D0(ETAXMAXMB/XMV2)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=16D0PKK(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
	+ & -2PKK(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.25D02D0PKK(3,5)PKK(4,6)
	+ & -0.5D0ETA/XMV2EPSI2D0(PKK(3,5)+PKK(4,6))
	+ & +6.25D-2ETA2/XMV4(-2D0PKK(3,4)2PKK(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 +2D0ETAXMAXMB/XMV*2
	+ & +(2D0ETAXMAXMB/XMV2)*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-4D0EIXWV
	+ EF=KCHG(IABS(KFL1(1)),1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+
	+ VF=AF-4D0EFXWV
	+ RMF=MIN(1D0,4D0PMAS(IABS(KFL1(1)),1)*2/SH)
	+ WT1=EI*2VINT(111)EF2+EIVIVINT(112)EF*VF+
	+ & (VI2+AI2)VINT(114)(VF*2+(1D0-RMF)AF**2)
	+ WT2=RMF(EI2VINT(111)EF2+EIVIVINT(112)EF*VF+
	+ & (VI2+AI2)VINT(114)VF**2)
	+ WT3=SQRT(1D0-RMF)(EIAIVINT(112)EF*AF+
	+ & 4D0VIAIVINT(114)VF*AF)
	+ WT=WT1(1D0+CTHE(1)2)+WT2(1D0-CTHE(1)**2)+
	+ & 2D0WT3CTHE(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-4D0RM3*RM4))
	+ WT=(1D0+BE34CTHE(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)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	+ CLIRF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,4)*2
	+ CRILF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	+ CRIRF=COUP(1,1)*2HGZ(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)*2HGZ(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)))S34S56
	+ & ((TI2+UI2+2D0SH(S34+S56))/(TIUI)-S34S56(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+GMMW2)
	+ CAWZ=COUP(2,3)/DT-2D0XW1COUP(1,2)(SH-SQMW)FACBW
	+ CBWZ=COUP(1,3)/DU+2D0XW1COUP(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=4D0D34D56(COUP(5,3)2+COUP(5,4)2)(CAWZ*2
	+ & DIGK(DT,DU)+CBWZ*2DIGK(DU,DT)+CAWZCBWZDJGK(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+SQMZPMAS(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+(CCWWFGK253)**2
	+ WTMAX=4D0D34D56(CAWW2DIGK(DT,DU)+CBWW*2DIGK(DU,DT)-
	+ & CAWWCBWWDJGK(DT,DU)+CCWW*2(DIGK(DT,DU)+DIGK(DU,DT)-
	+ & DJGK(DT,DU)))
	+ ELSE
	+ WT=POLLFGK1352+POLR(CCWWFGK253)*2
	+ WTMAX=4D0D34D56(POLL(CAWW*2DIGK(DT,DU)+
	+ & CBWW*2DIGK(DU,DT)-CAWWCBWWDJGK(DT,DU))+
	+ & POLRCCWW2(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)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	+ CLIRF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,4)*2
	+ CRILF=COUP(1,1)*2HGZ(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)*2HGZ(JTZ,3)COUP(3,3)*2
	+ CRIRF=COUP(1,1)*2HGZ(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)*2HGZ(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=16D0PKK(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-4D0EIXWV
	+ 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-4D0EFXWV
	+ 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(EIAIVINT(112)EFAF+EIAPIVINT(113)EF*APF+
	+ & 4D0VIAIVINT(114)VFAF+(VIAPI+VPIAI)VINT(115)*
	+ & (VFAPF+VPFAF)+4D0VPIAPIVINT(116)VPF*APF)/
	+ & (EI*2VINT(111)EF2+EIVIVINT(112)EF*VF+
	+ & EIVPIVINT(113)EFVPF+(VI2+AI2)VINT(114)
	+ & (VF2+AF2)+(VIVPI+AIAPI)VINT(115)(VFVPF+AFAPF)+
	+ & (VPI2+API2)VINT(116)(VPF2+APF2))
	+ WT=1D0+ASYMCTHE(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-4D0RM1RM2)
	+ & (1D0-2D0RM1-2D0RM2+RM12+RM22+10D0RM1RM2)
	+ CFLAT=-CCOS2+0.5D0(RM1+RM2)(1D0-2D0RM1-2D0RM2+
	+ & (RM2-RM1)**2)
	+ WT=CFLAT+CCOS2CTHE(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-4D0RM1*RM2)
	+ WT=1D0+FLAM2(1D0-CTHE(1)2)/(8D0RM1)
	+ 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=4D0D34D56(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=16D0PKK(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=8D0VIAIVFAF/((VI2+AI2)(VF2+AF*2))
	+ WT=1D0+ASYMCTHE(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-4D0RM1RM2)
	+ & (1D0-2D0RM1-2D0RM2+RM12+RM22+10D0RM1RM2)
	+ CFLAT=-CCOS2+0.5D0(RM1+RM2)(1D0-2D0RM1-2D0RM2+
	+ & (RM2-RM1)**2)
	+ WT=CFLAT+CCOS2CTHE(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-4D0RM1*RM2)
	+ WT=1D0+FLAM2(1D0-CTHE(1)2)/(8D0RM1)
	+ 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=4D0D34D56(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=16D0PKK(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+SIDECTHE(1)(1D0-0.5D0RM1)/(1D0+0.5D0RM1)
	+ WTMAX=1D0+(1D0-0.5D0RM1)/(1D0+0.5D0RM1)
	+ 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-2D0XW)/(4D0XW*(1D0-XW))
	+ BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	+ BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ KFAI=IABS(MINT(15))
	+ EI=KCHG(KFAI,1)/3D0
	+ AI=SIGN(1D0,EI+0.1D0)
	+ VI=AI-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ ALEFTI=(EI+VALIBWZR)2+(VALIBWZI)**2
	+ ARIGHI=(EI+VARIBWZR)2+(VARIBWZI)**2
	+ KFAF=IABS(KFL1(1))
	+ EF=KCHG(KFAF,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ VALF=0.5D0*(VF+AF)
	+ VARF=0.5D0*(VF-AF)
	+ ALEFTF=(EF+VALFBWZR)2+(VALFBWZI)**2
	+ ARIGHF=(EF+VARFBWZR)2+(VARFBWZI)**2
	+ ASAME=ALEFTIALEFTF+ARIGHIARIGHF
	+ AFLIP=ALEFTIARIGHF+ARIGHIALEFTF
	+ 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+GMMZ2)
	+ BWZI=(0.5D0/(1D0-XW))SHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ KFAI=IABS(MINT(15))
	+ EI=KCHG(KFAI,1)/3D0
	+ AI=SIGN(1D0,EI+0.1D0)
	+ VI=AI-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ BLEFTI=(EI-VALIBWZR)2+(VALIBWZI)**2
	+ BRIGHI=(EI-VARIBWZR)2+(VARIBWZI)**2
	+ KFAF=IABS(KFL1(1))
	+ EF=KCHG(KFAF,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ VALF=0.5D0*(VF+AF)
	+ VARF=0.5D0*(VF-AF)
	+ BLEFTF=(EF-VALFBWZR)2+(VALFBWZI)**2
	+ BRIGHF=(EF-VARFBWZR)2+(VARFBWZI)**2
	+ BSAME=BLEFTIBLEFTF+BRIGHIBRIGHF
	+ BFLIP=BLEFTIBRIGHF+BRIGHIBLEFTF
	+ 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-4D0EIXWV
	+ EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ RMF=MIN(1D0,4D0PMAS(PYCOMP(KFL1(1)),1)*2/SH)
	+ WT1=(VI2+AI2)(VF2+(1D0-RMF)AF**2)
	+ WT2=RMF(VI2+AI2)VF**2
	+ WT3=SQRT(1D0-RMF)4D0VIAIVF*AF
	+ WT=WT1(1D0+CTHE(1)2)+WT2(1D0-CTHE(1)**2)+
	+ & 2D0WT3CTHE(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-4D0RM3*RM4))
	+ WT=(1D0+BE34CTHE(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-3D0CTHE(1)2+4D0CTHE(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+6D0CTHE(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-4D0RM3*RM4))
	+ VINT(45)=-0.5D0SH(1D0-RM3-RM4-BE34*CTHE(1))
	+ VINT(46)=-0.5D0SH(1D0-RM3-RM4+BE34*CTHE(1))
	+ VINT(48)=0.25D0SHBE34*2MAX(0D0,1D0-CTHE(1)**2)
	+ VINT(47)=SQRT(VINT(48))
	+ ENDIF
	+
	+C...Possibility of colour rearrangement in W+W- events.
	+ IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
	+ IAKF1=IABS(KFL1(1))
	+ IAKF2=IABS(KFL1(2))
	+ IAKF3=IABS(KFL2(1))
	+ IAKF4=IABS(KFL2(2))
	+ IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
	+ & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
	+ & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
	+ IF(MINT(51).NE.0) RETURN
	+ ENDIF
	+
	+C...Loop back if needed.
	+ 710 IF(IP.LT.NP) GOTO 170
	+
	+C...Boost back to standard frame.
	+ 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
	+ &BEZIN)
	+
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYMULT
	+C...Initializes treatment of multiple interactions, selects kinematics
	+C...of hardest interaction if low-pT physics included in run, and
	+C...generates all non-hardest interactions.
	+
	+ SUBROUTINE PYMULT(MMUL)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
	+ &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
	+C...Local arrays and saved variables.
	+ DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
	+ SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
	+ &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
	+ &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
	+
	+C...Initialization of multiple interaction treatment.
	+ IF(MMUL.EQ.1) THEN
	+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
	+ ISUB=96
	+ MINT(1)=96
	+ VINT(63)=0D0
	+ VINT(64)=0D0
	+ VINT(143)=1D0
	+ VINT(144)=1D0
	+
	+C...Loop over phase space points: xT2 choice in 20 bins.
	+ 100 SIGSUM=0D0
	+ DO 120 IXT2=1,20
	+ NMUL(IXT2)=MSTP(83)
	+ SIGM(IXT2)=0D0
	+ DO 110 ITRY=1,MSTP(83)
	+ RSCA=0.05D0*((21-IXT2)-PYR(0))
	+ XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
	+ XT2=MAX(0.01D0*VINT(149),XT2)
	+ VINT(25)=XT2
	+
	+C...Choose tau and y*. Calculate cos(theta-hat).
	+ IF(PYR(0).LE.COEF(ISUB,1)) THEN
	+ TAUT=(2D0(1D0+SQRT(1D0-XT2))/XT2-1D0)*PYR(0)
	+ TAU=XT2(1D0+TAUT)2/(4D0TAUT)
	+ 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.5D0VINT(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=2D0PARP(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.5D0PARU(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=(P83AEXP(-MIN(50D0,B*2))+
	+ & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	+ ELSE
	+ OV=EXP(-B**POWIP)/PARU(2)
	+ SO=SO+PARU(2)BDELTAB*OV
	+ ENDIF
	+ IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)BDELTAB*OV
	+ PACC=1D0-EXP(-MIN(50D0,PARU(1)XKOV))
	+ SP=SP+PARU(2)BDELTAB*PACC
	+ SOP=SOP+PARU(2)BDELTABOVPACC
	+ BSP=BSP+BPARU(2)BDELTABPACC
	+ IF(IBDIV.EQ.0.AND.PARU(1)XKOV.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)XKSO/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=PIK0.5EXP(-BDIV**2)
	+ ELSEIF(MSTP(82).EQ.4) THEN
	+ S4A=P83AEXP(-BDIV*2)
	+ S4B=P83BEXP(-BDIV2CQ2R)
	+ S4C=P83CEXP(-BDIV2CQ2I)
	+ PHIGHB=PIK0.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=VNT146XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))
	+ & VINT(149)*(1D0+VINT(149))
	+ ELSE
	+ XC2=4D0CKIN(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=(P83AEXP(-MIN(50D0,B*2))+
	+ & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	+ ELSE
	+ OV=EXP(-B**POWIP)/PARU(2)
	+ ENDIF
	+ VINT(148)=OV/VNT147
	+ PACC=1D0-EXP(-MIN(50D0,PIK*OV))
	+ XT2=1D0
	+ XT2FAC=VNT146VINT(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=(P83AEXP(-MIN(50D0,B*2))+
	+ & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/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)*RPWIPEXP(-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,PIKOV)))/(PIKOV)
	+ 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*2exp(-(sigma above pT2)/norm)
	+C...or (MSTP(82)>=2) dpT2/(pT2+pT02)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=XT2FACXT2/(XT2FAC-XT2LOG(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(-XT2FACXT2/(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/(4D0TAUT)
	+ 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.5D0VINT(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=(4D0VINT(48)+2D0VINT(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))+
	+ & P83BCQ2REXP(-MIN(50D0,B2*CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B2CQ2I)))/(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.5D0POWIP)
	+ 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*RPWIPEXP(-RPWIP))
	+ 170 IF(PYR(0).LT.PROB1) THEN
	+ B2RPW=2D0RPWIPPYR(0)
	+ ACCIP=(B2RPW/RPWIP)*RPWIPEXP(RPWIP-B2RPW)
	+ ELSE
	+ B2RPW=2D0*(RPWIP-LOG(PYR(0)))
	+ ACCIP=(0.5D0B2RPW/RPWIP)RPWIPEXP(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-20D0RBIN)NMUL(IRBIN)
	+ SIGCOR=(IRBIN-20D0RBIN)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,VNT146VINT(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=VNT146VINT(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=XT2FACXT2/(XT2FAC-XT2LOG(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/(4D0TAUT)
	+ 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.5D0VINT(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.5D0VINT(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.25D0VINT(1)(VINT(41)(1D0+CTH)-VINT(42)(1D0-CTH))
	+ P(N+1,4)=0.25D0VINT(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.25D0VINT(1)(VINT(41)(1D0-CTH)-VINT(42)(1D0+CTH))
	+ P(N+2,4)=0.25D0VINT(1)(VINT(41)(1D0-CTH)+VINT(42)(1D0+CTH))
	+ P(N+2,5)=0D0
	+
	+ IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
	+C....Choose relevant string pieces to place gluons on.
	+ DO 260 I=N+1,N+2
	+ DMIN=1D8
	+ DO 250 ISTR=1,NSTR
	+ I1=KSTR(ISTR,1)
	+ I2=KSTR(ISTR,2)
	+ DIST=(P(I,4)P(I1,4)-P(I,1)P(I1,1)-P(I,2)*P(I1,2)-
	+ & P(I,3)P(I1,3))(P(I,4)P(I2,4)-P(I,1)P(I2,1)-
	+ & P(I,2)P(I2,2)-P(I,3)P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
	+ & P(I1,1)P(I2,1)-P(I1,2)P(I2,2)-P(I1,3)*P(I2,3))
	+ IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
	+ DMIN=DIST
	+ IST1=I1
	+ IST2=I2
	+ ISTM=ISTR
	+ ENDIF
	+ 250 CONTINUE
	+
	+C....Colour flow adjustments, new string pieces.
	+ IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
	+ & MOD(K(IST1,4),MSTU(5))
	+ IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
	+ & MSTU(5)*(K(IST1,5)/MSTU(5))+I
	+ K(I,5)=MSTU(5)*IST1
	+ K(I,4)=MSTU(5)*IST2
	+ IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
	+ & MOD(K(IST2,5),MSTU(5))
	+ IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
	+ & MSTU(5)*(K(IST2,4)/MSTU(5))+I
	+ KSTR(ISTM,2)=I
	+ KSTR(NSTR+1,1)=I
	+ KSTR(NSTR+1,2)=IST2
	+ NSTR=NSTR+1
	+ 260 CONTINUE
	+
	+C...String drawing and colour flow for gluon loop.
	+ ELSEIF(K(N+1,2).EQ.21) THEN
	+ K(N+1,4)=MSTU(5)*(N+2)
	+ K(N+1,5)=MSTU(5)*(N+2)
	+ K(N+2,4)=MSTU(5)*(N+1)
	+ K(N+2,5)=MSTU(5)*(N+1)
	+ KSTR(NSTR+1,1)=N+1
	+ KSTR(NSTR+1,2)=N+2
	+ KSTR(NSTR+2,1)=N+2
	+ KSTR(NSTR+2,2)=N+1
	+ NSTR=NSTR+2
	+
	+C...String drawing and colour flow for qqbar pair.
	+ ELSE
	+ K(N+1,4)=MSTU(5)*(N+2)
	+ K(N+2,5)=MSTU(5)*(N+1)
	+ KSTR(NSTR+1,1)=N+1
	+ KSTR(NSTR+1,2)=N+2
	+ NSTR=NSTR+1
	+ ENDIF
	+
	+C...Global statistics.
	+ MINT(351)=MINT(351)+1
	+ VINT(351)=VINT(351)+PT
	+ IF (MINT(351).EQ.1) VINT(356)=PT
	+
	+C...Update remaining energy; iterate.
	+ N=N+2
	+ IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	+ CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+ MINT(31)=MINT(31)+1
	+ VINT(151)=VINT(151)+VINT(41)
	+ VINT(152)=VINT(152)+VINT(42)
	+ VINT(143)=VINT(143)-VINT(41)
	+ VINT(144)=VINT(144)-VINT(42)
	+C...Allow FSR for UE (always handle with old showers)
	+ IF(MSTP(152).EQ.1) THEN
	+ M41SAV=MSTJ(41)
	+ IF (MSTJ(41).EQ.10) MSTJ(41)=2
	+ MSTJ(41)=MOD(MSTJ(41),10)
	+ CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
	+ MSTJ(41)=M41SAV
	+ ENDIF
	+ IF(MINT(31).LT.240) GOTO 220
	+ 270 CONTINUE
	+ MINT(1)=ISUBSV
	+ DO 280 J=11,80
	+ VINT(J)=VINTSV(J)
	+ 280 CONTINUE
	+ ENDIF
	+
	+C...Format statements for printout.
	+ 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
	+ &'actions for MSTP(82) =',I2,' ******')
	+ 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	+ &D9.2,' mb: rejected')
	+ 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	+ &D9.2,' mb: accepted')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYREMN
	+C...Adds on target remnants (one or two from each side) and
	+C...includes primordial kT for hadron beams.
	+
	+ SUBROUTINE PYREMN(IPU1,IPU2)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
	+C...Local arrays.
	+ DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
	+ &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
	+
	+C...Find event type and remaining energy.
	+ ISUB=MINT(1)
	+ NS=N
	+ IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
	+ VINT(143)=1D0-VINT(141)
	+ VINT(144)=1D0-VINT(142)
	+ ENDIF
	+
	+C...Define initial partons.
	+ NTRY=0
	+ 100 NTRY=NTRY+1
	+ DO 130 JT=1,2
	+ I=MINT(83)+JT+2
	+ IF(JT.EQ.1) IPU=IPU1
	+ IF(JT.EQ.2) IPU=IPU2
	+ K(I,1)=21
	+ K(I,2)=K(IPU,2)
	+ K(I,3)=I-2
	+ PMS(JT)=0D0
	+ VINT(156+JT)=0D0
	+ VINT(158+JT)=0D0
	+ IF(MINT(47).EQ.1) THEN
	+ DO 110 J=1,5
	+ P(I,J)=P(I-2,J)
	+ 110 CONTINUE
	+ ELSEIF(ISUB.EQ.95) THEN
	+ K(I,2)=21
	+ ELSE
	+ P(I,5)=P(IPU,5)
	+
	+C...No primordial kT, or chosen according to truncated Gaussian or
	+C...exponential, or (for photon) predetermined or power law.
	+ 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
	+ IF(MSTP(91).LE.0) THEN
	+ PT=0D0
	+ ELSEIF(MSTP(91).EQ.1) THEN
	+ PT=PARP(91)*SQRT(-LOG(PYR(0)))
	+ ELSE
	+ RPT1=PYR(0)
	+ RPT2=PYR(0)
	+ PT=-PARP(92)LOG(RPT1RPT2)
	+ 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(RPT1RPT2)
	+ ENDIF
	+ IF(PTB.GT.PARP(100)) GOTO 120
	+ PT=SQRT(PTA2+PTB2+2D0PTAPTBCOS(PARU(2)PYR(0)))
	+ PT=PT0.8D0*MINT(57)
	+ IF(NTRY.GT.10) PT=PT0.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(RPT1RPT2)
	+ 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-4D0PMS(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/(XNOMHPK)))
	+ 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
	+C...Modifications by Uta Klein for high-energy eh collisions
	+#ifndef PYTHIA6_EH
	+ IF(ABS(PEMV).LT.1D-10) THEN
	+ MINT(51)=1
	+ MINT(57)=MINT(57)+1
	+ RETURN
	+ ENDIF
	+#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)
	+C...Modifications by Uta Klein for high-energy eh collisions
	+#ifndef PYTHIA6_EH
	+ IF(ABS(HBE).GE.1D0) THEN
	+ MINT(51)=1
	+ MINT(57)=MINT(57)+1
	+ RETURN
	+ ENDIF
	+#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.5D0VINT(1)(VINT(151)+VINT(152))
	+ PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0VINT(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.5D0VINT(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.5D0PARP(111)
	+ PMIN(JT)=SQRT(PMIN(JT)2+P(MINT(83)+JT+2,1)2+
	+ & P(MINT(83)+JT+2,2)**2)
	+ 340 CONTINUE
	+C...Modifications by Uta Klein for high-energy eh collisions
	+#ifndef PYTHIA6_EH
	+ 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
	+#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+CUT2))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=CUTCUTR*PYR(0)
	+ CHI(JT)=(CHIR2-CUT2)/(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+CUT2)))**
	+ & (0.5D0PARP(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+2IMB)))
	+ 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-4D0DPMTR*DPMTL))
	+C IF(DSQLAM.LE.1D-6*DPMTB) THEN
	+C MINT(51)=1
	+C MINT(57)=MINT(57)+1
	+C RETURN
	+C 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=(DRKR2-1D0)/(DRKR2+1D0)
	+ DBEL=-(DRKL2-1D0)/(DRKL2+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)
	+C IF(PDEV.GT.1D-4*VINT(1)) THEN
	+C MINT(51)=1
	+C MINT(57)=MINT(57)+1
	+C RETURN
	+C ENDIF
	+
	+C...Calculate rotation and boost from overall CM frame to
	+C...hadronic CM frame in leptoproduction.
	+ MINT(91)=0
	+ IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
	+ MINT(91)=1
	+ LESD=1
	+ IF(MINT(42).EQ.1) LESD=2
	+ LPIN=MINT(83)+3-LESD
	+
	+C...Sum upp momenta of everything not lepton or photon to define boost.
	+ DO 510 J=1,4
	+ PSUM(J)=0D0
	+ 510 CONTINUE
	+ DO 530 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
	+ IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
	+ IF(K(I,2).EQ.22) GOTO 530
	+ DO 520 J=1,4
	+ PSUM(J)=PSUM(J)+P(I,J)
	+ 520 CONTINUE
	+ 530 CONTINUE
	+ VINT(223)=-PSUM(1)/PSUM(4)
	+ VINT(224)=-PSUM(2)/PSUM(4)
	+ VINT(225)=-PSUM(3)/PSUM(4)
	+
	+C...Boost incoming hadron to hadronic CM frame to determine rotations.
	+ K(N+1,1)=1
	+ DO 540 J=1,5
	+ P(N+1,J)=P(LPIN,J)
	+ V(N+1,J)=V(LPIN,J)
	+ 540 CONTINUE
	+ CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
	+ VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
	+ CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
	+ IF(LESD.EQ.2) THEN
	+ VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
	+ ELSE
	+ VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
	+ ENDIF
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYMIGN
	+C...Initializes treatment of new multiple interactions scenario,
	+C...selects kinematics of hardest interaction if low-pT physics
	+C...included in run, and generates all non-hardest interactions.
	+
	+ SUBROUTINE PYMIGN(MMUL)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+ EXTERNAL PYALPS
	+ DOUBLE PRECISION PYALPS
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
	+C...Local arrays and saved variables.
	+ DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
	+ &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
	+ SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
	+ &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
	+ &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
	+
	+C...Initialization of multiple interaction treatment.
	+ IF(MMUL.EQ.1) THEN
	+ IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
	+ ISUB=96
	+ MINT(1)=96
	+ VINT(63)=0D0
	+ VINT(64)=0D0
	+ VINT(143)=1D0
	+ VINT(144)=1D0
	+
	+C...Loop over phase space points: xT2 choice in 20 bins.
	+ 100 SIGSUM=0D0
	+ DO 120 IXT2=1,20
	+ NMUL(IXT2)=MSTP(83)
	+ SIGM(IXT2)=0D0
	+ DO 110 ITRY=1,MSTP(83)
	+ RSCA=0.05D0*((21-IXT2)-PYR(0))
	+ XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
	+ XT2=MAX(0.01D0*VINT(149),XT2)
	+ VINT(25)=XT2
	+
	+C...Choose tau and y*. Calculate cos(theta-hat).
	+ IF(PYR(0).LE.COEF(ISUB,1)) THEN
	+ TAUT=(2D0(1D0+SQRT(1D0-XT2))/XT2-1D0)*PYR(0)
	+ TAU=XT2(1D0+TAUT)2/(4D0TAUT)
	+ 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.5D0VINT(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=2D0PARP(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.5D0PARU(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=(P83AEXP(-MIN(50D0,B*2))+
	+ & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	+ ELSE
	+ OV=EXP(-B**POWIP)/PARU(2)
	+ SO=SO+PARU(2)BDELTAB*OV
	+ ENDIF
	+ IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)BDELTAB*OV
	+ PACC=1D0-EXP(-MIN(50D0,PARU(1)XKOV))
	+ SP=SP+PARU(2)BDELTAB*PACC
	+ SOP=SOP+PARU(2)BDELTABOVPACC
	+ BSP=BSP+BPARU(2)BDELTABPACC
	+ IF(IBDIV.EQ.0.AND.PARU(1)XKOV.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)XKSO/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=PIK0.5EXP(-BDIV**2)
	+ ELSEIF(MSTP(82).EQ.4) THEN
	+ S4A=P83AEXP(-BDIV*2)
	+ S4B=P83BEXP(-BDIV2CQ2R)
	+ S4C=P83CEXP(-BDIV2CQ2I)
	+ PHIGHB=PIK0.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=VNT146XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))
	+ & VINT(149)*(1D0+VINT(149))
	+ ELSE
	+ XC2=4D0CKIN(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=(P83AEXP(-MIN(50D0,B*2))+
	+ & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/PARU(2)
	+ ELSE
	+ OV=EXP(-B**POWIP)/PARU(2)
	+ ENDIF
	+ VINT(148)=OV/VNT147
	+ PACC=1D0-EXP(-MIN(50D0,PIK*OV))
	+ XT2=1D0
	+ XT2FAC=VNT146VINT(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=(P83AEXP(-MIN(50D0,B*2))+
	+ & P83BCQ2REXP(-MIN(50D0,B*2CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B*2CQ2I)))/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)*RPWIPEXP(-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,PIKOV)))/(PIKOV)
	+ 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*2exp(-(sigma above pT2)/norm)
	+C...or (MSTP(82)>=2) dpT2/(pT2+pT02)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=XT2FACXT2/(XT2FAC-XT2LOG(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(-XT2FACXT2/(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/(4D0TAUT)
	+ 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.5D0VINT(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=(4D0VINT(48)+2D0VINT(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))+
	+ & P83BCQ2REXP(-MIN(50D0,B2*CQ2R))+
	+ & P83CCQ2IEXP(-MIN(50D0,B2CQ2I)))/(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.5D0POWIP)
	+ 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*RPWIPEXP(-RPWIP))
	+ 170 IF(PYR(0).LT.PROB1) THEN
	+ B2RPW=2D0RPWIPPYR(0)
	+ ACCIP=(B2RPW/RPWIP)*RPWIPEXP(RPWIP-B2RPW)
	+ ELSE
	+ B2RPW=2D0*(RPWIP-LOG(PYR(0)))
	+ ACCIP=(0.5D0B2RPW/RPWIP)RPWIPEXP(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-20D0RBIN)NMUL(IRBIN)
	+ SIGCOR=(IRBIN-20D0RBIN)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,VNT146VINT(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=(4D0VINT(48)+2D0VINT(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=VNT146VINT(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=XT2FACXT2/(XT2FAC-XT2LOG(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/(4D0TAUT)
	+ 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.5D0VINT(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.5D0VINT(1)SQRT(XT2)
	+
	+C...Choose flavour of reacting partons (and subprocess).
	+ RSIGS=SIGS*PYR(0)
	+ DO 270 ICHN=1,NCHN
	+ KFL1=ISIG(ICHN,1)
	+ KFL2=ISIG(ICHN,2)
	+ ICONMI=ISIG(ICHN,3)
	+ RSIGS=RSIGS-SIGH(ICHN)
	+ IF(RSIGS.LE.0D0) GOTO 280
	+ 270 CONTINUE
	+
	+C...Reassign to appropriate process codes.
	+ 280 ISUBMI=ICONMI/10
	+ ICONMI=MOD(ICONMI,10)
	+
	+C...Choose new quark flavour for annihilation graphs
	+ IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
	+ SH=TAU*VINT(2)
	+ CALL PYWIDT(21,SH,WDTP,WDTE)
	+ 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
	+ DO 300 I=1,MDCY(21,3)
	+ KFLF=KFDP(I+MDCY(21,2)-1,1)
	+ RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
	+ IF(RKFL.LE.0D0) GOTO 310
	+ 300 CONTINUE
	+ 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
	+ IF(KFLF.GE.4) GOTO 290
	+ ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
	+ KFLF=4
	+ ICONMI=ICONMI-2
	+ ELSEIF(ISUBMI.EQ.53) THEN
	+ KFLF=5
	+ ICONMI=ICONMI-4
	+ ENDIF
	+ ENDIF
	+
	+C...Final state flavours and colour flow: default values
	+ JS=1
	+ KFL3=KFL1
	+ KFL4=KFL2
	+ KCC=20
	+ KCS=ISIGN(1,KFL1)
	+
	+ IF(ISUBMI.EQ.11) THEN
	+C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
	+ KCC=ICONMI
	+ IF(KFL1*KFL2.LT.0) KCC=KCC+2
	+
	+ ELSEIF(ISUBMI.EQ.12) THEN
	+C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
	+ KFL3=ISIGN(KFLF,KFL1)
	+ KFL4=-KFL3
	+ KCC=4
	+
	+ ELSEIF(ISUBMI.EQ.13) THEN
	+C...f + fbar -> g + g; th arbitrary
	+ KFL3=21
	+ KFL4=21
	+ KCC=ICONMI+4
	+
	+ ELSEIF(ISUBMI.EQ.28) THEN
	+C...f + g -> f + g; th = (p(f)-p(f))**2
	+ IF(KFL1.EQ.21) JS=2
	+ KCC=ICONMI+6
	+ IF(KFL1.EQ.21) KCC=KCC+2
	+ IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
	+ IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
	+
	+ ELSEIF(ISUBMI.EQ.53) THEN
	+C...g + g -> f + fbar; th arbitrary
	+ KCS=(-1)**INT(1.5D0+PYR(0))
	+ KFL3=ISIGN(KFLF,KCS)
	+ KFL4=-KFL3
	+ KCC=ICONMI+10
	+
	+ ELSEIF(ISUBMI.EQ.68) THEN
	+C...g + g -> g + g; th arbitrary
	+ KCC=ICONMI+12
	+ KCS=(-1)**INT(1.5D0+PYR(0))
	+ ENDIF
	+
	+C...Store flavours of scattering.
	+ MINT(13)=KFL1
	+ MINT(14)=KFL2
	+ MINT(15)=KFL1
	+ MINT(16)=KFL2
	+ MINT(21)=KFL3
	+ MINT(22)=KFL4
	+
	+C...Set flavours and mothers of scattering partons.
	+ K(N+1,1)=14
	+ K(N+2,1)=14
	+ K(N+3,1)=3
	+ K(N+4,1)=3
	+ K(N+1,2)=KFL1
	+ K(N+2,2)=KFL2
	+ K(N+3,2)=KFL3
	+ K(N+4,2)=KFL4
	+ K(N+1,3)=MINT(83)+1
	+ K(N+2,3)=MINT(83)+2
	+ K(N+3,3)=N+1
	+ K(N+4,3)=N+2
	+
	+C...Store colour connection indices.
	+ DO 320 J=1,2
	+ JC=J
	+ IF(KCS.EQ.-1) JC=3-J
	+ IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
	+ IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
	+ IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
	+ IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
	+ 320 CONTINUE
	+
	+C...Store incoming and outgoing partons in their CM-frame.
	+ SHR=SQRT(TAU)*VINT(1)
	+ P(N+1,3)=0.5D0*SHR
	+ P(N+1,4)=0.5D0*SHR
	+ P(N+2,3)=-0.5D0*SHR
	+ P(N+2,4)=0.5D0*SHR
	+ P(N+3,5)=PYMASS(K(N+3,2))
	+ P(N+4,5)=PYMASS(K(N+4,2))
	+ IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
	+ P(N+3,4)=0.5D0(SHR+(P(N+3,5)2-P(N+4,5)*2)/SHR)
	+ P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)2-P(N+3,5)2))
	+ P(N+4,4)=SHR-P(N+3,4)
	+ P(N+4,3)=-P(N+3,3)
	+
	+C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
	+ PHI=PARU(2)*PYR(0)
	+ CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
	+
	+C...Set up default values before showers.
	+ MINT(31)=MINT(31)+1
	+ IPU1=N+1
	+ IPU2=N+2
	+ IPU3=N+3
	+ IPU4=N+4
	+ VINT(141)=VINT(41)
	+ VINT(142)=VINT(42)
	+ N=N+4
	+
	+C...Showering of initial state partons (optional).
	+C...Note: no showering of final state partons here; it comes later.
	+ IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
	+ MINT(51)=0
	+ ALAMSV=PARJ(81)
	+ PARJ(81)=PARP(72)
	+ NSAV=N
	+ DO 340 I=1,4
	+ DO 330 J=1,5
	+ KSAV(I,J)=K(N-4+I,J)
	+ PSAV(I,J)=P(N-4+I,J)
	+ 330 CONTINUE
	+ 340 CONTINUE
	+ CALL PYSSPA(IPU1,IPU2)
	+ PARJ(81)=ALAMSV
	+C...If shower failed then restore to situation before shower.
	+ IF(MINT(51).GE.1) THEN
	+ N=NSAV
	+ DO 360 I=1,4
	+ DO 350 J=1,5
	+ K(N-4+I,J)=KSAV(I,J)
	+ P(N-4+I,J)=PSAV(I,J)
	+ 350 CONTINUE
	+ 360 CONTINUE
	+ IPU1=N-3
	+ IPU2=N-2
	+ VINT(141)=VINT(41)
	+ VINT(142)=VINT(42)
	+ ENDIF
	+ ENDIF
	+
	+C...Keep track of loose colour ends and information on scattering.
	+ 370 IMI(1,MINT(31),1)=IPU1
	+ IMI(2,MINT(31),1)=IPU2
	+ IMI(1,MINT(31),2)=0
	+ IMI(2,MINT(31),2)=0
	+ XMI(1,MINT(31))=VINT(141)
	+ XMI(2,MINT(31))=VINT(142)
	+ PT2MI(MINT(31))=VINT(54)
	+ IMISEP(MINT(31))=N
	+
	+C...Decide whether quarks in last scattering were valence, companion or
	+C...sea.
	+ DO 430 JS=1,2
	+ KFBEAM=MINT(10+JS)
	+ KFSBM=ISIGN(1,MINT(10+JS))
	+ IFL=K(IMI(JS,MINT(31),1),2)
	+ IMI(JS,MINT(31),2)=0
	+ IF (IABS(IFL).GT.6) GOTO 430
	+
	+C...Get PDFs at X and Q2 of the parton shower initiator for the
	+C...last scattering. At this point VINT(143:144) do not yet
	+C...include the scattered x values VINT(141:142).
	+ X=VINT(140+JS)/VINT(142+JS)
	+ IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
	+ Q2=PARP(62)**2
	+ ELSE
	+ Q2=VINT(54)
	+ ENDIF
	+C...Note: XPSVC = x*pdf.
	+ MINT(30)=JS
	+ CALL PYPDFU(KFBEAM,X,Q2,XPQ)
	+ SEA=XPSVC(IFL,-1)
	+ VAL=XPSVC(IFL,0)
	+ CMP=0D0
	+ DO 380 IVC=1,NVC(JS,IFL)
	+ CMP=CMP+XPSVC(IFL,IVC)
	+ 380 CONTINUE
	+
	+C...Decide (Extra factor x cancels in the dvision).
	+ RVCS=PYR(0)*(SEA+VAL+CMP)
	+ IVNOW=1
	+ 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
	+C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
	+ IVNOW=0
	+ IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
	+ IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
	+ IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
	+ IF(KFIVAL(JS,1).EQ.0) THEN
	+ IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
	+ IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
	+ IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
	+ & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
	+ ELSE
	+ DO 400 I1=1,NMI(JS)
	+ IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
	+ & IVNOW=IVNOW-1
	+ 400 CONTINUE
	+ ENDIF
	+ IF(IVNOW.EQ.0) GOTO 390
	+C...Mark valence.
	+ IMI(JS,MINT(31),2)=0
	+C...Sets valence content of gamma, pi0, K0S, K0L if not done.
	+ IF(KFIVAL(JS,1).EQ.0) THEN
	+ IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
	+ KFIVAL(JS,1)=IFL
	+ KFIVAL(JS,2)=-IFL
	+ ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
	+ KFIVAL(JS,1)=IFL
	+ IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
	+ IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
	+ ENDIF
	+ ENDIF
	+
	+ ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
	+C...If sea, add opposite sign companion parton. Store X and I.
	+ NVC(JS,-IFL)=NVC(JS,-IFL)+1
	+ XASSOC(JS,-IFL,NVC(JS,-IFL))=X
	+C...Set pointer to companion
	+ IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
	+ ELSE
	+C...If companion, decide which one.
	+ CMPSUM=VAL+SEA
	+ ISEL=0
	+ 410 ISEL=ISEL+1
	+ CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
	+ IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
	+C...Find original sea (anti-)quark:
	+ IASSOC=0
	+ DO 420 I1=1,NMI(JS)
	+ IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
	+ IF (-IMI(JS,I1,2).EQ.ISEL) THEN
	+ IMI(JS,MINT(31),2)=IMI(JS,I1,1)
	+ IMI(JS,I1,2)=IMI(JS,MINT(31),1)
	+ ENDIF
	+ 420 CONTINUE
	+C...Change X to what associated companion had, so that the correct
	+C...amount of momentum can be subtracted from the companion sum below.
	+ X=XASSOC(JS,IFL,ISEL)
	+C...Mark companion read.
	+ XASSOC(JS,IFL,ISEL)=0D0
	+ ENDIF
	+ 430 CONTINUE
	+
	+C...Global statistics.
	+ MINT(351)=MINT(351)+1
	+ VINT(351)=VINT(351)+PT
	+ IF (MINT(351).EQ.1) VINT(356)=PT
	+
	+C...Update remaining energy and other counters.
	+ IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
	+ CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+ NMI(1)=NMI(1)+1
	+ NMI(2)=NMI(2)+1
	+ VINT(151)=VINT(151)+VINT(41)
	+ VINT(152)=VINT(152)+VINT(42)
	+ VINT(143)=VINT(143)-VINT(141)
	+ VINT(144)=VINT(144)-VINT(142)
	+
	+C...Iterate, with more interactions allowed.
	+ IF(MINT(31).LT.240) GOTO 240
	+ 440 CONTINUE
	+
	+C...Restore saved quantities for hardest interaction.
	+ MINT(1)=ISUBSV
	+ MINT(13)=M13SV
	+ MINT(14)=M14SV
	+ MINT(15)=M15SV
	+ MINT(16)=M16SV
	+ MINT(21)=M21SV
	+ MINT(22)=M22SV
	+ DO 450 J=11,80
	+ VINT(J)=VINTSV(J)
	+ 450 CONTINUE
	+ VINT(141)=V141SV
	+ VINT(142)=V142SV
	+
	+ ENDIF
	+
	+C...Format statements for printout.
	+ 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
	+ &'actions for MSTP(82) =',I2,' ******')
	+ 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	+ &D9.2,' mb: rejected')
	+ 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
	+ &D9.2,' mb: accepted')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYMIHK
	+C...Finds left-behind remnant flavour content and hooks up
	+C...the colour flow between the hard scattering and remnants
	+
	+ SUBROUTINE PYMIHK
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...The event record
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+C...Parameters
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+C...The common block of dangling ends
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
	+C...Local variables
	+ PARAMETER (NERSIZ=4000)
	+ COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
	+ & ,MACCPT
	+ COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
	+ SAVE /PYCBLS/,/PYCTAG/
	+ DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
	+ & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
	+ DATA NERRPR/0/
	+ SAVE NERRPR
	+ FOUR(I,J)=P(I,4)P(J,4)-P(I,3)P(J,3)-P(I,2)P(J,2)-P(I,1)P(J,1)
	+
	+C...Set up error checkers
	+ IBOOST=0
	+
	+C...Initialize colour arrays: MCO (Original) and MCT (New)
	+ DO 110 I=MINT(84)+1,NERSIZ
	+ DO 100 JC=1,2
	+ MCT(I,JC)=0
	+ MCO(I,JC)=0
	+ 100 CONTINUE
	+C...Also zero colour tracing information, if existed.
	+ IF (I.LE.N) THEN
	+ K(I,4)=MOD(K(I,4),MSTU(5)**2)
	+ K(I,5)=MOD(K(I,5),MSTU(5)**2)
	+ ENDIF
	+ 110 CONTINUE
	+
	+C...Initialize colour tag collapse arrays:
	+C...JCCO (Original) and JCCN (New).
	+ DO 130 MG=MINT(84)+1,NERSIZ
	+ DO 120 JC=1,2
	+ JCCO(MG,JC)=0
	+ JCCN(MG,JC)=0
	+ 120 CONTINUE
	+ 130 CONTINUE
	+
	+C...Zero gluon insertion array
	+ DO 150 IM=1,1000
	+ DO 140 J=1,3
	+ INSR(IM,J)=0
	+ 140 CONTINUE
	+ 150 CONTINUE
	+
	+C...Compute hard scattering system rapidities
	+ IF (MSTP(89).EQ.1) THEN
	+ DO 160 IM=1,240
	+ IF (IM.LE.MINT(31)) THEN
	+ YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
	+ ELSE
	+C...Set (unsigned) rapidity = 100 for beam remnant systems.
	+ YMI(IM)=100D0
	+ ENDIF
	+ 160 CONTINUE
	+ ENDIF
	+
	+C...Treat each side separately
	+ DO 290 JS=1,2
	+
	+C...Initialize side.
	+ NG(JS)=0
	+ JV=0
	+ KFS=ISIGN(1,MINT(10+JS))
	+
	+C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
	+ IF(KFIVAL(JS,1).EQ.0) THEN
	+ IF(MINT(10+JS).EQ.111) THEN
	+ KFIVAL(JS,1)=INT(1.5D0+PYR(0))
	+ KFIVAL(JS,2)=-KFIVAL(JS,1)
	+ ELSEIF(MINT(10+JS).EQ.22) THEN
	+ PYRKF=PYR(0)
	+ KFIVAL(JS,1)=1
	+ IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
	+ IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
	+ IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
	+ KFIVAL(JS,2)=-KFIVAL(JS,1)
	+ ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
	+ IF(PYR(0).GT.0.5D0) THEN
	+ KFIVAL(JS,1)=1
	+ KFIVAL(JS,2)=-3
	+ ELSE
	+ KFIVAL(JS,1)=3
	+ KFIVAL(JS,2)=-1
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+
	+C...Initialize beam remnant sea and valence content flavour by flavour.
	+ NVSUM(JS)=0
	+ NBRTOT(JS)=0
	+ DO 210 JFA=1,6
	+C...Count up original number of JFA valence quarks and antiquarks.
	+ NVALQ=0
	+ NVALQB=0
	+ NSEA=0
	+ DO 170 J=1,3
	+ IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
	+ IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
	+ 170 CONTINUE
	+ NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
	+C...Subtract kicked out valence and determine sea from flavour cons.
	+ DO 180 IM=1,NMI(JS)
	+ IFL = K(IMI(JS,IM,1),2)
	+ IFA = IABS(IFL)
	+ IFS = ISIGN(1,IFL)
	+ IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
	+C...Subtract K.O. valence quark from remainder.
	+ NVALQ=NVALQ-1
	+ JV=NVSUM(JS)-NVALQ-NVALQB
	+ IV(JS,JV)=IMI(JS,IM,1)
	+ ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
	+C...Subtract K.O. valence antiquark from remainder.
	+ NVALQB=NVALQB-1
	+ JV=NVSUM(JS)-NVALQ-NVALQB
	+ IV(JS,JV)=IMI(JS,IM,1)
	+ ELSEIF (IFA.EQ.JFA) THEN
	+C...Outside sea without companion: add opposite sea flavour inside.
	+ IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
	+ ENDIF
	+ 180 CONTINUE
	+C...Check if space left in PYJETS for additional BR flavours
	+ NFLSUM=IABS(NSEA)+NVALQ+NVALQB
	+ NBRTOT(JS)=NBRTOT(JS)+NFLSUM
	+ IF (N+NFLSUM+1.GT.MSTU(4)) THEN
	+ CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+C...Add required val+sea content to beam remnant.
	+ IF (NFLSUM.GT.0) THEN
	+ DO 200 IA=1,NFLSUM
	+C...Insert beam remnant quark as p.t. symbolic parton in ER.
	+ N=N+1
	+ DO 190 IX=1,5
	+ K(N,IX)=0
	+ P(N,IX)=0D0
	+ V(N,IX)=0D0
	+ 190 CONTINUE
	+ K(N,1)=3
	+ K(N,2)=ISIGN(JFA,NSEA)
	+ IF (IA.LE.NVALQ) K(N,2)=JFA
	+ IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
	+ K(N,3)=MINT(83)+JS
	+C...Also update NMI, IMI, and IV arrays.
	+ NMI(JS)=NMI(JS)+1
	+ IMI(JS,NMI(JS),1)=N
	+ IMI(JS,NMI(JS),2)=-1
	+ IF (IA.LE.NVALQ+NVALQB) THEN
	+ IMI(JS,NMI(JS),2)=0
	+ JV=JV+1
	+ IV(JS,JV)=IMI(JS,NMI(JS),1)
	+ ENDIF
	+ 200 CONTINUE
	+ ENDIF
	+ 210 CONTINUE
	+
	+ IM=0
	+ 220 IM=IM+1
	+ IF (IM.LE.NMI(JS)) THEN
	+ IF (K(IMI(JS,IM,1),2).EQ.21) THEN
	+ NG(JS)=NG(JS)+1
	+C...Add fictitious parent gluons for companion pairs.
	+ ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
	+C...Randomly assign companions to sea quarks which have none.
	+ IF (IMI(JS,IM,2).LT.0) THEN
	+ IMC=PYR(0)*NMI(JS)
	+ 230 IMC=MOD(IMC,NMI(JS))+1
	+ IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
	+ IF (IMI(JS,IMC,2).GE.0) GOTO 230
	+ IMI(JS, IM,2) = IMI(JS,IMC,1)
	+ IMI(JS,IMC,2) = IMI(JS, IM,1)
	+ ENDIF
	+C...Add fictitious parent gluon
	+ N=N+1
	+ DO 240 IX=1,5
	+ K(N,IX)=0
	+ P(N,IX)=0D0
	+ V(N,IX)=0D0
	+ 240 CONTINUE
	+ K(N,1)=14
	+ K(N,2)=21
	+ K(N,3)=MINT(83)+JS
	+C...Set gluon (anti-)colour daughter pointers
	+ K(N,4)=IMI(JS, IM,1)
	+ K(N,5)=IMI(JS, IM,2)
	+C...Set quark (anti-)colour parent pointers
	+ K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
	+ K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
	+C...Add gluon to IMI
	+ NMI(JS)=NMI(JS)+1
	+ IMI(JS,NMI(JS),1)=N
	+ IMI(JS,NMI(JS),2)=0
	+ ENDIF
	+ GOTO 220
	+ ENDIF
	+
	+C...If incoming (anti-)baryon, insert inside (anti-)junction.
	+C...Set up initial v-v-j-v configuration. Otherwise set up
	+C...mesonic v-vbar configuration
	+ IF (IABS(MINT(10+JS)).GT.1000) THEN
	+C...Determine junction type (1: B=1 2: B=-1)
	+ ITJUNC(JS) = (3-KFS)/2
	+C...Insert junction.
	+ N=N+1
	+ DO 250 IX=1,5
	+ K(N,IX)=0
	+ P(N,IX)=0D0
	+ V(N,IX)=0D0
	+ 250 CONTINUE
	+C...Set special junction codes:
	+ K(N,1)=42
	+ K(N,2)=88
	+C...Set parent to side.
	+ K(N,3)=MINT(83)+JS
	+ K(N,4)=ITJUNC(JS)*MSTU(5)
	+ K(N,5)=0
	+C...Connect valence quarks to junction.
	+ MOUT(JS)=0
	+ MANTI=ITJUNC(JS)-1
	+C...Set (anti)colour mother = junction.
	+ DO 260 JV=1,3
	+ K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
	+ & +MSTU(5)*N
	+C...Keep track of partons adjacent to junction:
	+ JST(JS,JV)=IV(JS,JV)
	+ 260 CONTINUE
	+ ELSE
	+C...Mesons: set up initial q-qbar topology
	+ ITJUNC(JS)=0
	+ IF (K(IV(JS,1),2).GT.0) THEN
	+ IQ=IV(JS,1)
	+ IQBAR=IV(JS,2)
	+ ELSE
	+ IQ=IV(JS,2)
	+ IQBAR=IV(JS,1)
	+ ENDIF
	+ IV(JS,3)=0
	+ JST(JS,1)=IQ
	+ JST(JS,2)=IQBAR
	+ JST(JS,3)=0
	+ K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
	+ K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
	+C...Special for mesons. Insert gluon if BR empty.
	+ IF (NBRTOT(JS).EQ.0) THEN
	+ N=N+1
	+ DO 270 IX=1,5
	+ K(N,IX)=0
	+ P(N,IX)=0D0
	+ V(N,IX)=0D0
	+ 270 CONTINUE
	+ K(N,1)=3
	+ K(N,2)=21
	+ K(N,3)=MINT(83)+JS
	+ K(N,4)=0
	+ K(N,5)=0
	+ NBRTOT(JS)=1
	+ NG(JS)=NG(JS)+1
	+C...Add gluon to IMI
	+ NMI(JS)=NMI(JS)+1
	+ IMI(JS,NMI(JS),1)=N
	+ IMI(JS,NMI(JS),2)=0
	+ ENDIF
	+ MOUT(JS)=0
	+ ENDIF
	+
	+C...Count up number of valence quarks outside BR.
	+ DO 280 JV=1,3
	+ IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
	+ & MOUT(JS)=MOUT(JS)+1
	+ 280 CONTINUE
	+
	+ 290 CONTINUE
	+
	+C...Now both sides have been prepared in an initial vvjv (baryonic) or
	+C...v(g)vbar (mesonic) configuration.
	+
	+C...Create colour line tags starting from initiators.
	+ NCT=0
	+ DO 320 IM=1,MINT(31)
	+C...Consider each side in turn.
	+ DO 310 JS=1,2
	+ I1=IMI(JS,IM,1)
	+ I2=IMI(3-JS,IM,1)
	+ DO 300 JCS=4,5
	+ IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
	+ & GOTO 300
	+ IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
	+
	+ KCS=JCS
	+ CALL PYCTTR(I1,KCS,I2)
	+ IF(MINT(51).NE.0) RETURN
	+
	+ 300 CONTINUE
	+ 310 CONTINUE
	+ 320 CONTINUE
	+
	+ DO 340 JS=1,2
	+C...Create colour tags for beam remnant partons.
	+ DO 330 IM=MINT(31)+1,NMI(JS)
	+ IP=IMI(JS,IM,1)
	+ IF (K(IP,2).NE.21) THEN
	+ JC=(3-ISIGN(1,K(IP,2)))/2
	+ IF (MCT(IP,JC).EQ.0) THEN
	+ NCT=NCT+1
	+ MCT(IP,JC)=NCT
	+ ENDIF
	+ ELSE
	+C...Gluons
	+ ICD=K(IP,4)
	+ IAD=K(IP,5)
	+ IF (ICD.NE.0) THEN
	+C...Fictituous gluons just inherit from their quark daughters.
	+ ICC=MCT(ICD,1)
	+ IAC=MCT(IAD,2)
	+ ELSE
	+C...Real beam remnant gluons get their own colours
	+ ICC=NCT+1
	+ IAC=NCT+2
	+ NCT=NCT+2
	+ ENDIF
	+ MCT(IP,1)=ICC
	+ MCT(IP,2)=IAC
	+ ENDIF
	+ 330 CONTINUE
	+ 340 CONTINUE
	+
	+C...Create colour tags for colour lines which are detached from the
	+C...initial state.
	+
	+ DO 360 MQGST=1,2
	+ DO 350 I=MINT(84)+1,N
	+
	+C...Look for coloured string endpoint, or (later) leftover gluon.
	+ IF (K(I,1).NE.3) GOTO 350
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0) GOTO 350
	+ KQ=KCHG(KC,2)
	+ IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
	+
	+C...Pick up loose string end with no previous tag.
	+ KCS=4
	+ IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
	+ IF(MCT(I,KCS-3).NE.0) GOTO 350
	+
	+ CALL PYCTTR(I,KCS,I)
	+ IF(MINT(51).NE.0) RETURN
	+
	+ 350 CONTINUE
	+ 360 CONTINUE
	+
	+C...Store original colour tags
	+ DO 370 I=MINT(84)+1,N
	+ MCO(I,1)=MCT(I,1)
	+ MCO(I,2)=MCT(I,2)
	+ 370 CONTINUE
	+
	+C...Iteratively add gluons to already existing string pieces, enforcing
	+C...various possible orderings, and rejecting insertions that would give
	+C...rise to singlet gluons.
	+C...<kappa tau> normalization.
	+ RM0=1.5D0
	+ MRETRY=0
	+ PARP80=PARP(80)
	+
	+C...Set up simplified kinematics.
	+C...Boost hard interaction systems.
	+ IBOOST=IBOOST+1
	+ DO 380 IM=1,MINT(31)
	+ BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
	+ CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
	+ 380 CONTINUE
	+C...Assign preliminary beam remnant momenta.
	+ DO 390 I=MINT(53)+1,N
	+ JS=K(I,3)
	+ P(I,1)=0D0
	+ P(I,2)=0D0
	+ IF (K(I,2).NE.88) THEN
	+ P(I,4)=0.5D0VINT(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)+2MSTU(5)*2
	+ IF (K(IP2,2).NE.88) THEN
	+ K(IP2,5-MANTI)=K(IP2,5-MANTI)+2MSTU(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-2JS)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-2JS)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-2JS)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-2JS)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=1000K(IDQ(1),2)+100K(IDQ(2),2)
	+ IS=3
	+ IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
	+ & (1D0+3D0PARJ(4))PYR(0).LT.1D0) IS=1
	+ KFDQ=KFDQ+ISIGN(IS,KFDQ)
	+ ENDIF
	+
	+C...Collapse diquark-j-quark system to baryon, if allowed and possible.
	+C...Note: third quark can per definition not also be valence,
	+C...therefore we can only do this if we are allowed to use sea quarks.
	+ 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
	+ NTRY=0
	+ 780 NTRY=NTRY+1
	+ CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
	+ IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
	+ GOTO 780
	+ ELSEIF(NTRY.GT.100) THEN
	+C...If no baryon can be found, give up and form diquark.
	+ IDQ(3)=0
	+ GOTO 770
	+ ELSE
	+C...Replace junction by baryon.
	+ K(IJU,1)=1
	+ K(IJU,2)=KFBAR
	+ K(IJU,3)=MINT(83)+JS
	+ K(IJU,4)=0
	+ K(IJU,5)=0
	+ P(IJU,5)=PYMASS(KFBAR)
	+ DO 790 MSJ=1,3
	+C...Prepare removal of participating quarks from ER.
	+ K(JST(JS,MSJ),1)=-1
	+ 790 CONTINUE
	+ ENDIF
	+ ELSE
	+C...If collapse to baryon not possible or not allowed, replace junction
	+C...by diquark. This way, collapsed gluons that were pointing at the
	+C...junction will now point (correctly) at diquark.
	+ MANTI=ITJUNC(JS)-1
	+ K(IJU,1)=3
	+ K(IJU,2)=KFDQ
	+ K(IJU,3)=MINT(83)+JS
	+ K(IJU,4)=0
	+ K(IJU,5)=0
	+ DO 800 MSJ=1,3
	+ IP=JST(JS,MSJ)
	+ IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
	+ K(IJU,4+MANTI)=0
	+ K(IJU,5-MANTI)=IP*MSTU(5)
	+ K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
	+ & MSTU(5)*IJU
	+ MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
	+ ELSE
	+C...Prepare removal of participating quarks from ER.
	+ K(IP,1)=-1
	+ ENDIF
	+ 800 CONTINUE
	+ ENDIF
	+
	+C...Update so ER pointers to collapsed quarks
	+C...now go to collapsed object.
	+ DO 820 I=MINT(84)+1,N
	+ IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
	+ & .K(I,1).GT.0) THEN
	+ DO 810 ISID=4,5
	+ IMO=K(I,ISID)/MSTU(5)
	+ IDA=MOD(K(I,ISID),MSTU(5))
	+ IF (IMO.GT.0) THEN
	+ IF (K(IMO,1).EQ.-1) IMO=IJU
	+ ENDIF
	+ IF (IDA.GT.0) THEN
	+ IF (K(IDA,1).EQ.-1) IDA=IJU
	+ ENDIF
	+ K(I,ISID)=IDA+MSTU(5)*IMO
	+ 810 CONTINUE
	+ ENDIF
	+ 820 CONTINUE
	+ ENDIF
	+ ENDIF
	+
	+C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
	+C...(this only happens for baryons, where we want to force the gluon
	+C...to sit next to the junction. Mesons handled above.)
	+ IF (NBRTOT(JS).EQ.0) THEN
	+ N=N+1
	+ DO 830 IX=1,5
	+ K(N,IX)=0
	+ P(N,IX)=0D0
	+ V(N,IX)=0D0
	+ 830 CONTINUE
	+ IGL=N
	+ K(IGL,1)=3
	+ K(IGL,2)=21
	+ K(IGL,3)=MINT(83)+JS
	+ IF (ITJUNC(JS).NE.0) THEN
	+C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
	+ JLEG=PYR(0)*NVSUM(JS)+1
	+ I1=JST(JS,JLEG)
	+ JST(JS,JLEG)=IGL
	+ JCT=MCT(I1,ITJUNC(JS))
	+ MCT(IGL,3-ITJUNC(JS))=JCT
	+ NCT=NCT+1
	+ MCT(IGL,ITJUNC(JS))=NCT
	+ MANTI=ITJUNC(JS)-1
	+ ELSE
	+C...Meson. Should not happen.
	+ CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
	+ IF(NERRPR.LT.5) THEN
	+ WRITE(MSTU(11),*) 'This should not have been possible!'
	+ CALL PYLIST(4)
	+ NERRPR=NERRPR+1
	+ ENDIF
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+ I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
	+ K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
	+ K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
	+ K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
	+ IF (K(I2,2).NE.88) THEN
	+ K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
	+ ELSE
	+ IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
	+ K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
	+ ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
	+ K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
	+ ELSE
	+ K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 840 CONTINUE
	+
	+C...Remove collapsed quarks and junctions from ER and update IMI.
	+ CALL PYEDIT(11)
	+
	+C...Also update beam remnant part of IMI.
	+ NMI(1)=MINT(31)
	+ NMI(2)=MINT(31)
	+ DO 850 I=MINT(53)+1,N
	+ IF (K(I,1).LE.0) GOTO 850
	+C...Restore BR quark/diquark/baryon pointers in IMI.
	+ IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
	+ JS=K(I,3)-MINT(83)
	+ NMI(JS)=NMI(JS)+1
	+ IMI(JS,NMI(JS),1)=I
	+ IMI(JS,NMI(JS),2)=0
	+ ENDIF
	+ 850 CONTINUE
	+
	+C...Restore companion information from collapsed gluons.
	+ DO 870 I=MINT(53)+1,N
	+ IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
	+ JS=K(I,3)-MINT(83)
	+ JCD=MOD(K(I,4),MSTU(5))
	+ JAD=MOD(K(I,5),MSTU(5))
	+ DO 860 IM=1,NMI(JS)
	+ IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
	+ IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
	+ 860 CONTINUE
	+ IMI(JS,IMC,2)=IMI(JS,IMA,1)
	+ IMI(JS,IMA,2)=IMI(JS,IMC,1)
	+ ENDIF
	+ 870 CONTINUE
	+
	+C...Renumber colour lines (since some have disappeared)
	+ JCT=0
	+ JCD=0
	+ 880 JCT=JCT+1
	+ MFOUND=0
	+ I=MINT(84)
	+ 890 I=I+1
	+ IF (I.EQ.N+1) THEN
	+ IF (MFOUND.EQ.0) JCD=JCD+1
	+ ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
	+ MCT(I,1)=JCT-JCD
	+ MFOUND=1
	+ ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
	+ MCT(I,2)=JCT-JCD
	+ MFOUND=1
	+ ENDIF
	+ IF (I.LE.N) GOTO 890
	+ IF (JCT.LT.NCT) GOTO 880
	+ NCT=JCT-JCD
	+
	+C...Reset hard interaction subsystems to their CM frames.
	+ IF (IBOOST.EQ.1) THEN
	+ DO 900 IM=1,MINT(31)
	+ BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
	+ CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
	+ 900 CONTINUE
	+C...Zero beam remnant longitudinal momenta and energies
	+ DO 910 I=MINT(53)+1,N
	+ P(I,3)=0D0
	+ P(I,4)=0D0
	+ 910 CONTINUE
	+ ELSE
	+ CALL PYERRM(9
	+ & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
	+C...Kill event and start another.
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+
	+ 9999 RETURN
	+ END
	+C*********************************************************************
	+
	+C...PYCTTR
	+C...Adapted from PYPREP.
	+C...Assigns LHA1 colour tags to coloured partons based on
	+C...K(I,4) and K(I,5) colour connection record.
	+C...KCS negative signifies that a previous tracing should be continued.
	+C...(in case the tag to be continued is empty, the routine exits)
	+C...Starts at I and ends at I or IEND.
	+C...Special considerations for systems with junctions.
	+C...Special: if IEND=-1, means trace this parton to its color partner,
	+C... then exit. If no partner found, exit with 0.
	+
	+ SUBROUTINE PYCTTR(I,KCS,IEND)
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+C...The common block of colour tags.
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
	+ DATA NERRPR/0/
	+ SAVE NERRPR
	+
	+C...Skip if parton not existing or does not have KCS
	+ IF (K(I,1).LE.0) GOTO 120
	+ KC=PYCOMP(K(I,2))
	+ IF (KC.EQ.0) GOTO 120
	+ KQ=KCHG(KC,2)
	+ IF (KQ.EQ.0) GOTO 120
	+ IF (IABS(KQ).EQ.1.AND.KQ(9-2ABS(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.2MSTU(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)+2MSTU(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)+2MSTU(5)*2
	+ ELSE
	+ IF(MREV.EQ.0) KCS=9-KCS
	+ IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
	+C...Set KCS daughter traced tag for IA
	+ K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
	+ ENDIF
	+C...Assign new colour tag
	+ MCT(IA,KCS-3)=NCS
	+C...Finish if IEND=-1 and found final-state color partner
	+ IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
	+ IEND=IA
	+ GOTO 120
	+ ENDIF
	+ IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
	+
	+ 120 RETURN
	+ END
	+
	+*********************************************************************
	+
	+C...PYMIHG
	+C...Collapse JCP1 and connecting tags to JCG1.
	+C...Collapse JCP2 and connecting tags to JCG2.
	+
	+ SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...The event record
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+C...Parameters
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYINT1/
	+C...Local variables
	+ COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
	+ COMMON /PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYCBLS/,/PYCTAG/
	+
	+C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
	+C...in temporary tag collapse array JCCN. Only break up one connection.
	+ MACCPT=1
	+ MCLPS=0
	+ DO 100 ICC=1,NCC
	+ JCCN(ICC,1)=JCCO(ICC,1)
	+ JCCN(ICC,2)=JCCO(ICC,2)
	+C...If there was a mother, it was previously connected to JCP1.
	+C...Should be changed to JCP2.
	+ IF (MCLPS.EQ.0) THEN
	+ IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
	+ & ,JCP2)) THEN
	+ JCCN(ICC,1)=MAX(JCG2,JCP2)
	+ JCCN(ICC,2)=MIN(JCG2,JCP2)
	+ MCLPS=1
	+ ENDIF
	+ ENDIF
	+ 100 CONTINUE
	+C...Also collapse colours on JCP1 side of JCG1
	+ IF (JCP1.NE.0) THEN
	+ JCCN(NCC+1,1)=MAX(JCP1,JCG1)
	+ JCCN(NCC+1,2)=MIN(JCP1,JCG1)
	+ ELSE
	+ JCCN(NCC+1,1)=MAX(JCP2,JCG2)
	+ JCCN(NCC+1,2)=MIN(JCP2,JCG2)
	+ ENDIF
	+
	+C...Initialize event record colour tag array MCT array to MCO.
	+ DO 110 I=MINT(84)+1,N
	+ MCT(I,1)=MCO(I,1)
	+ MCT(I,2)=MCO(I,2)
	+ 110 CONTINUE
	+
	+C...Collapse tags:
	+C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
	+C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
	+C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
	+C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
	+ DO 160 IS=1,4
	+C...Skip if junction.
	+ IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
	+C...Define starting point in tag space.
	+C...JCA = previous tag
	+C...JCO = present tag
	+C...JCN = new tag
	+ IF (MOD(IS,2).EQ.1) THEN
	+ JCO=JCP1
	+ JCN=JCG1
	+ JCALL=JCG1
	+ ELSEIF (MOD(IS,2).EQ.0) THEN
	+ JCO=JCP2
	+ JCN=JCG2
	+ JCALL=JCG2
	+ ENDIF
	+ ITRACE=0
	+ 120 ITRACE=ITRACE+1
	+ IF (ITRACE.GT.1000) THEN
	+C...NB: Proper error message should be defined here.
	+ CALL PYERRM(14
	+ & ,'(PYMIHG:) Inf loop when collapsing colours.')
	+ MINT(57)=MINT(57)+1
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+C...Collapse all JCN tags to JCALL
	+ DO 130 I=MINT(84)+1,N
	+ IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
	+ IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
	+ 130 CONTINUE
	+C...IS = 1,2: first step forward. IS = 3,4: first step backward.
	+ IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
	+ JCA=JCN
	+ JCN=JCO
	+ ELSE
	+ JCA=JCO
	+ JCO=JCN
	+ ENDIF
	+C...If possible, step from JCO to new tag JCN not equal to JCA.
	+ DO 140 ICC=1,NCC+1
	+ IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
	+ & JCCN(ICC,2)
	+ IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
	+ & JCCN(ICC,1)
	+ 140 CONTINUE
	+C...Iterate if new colour was arrived at, but don't go in circles.
	+ IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
	+C...Change all JCN tags in MCO to JCALL in MCT.
	+ DO 150 I=MINT(84)+1,N
	+ IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
	+ IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
	+C...If gluon and colour tag = anticolour tag (and not = 0) try again.
	+ IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
	+ & .NE.0) MACCPT=0
	+ 150 CONTINUE
	+ 160 CONTINUE
	+
	+ DO 200 JCL=NCT,1,-1
	+ JCA=0
	+ JCN=JCL
	+ 170 JCO=JCN
	+ DO 180 ICC=1,NCC+1
	+ IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
	+ & =JCCN(ICC,2)
	+ IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
	+ & =JCCN(ICC,1)
	+ 180 CONTINUE
	+C...Overpaint all JCN with JCL
	+ IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
	+ DO 190 I=MINT(84)+1,N
	+ IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
	+ IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
	+C...If gluon and colour tag = anticolour tag (and not = 0) try again.
	+ IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
	+ & .NE.0) MACCPT=0
	+ 190 CONTINUE
	+ JCA=JCO
	+ GOTO 170
	+ ENDIF
	+ 200 CONTINUE
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYMIRM
	+C...Picks primordial kT and shares longitudinal momentum among
	+C...beam remnants.
	+
	+ SUBROUTINE PYMIRM
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...The event record
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+C...Parameters
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+C...The common block of colour tags.
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+C...The common block of dangling ends
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
	+C...Local variables
	+ DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
	+C...W(I,J)\| J=0 \| 1 \| 2 \|
	+C... I=0 \| Wrem**2 \| W+ \| W- \|
	+C... 1 \| W1**2 \| W1+ \| W1- \|
	+C... 2 \| W2**2 \| W2+ \| W2- \|
	+C...4-product
	+ FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	+C...Tentative parametrization of <kT> as a function of Q.
	+ SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
	+C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
	+C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
	+ GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
	+C...Lambda kinematic function.
	+ FLAM(A,B,C)=A2+B2+C*2-2D0(AB+BC+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/40D0SIGMA6/EPS*6)
	+ IF (PYR(0).LT.P12) THEN
	+C...Use flat approx with accept/reject up to EPS.
	+ PT=PYR(0)*EPS
	+ WT=(3D0/2D0SIGMA2/(PT2+3D0/2D0SIGMA2))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=PT6/(PT2+3D0/2D0SIGMA2)*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(PTX2+PTY2)
	+ 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(PTX2+PTY2)
	+ 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.5D0FACPTCX
	+ P(L1,2)=P(L1,2)+0.5D0FACPTCY
	+ P(L2,1)=P(L2,1)+0.5D0FACPTCX
	+ P(L2,2)=P(L2,2)+0.5D0FACPTCY
	+ P(L3,1)=P(L3,1)+0.5D0FACPTCX
	+ P(L3,2)=P(L3,2)+0.5D0FACPTCY
	+ P(IDA,1)=P(IDA,1)-0.5D0FACPTCX
	+ P(IDA,2)=P(IDA,2)-0.5D0FACPTCY
	+ 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(PT1PT2-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
	+ & (XCOMP2+XX2)/(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))/(2D0W(1,1)W(0,2))
	+ R2=(COMTRM+W(2,0)-W(1,0))/(2D0W(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=2D0FOUR(IJ1,IJ2)2D0*FOUR(IK1,IK2)
	+ RLN=2D0FOUR(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(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+C...The common block of colour tags.
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
	+ &/PYPARS/
	+C...MCN: Temporary storage of new colour tags
	+ INTEGER MCN(4000,2)
	+C...Arrays for storing color 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)*2P2AVG)
	+ 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 = 2RAPMAX/(1D0NBINY)
	+C... Explicitly zero histogram bin content
	+ DO 160 IBINY=1,NBINY
	+ NSTRY(IBINY)=0
	+ 160 CONTINUE
	+ DO 180 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 170 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.5DRAP.AND.Y2.GE.YBINLO+0.5DRAP)
	+ & NSTRY(IBINY) = NSTRY(IBINY) + 1
	+ 170 CONTINUE
	+ 180 CONTINUE
	+C... Loop over pieces to find individual reconnect probability
	+ DO 200 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)*2PT2AVG)
	+ ENDIF
	+ PKEEP = 1.0
	+ DO 190 IBINY=IBINLO,IBINHI
	+C DNSUM = DNSUM + 1D0
	+ DNOVL = MAX(0,NSTRY(IBINY)-1)
	+ PKEEP = PKEEP * (1D0-CRMODFPARP(78))(DRAPAVDNOVL)
	+C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
	+ 190 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
	+ 200 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
	+ 210 NLOOP=NLOOP+1
	+ MORD=1
	+ DO 220 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
	+ 220 CONTINUE
	+C...Max do 1000 reordering loops
	+ IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 210
	+
	+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 230 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
	+ 230 CONTINUE
	+ ENDIF
	+
	+C...Loop over CR partons
	+C...(Ignore junctions for now.)
	+ NLOOP=0
	+ 240 NLOOP=NLOOP+1
	+ RLMAX=0D0
	+ ICRMAX=0
	+C...Loop over coloured partons
	+ DO 260 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 260
	+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 260
	+ 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 250 IC2=1,NCR
	+ J=ICR(IC2)
	+ MSJ=MSCR(IC2)
	+C...Skip if already connected
	+ IF (MCN(J,MSJ).NE.0) GOTO 250
	+C...Skip if this not colour-anticolour pair
	+ IF (MSI.EQ.MSJ) GOTO 250
	+C...And do not let gluons connect to themselves
	+ IF (I.EQ.J) GOTO 250
	+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
	+ 250 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
	+ 260 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 240
	+ 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 290 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 290
	+ 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 280 KCT=ICTMIN,LCT
	+ IC=0
	+ IA=0
	+ DO 270 IT=MAX(1,IP),N
	+ IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 270
	+ IF (MCN(IT,1).EQ.KCT) IC=IT
	+ IF (MCN(IT,2).EQ.KCT) IA=IT
	+ 270 CONTINUE
	+C...Skip if this color tag no longer present in event record
	+ IF (IC.EQ.0.OR.IA.EQ.0) GOTO 280
	+ RL=FOUR(IC,I)*FOUR(IA,I)
	+ IF (RL.LT.RLMAX) THEN
	+ RLMAX=RL
	+ ICMAX=IC
	+ IAMAX=IA
	+ ENDIF
	+ 280 CONTINUE
	+ LCT=LCT+1
	+ MCN(I,1)=MCN(ICMAX,1)
	+ MCN(I,2)=LCT
	+ MCN(ICMAX,1)=LCT
	+ ENDIF
	+ 290 CONTINUE
	+C...Here we need to loop over entire event.
	+ DO 300 IZ=MAX(1,IP),N
	+C...Do not erase parton shower colour history
	+ IF (K(IZ,1).NE.3) GOTO 300
	+C...Check colour charge
	+ MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
	+ IF (MCI.EQ.0) GOTO 300
	+ IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
	+ IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
	+ 300 CONTINUE
	+ ENDIF
	+
	+ 9999 RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYDIFF
	+C...Handles diffractive and elastic scattering.
	+
	+ SUBROUTINE PYDIFF
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
	+
	+C...Reset K, P and V vectors. Store incoming particles.
	+ DO 110 JT=1,MSTP(126)+10
	+ I=MINT(83)+JT
	+ DO 100 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+ N=MINT(84)
	+ MINT(3)=0
	+ MINT(21)=0
	+ MINT(22)=0
	+ MINT(23)=0
	+ MINT(24)=0
	+ MINT(4)=4
	+ DO 130 JT=1,2
	+ I=MINT(83)+JT
	+ K(I,1)=21
	+ K(I,2)=MINT(10+JT)
	+ DO 120 J=1,5
	+ P(I,J)=VINT(285+5*JT+J)
	+ 120 CONTINUE
	+ 130 CONTINUE
	+ MINT(6)=2
	+
	+C...Subprocess; kinematics.
	+ SQLAM=(VINT(2)-VINT(63)-VINT(64))*2-4D0VINT(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,(PMMAS2-PM12-PM22)2-
	+ & 4D0PM12PM2*2))/(2D0PMMAS)
	+ P(N-1,3)=PZP
	+ P(N,3)=-PZP
	+ P(N-1,4)=SQRT(PM12+PZP2)
	+ P(N,4)=SQRT(PM22+PZP2)
	+ CALL PYROBO(N-1,N,ACOS(2D0PYR(0)-1D0),PARU(2)PYR(0),
	+ & 0D0,0D0,0D0)
	+ DBETAZ=PZ(-1)(JT+1)/SQRT(PZ2+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-
	+ & 4D0P(N-1,5)2P(N,5)**2
	+ P(N-1,3)=(PESQRT(SQLAM)+PZ(VINT(62+JT)+P(N-1,5)**2-
	+ & P(N,5)*2))/(2D0VINT(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((CHI2/(CHI2+CUT2))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=CUTCUTR*PYR(0)
	+ CHI=(CHIR2-CUT2)/(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(CHI2+CUT2)))**
	+ & (0.5D0PARP(98))(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
	+ ENDIF
	+ IF(CHI.LT.P(N,5)2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)2/
	+ & VINT(62+JT)) GOTO 160
	+ SQM=P(N-2,5)2/(1D0-CHI)+P(N,5)2/CHI
	+ PZI=(PE(VINT(62+JT)-SQM)+PZ(VINT(62+JT)+SQM))/
	+ & (2D0*VINT(62+JT))
	+ PEI=SQRT(PZI**2+SQM)
	+ PQQP=(1D0-CHI)*(PEI+PZI)
	+ P(N-2,3)=0.5D0(PQQP-P(N-2,5)2/PQQP)(-1)**(JT+1)
	+ P(N-2,4)=SQRT(P(N-2,3)2+P(N-2,5)2)
	+ P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
	+ P(N-1,3)=P(N-1,4)(-1)*JT
	+ P(N,3)=PZI(-1)*(JT+1)-P(N-2,3)
	+ P(N,4)=SQRT(P(N,3)2+P(N,5)2)
	+ ENDIF
	+
	+C...Documentation lines.
	+ K(I+2,1)=21
	+ IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
	+ IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
	+ & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
	+ K(I+2,3)=I
	+ P(I+2,3)=PZ(-1)*(JT+1)
	+ P(I+2,4)=PE
	+ P(I+2,5)=SQRT(VINT(62+JT))
	+ 200 CONTINUE
	+
	+C...Rotate outgoing partons/particles using cos(theta).
	+ IF(VINT(23).LT.0.9D0) THEN
	+ CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
	+ ELSE
	+ CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYDISG
	+C...Set up a DIS process as gamma* + f -> f, with beam remnant
	+C...and showering added consecutively. Photon flux by the PYGAGA
	+C...routine (if at all).
	+
	+ SUBROUTINE PYDISG
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
	+C...Local arrays.
	+ DIMENSION PMS(4)
	+
	+C...Choice of subprocess, number of documentation lines
	+ IDOC=7
	+ MINT(3)=IDOC-6
	+ MINT(4)=IDOC
	+ IPU1=MINT(84)+1
	+ IPU2=MINT(84)+2
	+ IPU3=MINT(84)+3
	+ ISIDE=1
	+ IF(MINT(107).EQ.4) ISIDE=2
	+
	+C...Reset K, P and V vectors. Store incoming particles
	+ DO 110 JT=1,MSTP(126)+20
	+ I=MINT(83)+JT
	+ DO 100 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+ DO 130 JT=1,2
	+ I=MINT(83)+JT
	+ K(I,1)=21
	+ K(I,2)=MINT(10+JT)
	+ DO 120 J=1,5
	+ P(I,J)=VINT(285+5*JT+J)
	+ 120 CONTINUE
	+ 130 CONTINUE
	+ MINT(6)=2
	+
	+C...Store incoming partons in hadronic CM-frame
	+ DO 140 JT=1,2
	+ I=MINT(84)+JT
	+ K(I,1)=14
	+ K(I,2)=MINT(14+JT)
	+ K(I,3)=MINT(83)+2+JT
	+ 140 CONTINUE
	+ IF(MINT(15).EQ.22) THEN
	+ P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
	+ P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
	+ P(MINT(84)+1,5)=-SQRT(VINT(307))
	+ P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
	+ P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
	+ KFRES=MINT(16)
	+ ISIDE=2
	+ ELSE
	+ P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
	+ P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
	+ P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
	+ P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
	+ P(MINT(84)+1,5)=-SQRT(VINT(308))
	+ KFRES=MINT(15)
	+ ISIDE=1
	+ ENDIF
	+ SIDESG=(-1D0)**(ISIDE-1)
	+
	+C...Copy incoming partons to documentation lines.
	+ DO 170 JT=1,2
	+ I1=MINT(83)+4+JT
	+ I2=MINT(84)+JT
	+ K(I1,1)=21
	+ K(I1,2)=K(I2,2)
	+ K(I1,3)=I1-2
	+ DO 150 J=1,5
	+ P(I1,J)=P(I2,J)
	+ 150 CONTINUE
	+
	+C...Second copy for partons before ISR shower, since no such.
	+ I1=MINT(83)+2+JT
	+ K(I1,1)=21
	+ K(I1,2)=K(I2,2)
	+ K(I1,3)=I1-2
	+ DO 160 J=1,5
	+ P(I1,J)=P(I2,J)
	+ 160 CONTINUE
	+ 170 CONTINUE
	+
	+C...Define initial partons.
	+ NTRY=0
	+ 180 NTRY=NTRY+1
	+ IF(NTRY.GT.100) THEN
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+
	+C...Scattered quark in hadronic CM frame.
	+ I=MINT(83)+7
	+ K(IPU3,1)=3
	+ K(IPU3,2)=KFRES
	+ K(IPU3,3)=I
	+ P(IPU3,5)=PYMASS(KFRES)
	+ P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
	+ P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
	+ P(IPU3,5)=0D0
	+ K(I,1)=21
	+ K(I,2)=KFRES
	+ K(I,3)=MINT(83)+4+ISIDE
	+ P(I,3)=P(IPU3,3)
	+ P(I,4)=P(IPU3,4)
	+ P(I,5)=P(IPU3,5)
	+ N=IPU3
	+ MINT(21)=KFRES
	+ MINT(22)=0
	+
	+C...No primordial kT, or chosen according to truncated Gaussian or
	+C...exponential, or (for photon) predetermined or power law.
	+ 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
	+ IF(MSTP(91).LE.0) THEN
	+ PT=0D0
	+ ELSEIF(MSTP(91).EQ.1) THEN
	+ PT=PARP(91)*SQRT(-LOG(PYR(0)))
	+ ELSE
	+ RPT1=PYR(0)
	+ RPT2=PYR(0)
	+ PT=-PARP(92)LOG(RPT1RPT2)
	+ 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(RPT1RPT2)
	+ ENDIF
	+ IF(PTB.GT.PARP(100)) GOTO 190
	+ PT=SQRT(PTA2+PTB2+2D0PTAPTBCOS(PARU(2)PYR(0)))
	+ IF(NTRY.GT.10) PT=PT0.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(RPT1RPT2)
	+ 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+PT2+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+2IMB)))
	+ 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-4D0PMS(1)*PMS(2)))
	+ DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
	+ &(2D0VINT(1)PCP)
	+ DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
	+ &(2D0VINT(1)PRP)
	+ DBEC=-SIDESG(DRKC2-1D0)/(DRKC*2+1D0)
	+ DBER=SIDESG(DRKR2-1D0)/(DRKR*2+1D0)
	+ CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
	+ CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
	+
	+C...Let current quark shower; recoil but no showering by colour partner.
	+ QMAX=2D0*SQRT(VINT(309-ISIDE))
	+ MSTJ48=MSTJ(48)
	+ MSTJ(48)=1
	+ PARJ86=PARJ(86)
	+ PARJ(86)=0D0
	+ IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
	+ MSTJ(48)=MSTJ48
	+ PARJ(86)=PARJ86
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYDOCU
	+C...Handles the documentation of the process in MSTI and PARI,
	+C...and also computes cross-sections based on accumulated statistics.
	+
	+ SUBROUTINE PYDOCU
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
	+ &/PYINT5/
	+
	+C...Calculate Monte Carlo estimates of cross-sections.
	+ ISUB=MINT(1)
	+ IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
	+ NGEN(0,3)=NGEN(0,3)+1
	+ XSEC(0,3)=0D0
	+ DO 100 I=1,500
	+ IF(I.EQ.96.OR.I.EQ.97) THEN
	+ XSEC(I,3)=0D0
	+ ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
	+ & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
	+ XSEC(I,3)=XSEC(96,2)NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))
	+ & DBLE(NGEN(96,2)))
	+ ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
	+ XSEC(I,3)=XSEC(96,2)NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))
	+ & DBLE(NGEN(96,2)))
	+ ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
	+ XSEC(I,3)=0D0
	+ ELSEIF(NGEN(I,2).EQ.0) THEN
	+ XSEC(I,3)=XSEC(I,2)NGEN(0,3)/(DBLE(NGEN(I,1))
	+ & DBLE(NGEN(0,2)))
	+ ELSE
	+ XSEC(I,3)=XSEC(I,2)NGEN(I,3)/(DBLE(NGEN(I,1))
	+ & DBLE(NGEN(I,2)))
	+ ENDIF
	+ XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
	+ 100 CONTINUE
	+
	+C...Rescale to known low-pT cross-section for standard QCD processes.
	+ IF(MSUB(95).EQ.1) THEN
	+ XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
	+ & XSEC(68,3)+XSEC(95,3)
	+ XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
	+ IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
	+ FAC=XSECW/XSECH
	+ XSEC(11,3)=FAC*XSEC(11,3)
	+ XSEC(12,3)=FAC*XSEC(12,3)
	+ XSEC(13,3)=FAC*XSEC(13,3)
	+ XSEC(28,3)=FAC*XSEC(28,3)
	+ XSEC(53,3)=FAC*XSEC(53,3)
	+ XSEC(68,3)=FAC*XSEC(68,3)
	+ XSEC(95,3)=FAC*XSEC(95,3)
	+ XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
	+ ENDIF
	+ ENDIF
	+
	+C...Save information for gamma-p and gamma-gamma.
	+ IF(MINT(121).GT.1) THEN
	+ IGA=MINT(122)
	+ CALL PYSAVE(2,IGA)
	+ CALL PYSAVE(5,0)
	+ ENDIF
	+
	+C...Reset information on hard interaction.
	+ DO 110 J=1,200
	+ MSTI(J)=0
	+ PARI(J)=0D0
	+ 110 CONTINUE
	+
	+C...Copy integer valued information from MINT into MSTI.
	+ DO 120 J=1,32
	+ MSTI(J)=MINT(J)
	+ 120 CONTINUE
	+ IF(MINT(121).GT.1) MSTI(9)=MINT(122)
	+
	+C...Store cross-section variables in PARI.
	+ PARI(1)=XSEC(0,3)
	+ PARI(2)=XSEC(0,3)/MINT(5)
	+ PARI(7)=VINT(97)
	+ PARI(9)=VINT(99)
	+ PARI(10)=VINT(100)
	+ VINT(98)=VINT(98)+VINT(100)
	+ IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
	+
	+C...Store kinematics variables in PARI.
	+ PARI(11)=VINT(1)
	+ PARI(12)=VINT(2)
	+ IF(ISUB.NE.95) THEN
	+ DO 130 J=13,26
	+ PARI(J)=VINT(30+J)
	+ 130 CONTINUE
	+ PARI(29)=VINT(39)
	+ PARI(30)=VINT(40)
	+ PARI(31)=VINT(141)
	+ PARI(32)=VINT(142)
	+ PARI(33)=VINT(41)
	+ PARI(34)=VINT(42)
	+ PARI(35)=PARI(33)-PARI(34)
	+ PARI(36)=VINT(21)
	+ PARI(37)=VINT(22)
	+ PARI(38)=VINT(26)
	+ PARI(39)=VINT(157)
	+ PARI(40)=VINT(158)
	+ PARI(41)=VINT(23)
	+ PARI(42)=2D0*VINT(47)/VINT(1)
	+ ENDIF
	+
	+C...Store information on scattered partons in PARI.
	+ IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
	+ DO 140 IS=7,8
	+ I=MINT(IS)
	+ PARI(36+IS)=P(I,3)/VINT(1)
	+ PARI(38+IS)=P(I,4)/VINT(1)
	+ PR=MAX(1D-20,P(I,5)2+P(I,1)2+P(I,2)**2)
	+ PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
	+ & SQRT(PR),1D20)),P(I,3))
	+ PR=MAX(1D-20,P(I,1)2+P(I,2)2)
	+ PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
	+ & SQRT(PR),1D20)),P(I,3))
	+ PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)2+P(I,2)2+P(I,3)**2)
	+ PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)2+P(I,2)2))
	+ PARI(48+IS)=PYANGL(P(I,1),P(I,2))
	+ 140 CONTINUE
	+ ENDIF
	+
	+C...Store sum up transverse and longitudinal momenta.
	+ PARI(65)=2D0*PARI(17)
	+ IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
	+ DO 150 I=MSTP(126)+1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
	+ PT=SQRT(P(I,1)2+P(I,2)2)
	+ PARI(69)=PARI(69)+PT
	+ IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
	+ IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
	+ 150 CONTINUE
	+ PARI(67)=PARI(68)
	+ PARI(71)=VINT(151)
	+ PARI(72)=VINT(152)
	+ PARI(73)=VINT(151)
	+ PARI(74)=VINT(152)
	+ ELSE
	+ PARI(66)=PARI(65)
	+ PARI(69)=PARI(65)
	+ ENDIF
	+
	+C...Store various other pieces of information into PARI.
	+ PARI(61)=VINT(148)
	+ PARI(75)=VINT(155)
	+ PARI(76)=VINT(156)
	+ PARI(77)=VINT(159)
	+ PARI(78)=VINT(160)
	+ PARI(81)=VINT(138)
	+
	+C...Store information on lepton -> lepton + gamma in PYGAGA.
	+ MSTI(71)=MINT(141)
	+ MSTI(72)=MINT(142)
	+ PARI(101)=VINT(301)
	+ PARI(102)=VINT(302)
	+ DO 160 I=103,114
	+ PARI(I)=VINT(I+202)
	+ 160 CONTINUE
	+
	+C...Set information for PYTABU.
	+ IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
	+ MSTU(161)=MINT(21)
	+ MSTU(162)=0
	+ ELSEIF(ISET(ISUB).EQ.5) THEN
	+ MSTU(161)=MINT(23)
	+ MSTU(162)=0
	+ ELSE
	+ MSTU(161)=MINT(21)
	+ MSTU(162)=MINT(22)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYFRAM
	+C...Performs transformations between different coordinate frames.
	+
	+ SUBROUTINE PYFRAM(IFRAME)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYDAT1/,/PYPARS/,/PYINT1/
	+
	+C...Check that transformation can and should be done.
	+ IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
	+ &MINT(91).EQ.1)) THEN
	+ IF(IFRAME.EQ.MINT(6)) RETURN
	+ ELSE
	+ WRITE(MSTU(11),5000) IFRAME,MINT(6)
	+ RETURN
	+ ENDIF
	+
	+ IF(MINT(6).EQ.1) THEN
	+C...Transform from fixed target or user specified frame to
	+C...overall CM frame.
	+ CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
	+ CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
	+ CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
	+ ELSEIF(MINT(6).EQ.3) THEN
	+C...Transform from hadronic CM frame in DIS to overall CM frame.
	+ CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
	+ & -VINT(225))
	+ ENDIF
	+
	+ IF(IFRAME.EQ.1) THEN
	+C...Transform from overall CM frame to fixed target or user specified
	+C...frame.
	+ CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
	+ ELSEIF(IFRAME.EQ.3) THEN
	+C...Transform from overall CM frame to hadronic CM frame in DIS.
	+ CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
	+ CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
	+ CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
	+ ENDIF
	+
	+C...Set information about new frame.
	+ MINT(6)=IFRAME
	+ MSTI(6)=IFRAME
	+
	+ 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
	+ &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
	+ &1X,I5)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYWIDT
	+C...Calculates full and partial widths of resonances.
	+
	+ SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
	+ &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
	+ COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	+ COMMON/PYPUED/IUED(0:99),RUED(0:99)
	+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
	+ &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
	+C...Local arrays and saved variables.
	+ COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
	+ DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
	+ &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
	+C...UED: equivalences between ordered particles (451->475)
	+C...and UED particle code (5 000 000 + id)
	+ PARAMETER(KKFLMI=451,KKFLMA=475)
	+ DIMENSION CHIDEL(3), IUEDPR(25)
	+ DIMENSION IUEDEQ(KKFLMA),MUED(2)
	+ COMMON/SW1/SW21,CW21
	+ DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
	+ & 6100001,6100002,6100003,6100004,6100005,6100006,
	+ & 5100001,5100002,5100003,5100004,5100005,5100006,
	+ & 6100011,6100013,6100015,
	+ & 5100012,5100011,5100014,5100013,5100016,5100015,
	+ & 5100021,5100022,5100023,5100024/
	+C...Save local variables
	+ SAVE MOFSV,WIDWSV,WID2SV
	+C...Initial values
	+ DATA MOFSV/60/,WIDWSV/60D0/,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.-X2/Y2
	+ FKAC2(X,Y)=2.+X2/Y2
	+
	+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-PM12-PM22)*2-
	+ & 4D0PM12PM2**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-4D0PMANPMBCN)
	+ & ((PMBCN-PMBN-PMCN)*2-4D0PMBNPMCN)))
	+ & ((SHR-PMA)2-(PMB+PMC)2)*
	+ & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
	+ & ((1D0-PMBCN)PMBCNSH)
	+ ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
	+ WDTP(I)=WDTP(I)*SQRT(
	+ & MAX(0D0,(SH-PM12-PM22)*2-4D0PM1*2PM2**2)/
	+ & MAX(1D-4,(PMR2-PM12-PM22)2-4D0PM12PM2**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-4D0PMANPMBCN)
	+ & ((PMBCN-PMBN-PMCN)*2-4D0PMBNPMCN)))
	+ & ((SHR-PMA)2-(PMB+PMC)2)*
	+ & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
	+ & ((1D0-PMBCN)PMBCNSH)
	+ PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
	+ PMAN=PMA2/PMR2
	+ PMBN=PMB2/PMR2
	+ PMCN=PMC2/PMR2
	+ PMBCN=PMBC2/PMR2
	+ FACNOM=SQRT(MAX(0D0,
	+ & ((1D0-PMAN-PMBCN)*2-4D0PMANPMBCN)
	+ & ((PMBCN-PMBN-PMCN)*2-4D0PMBNPMCN)))
	+ & ((PMR-PMA)2-(PMB+PMC)2)*
	+ & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
	+ & ((1D0-PMBCN)PMBCNPMR**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.
	+C...PS: bug fix 16/2 2012 to avoid problems caused by adding 0.0*NaN
	+ IF (WDTP(I).GT.0D0) 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)
	+ ELSE
	+ WDTE(I,MDME(IDC,1))= 0D0
	+ WDTE(I,0)= 0D0
	+ ENDIF
	+ 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)*2XW/PARU(1)
	+ AS=PYALPS(SH)
	+ RADC=1D0+AS/PARU(1)
	+
	+ IF(KFLA.EQ.6) THEN
	+C...t quark.
	+ FAC=(AEM/(16D0XW))(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)=FACVCKM(3,I-3)RADCT*
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	+ & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0+RM2-RM1)(RM2RPARU(141)2+1D0/PARU(141)2)+
	+ & 4D0SQRT(RM2RRM2))
	+ 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=SHRDCONJG(ZMIXC(IZ,4))/(2.0D0PMAS(24,1)*SINB)
	+ AR=-ETZMIXC(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))/(2D0SHR)
	+ WDTP(I)=(0.5D0PYALEM(SH)/PARU(102))PCM*
	+ & ((ABS(FL)2+ABS(FR)2)(SH+PMNCHI2-PMSTOP*2)+
	+ & SMZ(IZ)4D0SHRDBLE(FLDCONJG(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))/(2D0SHR)
	+ WDTP(I)=4D0/3D00.5D0PYALPS(SH)PCM((RL2+RR2)*
	+ & (SH+PMNCHI2-PMSTOP2)+PMNCHI4D0SHRRLRR)/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*2SHR/(96D0PARU(1)XMP2XMGR2)(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/(16D0XW))(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)=FACVCKM(I-3,4)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	+ & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0+RM2-RM1)(PARU(141)2+RM2/PARU(141)2)+4D0RM2)
	+ 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/(16D0XW))(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)=FACVCKM(4,I-3)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	+ & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0+RM2-RM1)(RM2PARU(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/(16D0XW))(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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0+RM2-RM1)(PARU(141)2+RM2/PARU(141)2)+4D0RM2)
	+ 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/(16D0XW))(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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0-RM2)*2+(1D0+RM2)RM1-2D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0+RM2-RM1)(RM2PARU(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+2D0RM1)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=FCOFPYHFTH(SH,SHRM1,1D0)
	+ WDTP(I)=FCOFEF2(1D0+2D0RM1)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+2D0RM1)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/(16D0XWXW1)
	+ FAC=(AEMXWC/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-4D0EIXWV
	+ 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)=
	+ & 2D0XWCSH(SH-SQMZ)/((SH-SQMZ)2+HZ*2)
	+ IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
	+ & XWC*2SH2/((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-4D0EFXWV
	+ FCOF=3D0*RADC
	+ IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOFPYHFTH(SH,SHRM1,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-4D0EFXWV
	+ 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)=FACFCOF(VF*2(1D0+2D0RM1)+AF2(1D0-4D0RM1))
	+ & BE34
	+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	+ WDTP(I)=FACFCOF((EI*2VINT(111)EF2+EIVIVINT(112)
	+ & EFVF+(VI2+AI2)VINT(114)VF2)(1D0+2D0*RM1)+
	+ & (VI2+AI2)VINT(114)AF*2(1D0-4D0RM1))BE34
	+ ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
	+ FGGF=FCOFEF2(1D0+2D0RM1)BE34
	+ FGZF=FCOFEFVF(1D0+2D0RM1)*BE34
	+ FZZF=FCOF(VF2(1D0+2D0RM1)+AF2(1D0-4D0RM1))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/(24D0XW))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=3D0RADCVCKM((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)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(8D0XW))(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)=FAC3D0(PYMRUN(KFDP(IDC,1),SH)*2/SHFS)
	+ & SQRT(MAX(0D0,1D0-4D0RM1))RADC
	+C...A0 behaves like beta, ho and H0 like beta**3.
	+ IF(IHIGG.NE.3) WDTP(I)=WDTP(I)(1D0-4D0RM1)
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
	+ IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)PARU(151+10IHIGG)**2
	+ IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)PARU(152+10IHIGG)**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+10IHIGG))*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)=FACRM1SQRT(MAX(0D0,1D0-4D0RM1))(SH/SHFS)
	+C...A0 behaves like beta, ho and H0 like beta**3.
	+ IF(IHIGG.NE.3) WDTP(I)=WDTP(I)(1D0-4D0RM1)
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
	+ & PARU(153+10IHIGG)*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=(2D0PMAS(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(RLN2-PARU(1)*2)
	+ PHIIM=0.5D0PARU(1)RLN
	+ ELSE
	+ PHIRE=(ASIN(1D0/SQRT(EPS)))**2
	+ PHIIM=0D0
	+ ENDIF
	+ IF(IHIGG.LE.2) THEN
	+ ETAREJ=-0.5D0EPS(1D0+(1D0-EPS)*PHIRE)
	+ ETAIMJ=-0.5D0EPS(1D0-EPS)*PHIIM
	+ ELSE
	+ ETAREJ=-0.5D0EPSPHIRE
	+ ETAIMJ=-0.5D0EPSPHIIM
	+ 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=ETAREJPARU(151+10IHIGG)
	+ ETAIMJ=ETAIMJPARU(151+10IHIGG)
	+ ELSE
	+ ETAREJ=ETAREJPARU(152+10IHIGG)
	+ ETAIMJ=ETAIMJPARU(152+10IHIGG)
	+ ENDIF
	+ ENDIF
	+ ETARE=ETARE+ETAREJ
	+ ETAIM=ETAIM+ETAIMJ
	+ 240 CONTINUE
	+ ETA2=ETARE2+ETAIM2
	+ WDTP(I)=FAC(AS/PARU(1))2ETA2
	+
	+ 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=(2D0PMAS(J,1))*2/SH
	+ ELSEIF(J.LE.3*MSTP(1)) THEN
	+ JL=2(J-2MSTP(1))-1
	+ EJ=KCHG(10+JL,1)/3D0
	+ EPS=(2D0PMAS(10+JL,1))*2/SH
	+ ELSEIF(J.EQ.3*MSTP(1)+1) THEN
	+ EPS=(2D0PMAS(24,1))*2/SH
	+ ELSE
	+ EPS=(2D0PMAS(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(RLN2-PARU(1)*2)
	+ PHIIM=0.5D0PARU(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.5D0EPS(1D0+(1D0-EPS)*PHIRE)
	+ PHIPIM=-0.5D0EPS(1D0-EPS)*PHIIM
	+ ELSE
	+ PHIPRE=-0.5D0EPSPHIRE
	+ PHIPIM=-0.5D0EPSPHIIM
	+ ENDIF
	+ IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
	+ EJC=3D0EJ*2
	+ EJH=PARU(151+10*IHIGG)
	+ ELSEIF(J.LE.2*MSTP(1)) THEN
	+ EJC=3D0EJ*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=EJCEJHPHIPRE
	+ ETAIMJ=EJCEJHPHIPIM
	+ ELSEIF(J.EQ.3*MSTP(1)+1) THEN
	+C...W loops: loop integral and charges.
	+ ETAREJ=0.5D0+0.75D0EPS(1D0+(2D0-EPS)*PHIRE)
	+ ETAIMJ=0.75D0EPS(2D0-EPS)*PHIIM
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
	+ ETAREJ=ETAREJPARU(155+10IHIGG)
	+ ETAIMJ=ETAIMJPARU(155+10IHIGG)
	+ ENDIF
	+ ELSE
	+C...Charged H loops: loop integral and charges.
	+ FACHHH=(PMAS(24,1)/PMAS(37,1))*2
	+ & PARU(158+10IHIGG+2(IHIGG/3))
	+ ETAREJ=EPS(1D0-EPSPHIRE)*FACHHH
	+ ETAIMJ=-EPS*2PHIIM*FACHHH
	+ ENDIF
	+ ETARE=ETARE+ETAREJ
	+ ETAIM=ETAIM+ETAIMJ
	+ 250 CONTINUE
	+ ETA2=ETARE2+ETAIM2
	+ WDTP(I)=FAC(AEM/PARU(1))20.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-4D0EJXWV
	+ EPS=(2D0PMAS(J,1))*2/SH
	+ EPSP=(2D0PMAS(J,1)/PMAS(23,1))*2
	+ ELSEIF(J.LE.3*MSTP(1)) THEN
	+ JL=2(J-2MSTP(1))-1
	+ EJ=KCHG(10+JL,1)/3D0
	+ AJ=SIGN(1D0,EJ+0.1D0)
	+ VJ=AJ-4D0EJXWV
	+ EPS=(2D0PMAS(10+JL,1))*2/SH
	+ EPSP=(2D0PMAS(10+JL,1)/PMAS(23,1))*2
	+ ELSE
	+ EPS=(2D0PMAS(24,1))*2/SH
	+ EPSP=(2D0PMAS(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(RLN2-PARU(1)*2)
	+ PHIIM=0.5D0PARU(1)RLN
	+ PSIRE=0.5D0ROOTRLN
	+ PSIIM=-0.5D0ROOTPARU(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(RLN2-PARU(1)*2)
	+ PHIIMP=0.5D0PARU(1)RLN
	+ PSIREP=0.5D0ROOTRLN
	+ PSIIMP=-0.5D0ROOTPARU(1)
	+ ELSE
	+ PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
	+ PHIIMP=0D0
	+ PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
	+ PSIIMP=0D0
	+ ENDIF
	+ FXYRE=EPSEPSP/(8D0(EPS-EPSP))(1D0+EPSEPSP/(EPS-EPSP)*
	+ & (PHIRE-PHIREP)+2D0EPS/(EPS-EPSP)(PSIRE-PSIREP))
	+ FXYIM=EPS*2EPSP/(8D0(EPS-EPSP)2)
	+ & (EPSP(PHIIM-PHIIMP)+2D0(PSIIM-PSIIMP))
	+ F1RE=-EPSEPSP/(2D0(EPS-EPSP))*(PHIRE-PHIREP)
	+ F1IM=-EPSEPSP/(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=-3D0EJVJ
	+ EJH=PARU(151+10*IHIGG)
	+ ELSEIF(J.LE.2*MSTP(1)) THEN
	+ EJC=-3D0EJVJ
	+ 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=EJCEJH(FXYRE-0.25D0*F1RE)
	+ ETAIMJ=EJCEJH(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=ETAREJPARU(155+10IHIGG)
	+ ETAIMJ=ETAIMJPARU(155+10IHIGG)
	+ ENDIF
	+ ELSE
	+C...Charged H loops: loop integral and charges.
	+ FACHHH=(PMAS(24,1)/PMAS(37,1))*2(1D0-2D0XW)
	+ & PARU(158+10IHIGG+2(IHIGG/3))
	+ ETAREJ=FACHHH*FXYRE
	+ ETAIMJ=FACHHH*FXYIM
	+ ENDIF
	+ ETARE=ETARE+ETAREJ
	+ ETAIM=ETAIM+ETAIMJ
	+ 260 CONTINUE
	+ ETA2=(ETARE2+ETAIM2)/(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+10D0PG1)**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-4D0RM1+12D0RM1*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-4D0RM1+12D0RM1*2)SQRT(MAX(0D0,
	+ & 1D0-4D0*RM1))
	+ WID2=1D0
	+ ELSE
	+ WIDW=WIDWSV(IHIGG,I-15)
	+ WID2=WID2SV(IHIGG,I-15)
	+ ENDIF
	+ ENDIF
	+ WDTP(I)=FACWIDW/(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+10IHIGG)*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)=FAC0.5D0SQRT(MAX(0D0,
	+ & (1D0-RM1-RM2)*2-4D0RM1RM2))*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)=FAC0.25D0
	+ & PMAS(23,1)4/SH2SQRT(MAX(0D0,1D0-4D0RM1))
	+ 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)=FAC0.5D0SQRT(MAX(0D0,
	+ & (1D0-RM1-RM2)*2-4D0RM1RM2))*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)=FAC0.5D0PARU(187)*2SQRT(MAX(0D0,
	+ & (1D0-RM1-RM2)*2-4D0RM1RM2))*3
	+ WID2=WIDS(36,2)*WIDS(23,2)
	+
	+ ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
	+C...H0 -> h0 + A0.
	+ WDTP(I)=FAC0.5D0PARU(180)*2
	+ & PMAS(23,1)4/SH2SQRT(MAX(0D0,1D0-4D0RM1))
	+ WID2=WIDS(25,2)*WIDS(36,2)
	+
	+ ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
	+C...H0 -> A0 + A0
	+ WDTP(I)=FAC0.25D0PARU(177)*2
	+ & PMAS(23,1)4/SH2SQRT(MAX(0D0,1D0-4D0RM1))
	+ WID2=WIDS(36,1)
	+
	+CMRENNA++
	+ ELSE
	+C...Add in SUSY decays (two-body) by rescaling by phase space factor.
	+ RM10=RM1SH/PMR*2
	+ RM20=RM2SH/PMR*2
	+ WFAC0=1D0+RM102+RM202-2D0(RM10+RM20+RM10RM20)
	+ WFAC=1D0+RM12+RM22-2D0(RM1+RM2+RM1RM2)
	+ 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/(16D0XWXW1)
	+ FAC=(AEMXWC/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-4D0EIXWV
	+ 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)=
	+ & 2D0XWCSH(SH-SQMZ)/((SH-SQMZ)2+HZ*2)
	+ IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
	+ & 2D0XWCSH(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*2SH2/((SH-SQMZ)2+HZ**2)
	+ IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
	+ & 2D0XWC2SH*2((SH-SQMZ)(SH-SQMZP)+HZHZP)/
	+ & (((SH-SQMZ)2+HZ2)((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*2SH2/((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-4D0EFXWV
	+ 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-4D0EFXWV
	+ 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(VF2(1D0+2D0RM1)+AF2(1D0-4D0RM1))BE34
	+ WDTP(I)=FACFCOF(VPF*2(1D0+2D0*RM1)+
	+ & APF*2(1D0-4D0RM1))BE34
	+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	+ WDTP(I)=FACFCOF((EI*2VINT(111)EF2+EIVIVINT(112)
	+ & EFVF+EIVPIVINT(113)EFVPF+(VI2+AI2)VINT(114)*
	+ & VF*2+(VIVPI+AIAPI)VINT(115)VFVPF+(VPI2+API2)*
	+ & VINT(116)VPF2)(1D0+2D0RM1)+((VI2+AI2)VINT(114)*
	+ & AF*2+(VIVPI+AIAPI)VINT(115)AFAPF+(VPI2+API2)*
	+ & VINT(116)APF2)(1D0-4D0RM1))BE34
	+ ELSEIF(MINT(61).EQ.2) THEN
	+ FGGF=FCOFEF2(1D0+2D0RM1)BE34
	+ FGZF=FCOFEFVF(1D0+2D0RM1)*BE34
	+ FGZPF=FCOFEFVPF(1D0+2D0RM1)*BE34
	+ FZZF=FCOF(VF2(1D0+2D0RM1)+AF2(1D0-4D0RM1))BE34
	+ FZZPF=FCOF(VFVPF(1D0+2D0RM1)+AFAPF(1D0-4D0RM1))
	+ & BE34
	+ FZPZPF=FCOF(VPF2(1D0+2D0RM1)+APF2(1D0-4D0RM1))
	+ & BE34
	+ ENDIF
	+ ELSEIF(I.EQ.17) THEN
	+C...Z'0 -> W+ + W-
	+ WDTPZP=PARU(129)*2XW1*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))3
	+ & (1D0+10D0RM1+10D0RM2+RM12+RM22+10D0RM1RM2)
	+ IF(ICASE.EQ.1) THEN
	+ WDTPZ=0D0
	+ WDTP(I)=FAC*WDTPZP
	+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	+ WDTP(I)=FAC(VPI2+API2)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-2D0XW)
	+ BE34C=(1D0-4D0RM1)SQRT(MAX(0D0,1D0-4D0*RM1))
	+ IF(ICASE.EQ.1) THEN
	+ WDTPZ=0.25D0PARU(142)2CZC*2BE34C
	+ WDTP(I)=FAC0.25D0PARU(143)*2CZC*2BE34C
	+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	+ WDTP(I)=FAC0.25D0(EI*2VINT(111)+PARU(142)EIVI*
	+ & VINT(112)CZC+PARU(143)EIVPIVINT(113)CZC+PARU(142)2
	+ & (VI2+AI2)VINT(114)CZC*2+PARU(142)PARU(143)*
	+ & (VIVPI+AIAPI)VINT(115)CZC2+PARU(143)2*
	+ & (VPI2+API2)VINT(116)CZC*2)BE34C
	+ ELSEIF(MINT(61).EQ.2) THEN
	+ FGGF=0.25D0*BE34C
	+ FGZF=0.25D0PARU(142)CZC*BE34C
	+ FGZPF=0.25D0PARU(143)CZC*BE34C
	+ FZZF=0.25D0PARU(142)2CZC*2BE34C
	+ FZZPF=0.25D0PARU(142)PARU(143)CZC2BE34C
	+ FZPZPF=0.25D0PARU(143)2CZC*2BE34C
	+ 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-4D0RM1*RM2))
	+ WDTPZP=PARU(145)*24D0ABS(1D0-2D0XW)*
	+ & (3D0RM1+0.25D0FLAM*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(VPI2+API2)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-4D0RM1RM2))*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*2BE34C
	+ WDTP(I)=FACCZPAH2BE34C
	+ ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
	+ WDTP(I)=FAC(CZAH2(VI2+AI2)VINT(114)+CZAHCZPAH*
	+ & (VIVPI+AIAPI)VINT(115)+CZPAH2(VPI2+API2)*
	+ & VINT(116))*BE34C
	+ ELSEIF(MINT(61).EQ.2) THEN
	+ FGGF=0D0
	+ FGZF=0D0
	+ FGZPF=0D0
	+ FZZF=CZAH*2BE34C
	+ FZZPF=CZAHCZPAHBE34C
	+ FZPZPF=CZPAH*2BE34C
	+ 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/(24D0XW))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=3D0CKMFACRADC(PARU(131)2+PARU(132)*2)
	+ FCOF2=3D0CKMFACRADC(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)=FAC0.5FCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	+ IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
	+C...PS 28/06/2010
	+C...Inserted (gV2-gA2)sqrt(m1m2) term (FCOF2), following M. Chizhov
	+ WDTP(I)=WDTP(I) + FAC0.56D0FCOF2SQRT(RM1*RM2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	+ ENDIF
	+ ELSEIF(I.EQ.21) THEN
	+C...W'+/- -> W+/- + Z0
	+ WDTP(I)=FACPARU(135)20.5D0XW1(RM1/RM2)*
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))3
	+ & (1D0+10D0RM1+10D0RM2+RM12+RM22+10D0RM1RM2)
	+ 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-4D0RM1*RM2))
	+ WDTP(I)=FACPARU(146)22D0(3D0RM1+0.25D0FLAM2)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/(8D0XW))(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)=FAC3D0RADCMAX(0D0,(RM1RPARU(141)**2+
	+ & RM2R/PARU(141)*2)(1D0-RM1R-RM2R)-4D0RM1RRM2R)*
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))(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((RM1PARU(141)2+RM2/PARU(141)2)*
	+ & (1D0-RM1-RM2)-4D0RM1RM2)*SQRT(MAX(0D0,
	+ & (1D0-RM1-RM2)*2-4D0RM1RM2))(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)=FACPARU(195)20.5D0*SQRT(MAX(0D0,
	+ & (1D0-RM1-RM2)*2-4D0RM1RM2))*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=RM1SH/PMR*2
	+ RM20=RM2SH/PMR*2
	+ WFAC0=1D0+RM102+RM202-2D0(RM10+RM20+RM10RM20)
	+ WFAC=1D0+RM12+RM22-2D0(RM1+RM2+RM1RM2)
	+ 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/(12D0XW))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)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)=FACSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))*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.25ALPHEMRMFLAS0.5CW21/CW2KCHG(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)=FACFKAC2(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.25ALPHEMRMFLAS/(4.*SW2)
	+ GAMMAW=FACFKAC2(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)=FACFKAC2(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)=FACFKAC1(RMQST,RMFLAS)2FKAC2(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./SW2RMZKK
	+ RMLST=PMAS(KKPART,1)
	+ WDTP(I)=FACFKAC1(RMLST,RMZKK)2FKAC2(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./SW2RMWKK
	+ RMLST=PMAS(KKPART,1)
	+ WDTP(I)=FACFKAC1(RMLST,RMWKK)2FKAC2(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/(32D0PARU(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/(4D0PARU(1))ITCM(1)/RTCM(1))**2
	+ & /(8D0PARU(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=FCOFRTCM(1+IKA)*2
	+ HM1=PYMRUN(KFDP(IDC,1),SH)
	+ HM2=PYMRUN(KFDP(IDC,2),SH)
	+ ELSEIF(IKA.EQ.15) THEN
	+ FCOF=FCOFRTCM(8)*2
	+ ENDIF
	+ WDTP(I)=FACFCOF(HM1+HM2)*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(32D0PARU(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/(4D0PARU(1))FCOFXMT2RTCM(7)**2
	+ KFC3=PYCOMP(KFDP(IDC,3))
	+ CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
	+ CHECK = SQRT(RM1)
	+ T0 = (1D0-CHECK*2)
	+ & (XMT2(6D0XMT2*2+3D0XMT2RM1-4D0RM1**2)-
	+ & (5D0XMT22+2D0XMT2RM1-8D0RM1*2))/(4D0XMT2**2)
	+ T1 = (1D0-XMT2)(RM1-XMT2)((XMT2*2+XMT2RM1+4D0RM1*2)
	+ & -3D0XMT22(XMT2+RM1))/(2D0XMT2*3)
	+ T3 = RM12/XMT23(3D0XMT2-4D0RM1+4D0XMT2*RM1)
	+ WDTP(I)=FACP(T0 + T1LOG((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=FCOFRTCM(5)*2
	+ ELSEIF(I.LE.4) THEN
	+ FCOF=FCOFRTCM(6)*2
	+ ELSEIF(I.EQ.5) THEN
	+ FCOF=FCOFRTCM(7)*2
	+ ENDIF
	+ HM1=PYMRUN(KFDP(IDC,1),SH)
	+ HM2=PYMRUN(KFDP(IDC,2),SH)
	+ ELSEIF(I.EQ.8) THEN
	+ FCOF=FCOFRTCM(8)*2
	+ ENDIF
	+ WDTP(I)=FACFCOF(HM1+HM2)*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)=FACRM1SQRT(MAX(0D0,1D0-4D0RM1))/(4D0PARU(1))
	+ IF(I.EQ.2) WID2=WIDS(6,1)
	+ ELSE
	+ WDTP(I)=FAC5D0AS*2/(96D0PARU(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)(AEM2/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-2D0XW)/(4D0XW*(1D0-XW))
	+ BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	+ BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ 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)=FACRTCM(3)4
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	+ & 2D0AEMSQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))
	+ & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0SQMW/SH)*
	+ & RTCM(3)2/4D0/XW/24D0/RTCM(13)2SHR*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)=FACRTCM(3)2(1D0-RTCM(3)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	+ & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0RM1)*
	+ & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(13)2SHR*3
	+ WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
	+ ELSEIF(I.EQ.3) THEN
	+C...rho_tc0 -> pi_tc+ + W-.
	+ WDTP(I)=FACRTCM(3)2(1D0-RTCM(3)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	+ & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0RM2)*
	+ & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(13)2SHR*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-4D0RM1RM2))*3
	+ WID2=WIDS(PYCOMP(KTECHN+211),1)
	+ ELSEIF(I.EQ.5) THEN
	+C...rho_tc0 -> gamma + pi_tc0
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (1D0-RTCM(4)2)/24D0/RTCM(12)2SHR*3
	+ WID2=WIDS(PYCOMP(KTECHN+221),2)
	+ ELSEIF(I.EQ.7) THEN
	+C...rho_tc0 -> Z0 + pi_tc0
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(2)-1D0)2(1D0-RTCM(3)2)/24D0/RTCM(12)2*
	+ & XW/XW1SHR*3
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
	+ ELSEIF(I.EQ.8) THEN
	+C...rho_tc0 -> Z0 + pi_tc0'
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (1D0-RTCM(4)2)/24D0/RTCM(12)2(1D0-2D0XW)**2/4D0/
	+ & XW/XW1SHR*3
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
	+ ELSEIF(I.EQ.9) THEN
	+C...rho_tc0 -> gamma + Z0
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(2)-1D0)2RTCM(3)2/24D0/RTCM(12)2SHR*3
	+ WID2=WIDS(23,2)
	+ ELSEIF(I.EQ.10) THEN
	+C...rho_tc0 -> Z0 + Z0
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(2)-1D0)2RTCM(3)*2XW/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-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ WDTP(I)=FACFFCOFSQRT(MAX(0D0,1D0-4D0RM1))((1D0-RM1)*
	+ & ((EI+VALIBWZR)2+(VALIBWZI)**2+
	+ & (EI+VARIBWZR)2+(VARIBWZI)*2)+6D0RM1*(
	+ & (EI+VALIBWZR)(EI+VARIBWZR)+VALIVARIBWZI*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)(AEM2/ALPRHT)SHR*
	+ & (0.125D0/XW*2)SH2/((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=.5D0SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	+c WDTP(I)=AEMPCM(AA2(PCM2+1.5D0RM1)+PCM*2VA2)
	+c & /3D0SHR*3
	+ IF(I.EQ.1) THEN
	+C...rho_tc+ -> W+ + Z0.
	+C......Goldstone
	+ WDTP(I)=FACRTCM(3)4
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3
	+ VA2=RTCM(3)*2(2D0RTCM(2)-1D0)2XW/XW1/RTCM(12)**2
	+ AA2=RTCM(3)2/RTCM(13)2/4D0/XW/XW1
	+C......W_L Z_T
	+ WDTP(I)=WDTP(I)+AEMPCM(AA2(PCM2+1.5D0RM2)+PCM*2VA2)
	+ & /3D0SHR*3
	+ VA2=0D0
	+ AA2=RTCM(3)2/RTCM(13)2/4D0/XW
	+C......W_T Z_L
	+ WDTP(I)=WDTP(I)+AEMPCM(AA2(PCM2+1.5D0RM1)+PCM*2VA2)
	+ & /3D0SHR*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)=FACRTCM(3)2(1D0-RTCM(3)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	+ & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0SQMW/SH)*
	+ & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(13)2SHR*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)=FACRTCM(3)2(1D0-RTCM(3)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	+ & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))
	+ & ((1D0-RM1-RM2)*2-4D0RM1RM2 + 6D0SQMZ/SH)*
	+ & (1D0-RTCM(3)2)/4D0/XW/XW1/24D0/RTCM(13)2SHR*3+
	+ & AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(2)-1D0)2(1D0-RTCM(3)2)/24D0/RTCM(12)2*
	+ & SHR*3XW/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-4D0RM1RM2))*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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (1D0-RTCM(4)2)/4D0/XW/24D0/RTCM(12)2SHR*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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(2)-1D0)2RTCM(3)2/24D0/RTCM(12)2SHR*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=3D0RADCVCKM((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)=FACFFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)(AEM2/ALPRHT)SHR(2D0RTCM(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+GMMZ2)
	+ BWZI=-(0.5D0/(1D0-XW))SHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ 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-4D0RM1RM2))3SHR**3
	+ WID2=WIDS(PYCOMP(KTECHN+111),2)
	+ ELSEIF(I.EQ.2) THEN
	+C...omega_tc0 -> Z0 + pi_tc0
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (1D0-RTCM(3)2)/24D0/RTCM(12)2(1D0-2D0XW)**2/4D0/
	+ & XW/XW1SHR*3
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
	+ ELSEIF(I.EQ.3) THEN
	+C...omega_tc0 -> gamma + pi_tc0'
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(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)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (2D0RTCM(2)-1D0)2(1D0-RTCM(4)2)/24D0/RTCM(12)2*
	+ & XW/XW1SHR*3
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
	+ ELSEIF(I.EQ.5) THEN
	+C...omega_tc0 -> W+ + pi_tc-
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(12)2SHR*3+
	+ & FACRTCM(3)2(1D0-RTCM(3)*2)RTCM(11)*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3
	+ WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
	+ ELSEIF(I.EQ.6) THEN
	+C...omega_tc0 -> pi_tc+ + W-
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & (1D0-RTCM(3)2)/4D0/XW/24D0/RTCM(12)2SHR*3+
	+ & FACRTCM(3)2(1D0-RTCM(3)*2)RTCM(11)*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*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)=FACRTCM(3)4RTCM(11)*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3+
	+ & 2D0AEMSQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))3
	+ & RTCM(3)2/4D0/XW/24D0/RTCM(12)2SHR*3
	+ WID2=WIDS(24,1)
	+ ELSEIF(I.EQ.8) THEN
	+C...omega_tc0 -> pi_tc+ + pi_tc-.
	+ WDTP(I)=FAC(1D0-RTCM(3)2)2RTCM(11)*2
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1RM2))*3
	+ WID2=WIDS(PYCOMP(KTECHN+211),1)
	+C...omega_tc0 -> gamma + Z0
	+ ELSEIF(I.EQ.9) THEN
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & RTCM(3)2/24D0/RTCM(12)2SHR*3
	+ WID2=WIDS(23,2)
	+C...omega_tc0 -> Z0 + Z0
	+ ELSEIF(I.EQ.10) THEN
	+ WDTP(I)=AEMSQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1RM2))3
	+ & RTCM(3)*2(XW1-XW)**2/XW/XW1/4D0
	+ & /24D0/RTCM(12)*2SHR**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-4D0EIXWV
	+ VALI=-0.5D0*(VI+AI)
	+ VARI=-0.5D0*(VI-AI)
	+ WDTP(I)=FACFFCOFSQRT(MAX(0D0,1D0-4D0RM1))((1D0-RM1)*
	+ & ((EI+VALIBWZR)2+(VALIBWZI)**2+
	+ & (EI+VARIBWZR)2+(VARIBWZI)*2)+6D0RM1*(
	+ & (EI+VALIBWZR)(EI+VARIBWZR)+VALIVARIBWZI*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+2D0RM1)SQRT(1D0-4D0RM1)*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/(4D0PARU(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/(8D0PARU(1))ITCM(1)/RTCM(1))**2
	+ & /(2D0PARU(1))SHSHRCLEBG
	+ 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)=FACFCOFHM1*2CLEBF*
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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=2D0TANT3/(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-RMV82)/((SH-RMV82)2+GMV8*2)
	+ FV8IM=SHGMV8/((SH-RMV82)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+FMIXXIJFV8RE)*2+(FMIXXIJFV8IM)*2
	+ WDTP(I)=FAC(1D0+2D0RM1)SQRT(1D0-4D0RM1)AS/ALPRHTXFAC
	+ ELSEIF(I.EQ.7) THEN
	+ WDTP(I)=SHRAS2/(4D0ALPRHT)
	+ ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
	+ PSH=SHR*(1D0-RM1)/2D0
	+ WDTP(I)=AS/9D0PSH*3/RM82
	+ IF(I.EQ.8) THEN
	+ WDTP(I)=2D0WDTP(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)=FACASRTCM(45)**2/3D0
	+ WID2=1D0
	+ ELSEIF(I.EQ.2) THEN
	+C...d* -> gamma + d.
	+ QF=-RTCM(43)/2D0+RTCM(44)/6D0
	+ WDTP(I)=FACAEMQF**2/4D0
	+ WID2=1D0
	+ ELSEIF(I.EQ.3) THEN
	+C...d* -> Z0 + d.
	+ QF=-RTCM(43)XW1/2D0-RTCM(44)XW/6D0
	+ WDTP(I)=FACAEMQF*2/(8D0XWXW1)
	+ & (1D0-RM1)*2(2D0+RM1)
	+ WID2=WIDS(23,2)
	+ ELSEIF(I.EQ.4) THEN
	+C...d* -> W- + u.
	+ WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	+ & (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)=FACASRTCM(45)**2/3D0
	+ WID2=1D0
	+ ELSEIF(I.EQ.2) THEN
	+C...u* -> gamma + u.
	+ QF=RTCM(43)/2D0+RTCM(44)/6D0
	+ WDTP(I)=FACAEMQF**2/4D0
	+ WID2=1D0
	+ ELSEIF(I.EQ.3) THEN
	+C...u* -> Z0 + u.
	+ QF=RTCM(43)XW1/2D0-RTCM(44)XW/6D0
	+ WDTP(I)=FACAEMQF*2/(8D0XWXW1)
	+ & (1D0-RM1)*2(2D0+RM1)
	+ WID2=WIDS(23,2)
	+ ELSEIF(I.EQ.4) THEN
	+C...u* -> W+ + d.
	+ WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	+ & (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)=FACAEMQF**2/4D0
	+ WID2=1D0
	+ ELSEIF(I.EQ.2) THEN
	+C...e* -> Z0 + e.
	+ QF=-RTCM(43)XW1/2D0+RTCM(44)XW/2D0
	+ WDTP(I)=FACAEMQF*2/(8D0XWXW1)
	+ & (1D0-RM1)*2(2D0+RM1)
	+ WID2=WIDS(23,2)
	+ ELSEIF(I.EQ.3) THEN
	+C...e* -> W- + nu.
	+ WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	+ & (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)=FACAEMQF*2/(8D0XWXW1)
	+ & (1D0-RM1)*2(2D0+RM1)
	+ WID2=WIDS(23,2)
	+ ELSEIF(I.EQ.2) THEN
	+C...nu*_e -> W+ + e.
	+ WDTP(I)=FACAEMRTCM(43)*2/(16D0XW)*
	+ & (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)=FACFCOFSQRT(MAX(0D0,1D0-4D0RM1))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)=FACSQRT(MAX(0D0,1D0-4D0RM1))*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)=FACSQRT(MAX(0D0,1D0-4D0RM1))*(13D0/12D0+
	+ & 14D0RM1/3D0+4D0RM1**2)/160D0
	+ WID2=WIDS(23,1)
	+ ELSEIF(I.EQ.20) THEN
	+C...G* -> W+ + W-.
	+ WDTP(I)=FACSQRT(MAX(0D0,1D0-4D0RM1))*(13D0/12D0+
	+ & 14D0RM1/3D0+4D0RM1**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/(768D0PARU(1)XW2))SHR5/PMWR4
	+ 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=3D0RADCVCKM((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=3D0RADCVCKM((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-8D0X2+8D0X6-X8-24D0X4LOG(X)
	+ Y=(SHR/PMWR)**2
	+ FY=(12D0(1D0-Y)LOG(1D0-Y)+12D0Y-6D0Y*2-2D0Y3)/Y4
	+ WDTP(I)=FACFCOFFX*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/(48D0XWXW1(1D0-2D0XW)))*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-2D0XW)
	+ VF=SIGN(1D0,EF+0.1D0)-4D0EFXW
	+ 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)=FACFCOF(VF*2(1D0+2D0RM1)+AF2(1D0-4D0RM1))
	+ & SQRT(MAX(0D0,1D0-4D0RM1))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/(24D0XW))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=3D0RADCVCKM((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)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(8D0PARU(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.5D0PARP(190)4PARP(192)2/PMAS(24,1)2*
	+ & (3D0*RM1+0.25D0/RM1-1D0)
	+ WID2=WIDS(24,4+(1-KFLS)/2)
	+ ENDIF
	+ WDTP(I)=FACFCOF
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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/(8D0PARU(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)=FACFCOF
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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)(AEM2/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/(4D0XW(1D0-XW))
	+ BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	+ BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ 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=.5D0SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*RM2))
	+ IF(I.LE.4) THEN
	+ FACPV=PCM**2
	+ FACPA=PCM*2+1.5D0RM1
	+ VA2=0D0
	+ AA2=0D0
	+C...a2_tc0 -> W+ + W-
	+ IF(I.EQ.1) THEN
	+ AA2=2D0RTCM(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)=AEMSHR3PCM/3D0(VA2FACPV+AA2*FACPA)
	+ ELSEIF(I.GE.5.AND.I.LE.10) THEN
	+ FACPV=PCM*2(1D0+RM1+RM2)+3D0RM1RM2
	+ FACPA=PCM*2(1D0+RM1+RM2)
	+ VA2=0D0
	+ AA2=0D0
	+ IF(I.EQ.5) THEN
	+C...a_T^0 -> gamma rho_T^0
	+ VA2=(2D0RTCM(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=(2D0RTCM(2)-1D0)2XW/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-2D0XW)2/XW/XW1/RTCM(50)4
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
	+ ENDIF
	+ WDTP(I)=AEMSHR5PCM/12D0(VA2FACPV+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-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ WDTP(I)=FACFFCOFSQRT(MAX(0D0,1D0-4D0RM1))((1D0-RM1)*
	+ & ((VALIBWZR)2+(VALIBWZI)**2+
	+ & (VARIBWZR)2+(VARIBWZI)*2)+6D0RM1*(
	+ & (VALIBWZR)(VARIBWZR)+VALIVARIBWZI*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)(AEM2/ALPRHT)SHR*
	+ & (0.125D0/XW*2)SH2/((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=.5D0SQRT(MAX(0D0,(1D0-RM1-RM2)2-4D0RM1*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-2D0XW)*2/
	+ & RTCM(49)**2
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
	+ ENDIF
	+ WDTP(I)=AEMPCM(AA2(PCM2+1.5D0RM1)+PCM*2VA2)
	+ & /3D0SHR*3
	+ ELSEIF(I.LE.10) THEN
	+ FACPV=PCM*2(1D0+RM1+RM2)+3D0RM1RM2
	+ FACPA=PCM*2(1D0+RM1+RM2)
	+ VA2=0D0
	+ AA2=0D0
	+C...a2_tc+ -> gamma + rho_tc+
	+ IF(I.EQ.7) THEN
	+ VA2=(2D0RTCM(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/(4D0XW)/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=(2D0RTCM(2)-1D0)2XW/XW1/RTCM(50)**4
	+ AA2=1D0/(4D0XWXW1)/RTCM(51)**4
	+ WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
	+ ENDIF
	+ WDTP(I)=AEMSHR5PCM/12D0(VA2FACPV+AA2*FACPA)
	+ ELSE
	+C...a2_tc+ -> f + fbar'.
	+ IA=I-10
	+ WID2=1D0
	+ IF(IA.LE.16) THEN
	+ FCOF=3D0RADCVCKM((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)=FACFFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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
	+C IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
	+ IF((KFMO.EQ.25.OR.KFMO.EQ.35).AND.MEQL.EQ.1.AND.
	+ &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
	+ IF(KFMO.EQ.36.AND.MEQL.EQ.1.AND.
	+ &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=4
	+ 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+2ILM).GT.CKIN(NOFF+2ILM-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((PML12-PMD(1)2)/(PMD(1)*PGD(1)))
	+ ATU1=ATAN((PMU12-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-4D0RM1*RM2))
	+ IF(MMED.EQ.1) FUNC1=FUNC1((1D0-RM1-RM2)2+8D0RM1*RM2)
	+ IF(MMED.EQ.4) FUNC1=FUNC1*3RM1*RM2
	+ IF(MMED.EQ.2) FUNC1=FUNC1*3(1D0+10D0RM1+10D0RM2+RM1**2+
	+ & RM2*2+10D0RM1*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-4D0RMG(1)*RMG(2)))
	+ IF(MMED.EQ.1) THEN
	+ WTBE=FLAM((1D0-RMG(1)-RMG(2))2+8D0RMG(1)*RMG(2))
	+ ELSEIF(MMED.EQ.4) THEN
	+ WTBE=FLAM*3RMG(1)*RMG(2)
	+ ELSEIF(MMED.EQ.2) THEN
	+ WTBE=FLAM*3(1D0+10D0RMG(1)+10D0RMG(2)+RMG(1)**2+
	+ & RMG(2)*2+10D0RMG(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(IDIVPML(1)+(10-IDIV)*PMU(1)))
	+ PMG(2)=MIN(PMD(2),0.1D0(IDIVPML(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))*2MAX((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)(PMV2-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)*2PMV2/(PML(I)2+PYR(0)*
	+ & (PMV2-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=PMV2-PML(I)2
	+ FI2=2D0*LOG(PMV/PML(I))
	+ FI3=1D0/PML(I)2-1D0/PMV2
	+ IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
	+ & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
	+ VINT(80)=VINT(80)20D0/(8D0+(FI0/F0)(F1/FI1+6D0*F2/FI2+
	+ & 5D0*F3/FI3))
	+ ELSE
	+ VINT(80)=VINT(80)10D0/(8D0+(FI0/F0)(F1/FI1+F2/FI2))
	+ ENDIF
	+ VINT(80)=VINT(80)*FI0
	+ 280 CONTINUE
	+ IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C***********************************************************************
	+
	+C...PYRECO
	+C...Handles the possibility of colour reconnection in W+W- events,
	+C...Based on the main scenarios of the Sjostrand and Khoze study:
	+C...I, II, II', intermediate and instantaneous; plus one model
	+C...along the lines of the Gustafson and Hakkinen: GH.
	+C...Note: also handles Z0 Z0 and W-W+ events, but notation below
	+C...is as if first resonance is W+ and second W-.
	+
	+ SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter value; number of points in MC integration.
	+ PARAMETER (NPT=100)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
	+C...Local arrays.
	+ DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
	+ &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
	+ &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
	+ &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
	+ &TMC(20),IJOIN(100)
	+
	+C...Functions to give four-product and to do determinants.
	+ FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	+ DETER(I,J,L)=Q(I,1)Q(J,2)Q(L,3)-Q(I,1)Q(L,2)Q(J,3)+
	+ &Q(J,1)Q(L,2)Q(I,3)-Q(J,1)Q(I,2)Q(L,3)+
	+ &Q(L,1)Q(I,2)Q(J,3)-Q(L,1)Q(J,2)Q(I,3)
	+
	+C...Only allow fraction of recoupling for GH, intermediate and
	+C...instantaneous.
	+ IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
	+ IF(PYR(0).GT.PARP(120)) RETURN
	+ ENDIF
	+ ISUB=MINT(1)
	+
	+C...Common part for scenarios I, II, II', and GH.
	+ IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
	+ &MSTP(115).EQ.5) THEN
	+
	+C...Read out frequently-used parameters.
	+ PI=PARU(1)
	+ HBAR=PARU(3)
	+ PMW=PMAS(24,1)
	+ IF(ISUB.EQ.22) PMW=PMAS(23,1)
	+ PGW=PMAS(24,2)
	+ IF(ISUB.EQ.22) PGW=PMAS(23,2)
	+ TFRAG=PARP(115)
	+ RHAD=PARP(116)
	+ FACT=PARP(117)
	+ BLOWR=PARP(118)
	+ BLOWT=PARP(119)
	+
	+C...Find range of decay products of the W's.
	+C...Background: the W's are stored in IW1 and IW2.
	+C...Their direct decay products in NSD1+1 through NSD1+4.
	+C...Products after shower (if any) in NSD1+5 through NAFT1
	+C...for first W and in NAFT1+1 through N for the second.
	+ IF(NAFT1.GT.NSD1+4) THEN
	+ NBEG(1)=NSD1+5
	+ NEND(1)=NAFT1
	+ ELSE
	+ NBEG(1)=NSD1+1
	+ NEND(1)=NSD1+2
	+ ENDIF
	+ IF(N.GT.NAFT1) THEN
	+ NBEG(2)=NAFT1+1
	+ NEND(2)=N
	+ ELSE
	+ NBEG(2)=NSD1+3
	+ NEND(2)=NSD1+4
	+ ENDIF
	+
	+C...Rearrange parton shower products along strings.
	+ NOLD=N
	+ CALL PYPREP(NSD1+1)
	+ IF(MINT(51).NE.0) RETURN
	+
	+C...Find partons pointing back to W+ and W-; store them with quark
	+C...end of string first.
	+ NNP=0
	+ NNM=0
	+ ISGP=0
	+ ISGM=0
	+ DO 120 I=NOLD+1,N
	+ IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
	+ IF(IABS(K(I,2)).GE.22) GOTO 120
	+ IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
	+ IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
	+ NNP=NNP+1
	+ IF(ISGP.EQ.1) THEN
	+ INP(NNP)=I
	+ ELSE
	+ DO 100 I1=NNP,2,-1
	+ INP(I1)=INP(I1-1)
	+ 100 CONTINUE
	+ INP(1)=I
	+ ENDIF
	+ IF(K(I,1).EQ.1) ISGP=0
	+ ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
	+ IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
	+ NNM=NNM+1
	+ IF(ISGM.EQ.1) THEN
	+ INM(NNM)=I
	+ ELSE
	+ DO 110 I1=NNM,2,-1
	+ INM(I1)=INM(I1-1)
	+ 110 CONTINUE
	+ INM(1)=I
	+ ENDIF
	+ IF(K(I,1).EQ.1) ISGM=0
	+ ENDIF
	+ 120 CONTINUE
	+
	+C...Boost to W+W- rest frame (not strictly needed).
	+ DO 130 J=1,3
	+ BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
	+ 130 CONTINUE
	+ CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
	+ CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
	+ CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
	+
	+C...Select decay vertices of W+ and W-.
	+ TP=HBAR(-LOG(PYR(0)))P(IW1,4)/
	+ & SQRT((P(IW1,5)2-PMW2)2+(P(IW1,5)2PGW/PMW)*2)
	+ TM=HBAR(-LOG(PYR(0)))P(IW2,4)/
	+ & SQRT((P(IW2,5)2-PMW2)2+(P(IW2,5)2PGW/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=2D0PIPYR(0)
	+ X=BLOWRRHADR*COS(PHI)
	+ Y=BLOWRRHADR*SIN(PHI)
	+ R=SQRT(-LOG(PYR(0)))
	+ PHI=2D0PIPYR(0)
	+ Z=BLOWRRHADR*COS(PHI)
	+ T=GTMAX+BLOWTSQRT(0.5D0)TFRAGRABS(SIN(PHI))
	+
	+C...Reject impossible points. Weight for sample distribution.
	+ IF(T2-X2-Y2-Z2.LT.0D0) GOTO 250
	+ WTSMP=EXP(-(X2+Y2+Z*2)/(BLOWRRHAD)*2)
	+ & EXP(-2D0(T-GTMAX)2/(BLOWTTFRAG)**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)/(2D0RHAD2))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)/(2D0RHAD2))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*3BLOWT*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)-TPV1P(J)+TMV1M(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=S11S22-S12S21
	+ ALP=(S12S23-S22S13)/DEN
	+ BET=(S21S13-S11S23)/DEN
	+
	+C...Check if solution acceptable.
	+ IANSW=1
	+ IF(T.LT.GTMAX) IANSW=0
	+ IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
	+ IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
	+
	+C...Find point of crossing and check that not inconsistent.
	+ DO 300 J=1,3
	+ XPP(J)=XP(J)+(V1P(J)+ALP(V2P(J)-V1P(J)))(T-TP)
	+ XMM(J)=XM(J)+(V1M(J)+BET(V2M(J)-V1M(J)))(T-TM)
	+ 300 CONTINUE
	+ D2PM=(XPP(1)-XMM(1))2+(XPP(2)-XMM(2))2+
	+ & (XPP(3)-XMM(3))**2
	+ D2P=XPP(1)2+XPP(2)2+XPP(3)**2
	+ D2M=XMM(1)2+XMM(2)2+XMM(3)**2
	+ IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
	+
	+C...Find string eigentimes at crossing.
	+ IF(IANSW.EQ.1) THEN
	+ TAUP=SQRT(MAX(0D0,(T-TP)2-(XPP(1)-XP(1))2-
	+ & (XPP(2)-XP(2))2-(XPP(3)-XP(3))2))
	+ TAUM=SQRT(MAX(0D0,(T-TM)2-(XMM(1)-XM(1))2-
	+ & (XMM(2)-XM(2))2-(XMM(3)-XM(3))2))
	+ ELSE
	+ TAUP=0D0
	+ TAUM=0D0
	+ ENDIF
	+
	+C...Order crossings by time. End loop over crossings.
	+ IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
	+ NCROSS=NCROSS+1
	+ DO 310 I1=NCROSS,1,-1
	+ IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
	+ IPC(I1)=IIP
	+ IMC(I1)=IIM
	+ TC(I1)=T
	+ TPC(I1)=TAUP
	+ TMC(I1)=TAUM
	+ GOTO 320
	+ ELSE
	+ IPC(I1)=IPC(I1-1)
	+ IMC(I1)=IMC(I1-1)
	+ TC(I1)=TC(I1-1)
	+ TPC(I1)=TPC(I1-1)
	+ TMC(I1)=TMC(I1-1)
	+ ENDIF
	+ 310 CONTINUE
	+ 320 CONTINUE
	+ ENDIF
	+ 330 CONTINUE
	+ 340 CONTINUE
	+
	+C...Loop over crossings; find first (if any) acceptable one.
	+ IACC=0
	+ IF(NCROSS.GE.1) THEN
	+ DO 350 IC=1,NCROSS
	+ PNFRAG=EXP(-(TPC(IC)2+TMC(IC)2)/TFRAG**2)
	+ IF(PNFRAG.GT.PYR(0)) THEN
	+C...Scenario II: only compare with fragmentation time.
	+ IF(MSTP(115).EQ.2) THEN
	+ IACC=IC
	+ IIP=IPC(IACC)
	+ IIM=IMC(IACC)
	+ GOTO 360
	+C...Scenario II': also require that string length decreases.
	+ ELSE
	+ IIP=IPC(IC)
	+ IIM=IMC(IC)
	+ I1P=INP(IIP)
	+ I2P=INP(IIP+1)
	+ I1M=INM(IIM)
	+ I2M=INM(IIM+1)
	+ ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
	+ ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
	+ IF(ELNEW.LT.ELOLD) THEN
	+ IACC=IC
	+ IIP=IPC(IACC)
	+ IIM=IMC(IACC)
	+ GOTO 360
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 350 CONTINUE
	+ 360 CONTINUE
	+ ENDIF
	+
	+C...Begin scenario GH specifics.
	+ ELSEIF(MSTP(115).EQ.5) THEN
	+
	+C...Loop through all string pieces, one from W+ and one from W-.
	+ IACC=0
	+ ELMIN=1D0
	+ DO 380 IIP=1,NNP-1
	+ IF(K(INP(IIP),2).LT.0) GOTO 380
	+ I1P=INP(IIP)
	+ I2P=INP(IIP+1)
	+ DO 370 IIM=1,NNM-1
	+ IF(K(INM(IIM),2).LT.0) GOTO 370
	+ I1M=INM(IIM)
	+ I2M=INM(IIM+1)
	+
	+C...Look for largest decrease of (exponent of) Lambda measure.
	+ ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
	+ ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
	+ ELDIF=ELNEW/MAX(1D-10,ELOLD)
	+ IF(ELDIF.LT.ELMIN) THEN
	+ IACC=IIP+IIM
	+ ELMIN=ELDIF
	+ IPC(1)=IIP
	+ IMC(1)=IIM
	+ ENDIF
	+ 370 CONTINUE
	+ 380 CONTINUE
	+ IIP=IPC(1)
	+ IIM=IMC(1)
	+ ENDIF
	+
	+C...Common for scenarios I, II, II' and GH: reconnect strings.
	+ IF(IACC.NE.0) THEN
	+ MINT(32)=1
	+ NJOIN=0
	+ DO 390 IS=1,NNP+NNM
	+ NJOIN=NJOIN+1
	+ IF(IS.LE.IIP) THEN
	+ I=INP(IS)
	+ ELSEIF(IS.LE.IIP+NNM-IIM) THEN
	+ I=INM(IS-IIP+IIM)
	+ ELSEIF(IS.LE.IIP+NNM) THEN
	+ I=INM(IS-IIP-NNM+IIM)
	+ ELSE
	+ I=INP(IS-NNM)
	+ ENDIF
	+ IJOIN(NJOIN)=I
	+ IF(K(I,2).LT.0) THEN
	+ CALL PYJOIN(NJOIN,IJOIN)
	+ NJOIN=0
	+ ENDIF
	+ 390 CONTINUE
	+
	+C...Restore original event record if no reconnection.
	+ ELSE
	+ DO 400 I=NSD1+1,NOLD
	+ IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
	+ K(I,4)=MOD(K(I,4),MSTU(5)**2)
	+ K(I,5)=MOD(K(I,5),MSTU(5)**2)
	+ ENDIF
	+ 400 CONTINUE
	+ DO 410 I=NOLD+1,N
	+ K(K(I,3),1)=3
	+ 410 CONTINUE
	+ N=NOLD
	+ ENDIF
	+
	+C...Boost back system.
	+ CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
	+ CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
	+ IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
	+ & BEWW(1),BEWW(2),BEWW(3))
	+
	+C...Common part for intermediate and instantaneous scenarios.
	+ ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
	+ MINT(32)=1
	+
	+C...Remove old shower products and reset showering ones.
	+ N=NSD1+4
	+ DO 420 I=NSD1+1,NSD1+4
	+ K(I,1)=3
	+ K(I,4)=MOD(K(I,4),MSTU(5)**2)
	+ K(I,5)=MOD(K(I,5),MSTU(5)**2)
	+ 420 CONTINUE
	+
	+C...Identify quark-antiquark pairs.
	+ IQ1=NSD1+1
	+ IQ2=NSD1+2
	+ IQ3=NSD1+3
	+ IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
	+ IQ4=2*NSD1+7-IQ3
	+
	+C...Reconnect strings.
	+ IJOIN(1)=IQ1
	+ IJOIN(2)=IQ4
	+ CALL PYJOIN(2,IJOIN)
	+ IJOIN(1)=IQ3
	+ IJOIN(2)=IQ2
	+ CALL PYJOIN(2,IJOIN)
	+
	+C...Do new parton showers in intermediate scenario.
	+ IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
	+ MSTJ50=MSTJ(50)
	+ MSTJ(50)=0
	+ CALL PYSHOW(IQ1,IQ2,P(IW1,5))
	+ CALL PYSHOW(IQ3,IQ4,P(IW2,5))
	+ MSTJ(50)=MSTJ50
	+
	+C...Do new parton showers in instantaneous scenario.
	+ ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
	+ PPM2=(P(IQ1,4)+P(IQ4,4))2-(P(IQ1,1)+P(IQ4,1))2-
	+ & (P(IQ1,2)+P(IQ4,2))2-(P(IQ1,3)+P(IQ4,3))2
	+ PPM=SQRT(MAX(0D0,PPM2))
	+ CALL PYSHOW(IQ1,IQ4,PPM)
	+ PPM2=(P(IQ3,4)+P(IQ2,4))2-(P(IQ3,1)+P(IQ2,1))2-
	+ & (P(IQ3,2)+P(IQ2,2))2-(P(IQ3,3)+P(IQ2,3))2
	+ PPM=SQRT(MAX(0D0,PPM2))
	+ CALL PYSHOW(IQ3,IQ2,PPM)
	+ ENDIF
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C***********************************************************************
	+
	+C...PYKLIM
	+C...Checks generated variables against pre-set kinematical limits;
	+C...also calculates limits on variables used in generation.
	+
	+ SUBROUTINE PYKLIM(ILIM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/
	+
	+C...Common kinematical expressions.
	+ MINT(51)=0
	+ ISUB=MINT(1)
	+ ISTSB=ISET(ISUB)
	+ IF(ISUB.EQ.96) GOTO 100
	+ SQM3=VINT(63)
	+ SQM4=VINT(64)
	+ IF(ILIM.NE.0) THEN
	+ IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
	+ CKIN09=MAX(CKIN(9),CKIN(13))
	+ CKIN10=MIN(CKIN(10),CKIN(14))
	+ CKIN11=MAX(CKIN(11),CKIN(15))
	+ CKIN12=MIN(CKIN(12),CKIN(16))
	+ ELSE
	+ CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
	+ CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
	+ CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
	+ CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
	+ ENDIF
	+ ENDIF
	+ IF(ILIM.NE.1) THEN
	+ TAU=VINT(21)
	+ RM3=SQM3/(TAU*VINT(2))
	+ RM4=SQM4/(TAU*VINT(2))
	+ BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)*2-4D0RM3*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(TAUVINT(2).LT.CKIN(1)*2) MINT(51)=1
	+ IF(CKIN(2).GE.0D0.AND.TAUVINT(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.5D0BE34SQRT(TAUVINT(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)+BE34SINH(YST)*
	+ & CTH)*2-4D0RM3))
	+ EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)COSH(YST)-BE34SINH(YST)*
	+ & CTH)*2-4D0RM4))
	+ IF(STH.GE.1D-10) THEN
	+ EXPET3=((1D0+RM3-RM4)SINH(YST)+BE34COSH(YST)*CTH+EXSQ3)/
	+ & (BE34*STH)
	+ EXPET4=((1D0-RM3+RM4)SINH(YST)-BE34COSH(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)+BE34COSH(YST)*CTH)/EXSQ3
	+ CTS4=((1D0-RM3+RM4)SINH(YST)-BE34COSH(YST)*CTH)/EXSQ4
	+ CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
	+ CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
	+ SH=TAU*VINT(2)
	+ RPTS=4D0VINT(71)*2/SH
	+ BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)*2-4D0RM3*RM4-RPTS))
	+ RM34=MAX(1D-20,2D0RM3RM4)
	+ IF(2D0VINT(71)2/(VINT(21)VINT(2)).LT.0.0001D0)
	+ & RM34=MAX(RM34,2D0VINT(71)2/(VINT(21)VINT(2)))
	+ RTHM=(4D0RM3RM4+RPTS)/(1D0-RM3-RM4+BE34L)
	+ THA=0.5D0SHMAX(RTHM,1D0-RM3-RM4-BE34*CTH)
	+ UHA=0.5D0SHMAX(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(TAUPVINT(2).LT.CKIN(31)*2) MINT(51)=1
	+ IF(CKIN(32).GE.0D0.AND.TAUPVINT(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+2D0TM3TM4YDCOSH+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+PTHMIN2/(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-4D0PTHMIN2/(BE342TAUE*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-4D0PTHMIN2/(BE342TAU*VINT(2))))
	+ CTPMX2=-CTNMN2
	+ CTNMX2=0D0
	+ CTPMN2=0D0
	+ IF(CKIN(4).GE.0D0) THEN
	+ CTNMX2=-SQRT(MAX(0D0,1D0-4D0CKIN(4)*2/
	+ & (BE34*2TAU*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=TAUMAXTAUMIN/(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=TAURETAUMIN/((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+GAMRETAN(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,2D0VINT(63)VINT(64)/(VINT(21)VINT(2))*2)
	+ RSQM=1D0+RM34
	+ IF(2D0VINT(71)2/(VINT(21)VINT(2)).LT.0.0001D0)
	+ & RM34=MAX(RM34,2D0VINT(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-PM12-(PM2+PM3)2)*2-(2D0PM1(PM2+PM3))*2)/
	+ & (4D0*SHP)
	+ IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
	+ PTSMN1=CKIN(51)**2
	+ PTSMX2=((SHP-PM22-(PM1+PM3)2)*2-(2D0PM2(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,HMNHMX/(HMN+PYR(0)HDE)-PMRS1)
	+ ENDIF
	+ WTPTS1=HDE/(HWT1+HWT2HDE/(LOG(HMX/HMN)(PMRS1+PTS1))+
	+ & HWT3HMNHMX/(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,HMNHMX/(HMN+PYR(0)HDE)-PMRS2)
	+ ENDIF
	+ WTPTS2=HDE/(HWT1+HWT2HDE/(LOG(HMX/HMN)(PMRS2+PTS2))+
	+ & HWT3HMNHMX/(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+2D0SQRT(PTS1PTS2)*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-
	+ & 4D0PMS3PM12)))/(2D0SHPRPMT3))
	+ IF(Y3MAX.LT.1D-6) THEN
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+ Y3=(2D0PYR(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=PE122-PZ122
	+ SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)*2-4D0PMS1*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.5D0TFAC(PE12-PZ12)(PMM2+EPSSQL12)
	+ VINT(218)=-0.5D0TFAC(PE12+PZ12)(PMM1+EPSSQL12)
	+ 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/pisH_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/pid(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)^32E_i))
	+C...(2pi)^4 delta^4(P - sum p_i)
	+C...COMFAC contains the factor pi/s (or equivalent) and
	+C...the conversion factor from GeV^-2 to mb
	+
	+ SUBROUTINE PYSIGH(NCHN,SIGS)
	+
	+C...Double precision and integer declarations
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	+ COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
	+ &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
	+ COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	+ COMMON/PYPUED/IUED(0:99),RUED(0:99)
	+ COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
	+ &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
	+ &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
	+ &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
	+ COMMON/PYTCCO/COEFX(194:380,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
	+ &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
	+ &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
	+C...Local arrays and complex variables
	+ DIMENSION XPQ(-25:25)
	+
	+C...Map of processes onto which routine to call
	+C...in order to evaluate cross section:
	+C...0 = not implemented;
	+C...1 = standard QCD (including photons);
	+C...2 = heavy flavours;
	+C...3 = W/Z;
	+C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
	+C...5 = SUSY;
	+C...6 = Technicolor;
	+C...7 = exotics (Z'/W'/LQ/R/f/H++/Z_R/W_R/G).
	+C...8 = Universal Extra Dimensions
	+ DIMENSION MAPPR(500)
	+ DATA (MAPPR(I),I=1,180)/
	+ & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
	+ 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
	+ 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
	+ 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
	+ 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
	+ 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
	+ 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
	+ 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
	+ 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
	+ & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
	+ 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
	+ 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
	+ 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
	+ 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
	+ 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
	+ 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
	+ 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
	+ DATA (MAPPR(I),I=181,500)/
	+ 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
	+ 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
	+ & 100*5,
	+ & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
	+ & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
	+ 1 20*0,
	+ 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
	+ 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
	+ 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
	+ 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
	+ 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
	+ 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
	+ & 4, 4, 18*0,
	+ 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	+ 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
	+ 4 20*0,
	+ 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
	+ 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
	+ 8 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-4D0RM3*RM4))
	+ RPTS=4D0VINT(71)*2/SH
	+ BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)*2-4D0RM3*RM4-RPTS))
	+ RM34=MAX(1D-20,2D0RM3RM4)
	+ RSQM=1D0+RM34
	+ IF(2D0VINT(71)2/MAX(1D0,VINT(21)VINT(2)).LT.0.0001D0)
	+ &RM34=MAX(RM34,2D0VINT(71)2/MAX(1D0,VINT(21)VINT(2)))
	+ RTHM=(4D0RM3RM4+RPTS)/(1D0-RM3-RM4+BE34L)
	+ IF(ISTSB.EQ.0) THEN
	+ TH=VINT(45)
	+ UH=-0.5D0SHMAX(RTHM,1D0-RM3-RM4+BE34*CTH)
	+ SQPTH=MAX(VINT(71)*2,0.25D0SHBE342VINT(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-4D0RM1*RM2))
	+ TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
	+ TH=-0.5D0SHMAX(RTHM,TUCOM-2D0RM1RM4-2D0RM2RM3-
	+ & BE12BE34CTH)
	+ UH=-0.5D0SHMAX(RTHM,TUCOM-2D0RM1RM3-2D0RM2RM4+
	+ & BE12BE34CTH)
	+ SQPTH=MAX(VINT(71)*2,0.25D0SHBE342(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=2D0SHTHUH/(SH2+TH2+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+XSF1Q2IN1/SH+XSF2Q2IN2/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+2SQRT(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=(4D0VINT(48)+2D0VINT(63)+2D0*VINT(64))/VINT(2)
	+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
	+ ENDIF
	+ VINT(62)=0.25D0XT2GMXVINT(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.1PMAS(4,1)*2) THEN
	+ XPQ(4)=0D0
	+ XPQ(-4)=0D0
	+ ENDIF
	+ IF(Q2SF.LT.1.1PMAS(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/(16D0XWXW1)
	+ AEM=PYALEM(Q2)
	+ IF(MSTP(8).GE.1) AEM=SQRT(2D0)PARU(105)PMAS(24,1)*2XW/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+GAMR12)
	+ 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+GAMR22)
	+ 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+GAMR32)
	+ 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=COMFACATAU1/(TAUH1)
	+ 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=COMFAC0.5D0ACTH0
	+ ELSE
	+ COMFAC=COMFAC0.125D0(3D0ACTH0+CTNMAX3-CTNMIN*3+
	+ & CTPMAX3-CTPMIN3)
	+ 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=COMFACACTH00.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)3TAU/TAUP
	+ ENDIF
	+ COMFAC=COMFAC*FZW
	+ ENDIF
	+
	+C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
	+ IF(ISTSB.EQ.5) THEN
	+ COMFAC=COMFACVINT(205)VINT(210)VINT(212)VINT(214)/
	+ & (128D0PARU(1)4VINT(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)FACK0.5D0VINT(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=COMFACXT22(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=COMFACXT22/(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=4D0Q2Q2GA/(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=4D0Q2GA/(PMVIRT*2+Q2GA)
	+ ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
	+ PMVIRT=PMAS(PYCOMP(113),1)
	+ REDUCE=4D0PMVIRT2Q2GA/(PMVIRT2+Q2GA)2
	+ ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
	+ PMVIRT=PMAS(PYCOMP(113),1)
	+ REDUCE=4D0PMVIRT2Q2GA/(PMVIRT2+Q2GA)2
	+ ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
	+ PMVSMN=4D0PARP(15)*2
	+ PMVSMX=4D0VINT(154)*2
	+ REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
	+ REDLON=(3D0PMVSMN+Q2GA)/(PMVSMN+Q2GA)*3-
	+ & (3D0PMVSMX+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=4D0Q2GA/(PMVIRT*2+Q2GA)
	+ ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
	+ PMVIRT=PMAS(PYCOMP(113),1)
	+ REDUCE=4D0Q2GA/(PMVIRT*2+Q2GA)
	+ ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
	+ PMVSMN=4D0PARP(15)*2
	+ PMVSMX=4D0VINT(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-2D0BEAMAS*2/Q2GA))
	+ VINT(314+ISDE)=1D0+PARP(165)REDUCEFRACLT
	+ 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=COMFACAEM22D0*(SH2+UH2)/TH2
	+ FACGZF=COMFACAEM2XWC4D0SH2/(TH*(TH-SQMZ))
	+ FACZZF=COMFAC(AEMXWC)*22D0SH2/(TH-SQMZ)*2
	+ FACWWF=COMFAC(0.5D0AEM/XW)*2SH2/(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-4D0EIXWV
	+ EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
	+ AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
	+ VJ=AJ-4D0EJXWV
	+ 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=FACGGFEI2EJ*2+FACGZFEIEJ
	+ & (VIVJ(1D0+UH2/SH2)+AIAJEPSIJ*(1D0-UH2/SH2))+
	+ & FACZZF((VI2+AI2)(VJ2+AJ2)*(1D0+UH2/SH2)+
	+ & 4D0VIVJAIAJEPSIJ(1D0-UH2/SH2))
	+ ELSEIF(MSTP(21).EQ.2) THEN
	+ FACNCF=FACGGFEI2EJ**2
	+ ELSE
	+ FACNCF=FACZZF((VI2+AI2)(VJ2+AJ2)*
	+ & (1D0+UH2/SH2)+4D0VIVJAIAJEPSIJ(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=FACWWFVINT(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=COMFACAS24D0/9D0*(SH2+UH2)/TH2
	+ FACQQB=COMFACAS24D0/9D0((SH2+UH2)/TH2FACA-
	+ & MSTP(34)2D0/3D0UH2/(SH*TH))
	+ FACQQ2=COMFACAS24D0/9D0*((SH2+TH2)/UH2-
	+ & MSTP(34)2D0/3D0SH2/(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=COMFACAS24D0/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=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2)
	+ FACGG2=COMFACAS232D0/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=COMFACASAEM8D0/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)=FACGGEI*2
	+ 160 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.18) THEN
	+C...f + fbar -> gamma + gamma
	+ FACGG=COMFACAEM22D0(TH2+UH2)/(THUH)
	+ 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.5D0FACGGFCOIEI*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=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*UH2/TH2-
	+ & UH/SH)*FACA
	+ FACQG2=COMFACAS24D0/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=COMFACFACAASAEM1D0/3D0(SH2+UH2)/(-SHUH)
	+ DO 210 I=MMINA,MMAXA
	+ IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
	+ EI=KCHG(IABS(I),1)/3D0
	+ FACGQ=FGQEI*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=COMFACASAEM8D0/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=FGQEI*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=COMFACAEM22D0(SH2+UH2)/(-SHUH)
	+ DO 250 I=MMINA,MMAXA
	+ IF(I.EQ.0) GOTO 250
	+ EI=KCHG(IABS(I),1)/3D0
	+ FACGQ=FGQEI*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-4D0PMAS(1,1)*2/SH))
	+ IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
	+ & SQRT(MAX(0D0,1D0-4D0PMAS(2,1)*2/SH))
	+ IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
	+ & SQRT(MAX(0D0,1D0-4D0PMAS(3,1)*2/SH))
	+ FACQQ1=COMFACAS21D0/6D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2)FLAVWTFACA
	+ FACQQ2=COMFACAS21D0/6D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	+ & TH2/SH2)FLAVWTFACA
	+ 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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ THUHQ=THQUHQ-SQMAVGSH
	+ IF(MSTP(34).EQ.0) THEN
	+ FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	+ FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	+ ELSE
	+ FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	+ FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	+ ENDIF
	+ FACQQ1=COMFACFACAAS*2(1D0/6D0)FACQQ1BE34
	+ FACQQ2=COMFACFACAAS*2(1D0/6D0)FACQQ2BE34
	+ 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=COMFACAEMASWDTESU(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=COMFACAEM2WDTESU2D0(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=COMFACAS29D0/4D0(SH2/TH2+2D0SH/TH+3D0+2D0*TH/SH+
	+ & TH2/SH2)*FACA
	+ FACGG2=COMFACAS29D0/4D0(UH2/SH2+2D0UH/SH+3D0+2D0*SH/UH+
	+ & SH2/UH2)*FACA
	+ FACGG3=COMFACAS29D0/4D0(TH2/UH2+2D0TH/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(2D0AEM/9D0)(-SH/TH)(1D0/SH2+1D0/TH2)
	+ ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
	+ Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
	+ DELSH=UHSQRT(ASSHQ2FPSH)
	+ ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
	+ Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
	+ DELUH=SHSQRT(ASUHQ2FPUH)
	+ 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(EIDELSH+EJDELUH)*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=COMFACAS24D0/9D0*(SH2+UH2)/TH2
	+ FACQQB=COMFACAS24D0/9D0((SH2+UH2)/TH2FACA-
	+ & MSTP(34)2D0/3D0UH2/(SH*TH))
	+ FACQQ2=COMFACAS24D0/9D0*(SH2+TH2)/UH2
	+ FACQQI=-COMFACAS24D0/9D0MSTP(34)2D0/3D0SH2/(THUH)
	+ 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.5D0FACQQ1RATQQI
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=112
	+ SIGH(NCHN)=0.5D0FACQQ2RATQQI
	+ ENDIF
	+ 330 CONTINUE
	+ 340 CONTINUE
	+
	+C...q + qbar -> q' + qbar' or g + g
	+ FACQQB=COMFACAS24D0/9D0(TH2+UH2)/SH2
	+ & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
	+ FACGG1=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2)
	+ FACGG2=COMFACAS232D0/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=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*UH2/TH2-
	+ & UH/SH)*FACA
	+ FACQG2=COMFACAS24D0/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-4D0PMAS(1,1)*2/SH))
	+ IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
	+ & SQRT(MAX(0D0,1D0-4D0PMAS(2,1)*2/SH))
	+ IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
	+ & SQRT(MAX(0D0,1D0-4D0PMAS(3,1)*2/SH))
	+ FACQQ1=COMFACAS21D0/6D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2)FLAVWTFACA
	+ FACQQ2=COMFACAS21D0/6D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	+ & TH2/SH2)FLAVWTFACA
	+ 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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ THUHQ=THQUHQ-SQMAVGSH
	+ IF(MSTP(34).EQ.0) THEN
	+ FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	+ FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	+ ELSE
	+ FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	+ FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	+ ENDIF
	+ FACQQ1=COMFACFACAAS*2(1D0/6D0)FACQQ1BE34
	+ FACQQ2=COMFACFACAAS*2(1D0/6D0)FACQQ2BE34
	+ 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=COMFACAS29D0/4D0(SH2/TH2+2D0SH/TH+3D0+
	+ & 2D0TH/SH+TH2/SH2)FACA
	+ FACGG2=COMFACAS29D0/4D0(UH2/SH2+2D0UH/SH+3D0+
	+ & 2D0SH/UH+SH2/UH2)FACA
	+ FACGG3=COMFACAS29D0/4D0(TH2/UH2+2D0TH/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)4D0PARU(1)*2PARU(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=COMFACQ2GA/(Q2GA+PM2RHO)*2
	+ ELSE
	+ COMFAC=COMFACQ2GA/(Q2GA+PM2RHO)*2
	+ W2GA=VINT(2)
	+ IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
	+ RDRDS=4.1D-3W2GA2.167D0/((Q2GA+0.15D0W2GA)*2
	+ & Q2GA*0.75D0)(1D0+0.11D0Q2GAP2GA/(1D0+0.02D0P2GA*2))
	+ XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
	+ ELSE
	+ RDRDS=1.5D-4W2GA2.167D0/((Q2GA+0.041D0W2GA)*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)=COMFACEI*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)/SHALTU+0.5D0(TH2+UH2)/SH2(ALTU*2+
	+ & PARU(1)**2)
	+ B0STUI=0D0
	+ B0TSUR=1D0+(SH-UH)/THALSU+0.5D0(SH2+UH2)/TH2ALSU*2
	+ B0TSUI=-PARU(1)((SH-UH)/TH+(SH2+UH2)/TH2ALSU)
	+ B0UTSR=1D0+(SH-TH)/UHALST+0.5D0(SH2+TH2)/UH2ALST*2
	+ B0UTSI=-PARU(1)((SH-TH)/UH+(SH2+TH2)/UH2ALST)
	+ 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+2D0TH/SH)W1TR+(1D0+2D0UH/SH)W1UR+
	+ & 0.5D0((TH2+UH2)/SH2-EPSS)(W2TR+W2UR)-
	+ & 0.25D0EPST(1D0-0.5D0EPSS)(Y3SUTR+Y3TUSR)-
	+ & 0.25D0EPSU(1D0-0.5D0EPSS)(Y3STUR+Y3UTSR)+
	+ & 0.25D0(-2D0(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
	+ & 0.5D0EPSTEPSU)*(Y3TSUR+Y3USTR)
	+ B0STUI=(1D0+2D0TH/SH)W1TI+(1D0+2D0UH/SH)W1UI+
	+ & 0.5D0((TH2+UH2)/SH2-EPSS)(W2TI+W2UI)-
	+ & 0.25D0EPST(1D0-0.5D0EPSS)(Y3SUTI+Y3TUSI)-
	+ & 0.25D0EPSU(1D0-0.5D0EPSS)(Y3STUI+Y3UTSI)+
	+ & 0.25D0(-2D0(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
	+ & 0.5D0EPSTEPSU)*(Y3TSUI+Y3USTI)
	+ B0TSUR=1D0+(1D0+2D0SH/TH)W1SR+(1D0+2D0UH/TH)W1UR+
	+ & 0.5D0((SH2+UH2)/TH2-EPST)(W2SR+W2UR)-
	+ & 0.25D0EPSS(1D0-0.5D0EPST)(Y3TUSR+Y3SUTR)-
	+ & 0.25D0EPSU(1D0-0.5D0EPST)(Y3TSUR+Y3USTR)+
	+ & 0.25D0(-2D0(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
	+ & 0.5D0EPSSEPSU)*(Y3STUR+Y3UTSR)
	+ B0TSUI=(1D0+2D0SH/TH)W1SI+(1D0+2D0UH/TH)W1UI+
	+ & 0.5D0((SH2+UH2)/TH2-EPST)(W2SI+W2UI)-
	+ & 0.25D0EPSS(1D0-0.5D0EPST)(Y3TUSI+Y3SUTI)-
	+ & 0.25D0EPSU(1D0-0.5D0EPST)(Y3TSUI+Y3USTI)+
	+ & 0.25D0(-2D0(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
	+ & 0.5D0EPSSEPSU)*(Y3STUI+Y3UTSI)
	+ B0UTSR=1D0+(1D0+2D0TH/UH)W1TR+(1D0+2D0SH/UH)W1SR+
	+ & 0.5D0((TH2+SH2)/UH2-EPSU)(W2TR+W2SR)-
	+ & 0.25D0EPST(1D0-0.5D0EPSU)(Y3USTR+Y3TSUR)-
	+ & 0.25D0EPSS(1D0-0.5D0EPSU)(Y3UTSR+Y3STUR)+
	+ & 0.25D0(-2D0(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
	+ & 0.5D0EPSTEPSS)*(Y3TUSR+Y3SUTR)
	+ B0UTSI=(1D0+2D0TH/UH)W1TI+(1D0+2D0SH/UH)W1SI+
	+ & 0.5D0((TH2+SH2)/UH2-EPSU)(W2TI+W2SI)-
	+ & 0.25D0EPST(1D0-0.5D0EPSU)(Y3USTI+Y3TSUI)-
	+ & 0.25D0EPSS(1D0-0.5D0EPSU)(Y3UTSI+Y3STUI)+
	+ & 0.25D0(-2D0(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
	+ & 0.5D0EPSTEPSS)*(Y3TUSI+Y3SUTI)
	+ B1STUR=-1D0-0.25D0(EPSS+EPST+EPSU)(W2SR+W2TR+W2UR)+
	+ & 0.25D0(EPSU+0.5D0EPSSEPST)(Y3SUTR+Y3TUSR)+
	+ & 0.25D0(EPST+0.5D0EPSSEPSU)(Y3STUR+Y3UTSR)+
	+ & 0.25D0(EPSS+0.5D0EPSTEPSU)(Y3TSUR+Y3USTR)
	+ B1STUI=-0.25D0(EPSS+EPST+EPSU)(W2SI+W2TI+W2UI)+
	+ & 0.25D0(EPSU+0.5D0EPSSEPST)(Y3SUTI+Y3TUSI)+
	+ & 0.25D0(EPST+0.5D0EPSSEPSU)(Y3STUI+Y3UTSI)+
	+ & 0.25D0(EPSS+0.5D0EPSTEPSU)(Y3TSUI+Y3USTI)
	+ B2STUR=-1D0+0.125D0EPSSEPST*(Y3SUTR+Y3TUSR)+
	+ & 0.125D0EPSSEPSU*(Y3STUR+Y3UTSR)+
	+ & 0.125D0EPSTEPSU*(Y3TSUR+Y3USTR)
	+ B2STUI=0.125D0EPSSEPST*(Y3SUTI+Y3TUSI)+
	+ & 0.125D0EPSSEPSU*(Y3STUI+Y3UTSI)+
	+ & 0.125D0EPSTEPSU*(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=A0STUR2+A0STUI2+A0TSUR2+A0TSUI2+A0UTSR**2+
	+ & A0UTSI*2+4D0A1STUR*2+4D0A1STUI2+A2STUR2+A2STUI**2
	+ FACGG=COMFACFACA/(16D0PARU(1)*2)AS*2AEM*2ASQSUM
	+ FACGP=COMFACFACA5D0/(192D0PARU(1)2)AS*3AEM*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=COMFACASAEM8D0/3D0SH2/(SH+PH)2*
	+ & ((SH2+UH2-2D0PHTH)/(-SHUH)-2D0PHTH/(SH+PH)*2)
	+ ELSE
	+ FGQ=COMFACASAEM8D0/3D0SH2/(SH+PH)4(-4D0PH*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=FGQEI*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=COMFACAEM22D0SH2/(SH+PH)2
	+ & ((SH2+UH2-2D0PHTH)/(-SHUH)-2D0PHTH/(SH+PH)*2)
	+ ELSE
	+ FGQ=COMFACAEM22D0SH2/(SH+PH)4(-4D0PHTH)
	+ ENDIF
	+ DO 450 I=MMINA,MMAXA
	+ IF(I.EQ.0) GOTO 450
	+ EI=KCHG(IABS(I),1)/3D0
	+ FACGQ=FGQEI*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=COMFACAEMASWDTESUSH2/(SH+PH)2*
	+ & ((TH2+UH2-2D0PHSH)/(THUH)+4D0PHSH/(SH+PH)*2)
	+ ELSE
	+ FACQQ=COMFACAEMASWDTESUSH2/(SH+PH)48D0PH*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-4D0PH1*PH2
	+ IF(ISUB.EQ.137) THEN
	+ FPARAM=-SH*(TH+UH)/DLAMB2
	+ FACFF=COMFACAEM2WDTESU2D0SH2/(DLAMB2TH2UH2)*
	+ & (THUH-PH1PH2)((TH2+UH2)(1D0-2D0FPARAM(1D0-FPARAM))-
	+ & 2D0PH1PH2FPARAM*2)
	+ ELSEIF(ISUB.EQ.138) THEN
	+ FACFF=COMFACAEM2WDTESU4D0SH2SH/(DLAMB22TH2UH2)
	+ & PH2(4D0(THUH-PH1PH2)(THUH+PH1SH(TH-UH)**2/DLAMB2)+
	+ & 2D0PH12(TH-UH)**2)
	+ ELSEIF(ISUB.EQ.139) THEN
	+ FACFF=COMFACAEM2WDTESU4D0SH2SH/(DLAMB22TH2UH2)
	+ & PH1(4D0(THUH-PH1PH2)(THUH+PH2SH(TH-UH)**2/DLAMB2)+
	+ & 2D0PH22(TH-UH)**2)
	+ ELSE
	+ FACFF=COMFACAEM2WDTESU32D0SH22/(DLAMB23TH2UH2)*
	+ & PH1PH2(THUH-PH1PH2)(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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ FACQQB=COMFACAS24D0/9D0((THQ2+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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ THUHQ=THQUHQ-SQMAVGSH
	+ IF(MSTP(34).EQ.0) THEN
	+ FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	+ FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	+ ELSE
	+ FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	+ FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	+ ENDIF
	+ FACQQ1=COMFACFACAAS*2(1D0/6D0)*FACQQ1
	+ FACQQ2=COMFACFACAAS*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.5D0AEM/XW)*2SH(SH-SQM3)/(SQMW-TH)*2
	+ FACQQU=COMFAC(0.5D0AEM/XW)*2UH(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(IJ.GT.0) SIGH(NCHN)=FACQQSFACCKM*WID2
	+ IF(IJ.LT.0) SIGH(NCHN)=FACQQUFACCKM*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(IJ.GT.0) SIGH(NCHN)=FACQQSFACCKM*WID2
	+ IF(IJ.LT.0) SIGH(NCHN)=FACQQUFACCKM*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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ FACQQ=COMFACASAEM(KCHG(IABS(MINT(55)),1)/3D0)2
	+ & (THQ2+UHQ2+4D0SQMAVGSH(1D0-SQMAVGSH/(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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ FACFF=COMFACAEM2(KCHG(IABS(MINT(56)),1)/3D0)*42D0*
	+ & ((1D0-PARJ(131)PARJ(132))(THQUHQ-SQMAVGSH)*
	+ & (UHQ2+THQ2+2D0SQMAVGSH)+(1D0+PARJ(131)PARJ(132))
	+ & SQMAVGSH2(SH-2D0SQMAVG))/(THQUHQ)**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=COMFACAS3(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=(SHTH+THUH+UH*SH)/SH2
	+ QGTW=(SHTHUH)/SH**3
	+ RGTW=SQM3/SH
	+ FACQQG=COMFACAS34D0(PARP(39)/SQRT(SQM3))(1D0/SH)*
	+ & (9D0RGTW2PGTW*4(RGTW*4-2D0RGTW*2PGTW+PGTW**2)-
	+ & 6D0RGTWPGTW*3QGTW(2D0RGTW*4-5D0RGTW*2PGTW+PGTW**2)-
	+ & PGTW*2QGTW*2(RGTW*4+2D0RGTW*2PGTW-PGTW**2)+
	+ & 2D0RGTWPGTWQGTW3(RGTW*2-PGTW)+6D0RGTW*2QGTW**4)/
	+ & (QGTW(QGTW-RGTWPGTW)**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=(SHTH+THUH+UH*SH)/SH2
	+ QGTW=(SHTHUH)/SH**3
	+ RGTW=SQM3/SH
	+ FACQQG=COMFACAS312D0(PARP(39)/SQRT(SQM3))(1D0/SH)*
	+ & PGTW*2(RGTWPGTW2(RGTW*2-4D0PGTW)+2D0QGTW(-RGTW**4+
	+ & 5D0RGTW2PGTW+PGTW*2)-15D0RGTWQGTW*2)/
	+ & (QGTW-RGTWPGTW)*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=(SHTH+THUH+UH*SH)/SH2
	+ QGTW=(SHTHUH)/SH**3
	+ RGTW=SQM3/SH
	+ FACQQG=COMFACAS34D0(PARP(39)/SQRT(SQM3))(1D0/SH)*
	+ & (12D0RGTW2PGTW*4(RGTW*4-2D0RGTW*2PGTW+PGTW**2)-
	+ & 3D0RGTWPGTW*3QGTW(8D0RGTW4-RGTW2PGTW+4D0PGTW**2)+
	+ & 2D0PGTW2QGTW*2(-7D0RGTW4+43D0RGTW*2PGTW+PGTW**2)+
	+ & RGTWPGTWQGTW*3(16D0RGTW2-61D0PGTW)+12D0RGTW2
	+ & QGTW*4)/(QGTW(QGTW-RGTWPGTW)*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=COMFAC12D0AS*2PARP(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=COMFAC16D0AS*2PARP(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=COMFACAEMEQ*2AS*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=COMFACAEMEQ*2AS*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=COMFACAEM3EQ*6384D0PARP(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/(2D0X(1)) + SHTH/(2D0X(2))
	+ BQ=UHSH/(2D0X(1)) - SHTH/(2D0X(2))
	+ ATILK1=X(1)VINT(2)/2D0-UHSH/(2D0SQMQQ)*AQ
	+ ATILK2=X(2)VINT(2)/2D0-SHTH/(2D0SQMQQ)*AQ
	+ BTILK1=-X(1)VINT(2)/2D0-UHSH/(2D0SQMQQ)*BQ
	+ BTILK2=X(2)VINT(2)/2D0-SHTH/(2D0SQMQQ)*BQ
	+ ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
	+ & ISUB.GE.437) THEN
	+ AQ=SHTH/(2D0X(1)) + UHSH/(2D0X(2))
	+ BQ=SHTH/(2D0X(1)) - UHSH/(2D0X(2))
	+ ATILK1=X(1)VINT(2)/2D0-SHTH/(2D0SQMQQ)*AQ
	+ ATILK2=X(2)VINT(2)/2D0-UHSH/(2D0SQMQQ)*AQ
	+ BTILK1=-X(1)VINT(2)/2D0-SHTH/(2D0SQMQQ)*BQ
	+ BTILK2=X(2)VINT(2)/2D0-UHSH/(2D0SQMQQ)*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=AQBQ/(POLH1POLH2)
	+ BX=-POLH1/POLH2
	+ ELSEIF(MSTP(146).EQ.2) THEN
	+C...Gottfried Jackson frame
	+ POLH1=AQ+BQ
	+ POLH2=POLH1SQRT(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=POLH1SQRT(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=-SQMQQRAQ/SQRT(POLH1(POLH1-SMQQ2))
	+ BX=SQMQQRBQ/SQRT(POLH1(POLH1-SMQQ2))
	+ ENDIF
	+C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
	+ EL1K10=AZATILK1+BZBTILK1
	+ EL1K20=AZATILK2+BZBTILK2
	+ EL2K10=EL1K10
	+ EL2K20=EL1K20
	+ EL1K11=1D0/SQRT(2D0)(AXATILK1+BX*BTILK1)
	+ EL1K21=1D0/SQRT(2D0)(AXATILK2+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=COMFACPARU(1)AS*3(10D0/81D0)SQMQQR
	+* & (SH2THUH2+TH2UHSH2+UH2SHTH2)/(SHTH2THUH2*UHSH2)
	+ FACQQG=COMFACPARU(1)AS*3(10D0/81D0)SQMQQR
	+ & (SH2THUH2+TH2UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
	+* FACQQG=COMFACPARU(1)AS*3(10D0/81D0)SQMQQR
	+* & (SH2/(SHTH2UHSH2)+TH2/(SHTH2THUH2)+UH2/(THUH2*UHSH2))
	+ ELSE
	+ FF=-PARU(1)AS3(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
	+ AA=(SHTH2UH2+UHSH2TH2+THUH2*SH2)/2D0
	+ BB=2D0*(SH2+TH2)
	+ CC=2D0*(SH2+UH2)
	+ DD=2D0*SH2
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=-COMFACPARU(1)AS*3(1D0/72D0)*
	+ & (16D0SQMQQ2-27D0(SHTH2+THUH2+UHSH2))/
	+ & (SQMQQSQMQQR)
	+ & ((SH2THUH2+TH2UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
	+ ELSE
	+ FF=PARU(1)AS3(16D0SQMQQ2-27D0(SHTH2+THUH2+UHSH2))/
	+ & (72D0SQMQQSQMQQRSHTH2THUH2*UHSH2)
	+ AA=(SHTH2UH2+UHSH2TH2+THUH2*SH2)/2D0
	+ BB=2D0*(SH2+TH2)
	+ CC=2D0*(SH2+UH2)
	+ DD=2D0*SH2
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ ENDIF
	+C...Split total contribution into different colour flows just like
	+C...in g g -> g g (recalculate kinematics for massless partons).
	+ THP=-0.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(1D0+CTH)
	+ FACGG1=(SH/THP)*2+2D0SH/THP+3D0+2D0THP/SH+(THP/SH)*2
	+ FACGG2=(UHP/SH)*2+2D0UHP/SH+3D0+2D0SH/UHP+(SH/UHP)*2
	+ FACGG3=(THP/UHP)*2+2D0THP/UHP+3D0+2D0UHP/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)=FACQQGPARP(IONIUM+2)FACGG1/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=21
	+ ISIG(NCHN,2)=21
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+2)FACGG2/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=21
	+ ISIG(NCHN,2)=21
	+ ISIG(NCHN,3)=3
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+2)FACGG3/FACGGS
	+ ENDIF
	+
	+ ELSEIF(ISUB.EQ.423) THEN
	+C...g + g -> QQ~[1S08] + g
	+ IF(MSTP(145).EQ.0) THEN
	+* FACQQG=COMFACPARU(1)AS*3(5D0/16D0)*
	+* & (SHTH2UH2+THUH2SH2+UHSH2TH2)/(SQMQQRSHTHUH)*
	+* & (12D0SQMQQSHTHUH+SHTH22+THUH22+UHSH2**2)/
	+* & (SHTH2THUH2UHSH2)
	+ FACQQG=COMFACPARU(1)AS*3(5D0/16D0)SQMQQR
	+ & (UH2/(THUH2UHSH2)+SH2/(SHTH2UHSH2)+
	+ & TH2/(SHTH2THUH2))
	+ & (12D0+(SHTH22+THUH22+UHSH2*2)/(SQMQQSHTHUH))
	+ ELSE
	+ FA=PARU(1)AS3(5D0/48D0)SQMQQR
	+ & (UH2/(THUH2UHSH2)+SH2/(SHTH2UHSH2)+
	+ & TH2/(SHTH2THUH2))
	+ & (12D0+(SHTH22+THUH22+UHSH2*2)/(SQMQQSHTHUH))
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=COMFAC*FA
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=COMFAC2D0FA
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(1D0+CTH)
	+ FACGG1=(SH/THP)*2+2D0SH/THP+3D0+2D0THP/SH+(THP/SH)*2
	+ FACGG2=(UHP/SH)*2+2D0UHP/SH+3D0+2D0SH/UHP+(SH/UHP)*2
	+ FACGG3=(THP/UHP)*2+2D0THP/UHP+3D0+2D0UHP/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)=FACQQGPARP(IONIUM+3)FACGG1/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=21
	+ ISIG(NCHN,2)=21
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+3)FACGG2/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=21
	+ ISIG(NCHN,2)=21
	+ ISIG(NCHN,3)=3
	+ SIGH(NCHN)=FACQQGPARP(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=COMFAC5D0PARU(1)AS3(3D0SHTHSHTHPOLY**4
	+ & -SQMQQPOLY2(7D0SH6+36D0SH*5TH+45D0SH4TH2
	+ & +28D0SH3TH*3+45D0SH2TH4+36D0SHTH*5
	+ & +7D0TH*6)
	+ & +SQMQQ*2SHTH(35D0SH*8+169D0SH*7TH
	+ & +299D0SH6TH2+401D0SH5TH*3+418D0SH*4TH**4
	+ & +401D0SH3TH*5+299D0SH2TH6+169D0SHTH*7
	+ & +35D0TH*8)
	+ & -SQMQQ*3(84D0SH8+432D0SH*7TH+905D0SH6TH2
	+ & +1287D0SH5TH*3+1436D0SH*4TH**4
	+ & +1287D0SH3TH*5+905D0SH2TH6+432D0SHTH*7
	+ & +84D0TH*8)
	+ & +SQMQQ*4SHTH(126D0SH*6+451D0SH*5TH
	+ & +677D0SH4TH2+836D0SH3TH*3+677D0SH2TH*4
	+ & +451D0SHTH*5+126D0TH**6)
	+ & -3D0SQMQQ5(42D0SH6+171D0SH*5TH
	+ & +304D0SH4TH2+362D0SH3TH*3+304D0SH2TH*4
	+ & +171D0SHTH*5+42D0TH**6)
	+ & +2D0SQMQQ6SHTH(42D0SH*4+106D0SH*3TH
	+ & +119D0SH2TH2+106D0SHTH*3+42D0TH**4)
	+ & -SQMQQ*7(35D0SH4+99D0SH*3TH+120D0SH2TH2
	+ & +99D0SHTH*3+35D0TH**4)
	+ & +7D0SQMQQ8SHTH*POLY)/
	+ & (SHTHUHSQMQQRSQMQQ*
	+ & SHTHSHTH2THUHTHUH2UHSH*UHSH2)
	+ ELSE
	+ FF=-5D0PARU(1)AS*3/(SH2TH2*UH2
	+ & SQMQQRSQMQQSHTHSHTH2THUHTHUH2UHSHUHSH2)
	+ AA=SHTHUH(SHTHSHTHPOLY**4
	+ & -SQMQQSHTH2POLY*2
	+ & (SH*4+6D0SH*3TH-6D0SH2TH2+6D0SHTH3+TH4)
	+ & +SQMQQ*2SHTH(5D0SH*8+35D0SH*7TH+49D0SH6TH2
	+ & +57D0SH5TH*3+46D0SH*4TH*4+57D0SH*3TH**5
	+ & +49D0SH2TH*6+35D0SHTH7+5D0TH**8)
	+ & -SQMQQ*3(16D0SH8+104D0SH*7TH+215D0SH6TH2
	+ & +291D0SH5TH*3+316D0SH*4TH*4+291D0SH*3TH**5
	+ & +215D0SH2TH*6+104D0SHTH7+16D0TH**8)
	+ & +SQMQQ*4SHTH(34D0SH*6+145D0SH*5TH
	+ & +211D0SH4TH2+262D0SH3TH*3+211D0SH2TH*4
	+ & +145D0SHTH*5+34D0TH**6)
	+ & -SQMQQ*5(44D0SH6+193D0SH*5TH+346D0SH4TH2
	+ & +410D0SH3TH*3+346D0SH2TH4+193D0SHTH*5
	+ & +44D0TH*6)
	+ & +2D0SQMQQ6SHTH(17D0SH*4+45D0SH*3TH
	+ & +49D0SH2TH2+45D0SHTH*3+17D0TH**4)
	+ & -SQMQQ*7(3D0SH2+2D0SHTH+3D0TH2)
	+ & (5D0SH2+11D0SHTH+5D0*TH2)
	+ & +3D0SQMQQ8SHTH*POLY)
	+ BB=4D0SHTH2POLY**3
	+ & (SH4+SH3TH-SH2TH2+SHTH3+TH4)
	+ & -SQMQQSHTH(20D0SH10+84D0SH*9TH+166D0SH8TH2
	+ & +231D0SH7TH*3+250D0SH*6TH*4+250D0SH*5TH**5
	+ & +250D0SH4TH*6+231D0SH*3TH*7+166D0SH2TH*8
	+ & +84D0SHTH*9+20D0TH**10)
	+ & +SQMQQ*2SHTH2(40D0SH*8+86D0SH*7TH
	+ & +66D0SH6TH2+67D0SH5TH*3+6D0SH*4TH**4
	+ & +67D0SH3TH*5+66D0SH2TH6+86D0SHTH*7
	+ & +40D0TH*8)
	+ & -SQMQQ*3SHTH(40D0SH*8+57D0SH*7TH
	+ & -110D0SH6TH2-263D0SH5TH*3-384D0SH*4TH**4
	+ & -263D0SH3TH*5-110D0SH2TH6+57D0SHTH*7
	+ & +40D0TH*8)
	+ & +SQMQQ*4(20D0SH8-33D0SH*7TH-368D0SH6TH2
	+ & -751D0SH5TH*3-920D0SH*4TH*4-751D0SH*3TH**5
	+ & -368D0SH2TH*6-33D0SHTH7+20D0TH**8)
	+ & -SQMQQ*5SHTH(4D0SH*6-81D0SH*5TH-242D0SH4TH2
	+ & -250D0SH3TH*3-242D0SH2TH4-81D0SHTH*5
	+ & +4D0TH*6)
	+ & -SQMQQ*6SHTH(41D0SH4+120D0SH*3TH
	+ & +142D0SH2TH2+120D0SHTH*3+41D0TH**4)
	+ & +8D0SQMQQ7SHTHSHTH*POLY
	+ CC=4D0TH2POLY**3
	+ & (-SH4-2D0SH*3TH+2D0SH2TH2+3D0SHTH3+TH4)
	+ & -SQMQQTH2(-20D0SH9-56D0SH*8TH-24D0SH7TH2
	+ & +147D0SH6TH*3+409D0SH*5TH*4+599D0SH*4TH**5
	+ & +571D0SH3TH*6+370D0SH2TH7+148D0SHTH*8
	+ & +28D0TH*9)
	+ & +SQMQQ*2(4D0SH10+20D0SH*9TH-16D0SH8TH2
	+ & -48D0SH7TH*3+150D0SH*6TH*4+611D0SH*5TH**5
	+ & +1060D0SH4TH*6+1155D0SH*3TH*7+854D0SH2TH*8
	+ & +394D0SHTH*9+84D0TH**10)
	+ & -SQMQQ*3SHTH(20D0SH*8+68D0SH*7TH-20D0SH6TH2
	+ & +32D0SH5TH*3+286D0SH*4TH*4+577D0SH*3TH**5
	+ & +618D0SH2TH*6+443D0SHTH7+140D0TH**8)
	+ & +SQMQQ*4(40D0SH8+152D0SH*7TH+94D0SH6TH2
	+ & +38D0SH5TH*3+290D0SH*4TH*4+631D0SH*3TH**5
	+ & +738D0SH2TH*6+513D0SHTH7+140D0TH**8)
	+ & -SQMQQ*5(40D0SH7+129D0SH*6TH+53D0SH5TH2
	+ & +7D0SH4TH*3+129D0SH*3TH*4+264D0SH2TH*5
	+ & +266D0SHTH*6+84D0TH**7)
	+ & +SQMQQ*6(20D0SH6+55D0SH*5TH+2D0SH4TH2
	+ & -15D0SH3TH*3+30D0SH2TH4+76D0SHTH*5
	+ & +28D0TH*6)
	+ & -SQMQQ*7SHTH(4D0SH*4+7D0SH*3TH-14D0SH2TH2
	+ & +7D0SHTH*3+4TH**4)
	+ & +SQMQQ*8SH(SH-TH)2TH
	+ DD=2D0TH2SHTH2POLY*3
	+ & (-SH2+2SHTH+2TH2)
	+ & +SQMQQ(4D0SH*11+22D0SH*10TH+70D0SH9TH2
	+ & +115D0SH8TH*3+71D0SH*7TH*4-119D0SH*6TH**5
	+ & -381D0SH5TH*6-552D0SH*4TH*7-512D0SH*3TH**8
	+ & -320D0SH2TH*9-126D0SHTH10-24D0TH**11)
	+ & -SQMQQ*2SHTH(20D0SH*9+84D0SH*8TH
	+ & +212D0SH7TH2+247D0SH6TH*3+105D0SH*5TH**4
	+ & -178D0SH4TH*5-380D0SH*3TH*6-364D0SH2TH*7
	+ & -210D0SHTH*8-60D0TH**9)
	+ & +SQMQQ*3SHTH(40D0SH*8+159D0SH*7TH
	+ & +374D0SH6TH2+404D0SH5TH*3+192D0SH*4TH**4
	+ & -141D0SH3TH*5-264D0SH2TH6-216D0SHTH*7
	+ & -80D0TH*8)
	+ & -SQMQQ*4(40D0SH8+197D0SH*7TH+506D0SH6TH2
	+ & +672D0SH5TH*3+460D0SH*4TH*4+79D0SH*3TH**5
	+ & -138D0SH2TH*6-164D0SHTH7-60D0TH**8)
	+ & +SQMQQ*5(20D0SH7+107D0SH*6TH+267D0SH5TH2
	+ & +307D0SH4TH*3+185D0SH*3TH*4+56D0SH2TH*5
	+ & -30D0SHTH*6-24D0TH**7)
	+ & -SQMQQ*6(4D0SH6+31D0SH*5TH+74D0SH4TH2
	+ & +71D0SH3TH*3+46D0SH2TH4+10D0SHTH*5
	+ & -4D0TH*6)
	+ & +4D0SQMQQ7SHTHSHTH*POLY
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ ENDIF
	+C...Split total contribution into different colour flows just like
	+C...in g g -> g g (recalculate kinematics for massless partons).
	+ THP=-0.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(1D0+CTH)
	+ FACGG1=(SH/THP)*2+2D0SH/THP+3D0+2D0THP/SH+(THP/SH)*2
	+ FACGG2=(UHP/SH)*2+2D0UHP/SH+3D0+2D0SH/UHP+(SH/UHP)*2
	+ FACGG3=(THP/UHP)*2+2D0THP/UHP+3D0+2D0UHP/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)=FACQQGPARP(IONIUM+4)FACGG1/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=21
	+ ISIG(NCHN,2)=21
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+4)FACGG2/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=21
	+ ISIG(NCHN,2)=21
	+ ISIG(NCHN,3)=3
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+4)FACGG3/FACGGS
	+ ENDIF
	+
	+ ELSEIF(ISUB.EQ.425) THEN
	+C...q + g -> q + QQ~[3S18]
	+ IF(MSTP(145).EQ.0) THEN
	+ FACQQG=-COMFACPARU(1)AS*3(1D0/27D0)*
	+ & (4D0(SH2+UH2)-SHUH)*(SHTH2+THUH2)/
	+ & (SQMQQSQMQQRSHUHUHSH2)
	+ ELSE
	+ FF=PARU(1)AS3(4D0(SH2+UH2)-SHUH)/
	+ & (54D0SQMQQSQMQQRSHUH*UHSH2)
	+ AA=SHTH2+THUH2
	+ BB=4D0
	+ CC=8D0
	+ DD=4D0
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+2)FACQG1/FACQGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,ISDE)=I
	+ ISIG(NCHN,3-ISDE)=21
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(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=-COMFACPARU(1)AS*3(5D0/18D0)*
	+ & (SH2+UH2)/(SQMQQRTHUHSH2)
	+ ELSE
	+ FA=-PARU(1)AS3(5D0/54D0)(SH2+UH2)/(SQMQQRTH*UHSH2)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=COMFAC*FA
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=COMFAC2D0FA
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+3)FACQG1/FACQGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,ISDE)=I
	+ ISIG(NCHN,3-ISDE)=21
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(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=-COMFACPARU(1)AS*3(10D0/9D0)*
	+ & ((7D0UHSH+8D0TH)*(SH2+UH2)
	+ & +4D0TH(2D0SQMQQ*2-SHTH2-THUH2))/
	+ & (SQMQQSQMQQRTHUHSH2UHSH)
	+ ELSE
	+ FF=10D0PARU(1)AS**3/
	+ & (9D0SQMQQSQMQQRTH2UHSH2*UHSH)
	+ AA=THUHSH(2D0SQMQQ*2+SHTH2+THUH2)
	+ BB=8D0(SHTH2+THUH)
	+ CC=8D0UHSH(SHTH+THUH)
	+ DD=4D0(2D0SQMQQSH+THUHSH)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+4)FACQG1/FACQGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,ISDE)=I
	+ ISIG(NCHN,3-ISDE)=21
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(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=COMFACPARU(1)AS*3(8D0/81D0)*
	+ & (4D0(TH2+UH2)-THUH)*(SHTH2+UHSH2)/
	+ & (SQMQQSQMQQRTHUHTHUH2)
	+ ELSE
	+ FF=-4D0PARU(1)AS*3(4D0(TH2+UH2)-THUH)/
	+ & (81D0SQMQQSQMQQRTHUH*THUH2)
	+ AA=SHTH2+UHSH2
	+ BB=4D0
	+ CC=4D0
	+ DD=0D0
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+2)FACGG1/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+2)FACGG2/FACGGS
	+ 2447 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.429) THEN
	+C...q + q~ -> g + QQ~[1S08]
	+ IF(MSTP(145).EQ.0) THEN
	+ FACQQG=COMFACPARU(1)AS*3(20D0/27D0)*
	+ & (TH2+UH2)/(SQMQQRSHTHUH2)
	+ ELSE
	+ FA=PARU(1)AS3(20D0/81D0)(TH2+UH2)/(SQMQQRSH*THUH2)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=COMFAC*FA
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=COMFAC2D0FA
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+3)FACGG1/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+3)FACGG2/FACGGS
	+ 2448 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.430) THEN
	+C...q + q~ -> g + QQ~[3PJ8]
	+ IF(MSTP(145).EQ.0) THEN
	+ FACQQG=COMFACPARU(1)AS*3(80D0/27D0)*
	+ & ((7D0THUH+8D0SH)*(TH2+UH2)
	+ & +4D0SH(2D0SQMQQ*2-SHTH2-UHSH2))/
	+ & (SQMQQSQMQQRSHTHUH2THUH)
	+ ELSE
	+ FF=-80D0PARU(1)AS*3/(27D0SQMQQSQMQQRSH2THUH2THUH)
	+ AA=SHTHUH(2D0SQMQQ*2+SHTH2+UHSH2)
	+ BB=8D0(UHSH2+SHTH)
	+ CC=8D0(SHTH2+SHUH)
	+ DD=4D0(SHTH2+UHSH2+SHSQMQQ-SQMQQ**2)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11)))
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K10EL2K10+CCEL1K20*EL2K20
	+ & +DD(EL1K10EL2K20+EL1K20*EL2K10))
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-AA+SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K10+CCEL1K21*EL2K20
	+ & +DD(EL1K11EL2K20+EL1K21*EL2K10))
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=SQMQQ(BBEL1K11EL2K11+CCEL1K21*EL2K21
	+ & +DD(EL1K11EL2K21+EL1K21*EL2K11))
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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.5D0SH(1D0-CTH)
	+ UHP=-0.5D0SH(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)=FACQQGPARP(IONIUM+4)FACGG1/FACGGS
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACQQGPARP(IONIUM+4)FACGG2/FACGGS
	+ 2449 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.431) THEN
	+C...g + g -> QQ~[3P01] + g
	+ PGTW=(SHTH+THUH+UH*SH)/SH2
	+ QGTW=(SHTHUH)/SH**3
	+ RGTW=SQMQQ/SH
	+ IF(MSTP(145).EQ.0) THEN
	+ FACQQG=COMFACPARU(1)AS*38D0/(9D0SQMQQRSH)*
	+ & (9D0RGTW2PGTW*4
	+ & (RGTW*4-2D0RGTW*2PGTW+PGTW**2)
	+ & -6D0RGTWPGTW*3QGTW*
	+ & (2D0RGTW4-5D0RGTW*2PGTW+PGTW**2)
	+ & -PGTW*2QGTW*2(RGTW*4+2D0RGTW*2PGTW-PGTW**2)
	+ & +2D0RGTWPGTWQGTW3(RGTW**2-PGTW)
	+ & +6D0RGTW2QGTW*4)/(QGTW(QGTW-RGTWPGTW)*4)
	+ ELSE
	+ FC1=PARU(1)AS38D0/(27D0SQMQQRSH)*
	+ & (9D0RGTW2PGTW*4
	+ & (RGTW*4-2D0RGTW*2PGTW+PGTW**2)
	+ & -6D0RGTWPGTW*3QGTW*
	+ & (2D0RGTW4-5D0RGTW*2PGTW+PGTW**2)
	+ & -PGTW*2QGTW*2(RGTW*4+2D0RGTW*2PGTW-PGTW**2)
	+ & +2D0RGTWPGTWQGTW3(RGTW**2-PGTW)
	+ & +6D0RGTW2QGTW*4)/(QGTW(QGTW-RGTWPGTW)*4)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=COMFAC*FC1
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=COMFAC2D0FC1
	+ 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=(SHTH+THUH+UH*SH)/SH2
	+ QGTW=(SHTHUH)/SH**3
	+ RGTW=SQMQQ/SH
	+ IF(MSTP(145).EQ.0) THEN
	+ FACQQG=COMFACPARU(1)AS*38D0/(3D0SQMQQRSH)*
	+ & PGTW*2(RGTWPGTW2(RGTW*2-4D0PGTW)
	+ & +2D0QGTW(-RGTW*4+5D0RGTW*2PGTW+PGTW**2)
	+ & -15D0RGTWQGTW*2)/(QGTW-RGTWPGTW)**4
	+ ELSE
	+ FF=4D0/3D0PARU(1)AS*3SQMQQR/SHTH22/THUH22/UHSH2**2
	+ C1=(4D0PGTW5+23D0PGTW*2QGTW**2
	+ & +(-14D0PGTW3QGTW+3D0QGTW3)RGTW
	+ & -(PGTW*4+2D0PGTWQGTW2)RGTW**2
	+ & +3D0PGTW2QGTWRGTW3)SH2**5
	+ C2=2D0SHTH2(SH2THUH(SHTHUH(SH-TH)*(SH-UH)
	+ & -THUH(TH-UH)2)+SH22(TH-UH)(TH2+UH2-SH*THUH)
	+ & (PGTW2-QGTW(SH+2D0*UH)/SH))
	+ C3=2D0UHSH2(SH2THUH(SHTHUH(SH-TH)*(SH-UH)
	+ & -THUH(TH-UH)2)-SH22(TH-UH)(TH2+UH2-SH*THUH)
	+ & (PGTW2-QGTW(SH+2D0*TH)/SH))
	+ C4=-4D0THUH(TH-UH)*2
	+ & (TH*3UH3+SH22(2D0TH+UH)(TH+2D0UH)
	+ & -SH2THUH*(TH2+UH2))
	+ & +4D0THUH2(SH*3(SH22+TH22+UH2**2)
	+ & -SHTHUH(SH22+THUH(TH2-3D0TH*UH+UH2)
	+ & +SH2(5D0THUH2-17D0THUH)))
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	+ & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-C1+C2EL1K11EL2K11+C3EL1K21*EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0)
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	+ & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-C1+C2EL1K11EL2K11+C3EL1K21EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=C2EL1K11EL2K10+C3EL1K21EL2K20
	+ & +C4(EL1K11EL2K20+EL1K21*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=C2EL1K11EL2K11+C3EL1K21EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=(SHTH+THUH+UH*SH)/SH2
	+ QGTW=(SHTHUH)/SH**3
	+ RGTW=SQMQQ/SH
	+ IF(MSTP(145).EQ.0) THEN
	+ FACQQG=COMFACPARU(1)AS*38D0/(9D0SQMQQRSH)*
	+ & (12D0RGTW2PGTW*4
	+ & (RGTW*4-2D0RGTW*2PGTW+PGTW**2)
	+ & -3D0RGTWPGTW*3QGTW*
	+ & (8D0RGTW4-RGTW2PGTW+4D0PGTW*2)
	+ & +2D0PGTW2QGTW*2
	+ & (-7D0RGTW4+43D0RGTW*2PGTW+PGTW**2)
	+ & +RGTWPGTWQGTW*3(16D0RGTW2-61D0PGTW)
	+ & +12D0RGTW2QGTW*4)/(QGTW(QGTW-RGTWPGTW)*4)
	+ ELSE
	+ FF=(16D0PARU(1)AS*3SQMQQ*SQMQQR)/
	+ & (3D0SH2TH2UH2SHTH2*2THUH2*2UHSH2**2)
	+ C1=PGTW*2QGTW(PGTWRGTW-QGTW)*2(RGTW*2-2D0PGTW)
	+ & SHSH2**7
	+ C2=2D0SHTH2(-SH2*3TH23-SH5TH5UH*SHTH
	+ & +SH2*2TH2*2UH2(8D0SHTH2-5D0SHTH)
	+ & +SH*3TH*3UH*3SHTH(17D0SHTH2-2D0SHTH)
	+ & +SH2TH2UH2*2(105D0SH2TH2+64D0SHTH*(SH2+TH2)
	+ & +10D0(SH22+TH2*2))
	+ & +SH2TH2UH*5SHTH(32D0SHTH2+7D0SHTH)
	+ & -UH2*3(SH2*3-87D0SH*3TH3+TH23
	+ & -45D0SH2TH2(SH2+TH2)-5D0SHTH(SH22+TH22))
	+ & +SHTHUH*7SHTH(7D0SHTH2+12D0SHTH)
	+ & +4D0SHTHUH24SHTH2)
	+ C3=2D0UHSH2(-SH2*3UH23-SH5UH5TH*UHSH
	+ & +SH2*2UH2*2TH2(8D0UHSH2-5D0SHUH)
	+ & +SH*3UH*3TH*3UHSH(17D0UHSH2-2D0SHUH)
	+ & +SH2UH2TH2*2(105D0SH2UH2+64D0SHUH*(SH2+UH2)
	+ & +10D0(SH22+UH2*2))
	+ & +SH2UH2TH*5UHSH(32D0UHSH2+7D0SHUH)
	+ & -TH2*3(SH2*3-87D0SH*3UH3+UH23
	+ & -45D0SH2UH2(SH2+UH2)-5D0SHUH(SH22+UH22))
	+ & +SHUHTH*7UHSH(7D0UHSH2+12D0SHUH)
	+ & +4D0SHUHTH24UHSH2)
	+ C4=-2D0SHTHUHSH(-2D0TH2*3UH2**3
	+ & -SH*5TH2UH2THUH(5D0TH+3D0UH)(3D0TH+5D0UH)
	+ & +SH2*3(2D0TH+UH)(TH+2D0UH)(TH2-UH2)**2
	+ & -SHTH22UH2*2THUH(5D0THUH2-4D0THUH)
	+ & -SH2TH3UH*3THUH2(13D0THUH2-16D0THUH)
	+ & -SH*3TH2UH2(92D0TH2UH2*THUH
	+ & +53D0THUH(TH3+UH3)+11D0(TH5+UH5))
	+ & -SH2*2THUH(114D0TH3UH**3
	+ & +83D0TH2UH2(TH2+UH2)+28D0THUH(TH22+UH22)
	+ & +3D0(TH23+UH2*3)))
	+ C5=4D0SHTHUH2SHTH2(2D0SHTH+SHUH+THUH)*2
	+ & (2D0UHSQMQQ2+SHTH(SH*TH-UH2))
	+ C6=4D0SHUHTH2UHSH2(2D0SHUH+SHTH+THUH)*2
	+ & (2D0THSQMQQ2+UHSH(SH*UH-TH2))
	+ C7=4D0SHTHUH2SHTH(SH22TH*3(11D0SH+16D0TH)
	+ & +SH*3TH2UH(31D0SH2+83D0SHTH+61D0TH2)
	+ & +SH2THUH2(19D0SH*3+110D0SH2TH+156D0SH*TH2+
	+ & 82D0TH*3)
	+ & +SHTHUH*3(43D0SH3+132D0SH2TH+124D0SH*TH2
	+ & +45D0TH*3)
	+ & +THUH22(37D0SH3+68D0SH2TH+43D0SH*TH2+
	+ & 8D0TH*3)
	+ & +THUH5(11D0SH2+13D0SHTH+5D0TH2)
	+ & +SH*3UH*3(3D0UHSH2-2D0SH*UH)
	+ & +TH*5UHSH(5D0UHSH2+2D0SHUH))
	+ C8=4D0SHUHTH2UHSH(SH22UH*3(11D0SH+16D0UH)
	+ & +SH*3UH2TH(31D0SH2+83D0SHUH+61D0UH2)
	+ & +SH2UHTH2(19D0SH*3+110D0SH2UH+156D0SH*UH2+
	+ & 82D0UH*3)
	+ & +SHUHTH*3(43D0SH3+132D0SH2UH+124D0SH*UH2
	+ & +45D0UH*3)
	+ & +UHTH22(37D0SH3+68D0SH2UH+43D0SH*UH2+
	+ & 8D0UH*3)
	+ & +UHTH5(11D0SH2+13D0SHUH+5D0UH2)
	+ & +SH*3TH*3(3D0SHTH2-2D0SH*TH)
	+ & +UH*5SHTH(5D0SHTH2+2D0SHTH))
	+ C9=4D0SHTHUHSH(2D0TH*5UH*5THUH
	+ & +4D0SHTH2*2UH2*2THUH2
	+ & -SH2TH3UH*3THUH*(TH2+UH2)
	+ & -2D0SH3TH2UH2(THUH2*2+2D0THUHTHUH2-TH2*UH2)
	+ & +SH2*2THUHTHUH(-THUHTHUH2+3D0(TH22+UH22))
	+ & +SH*5(4D0TH2UH2(THUH2-THUH)
	+ & +5D0THUH(TH22+UH22)+2D0(TH23+UH23)))
	+ C0=-4D0(2D0TH2*3UH2*3SQMQQ
	+ & -SH2TH22UH2*2THUH(19D0THUH2-4D0THUH)
	+ & -SH*3TH*3UH*3THUH2(32D0THUH2+29D0THUH)
	+ & -SH2*2TH2UH2THUH(264D0TH2*UH2
	+ & +136D0THUH(TH2+UH2)+15D0(TH22+UH22))
	+ & +SH*5THUH(-428D0TH3UH**3
	+ & -256D0TH2UH2(TH2+UH2)-43D0THUH(TH22+UH22)
	+ & +2D0(TH23+UH2*3))
	+ & +SH*7(-46D0TH3UH*3-21D0TH2UH2(TH2+UH2)
	+ & +2D0THUH(TH22+UH22)+2D0(TH23+UH23))
	+ & +SH2*3THUH(-134TH*3UH*3-53D0TH2UH2(TH2+UH2)
	+ & +4D0THUH(TH22+UH22)+2D0(TH23+UH23)))
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=1D0/3D0(C13D0
	+ & -C2(2D0EL1K10EL2K10+EL1K11EL2K11)
	+ & -C3(2D0EL1K20EL2K20+EL1K21EL2K21)
	+ & -C4(2D0EL1K10EL2K20+EL1K11EL2K21)
	+ & +C52D0(EL1K10EL2K10-EL1K11EL2K11)**2
	+ & +C62D0(EL1K20EL2K20-EL1K21EL2K21)**2
	+ & +C72D0(EL1K10EL2K10-EL1K11EL2K11)
	+ & (EL1K10EL2K20-EL1K11*EL2K21)
	+ & +C82D0(EL1K20EL2K20-EL1K21EL2K21)
	+ & (EL1K10EL2K20-EL1K11*EL2K21)
	+ & +C92D0(EL1K10EL2K10-EL1K11EL2K11)
	+ & (EL1K20EL2K20-EL1K21*EL2K21)
	+ & +C02D0(EL1K10EL2K20-EL1K11EL2K21)**2)
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=C1*2D0
	+ & -C2(EL1K10EL2K10+EL1K11*EL2K11)
	+ & -C3(EL1K20EL2K20+EL1K21*EL2K21)
	+ & -C4(EL1K10EL2K20+EL1K11*EL2K21)
	+ & +C54D0EL1K10EL2K10EL1K11*EL2K11
	+ & +C64D0EL1K20EL2K20EL1K21*EL2K21
	+ & +C72D0(EL1K10EL2K10EL1K11*EL2K21
	+ & +EL1K10EL2K20EL1K11*EL2K11)
	+ & +C82D0(EL1K20EL2K20EL1K11*EL2K21
	+ & +EL1K10EL2K20EL1K21*EL2K21)
	+ & +C94D0EL1K10EL2K20EL1K11*EL2K21
	+ & +C0(EL1K10EL2K10EL1K21EL2K21
	+ & +2D0EL1K10EL2K20EL1K11EL2K21
	+ & +EL1K20EL2K20EL1K11*EL2K11)
	+ ELSEIF(MSTP(147).EQ.2) THEN
	+ FACQQG=2D0*(C1
	+ & -C2EL1K11EL2K11
	+ & -C3EL1K21EL2K21
	+ & -C4EL1K11EL2K21
	+ & +C5(EL1K11EL2K11)**2
	+ & +C6(EL1K21EL2K21)**2
	+ & +C7EL1K11EL2K11EL1K11EL2K21
	+ & +C8EL1K21EL2K21EL1K11EL2K21
	+ & +(C9+C0)(EL1K11EL2K21)**2)
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=-COMFACPARU(1)AS*3(16D0/81D0)*
	+ & (TH-3D0SQMQQ)2(SH2+UH2)/(SQMQQRTHUHSH2**2)
	+ ELSE
	+ FA=-PARU(1)AS3(16D0/243D0)*
	+ & (TH-3D0SQMQQ)2(SH2+UH2)/(SQMQQRTHUHSH2**2)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=COMFAC*FA
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=COMFAC2D0FA
	+ 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=-COMFACPARU(1)AS*3(32D0/27D0)*
	+ & (4D0SQMQQSHUH+TH(SH2+UH2))/(SQMQQRUHSH2*2)
	+ ELSE
	+ FF=(64D0PARU(1)AS*3SQMQQR)/(27D0UHSH2*2)
	+ C1=SH*UH
	+ C2=2D0*SH
	+ C3=0D0
	+ C4=2D0*(SH-UH)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	+ & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-C1+C2EL1K11EL2K11+C3EL1K21*EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0)
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	+ & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-C1+C2EL1K11EL2K11+C3EL1K21EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=C2EL1K11EL2K10+C3EL1K21EL2K20
	+ & +C4(EL1K11EL2K20+EL1K21*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=C2EL1K11EL2K11+C3EL1K21EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=-COMFACPARU(1)AS*3(32D0/81D0)*
	+ & ((6D0SQMQQ2+TH2)UHSH2
	+ & -2D0SHUH(TH2+6D0SQMQQ*UHSH))/
	+ & (SQMQQRTHUHSH2**2)
	+ ELSE
	+ FF=-(32D0PARU(1)AS*3SQMQQSQMQQR)/(27D0TH2UHSH2*2)
	+ C1=TH*UHSH2
	+ C2=4D0(SH2+TH2+2D0TH*UHSH)
	+ C3=4D0*UHSH2
	+ C4=8D0SHUHSH
	+ 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(C13D0
	+ & -C2(2D0EL1K10EL2K10+EL1K11EL2K11)
	+ & -C3(2D0EL1K20EL2K20+EL1K21EL2K21)
	+ & -C4(2D0EL1K10EL2K20+EL1K11EL2K21)
	+ & +C52D0(EL1K10EL2K10-EL1K11EL2K11)**2
	+ & +C62D0(EL1K20EL2K20-EL1K21EL2K21)**2
	+ & +C72D0(EL1K10EL2K10-EL1K11EL2K11)
	+ & (EL1K10EL2K20-EL1K11*EL2K21)
	+ & +C82D0(EL1K20EL2K20-EL1K21EL2K21)
	+ & (EL1K10EL2K20-EL1K11*EL2K21)
	+ & +C92D0(EL1K10EL2K10-EL1K11EL2K11)
	+ & (EL1K20EL2K20-EL1K21*EL2K21)
	+ & +C02D0(EL1K10EL2K20-EL1K11EL2K21)**2)
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=C1*2D0
	+ & -C2(EL1K10EL2K10+EL1K11*EL2K11)
	+ & -C3(EL1K20EL2K20+EL1K21*EL2K21)
	+ & -C4(EL1K10EL2K20+EL1K11*EL2K21)
	+ & +C54D0EL1K10EL2K10EL1K11*EL2K11
	+ & +C64D0EL1K20EL2K20EL1K21*EL2K21
	+ & +C72D0(EL1K10EL2K10EL1K11*EL2K21
	+ & +EL1K10EL2K20EL1K11*EL2K11)
	+ & +C82D0(EL1K20EL2K20EL1K11*EL2K21
	+ & +EL1K10EL2K20EL1K21*EL2K21)
	+ & +C94D0EL1K10EL2K20EL1K11*EL2K21
	+ & +C0(EL1K10EL2K10EL1K21EL2K21
	+ & +2D0EL1K10EL2K20EL1K11EL2K21
	+ & +EL1K20EL2K20EL1K11*EL2K11)
	+ ELSEIF(MSTP(147).EQ.2) THEN
	+ FACQQG=2D0*(C1
	+ & -C2EL1K11EL2K11
	+ & -C3EL1K21EL2K21
	+ & -C4EL1K11EL2K21
	+ & +C5(EL1K11EL2K11)**2
	+ & +C6(EL1K21EL2K21)**2
	+ & +C7EL1K11EL2K11EL1K11EL2K21
	+ & +C8EL1K21EL2K21EL1K11EL2K21
	+ & +(C9+C0)(EL1K11EL2K21)**2)
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=COMFACPARU(1)AS*3(128D0/243D0)*
	+ & (SH-3D0SQMQQ)2(TH2+UH2)/(SQMQQRSHTHUH2**2)
	+ ELSE
	+ FA=PARU(1)AS3(128D0/729D0)*
	+ & (SH-3D0SQMQQ)2(TH2+UH2)/(SQMQQRSHTHUH2**2)
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=COMFAC*FA
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=COMFAC2D0FA
	+ 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=COMFACPARU(1)AS*3256D0/81D0*
	+ & (4D0SQMQQTHUH+SH(TH2+UH2))/(SQMQQRTHUH2*2)
	+ ELSE
	+ FF=-(512D0PARU(1)AS*3SQMQQR)/(81D0THUH2*2)
	+ C1=TH*UH
	+ C2=2D0*UH
	+ C3=2D0*TH
	+ C4=2D0*THUH
	+ IF(MSTP(147).EQ.0) THEN
	+ FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	+ & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=2D0(-C1+C2EL1K11EL2K11+C3EL1K21*EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0)
	+ ELSEIF(MSTP(147).EQ.3) THEN
	+ FACQQG=-C1+C2EL1K10EL2K10+C3EL1K20EL2K20
	+ & +C4(EL1K10EL2K20+EL1K20*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.4) THEN
	+ FACQQG=-C1+C2EL1K11EL2K11+C3EL1K21EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	+ ELSEIF(MSTP(147).EQ.5) THEN
	+ FACQQG=C2EL1K11EL2K10+C3EL1K21EL2K20
	+ & +C4(EL1K11EL2K20+EL1K21*EL2K10)/2D0
	+ ELSEIF(MSTP(147).EQ.6) THEN
	+ FACQQG=C2EL1K11EL2K11+C3EL1K21EL2K21
	+ & +C4(EL1K11EL2K21+EL1K21*EL2K11)/2D0
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=COMFACPARU(1)AS*3(256D0/243D0)*
	+ & ((6D0SQMQQ2+SH2)THUH2
	+ & -2D0THUH(SH2+6D0SQMQQ*THUH))/
	+ & (SQMQQRSHTHUH2**2)
	+ ELSE
	+ FF=(256D0PARU(1)AS*3SQMQQSQMQQR)/(81D0SH2THUH2*2)
	+ C1=SH*THUH2
	+ C2=4D0(SH2+UH2+2D0SH*THUH)
	+ C3=4D0(SH2+TH2+2D0SH*THUH)
	+ C4=8D0(SH2-THUH+2D0SHTHUH)
	+ 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(C13D0
	+ & -C2(2D0EL1K10EL2K10+EL1K11EL2K11)
	+ & -C3(2D0EL1K20EL2K20+EL1K21EL2K21)
	+ & -C4(2D0EL1K10EL2K20+EL1K11EL2K21)
	+ & +C52D0(EL1K10EL2K10-EL1K11EL2K11)**2
	+ & +C62D0(EL1K20EL2K20-EL1K21EL2K21)**2
	+ & +C72D0(EL1K10EL2K10-EL1K11EL2K11)
	+ & (EL1K10EL2K20-EL1K11*EL2K21)
	+ & +C82D0(EL1K20EL2K20-EL1K21EL2K21)
	+ & (EL1K10EL2K20-EL1K11*EL2K21)
	+ & +C92D0(EL1K10EL2K10-EL1K11EL2K11)
	+ & (EL1K20EL2K20-EL1K21*EL2K21)
	+ & +C02D0(EL1K10EL2K20-EL1K11EL2K21)**2)
	+ ELSEIF(MSTP(147).EQ.1) THEN
	+ FACQQG=C1*2D0
	+ & -C2(EL1K10EL2K10+EL1K11*EL2K11)
	+ & -C3(EL1K20EL2K20+EL1K21*EL2K21)
	+ & -C4(EL1K10EL2K20+EL1K11*EL2K21)
	+ & +C54D0EL1K10EL2K10EL1K11*EL2K11
	+ & +C64D0EL1K20EL2K20EL1K21*EL2K21
	+ & +C72D0(EL1K10EL2K10EL1K11*EL2K21
	+ & +EL1K10EL2K20EL1K11*EL2K11)
	+ & +C82D0(EL1K20EL2K20EL1K11*EL2K21
	+ & +EL1K10EL2K20EL1K21*EL2K21)
	+ & +C94D0EL1K10EL2K20EL1K11*EL2K21
	+ & +C0(EL1K10EL2K10EL1K21EL2K21
	+ & +2D0EL1K10EL2K20EL1K11EL2K21
	+ & +EL1K20EL2K20EL1K11*EL2K11)
	+ ELSEIF(MSTP(147).EQ.2) THEN
	+ FACQQG=2D0*(C1
	+ & -C2EL1K11EL2K11
	+ & -C3EL1K21EL2K21
	+ & -C4EL1K11EL2K21
	+ & +C5(EL1K11EL2K11)**2
	+ & +C6(EL1K21EL2K21)**2
	+ & +C7EL1K11EL2K11EL1K11EL2K21
	+ & +C8EL1K21EL2K21EL1K11EL2K21
	+ & +(C9+C0)(EL1K11EL2K21)**2)
	+ ENDIF
	+ FACQQG=COMFACFFFACQQG
	+ 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=4D0COMFAC3D0
	+ HP0=AEM/3D0*SH
	+ HP1=AEM/3D0XWCSH
	+ 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-4D0EIXWV
	+ 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(EI2/SH2HI0HP0VINT(111)+
	+ & EIVI(1D0-SQMZ/SH)/((SH-SQMZ)2+HS2)*
	+ & (HI0HP1+HI1HP0)VINT(112)+(VI2+AI*2)/
	+ & ((SH-SQMZ)2+HS2)HI1HP1*VINT(114))
	+ 100 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.2) THEN
	+C...f + fbar' -> W+/-
	+ CALL PYWIDT(24,SH,WDTP,WDTE)
	+ HS=SHR*WDTP(0)
	+ FACBW=4D0COMFAC/((SH-SQMW)2+HS2)3D0
	+ HP=AEM/(24D0XW)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=HIVCKM((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)=HIFACBWHF
	+ 110 CONTINUE
	+ 120 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.15) THEN
	+C...f + fbar -> g + (gamma/Z0) (q + qbar -> g + (gamma/Z0) only)
	+ FACZG=COMFACASAEM(8D0/9D0)(TH2+UH2+2D0SQM4SH)/(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-4D0EFXWV
	+ ELSEIF(I.LE.16) THEN
	+ EF=KCHG(I+2,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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+FCOFEF2(1D0+2D0RM1)BE34
	+ HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	+ HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	+ & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	+ HFGZ=HFGZHFAEMVINT(112)/SQM4
	+ HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACZG(EI2HFGG+EIVIHFGZ+
	+ & (VI2+AI2)*HFZZ)/HBW4
	+ 140 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.16) THEN
	+C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
	+ FACWG=COMFACASAEM/XW2D0/9D0(TH2+UH2+2D0SQM4SH)/(TH*UH)
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
	+ GMMWC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	+ 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)=FACWGFCKMWIDSC
	+ 150 CONTINUE
	+ 160 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.19) THEN
	+C...f + fbar -> gamma + (gamma*/Z0)
	+ FACGZ=COMFAC2D0AEM*2(TH2+UH2+2D0SQM4SH)/(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-4D0EFXWV
	+ ELSEIF(I.LE.16) THEN
	+ EF=KCHG(I+2,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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+FCOFEF2(1D0+2D0RM1)BE34
	+ HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	+ HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	+ & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	+ HFGZ=HFGZHFAEMVINT(112)/SQM4
	+ HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	+ 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)=FACGZFCOIEI*2(EI*2HFGG+EIVIHFGZ+
	+ & (VI2+AI2)*HFZZ)/HBW4
	+ 180 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.20) THEN
	+C...f + fbar' -> gamma + W+/-
	+ FACGW=COMFAC0.5D0AEM**2/XW
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
	+ GMMWC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	+ FACGW=FACGW*HBW4C/HBW4
	+C...Anomalous couplings
	+ TERM1=(TH2+UH2+2D0SQM4SH)/(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.5D0RTCM(46)2(THUH+(TH2+UH2)SH/
	+ & (4D0SQMW))/(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=TERM1FACWR2+TERM2FACWR+TERM3
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACGWFACWKFCOIFCKMWIDSC
	+ 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=COMFACAEM2((TH2+UH2+2D0(SQM3+SQM4)SH)/(TH*UH)-
	+ & SQM3SQM4(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-4D0EFXWV
	+ ELSEIF(I.LE.16) THEN
	+ EF=KCHG(I+2,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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)+FCOFEF2(1D0+2D0RM1)BE34
	+ HGZ(2,IMDM)=HGZ(2,IMDM)+FCOFEFVF(1D0+2D0RM1)*BE34
	+ HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF(VF2(1D0+2D0*RM1)+
	+ & AF*2(1D0-4D0RM1))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)+FCOFEF2(1D0+2D0RM1)BE34
	+ HGZ(5,IMDM)=HGZ(5,IMDM)+FCOFEFVF(1D0+2D0RM1)*BE34
	+ HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF(VF2(1D0+2D0*RM1)+
	+ & AF*2(1D0-4D0RM1))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)HFAEMVINT(111)/SQM3
	+ HGZ(2,J)=HGZ(2,J)HFAEMVINT(112)/SQM3
	+ HGZ(3,J)=HGZ(3,J)HFAEMVINT(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)HFAEMVINT(111)/SQM4
	+ HGZ(5,J)=HGZ(5,J)HFAEMVINT(112)/SQM4
	+ HGZ(6,J)=HGZ(6,J)HFAEMVINT(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-4D0EIXWV
	+ VALI=VI-AI
	+ VARI=VI+AI
	+ FCOI=1D0
	+ IF(IABS(I).LE.10) FCOI=FACA/3D0
	+ DO 260 J=1,3
	+ HL3(J)=EI*2HGZ(1,J)+EIVALIHGZ(2,J)+VALI*2HGZ(3,J)
	+ HR3(J)=EI*2HGZ(1,J)+EIVARIHGZ(2,J)+VARI*2HGZ(3,J)
	+ HL4(J)=EI*2HGZ(4,J)+EIVALIHGZ(5,J)+VALI*2HGZ(6,J)
	+ HR4(J)=EI*2HGZ(4,J)+EIVARIHGZ(5,J)+VARI*2HGZ(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.5D0FACZZFCOIFACLR/(HBW3HBW4)
	+ 270 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.23) THEN
	+C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
	+ FACZW=COMFAC0.5D0(AEM/XW)**2
	+ FACZW=FACZW*WIDS(23,2)
	+ THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	+ FACBW=1D0/((SH-SQMW)2+GMMW2)
	+ 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-4D0EIXWV
	+ EJ=KCHG(JA,1)/3D0
	+ AJ=SIGN(1D0,EJ+0.1D0)
	+ VJ=AJ-4D0EJXWV
	+ 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)=FACZWFCOIFCKM(FACBW((9D0-8D0XW)/4D0THUH+
	+ & (8D0XW-6D0)/4D0SH(SQM3+SQM4))+(THUH-SH(SQM3+SQM4))*
	+ & (SH-SQMW)FACBW0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
	+ & THUH/(16D0XW1)((VJ+AJ)2/TH2+(VI+AI)2/UH2)+
	+ & SH(SQM3+SQM4)/(8D0XW1)(VI+AI)(VJ+AJ)/(THUH))
	+ & 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=SH2/((SH-SQMZ)2+GMMZC**2)
	+ HBW3=GMMW/((SQM3-SQMW)2+GMMW2)
	+ CALL PYWIDT(24,SQM3,WDTP,WDTE)
	+ GMMW3=SQRT(SQM3)*WDTP(0)
	+ HBW3C=GMMW3/((SQM3-SQMW)2+GMMW32)
	+ HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
	+ GMMW4=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMW4/((SQM4-SQMW)2+GMMW42)
	+C...Kinematical functions
	+ THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	+ THUH34=(2D0SH(SQM3+SQM4)+THUH)/(SQM3*SQM4)
	+ GS=(((SH-SQM3-SQM4)*2-4D0SQM3SQM4)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/(4D0XW)HBWZC(1D0-SQMZ/SH)
	+ CZZ=AEM*2/(32D0XW*2)HBWZC
	+ CNG=AEM*2/(4D0XW)
	+ CNZ=AEM*2/(16D0XW*2)HBWZC*(1D0-SQMZ/SH)
	+ CNN=AEM*2/(16D0XW**2)
	+C...Coulomb factor for W+W- pair
	+ IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
	+ COULE=(SH-4D0SQMW)/(4D0PMAS(24,1))
	+ COULP=MAX(1D-10,0.5D0BE34SQRT(SH))
	+ IF(COULE.LT.100D0*PMAS(24,2)) THEN
	+ COULP1=SQRT(0.5D0PMAS(24,1)(SQRT(COULE**2+
	+ & PMAS(24,2)**2)-COULE))
	+ ELSE
	+ COULP1=SQRT(0.5D0PMAS(24,1)(0.5D0PMAS(24,2)*2/COULE))
	+ ENDIF
	+ IF(COULE.GT.-100D0*PMAS(24,2)) THEN
	+ COULP2=SQRT(0.5D0PMAS(24,1)(SQRT(COULE**2+
	+ & PMAS(24,2)**2)+COULE))
	+ ELSE
	+ COULP2=SQRT(0.5D0PMAS(24,1)(0.5D0PMAS(24,2)*2/
	+ & ABS(COULE)))
	+ ENDIF
	+ IF(MSTP(40).EQ.1) THEN
	+ COULDC=PARU(1)-2D0ATAN((COULP12+COULP22-COULP*2)/
	+ & MAX(1D-10,2D0COULPCOULP1))
	+ FACCOU=1D0+0.5D0PARU(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))/
	+ & (4D0COULCP)LOG(COULCD)
	+ COULCS=DCMPLX(0D0,0D0)
	+ NSTP=100
	+ DO 300 ISTP=1,NSTP
	+ COULXX=(ISTP-0.5)/NSTP
	+ COULCS=COULCS+(1D0/COULXX)LOG((1D0+COULXXCOULCD)/
	+ & (1D0+COULXX/COULCD))
	+ 300 CONTINUE
	+ COULCR=COULCR+DBLE(PARU(101)*2SH)/(16D0COULCPCOULCK)*
	+ & (COULCS/NSTP)
	+ FACCOU=ABS(COULCR)**2
	+ ELSEIF(MSTP(40).EQ.3) THEN
	+ COULDC=PARU(1)-2D0(1D0-BE34)2ATAN((COULP1**2+
	+ & COULP22-COULP2)/MAX(1D-10,2D0COULPCOULP1))
	+ FACCOU=1D0+0.5D0PARU(101)COULDC/MAX(1D-5,BE34)
	+ ENDIF
	+ ELSEIF(MSTP(40).EQ.4) THEN
	+ FACCOU=1D0+0.5D0PARU(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-4D0EIXWV
	+ 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=(CGGEI2+CGZVIEI+CZZ(VI2+AI2))*GS+
	+ & (CNGEI+CNZ(VI+AI))GST+CNNGT
	+ ELSE
	+ DSIGWW=(CGGEI2+CGZVIEI+CZZ(VI2+AI2))*GS-
	+ & (CNGEI+CNZ(VI+AI))GSU+CNNGU
	+ 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+(4D0BET2GAT2+3D0/GAT2)*STHE2)
	+ AMPNU=BET(2D0+BET2GAT*2STHE2/2D0+
	+ & 2D0BET2(1D0-BET*2)STHE2/(1D0-2D0BETCTH+BET2)2)
	+ AMPNG=BET((1D0+BET2)(4D0+BET*2GAT*2STHE2)+
	+ & 2D0(1D0-BET2)(BET*2STHE2-2D0(1D0-BET*2))/
	+ & (1D0-2D0BETCTH+BET**2))
	+ PROPI1=(0.25D0SQMZ/XMW02)HBWZC*(1D0-SQMZ/SH)
	+ PROPI2=(0.25D0SQMZ/XMW02)2HBWZC
	+ A0=(2D0(XMW02/SQMZ)-(1D0-BET2)XW)*POLL
	+ A1=(2D0(XMW02/SQMZ)2-2XMW02/SQMZ(1D0-BET2)XW)*POLL
	+ A2=(1D0-BET2)2XW2(POLR+POLL)/2D0
	+ ATOT=AMPNUPOLL+(A1+A2)PROPI2AMPZG-A0PROPI1*AMPNG
	+ ATOT=ATOTCNN/SQMWSH/BET*2D0
	+ DSIGWW=ATOT
	+ ENDIF
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACWWFCOIDSIGWW
	+ 310 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.30) THEN
	+C...f + g -> f + (gamma/Z0) (q + g -> q + (gamma/Z0) only)
	+ FZQ=COMFACFACAASAEM(1D0/3D0)(SH2+UH2+2D0SQM4*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-4D0EFXWV
	+ ELSEIF(I.LE.16) THEN
	+ EF=KCHG(I+2,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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+FCOFEF2(1D0+2D0RM1)BE34
	+ HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	+ HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	+ & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	+ HFGZ=HFGZHFAEMVINT(112)/SQM4
	+ HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	+ FACZQ=FZQ(EI2HFGG+EIVIHFGZ+
	+ & (VI2+AI2)*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=COMFACFACAASAEM/XW1D0/12D0*
	+ & (SH2+UH2+2D0SQM4TH)/(-SH*UH)
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
	+ GMMWC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	+ 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)=FACWQVINT(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)*2SQM4-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)*2SQM4-SH(UH-VINT(3)*2)
	+ ELSE
	+ FZQN=SH2+UH2+2D0SQM4TH
	+ FZQDTM=-SH*UH
	+ ENDIF
	+ FZQN=COMFAC2D0AEM*2MAX(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-4D0EFXWV
	+ ELSEIF(I.LE.16) THEN
	+ EF=KCHG(I+2,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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+FCOFEF2(1D0+2D0RM1)BE34
	+ HFGZ=HFGZ+FCOFEFVF(1D0+2D0RM1)*BE34
	+ HFZZ=HFZZ+FCOF(VF2(1D0+2D0*RM1)+
	+ & AF*2(1D0-4D0RM1))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=HFGGHFAEMVINT(111)/SQM4
	+ HFGZ=HFGZHFAEMVINT(112)/SQM4
	+ HFZZ=HFZZHFAEMVINT(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-4D0EIXWV
	+ FACZQ=EI*2(EI*2HFGG+EIVIHFGZ+
	+ & (VI2+AI2)*HFZZ)/HBW4
	+ FZQD=MAX(PMAS(IABS(I),1)*2SQM4,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=COMFACAEM2/(2D0XW)*
	+ & (SH2+UH2+2D0SQM4TH)/(SQPTHSQM4-SHUH)
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMW/((SQM4-SQMW)2+GMMW2)
	+ CALL PYWIDT(24,SQM4,WDTP,WDTE)
	+ GMMWC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMWC/((SQM4-SQMW)2+GMMWC2)
	+ 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)=FACWQVINT(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.5D0SQMW,SQRT(SQM3SQM4))
	+ FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
	+ FACWW=COMFAC6D0AEM*2(1D0-FPROP(4D0/3D0+2D0SQMWE/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.5D0SQMW,SQRT(SQM3SQM4))
	+ FPROP=(TH-SQMWE)*2/(-SH(SQMWE-UH))
	+ FACZW=COMFAC6D0AEM*2(XW1/XW)*
	+ & (1D0-FPROP(4D0/3D0+2D0SQMWE/(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,24KCHW).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/(288D0PARU(1)2)+(PARP(47)/PARP(45))2)
	+ HDTLQ=LOG(PARP(45)/PARP(44))
	+ HDTMR=-(4D0PARU(1))20.5D0*HDTNM+HDTLQ/12D0
	+ HDTNR=(4D0PARU(1))2HDTNM+HDTLQ/6D0
	+ ENDIF
	+
	+C...Calculate lowest and next-to-lowest order partial wave amplitudes
	+ HDTV=1D0/(16D0PARU(1)PARP(47)**2)
	+ A00L=DBLE(HDTV*SH)
	+ A20L=-0.5D0*A00L
	+ A11L=A00L/6D0
	+ HDTLS=LOG(SH/PARP(44)**2)
	+ A004=DBLE((HDTVSH)2/(4D0PARU(1)))*
	+ & CMPLX(DBLE((176D0HDTMR+112D0HDTNR)/3D0+11D0/27D0-
	+ & (50D0/9D0)HDTLS),DBLE(4D0PARU(1)))
	+ A204=DBLE((HDTVSH)2/(4D0PARU(1)))*
	+ & CMPLX(DBLE(32D0(HDTMR+2D0HDTNR)/3D0+25D0/54D0-
	+ & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
	+ A114=DBLE((HDTVSH)2/(6D0PARU(1)))*
	+ & CMPLX(DBLE(4D0(-2D0HDTMR+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=4D0COMFAC/((SH-SQMH)2+HS*2)
	+ IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
	+ & FACBW=0D0
	+ HP=AEM/(8D0XW)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=HPRMQFACA/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=HIPARU(150+10IHIGG+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+10IHIGG))*2
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=HIFACBWHF
	+ 100 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.5) THEN
	+C...Z0 + Z0 -> h0
	+ CALL PYWIDT(25,SH,WDTP,WDTE)
	+ HS=SHR*WDTP(0)
	+ FACBW=4D0COMFAC/((SH-SQMH)2+HS*2)
	+ IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
	+ HP=AEM/(8D0XW)SH/SQMW*SH
	+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
	+ HI=HP/4D0
	+ FACI=8D0/(PARU(1)*2XW1)(AEMXWC)**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-4D0EIXWV
	+ EJ=KCHG(IABS(J),1)/3D0
	+ AJ=SIGN(1D0,EJ)
	+ VJ=AJ-4D0EJXWV
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACI(VI2+AI2)(VJ2+AJ2)HIFACBW*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=4D0COMFAC/((SH-SQMH)2+HS*2)
	+ IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
	+ HP=AEM/(8D0XW)SH/SQMW*SH
	+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
	+ HI=HP/2D0
	+ FACI=1D0/(4D0PARU(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)=FACIVINT(180+I)VINT(180+J)HIFACBW*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+GMMZ2)
	+ CALL PYWIDT(23,SQM3,WDTP,WDTE)
	+ GMMZ3=SQRT(SQM3)*WDTP(0)
	+ HBW3C=GMMZ3/((SQM3-SQMZ)2+GMMZ32)
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
	+ GMMH4=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	+ THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	+ FACHZ=COMFAC(HBW3C/HBW3)(HBW4C/HBW4)8D0(AEMXWC)2
	+ & (THUH+2D0SHSQM3)/((SH-SQMZ)2+GMMZ2)
	+ FACHZ=FACHZWIDS(23,2)WIDS(KFHIGG,2)
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
	+ & PARU(154+10IHIGG)*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-4D0EIXWV
	+ 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)=FACHZFCOI(VI2+AI2)
	+ 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+GMMW2)
	+ CALL PYWIDT(24,SQM3,WDTP,WDTE)
	+ GMMW3=SQRT(SQM3)*WDTP(0)
	+ HBW3C=GMMW3/((SQM3-SQMW)2+GMMW32)
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
	+ GMMH4=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	+ THUH=MAX(THUH-SQM3SQM4,SHCKIN(3)*2)
	+ FACHW=COMFAC0.125D0(AEM/XW)*2(THUH+2D0SHSQM3)/
	+ & ((SH-SQMW)2+GMMW2)(HBW3C/HBW3)(HBW4C/HBW4)
	+ FACHW=FACHW*WIDS(KFHIGG,2)
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
	+ & PARU(155+10IHIGG)*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)=FACHWFCOIFCKM*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=COMFACFACAASAEM/XW1D0/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+GMMHC2)
	+ CALL PYWIDT(25,SQM4,WDTP,WDTE)
	+ GMMHCC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMHCC/((SQM4-SQMHC)2+GMMHCC2)
	+ 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=FHCQSQML/SQMW
	+ & (SH/(SQMQ-UH)+2D0SQMQ(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
	+ & 2D0SQMQ/(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.5D0SHBE2*(1D0-CTH)
	+ UH=-0.5D0SHBE2*(1D0+CTH)
	+ IF(MAX(TH,UH).GT.-1D0) GOTO 220
	+ SHANG=1D0/XW1SQMW/SQMZ(1D0+BE2)**2
	+ ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	+ ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	+ THANG=1D0/XW1SQMW/SQMZ(BE2-CTH)**2
	+ ATHRE=(TH-SQMH)/((TH-SQMH)2+GMMH2)*THANG
	+ ATHIM=-GMMH/((TH-SQMH)2+GMMH2)*THANG
	+ UHANG=1D0/XW1SQMW/SQMZ(BE2+CTH)**2
	+ AUHRE=(UH-SQMH)/((UH-SQMH)2+GMMH2)*UHANG
	+ AUHIM=-GMMH/((UH-SQMH)2+GMMH2)*UHANG
	+ FACZZ=COMFAC1D0/(4096D0PARU(1)*216D0XW12)
	+ & (AEM/XW)*4(SH/SQMW)*2(SQMZ/SQMW)*SH2
	+ IF(MSTP(46).LE.0) FACZZ=FACZZ(ASHRE2+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/(16D0PARU(1)XWXW1))*2(64D0/9D0)*
	+ & ABS(A00U+2D0A20U)*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-4D0EIXWV
	+ AVI=AI2+VI2
	+ 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-4D0EJXWV
	+ AVJ=AJ2+VJ2
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=0.5D0FACZZAVI*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-4D0SQMW/SH)(1D0-4D0*SQMZ/SH))
	+ CTH2=CTH**2
	+ TH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH-BE2CTH)
	+ UH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH+BE2CTH)
	+ IF(MAX(TH,UH).GT.-1D0) GOTO 250
	+ SHANG=4D0SQRT(SQMW/(SQMZXW1))(1D0-2D0SQMW/SH)*
	+ & (1D0-2D0*SQMZ/SH)
	+ ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	+ ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	+ ATWRE=XW1/SQMZSH/(TH-SQMW)((CTH-BE2)*2(3D0/2D0+BE2/2D0*
	+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	+ & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	+ & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2+
	+ & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	+ ATWIM=0D0
	+ AUWRE=XW1/SQMZSH/(UH-SQMW)((CTH+BE2)*2(3D0/2D0-BE2/2D0*
	+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	+ & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	+ & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2-
	+ & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	+ AUWIM=0D0
	+ A4RE=2D0XW1/SQMZ(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
	+ A4IM=0D0
	+ FACWW=COMFAC1D0/(4096D0PARU(1)*216D0XW12)
	+ & (AEM/XW)*4(SH/SQMW)*2(SQMZ/SQMW)*SH2
	+ IF(MSTP(46).LE.0) FACWW=FACWW(ASHRE2+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/(16D0PARU(1)XWXW1))*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-4D0EIXWV
	+ AVI=AI2+VI2
	+ 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-4D0EJXWV
	+ AVJ=AJ2+VJ2
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACWWAVIAVJ
	+ 230 CONTINUE
	+ 240 CONTINUE
	+ 250 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.73) THEN
	+C...Z0 + W+/- -> Z0 + W+/-
	+ IF(SH.LE.2D0SQMZ+2D0SQMW) 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.5D0SHBE2*(1D0-CTH)
	+ UH=(SQMZ-SQMW)*2/SH-0.5D0SHBE2(1D0+CTH)
	+ IF(MAX(TH,UH).GT.-1D0) GOTO 280
	+ THANG=(BE2-EP1CTH)(BE2-EP2*CTH)
	+ ATHRE=(TH-SQMH)/((TH-SQMH)2+GMMH2)*THANG
	+ ATHIM=-GMMH/((TH-SQMH)2+GMMH2)*THANG
	+ ASWRE=-XW1/SQMZSH/(SH-SQMW)(-BE2(EP1+EP2)4CTH+
	+ & 1D0/4D0(BE2+EP1EP2)*2((EP1-EP2)*2-4D0BE2*CTH)+
	+ & 2D0BE2(BE2+EP1EP2)(EP1+EP2)*2CTH-
	+ & 1D0/16D0SH/SQMW(EP12-EP22)*2(BE2+EP1EP2)*2)
	+ ASWIM=0D0
	+ AUWRE=XW1/SQMZSH/(UH-SQMW)(-BE2(EP2+EP1CTH)*
	+ & (EP1+EP2CTH)(BE2+EP1EP2)+BE2(EP2+EP1CTH)
	+ & (BE2+EP1EP2CTH)(2D0EP2-EP2*CTH+EP1)-
	+ & BE2(EP2+EP1CTH)*2(BE2-EP2*2CTH)-1D0/8D0*
	+ & (BE2+EP1EP2CTH)*2((EP1+EP2)*2+2D0BE2*(1D0-CTH))+
	+ & 1D0/32D0SH/SQMW(BE2+EP1EP2CTH)*2
	+ & (EP12-EP22)*2-BE2(EP1+EP2CTH)(EP2+EP1CTH)
	+ & (BE2+EP1EP2)+BE2(EP1+EP2CTH)(BE2+EP1EP2CTH)*
	+ & (2D0EP1-EP1CTH+EP2)-BE2(EP1+EP2CTH)*2
	+ & (BE2-EP1*2CTH)-1D0/8D0(BE2+EP1EP2CTH)2
	+ & ((EP1+EP2)*2+2D0BE2(1D0-CTH))+1D0/32D0SH/SQMW*
	+ & (BE2+EP1EP2CTH)*2(EP12-EP22)**2)
	+ AUWIM=0D0
	+ A4RE=XW1/SQMZ(EP12EP2*2(CTH**2-1D0)-
	+ & 2D0BE2(EP12+EP22+EP1EP2)CTH-2D0BE2EP1*EP2)
	+ A4IM=0D0
	+ FACZW=COMFAC1D0/(4096D0PARU(1)*24D0XW1)(AEM/XW)*4
	+ & (SH/SQMW)*2SQRT(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=COMFACAEM2/(64D0PARU(1)*2XW*2XW1)16D0
	+ & ABS(A20U+3D0A11UDBLE(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-4D0EIXWV
	+ AVI=AI2+VI2
	+ 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-4D0EJXWV
	+ AVJ=AJ2+VJ2
	+ 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)=FACZWAVIVINT(180+J)*WIDS(24,(5-KCHWJ)/2)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=FACZWVINT(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-4D0SQMW/SH)(1D0-4D0*SQMZ/SH))
	+ CTH2=CTH**2
	+ TH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH-BE2CTH)
	+ UH=-0.5D0SH(1D0-2D0(SQMW+SQMZ)/SH+BE2CTH)
	+ IF(MAX(TH,UH).GT.-1D0) GOTO 310
	+ SHANG=4D0SQRT(SQMW/(SQMZXW1))(1D0-2D0SQMW/SH)*
	+ & (1D0-2D0*SQMZ/SH)
	+ ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	+ ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	+ ATWRE=XW1/SQMZSH/(TH-SQMW)((CTH-BE2)*2(3D0/2D0+BE2/2D0*
	+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	+ & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	+ & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2+
	+ & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	+ ATWIM=0D0
	+ AUWRE=XW1/SQMZSH/(UH-SQMW)((CTH+BE2)*2(3D0/2D0-BE2/2D0*
	+ & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)*2/(SHSQMW))+4D0*
	+ & ((SQMW+SQMZ)/SH(1D0-3D0CTH2)+8D0SQMWSQMZ/SH2*
	+ & (2D0CTH2-1D0)+4D0(SQMW2+SQMZ2)/SH2*CTH2-
	+ & 2D0(SQMW+SQMZ)/SHBE2*CTH))
	+ AUWIM=0D0
	+ A4RE=2D0XW1/SQMZ(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
	+ A4IM=0D0
	+ FACZZ=COMFAC1D0/(4096D0PARU(1)*2)(AEM/XW)*4
	+ & (SH/SQMW)*2SH2
	+ IF(MSTP(46).LE.0) FACZZ=FACZZ(ASHRE2+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/(4D0PARU(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.5D0FACZZVINT(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.5D0SHBE2*(1D0-CTH)
	+ UH=-0.5D0SHBE2*(1D0+CTH)
	+ IF(MAX(TH,UH).GT.-1D0) GOTO 340
	+ SHANG=(1D0+BE2)**2
	+ ASHRE=(SH-SQMH)/((SH-SQMH)2+GMMH2)*SHANG
	+ ASHIM=-GMMH/((SH-SQMH)2+GMMH2)*SHANG
	+ THANG=(BE2-CTH)**2
	+ ATHRE=(TH-SQMH)/((TH-SQMH)2+GMMH2)*THANG
	+ ATHIM=-GMMH/((TH-SQMH)2+GMMH2)*THANG
	+ UHANG=(BE2+CTH)**2
	+ AUHRE=(UH-SQMH)/((UH-SQMH)2+GMMH2)*UHANG
	+ AUHIM=-GMMH/((UH-SQMH)2+GMMH2)*UHANG
	+ SGZANG=1D0/SQMWBE2(3D0-BE2)*2CTH
	+ ASGRE=XW*SGZANG
	+ ASGIM=0D0
	+ ASZRE=XW1SH/(SH-SQMZ)SGZANG
	+ ASZIM=0D0
	+ TGZANG=1D0/SQMW(BE2(4D0-2D0BE2+BE4)+BE2(4D0-10D0*BE2+
	+ & BE4)CTH+(2D0-11D0BE2+10D0BE4)CTH2+BE2*CTH3)
	+ ATGRE=0.5D0XWSH/TH*TGZANG
	+ ATGIM=0D0
	+ ATZRE=0.5D0XW1SH/(TH-SQMZ)*TGZANG
	+ ATZIM=0D0
	+ UGZANG=1D0/SQMW(BE2(4D0-2D0BE2+BE4)-BE2(4D0-10D0*BE2+
	+ & BE4)CTH+(2D0-11D0BE2+10D0BE4)CTH2-BE2*CTH3)
	+ AUGRE=0.5D0XWSH/UH*UGZANG
	+ AUGIM=0D0
	+ AUZRE=0.5D0XW1SH/(UH-SQMZ)*UGZANG
	+ AUZIM=0D0
	+ A4ARE=1D0/SQMW(1D0+2D0BE2-6D0BE2CTH-CTH2)
	+ A4AIM=0D0
	+ A4SRE=2D0/SQMW(1D0+2D0BE2-CTH2)
	+ A4SIM=0D0
	+ FWW=COMFAC1D0/(4096D0PARU(1)*2)(AEM/XW)*4
	+ & (SH/SQMW)*2SH2
	+ 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=AWWARE2+AWWAIM2
	+ AWWS2=AWWSRE2+AWWSIM2
	+
	+ ELSE
	+C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
	+ FWWA=COMFAC(AEM/(4D0PARU(1)XW))2(64D0/9D0)*
	+ & ABS(A00U+0.5D0A20U+4.5D0A11UDBLE(CTH))*2
	+ FWWS=COMFAC(AEM/(4D0PARU(1)XW))264D0ABS(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=FWWAWWA2WIDS(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)=FACWWVINT(180+I)VINT(180+J)
	+ IF(EIEJ.GT.0D0) SIGH(NCHN)=0.5D0SIGH(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=4D0COMFAC/((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)=HIFACBWHF
	+ 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=4D0COMFAC/((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=SHRWDTP142D0
	+ ELSE
	+ HI=SHRWDTP(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)=HIFACBWHF
	+ 360 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.110) THEN
	+C...f + fbar -> gamma + h0
	+ THUH=MAX(THUH,SHCKIN(3)**2)
	+ FACHG=COMFAC(3D0AEM*4)/(2D0PARU(1)*2XWSQMW)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-4D0EJXWV
	+ BALP=SQM4/(2D0PMAS(J,1))*2
	+ BBET=SH/(2D0PMAS(J,1))*2
	+ ELSEIF(J.LE.3*MSTP(1)) THEN
	+ FNC=3D0
	+ JL=2(J-2MSTP(1))-1
	+ EJ=KCHG(10+JL,1)/3D0
	+ AJ=SIGN(1D0,EJ+0.1D0)
	+ VJ=AJ-4D0EJXWV
	+ BALP=SQM4/(2D0PMAS(10+JL,1))*2
	+ BBET=SH/(2D0PMAS(10+JL,1))*2
	+ ELSE
	+ BALP=SQM4/(2D0PMAS(24,1))*2
	+ BBET=SH/(2D0PMAS(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.5D0BABI)+DBLE(BABI2)(DBLE(0.5D0*(1D0-BALP+
	+ & BBET))(F1BET-F1ALP)+DBLE(BBET)(F2BET-F2ALP))
	+ CIGTOT=CIGTOT+DBLE(FNCEJ2)FIF
	+ CIZTOT=CIZTOT+DBLE(FNCEJVJ)*FIF
	+ ELSE
	+ TXW=XW/XW1
	+ CIGTOT=CIGTOT-0.5(DBLE(BABI(1.5D0+BALP))+DBLE(BABI*2)
	+ & (DBLE(1.5D0-3D0BALP+4D0BBET)*(F1BET-F1ALP)+
	+ & DBLE(BBET(2D0BALP+3D0))*(F2BET-F2ALP)))
	+ CIZTOT=CIZTOT-DBLE(0.5D0BABIXW1)(DBLE(5D0-TXW+2D0BALP*
	+ & (1D0-TXW))(1D0+DBLE(2D0BABIBBET)(F2BET-F2ALP))+
	+ & DBLE(BABI(4D0BBET(3D0-TXW)-(2D0BALP-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-4D0EIXWV
	+ 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)=FACHGFCOI(ABS(DBLE(EI)CIGTOT+DBLE(VI)
	+ & CIZTOT)2+AI2ABS(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=COMFACFACA(2D0/9D0)AS(WDTP13/SQRT(SQM4))*
	+ & (TH2+UH2)/(SH*SQM4)
	+ ELSE
	+ FACGH=COMFACFACA(2D0/9D0)AS(WDTP(13)/SQRT(SQM4))*
	+ & (TH2+UH2)/(SH*SQM4)
	+ ENDIF
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ GMMHC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
	+ & ((SQM4-SQMH)2+GMMHC2)
	+ 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=COMFACFACA/(144D0PARU(1)*2)AEM/XWAS3SQMH/SQMW*
	+ & SQMH/SH(UH2+TH2)/(UH+TH)2(A5STUR2+A5STUI2)
	+ 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=COMFACFACA(1D0/12D0)AS(WDTP13/SQRT(SQM4))*
	+ & (SH2+UH2)/(-TH*SQM4)
	+ ELSE
	+ FACQH=COMFACFACA(1D0/12D0)AS(WDTP(13)/SQRT(SQM4))*
	+ & (SH2+UH2)/(-TH*SQM4)
	+ ENDIF
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ GMMHC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
	+ & ((SQM4-SQMH)2+GMMHC2)
	+ 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=COMFACFACA/(384D0PARU(1)*2)AEM/XWAS3SQMH/SQMW*
	+ & SQMH/(-TH)(UH2+SH2)/(UH+SH)2(A5TSUR2+A5TSUI2)
	+ 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=COMFACFACA(3D0/16D0)AS(WDTP13/SQRT(SQM4))*
	+ & (SH4+TH4+UH4+SQM44)/(SHTHUH*SQM4)
	+ ELSE
	+ FACGH=COMFACFACA(3D0/16D0)AS(WDTP(13)/SQRT(SQM4))*
	+ & (SH4+TH4+UH4+SQM44)/(SHTHUH*SQM4)
	+ ENDIF
	+C...Propagators: as simulated in PYOFSH and as desired
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ GMMHC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
	+ & ((SQM4-SQMH)2+GMMHC2)
	+ 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)+2D0THUH
	+ & (UH+2D0SH)/(SH+UH)2(W1TR-W1HR)+(SQMQ-SH/4D0)*
	+ & (0.5D0W2SR+0.5D0W2HR-W2TR+W3STUR)+SH2(2D0SQMQ/
	+ & (SH+UH)*2-0.5D0/(SH+UH))(W2TR-W2HR)+0.5D0THUH/SH*
	+ & (W2HR-2D0W2TR)+0.125D0(SH-12D0SQMQ-4D0THUH/SH)W3TSUR)
	+ B2STUI=SQMQ/SQMH*2(2D0THUH(UH+2D0SH)/(SH+UH)*2
	+ & (W1TI-W1HI)+(SQMQ-SH/4D0)(0.5D0W2SI+0.5D0*W2HI-W2TI+
	+ & W3STUI)+SH2(2D0SQMQ/(SH+UH)*2-0.5D0/(SH+UH))
	+ & (W2TI-W2HI)+0.5D0THUH/SH(W2HI-2D0W2TI)+0.125D0*
	+ & (SH-12D0SQMQ-4D0THUH/SH)W3TSUI)
	+ B2SUTR=SQMQ/SQMH*2(SH(TH-SH)/(SH+TH)+2D0UHTH
	+ & (TH+2D0SH)/(SH+TH)2(W1UR-W1HR)+(SQMQ-SH/4D0)*
	+ & (0.5D0W2SR+0.5D0W2HR-W2UR+W3SUTR)+SH2(2D0SQMQ/
	+ & (SH+TH)*2-0.5D0/(SH+TH))(W2UR-W2HR)+0.5D0UHTH/SH*
	+ & (W2HR-2D0W2UR)+0.125D0(SH-12D0SQMQ-4D0UHTH/SH)W3USTR)
	+ B2SUTI=SQMQ/SQMH*2(2D0UHTH(TH+2D0SH)/(SH+TH)*2
	+ & (W1UI-W1HI)+(SQMQ-SH/4D0)(0.5D0W2SI+0.5D0*W2HI-W2UI+
	+ & W3SUTI)+SH2(2D0SQMQ/(SH+TH)*2-0.5D0/(SH+TH))
	+ & (W2UI-W2HI)+0.5D0UHTH/SH(W2HI-2D0W2UI)+0.125D0*
	+ & (SH-12D0SQMQ-4D0UHTH/SH)W3USTI)
	+ B2TSUR=SQMQ/SQMH*2(TH(UH-TH)/(TH+UH)+2D0SHUH
	+ & (UH+2D0TH)/(TH+UH)2(W1SR-W1HR)+(SQMQ-TH/4D0)*
	+ & (0.5D0W2TR+0.5D0W2HR-W2SR+W3TSUR)+TH2(2D0SQMQ/
	+ & (TH+UH)*2-0.5D0/(TH+UH))(W2SR-W2HR)+0.5D0SHUH/TH*
	+ & (W2HR-2D0W2SR)+0.125D0(TH-12D0SQMQ-4D0SHUH/TH)W3STUR)
	+ B2TSUI=SQMQ/SQMH*2(2D0SHUH(UH+2D0TH)/(TH+UH)*2
	+ & (W1SI-W1HI)+(SQMQ-TH/4D0)(0.5D0W2TI+0.5D0*W2HI-W2SI+
	+ & W3TSUI)+TH2(2D0SQMQ/(TH+UH)*2-0.5D0/(TH+UH))
	+ & (W2SI-W2HI)+0.5D0SHUH/TH(W2HI-2D0W2SI)+0.125D0*
	+ & (TH-12D0SQMQ-4D0SHUH/TH)W3STUI)
	+ B2TUSR=SQMQ/SQMH*2(TH(SH-TH)/(TH+SH)+2D0UHSH
	+ & (SH+2D0TH)/(TH+SH)2(W1UR-W1HR)+(SQMQ-TH/4D0)*
	+ & (0.5D0W2TR+0.5D0W2HR-W2UR+W3TUSR)+TH2(2D0SQMQ/
	+ & (TH+SH)*2-0.5D0/(TH+SH))(W2UR-W2HR)+0.5D0UHSH/TH*
	+ & (W2HR-2D0W2UR)+0.125D0(TH-12D0SQMQ-4D0UHSH/TH)W3UTSR)
	+ B2TUSI=SQMQ/SQMH*2(2D0UHSH(SH+2D0TH)/(TH+SH)*2
	+ & (W1UI-W1HI)+(SQMQ-TH/4D0)(0.5D0W2TI+0.5D0*W2HI-W2UI+
	+ & W3TUSI)+TH2(2D0SQMQ/(TH+SH)*2-0.5D0/(TH+SH))
	+ & (W2UI-W2HI)+0.5D0UHSH/TH(W2HI-2D0W2UI)+0.125D0*
	+ & (TH-12D0SQMQ-4D0UHSH/TH)W3UTSI)
	+ B2USTR=SQMQ/SQMH*2(UH(TH-UH)/(UH+TH)+2D0SHTH
	+ & (TH+2D0UH)/(UH+TH)2(W1SR-W1HR)+(SQMQ-UH/4D0)*
	+ & (0.5D0W2UR+0.5D0W2HR-W2SR+W3USTR)+UH2(2D0SQMQ/
	+ & (UH+TH)*2-0.5D0/(UH+TH))(W2SR-W2HR)+0.5D0SHTH/UH*
	+ & (W2HR-2D0W2SR)+0.125D0(UH-12D0SQMQ-4D0SHTH/UH)W3SUTR)
	+ B2USTI=SQMQ/SQMH*2(2D0SHTH(TH+2D0UH)/(UH+TH)*2
	+ & (W1SI-W1HI)+(SQMQ-UH/4D0)(0.5D0W2UI+0.5D0*W2HI-W2SI+
	+ & W3USTI)+UH2(2D0SQMQ/(UH+TH)*2-0.5D0/(UH+TH))
	+ & (W2SI-W2HI)+0.5D0SHTH/UH(W2HI-2D0W2SI)+0.125D0*
	+ & (UH-12D0SQMQ-4D0SHTH/UH)W3SUTI)
	+ B2UTSR=SQMQ/SQMH*2(UH(SH-UH)/(UH+SH)+2D0THSH
	+ & (SH+2D0UH)/(UH+SH)2(W1TR-W1HR)+(SQMQ-UH/4D0)*
	+ & (0.5D0W2UR+0.5D0W2HR-W2TR+W3UTSR)+UH2(2D0SQMQ/
	+ & (UH+SH)*2-0.5D0/(UH+SH))(W2TR-W2HR)+0.5D0THSH/UH*
	+ & (W2HR-2D0W2TR)+0.125D0(UH-12D0SQMQ-4D0THSH/UH)W3TUSR)
	+ B2UTSI=SQMQ/SQMH*2(2D0THSH(SH+2D0UH)/(UH+SH)*2
	+ & (W1TI-W1HI)+(SQMQ-UH/4D0)(0.5D0W2UI+0.5D0*W2HI-W2TI+
	+ & W3UTSI)+UH2(2D0SQMQ/(UH+SH)*2-0.5D0/(UH+SH))
	+ & (W2TI-W2HI)+0.5D0THSH/UH(W2HI-2D0W2TI)+0.125D0*
	+ & (UH-12D0SQMQ-4D0THSH/UH)W3TUSI)
	+ B4STUR=0.25D0EPSH(-2D0/3D0+0.25D0(EPSH-1D0)
	+ & (W2SR-W2HR+W3STUR))
	+ B4STUI=0.25D0EPSH0.25D0(EPSH-1D0)(W2SI-W2HI+W3STUI)
	+ B4TUSR=0.25D0EPSH(-2D0/3D0+0.25D0(EPSH-1D0)
	+ & (W2TR-W2HR+W3TUSR))
	+ B4TUSI=0.25D0EPSH0.25D0(EPSH-1D0)(W2TI-W2HI+W3TUSI)
	+ B4USTR=0.25D0EPSH(-2D0/3D0+0.25D0(EPSH-1D0)
	+ & (W2UR-W2HR+W3USTR))
	+ B4USTI=0.25D0EPSH0.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=COMFACFACA3D0/(128D0PARU(1)2)AEM/XWAS3
	+ & SQMH/SQMWSQMH3/(SHTHUH)(A2STUR2+A2STUI2+A2USTR**2+
	+ & A2USTI2+A2TUSR2+A2TUSI2+A4STUR2+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(4D0PARU(1)AEM/XW)(4D0PARU(1)AS)*2
	+ & (0.5D0PMF/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=FACQQHPARU(150+10IHIGG+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+10IHIGG))*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+HS2)
	+ 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)=FACQQHWTQQBHFACBW
	+ 460 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.122) THEN
	+C...q + qbar -> Q + Qbar + h0
	+ IA=KFPR(ISUBSV,2)
	+ PMF=PYMRUN(IA,SH)
	+ FACQQH=COMFAC(4D0PARU(1)AEM/XW)(4D0PARU(1)AS)*2
	+ & (0.5D0PMF/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=FACQQHPARU(150+10IHIGG+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+10IHIGG))*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+HS2)
	+ 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)=FACQQHWTQQBHFACBW
	+ 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(4D0PARU(1)AEM/(XWXW1))*3SQMZ/32D0
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
	+ & PARU(154+10IHIGG)*2
	+ FACPRP=1D0/((VINT(215)-VINT(204)*2)
	+ & (VINT(216)-VINT(209)2))2
	+ FACZZ1=FACNORFACPRP(0.5D0TAUPVINT(2))*VINT(219)
	+ FACZZ2=FACNORFACPRPVINT(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+HS2)
	+ 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-4D0EIXWV
	+ EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
	+ AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
	+ VJ=AJ-4D0EJXWV
	+ FACLR1=(VI2+AI2)(VJ2+AJ2)+4D0VIAIVJ*AJ
	+ FACLR2=(VI2+AI2)(VJ2+AJ2)-4D0VIAIVJ*AJ
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=(FACLR1FACZZ1+FACLR2FACZZ2)*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(4D0PARU(1)AEM/XW)3SQMW
	+ IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
	+ & PARU(155+10IHIGG)*2
	+ FACPRP=1D0/((VINT(215)-VINT(204)*2)
	+ & (VINT(216)-VINT(209)2))2
	+ FACWW=FACNORFACPRP(0.5D0TAUPVINT(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+HS2)
	+ 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)=FACLRFACWWFACBW
	+ 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=4D0COMFAC/((SH-SQMHC)2+HS*2)
	+ HP=AEM/(8D0XW)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(RMLPARU(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)=HIFACBWHF
	+ 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=COMFACFACAASAEM/XW1D0/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+GMMHC2)
	+ CALL PYWIDT(37,SQM4,WDTP,WDTE)
	+ GMMHCC=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMHCC/((SQM4-SQMHC)2+GMMHCC2)
	+ 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(SQMLPARU(141)2+SQMQ/PARU(141)2)/SQMW*
	+ & (SH/(SQMQ-UH)+2D0SQMQ(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
	+ & 2D0SQMQ/(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+HS2)
	+ 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)=2d0COMFACWTTBH*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+HS2)
	+ 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)=2d0COMFACWTTBH*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-2D0XW)/(2D0XW/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=.5D0PARU(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+GMMS2)
	+ CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
	+ GMMI=SQRT(SQMI)*WDTP(0)
	+ HBWI=GMMI/((SQMI-SQMS)2+GMMI2)
	+ 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-EJXW)A1
	+ XRQ=(-EJXW)A2
	+ XLF=(TT3I-EI*XW)
	+ XRF=(-EI*XW)
	+ TAA=(EIEJ)2(POLL+POLR)
	+ TZZ=(XLF*2POLL+XRF*2POLR)(XLQ+XRQ)2/XW2/XW1*2
	+ TZZ=TZZ/((1D0-SQMZ/SH)*2+SQMZZWID/SH**2)
	+ TAZ=2D0EIEJ(XLQ+XRQ)(XLFPOLL+XRFPOLR)/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(TT3IZMIX(II,2)-TANW(TT3I-EI)
	+ & ZMIX(II,1))
	+ FREK=FAC2TANWEI*ZMIX(II,1)
	+ TNN1=TNN1+FLEK*2DK
	+ TNN2=TNN2+FREK*2DK
	+ DO 110 JJ=1,4
	+ DL=1D0/(TH-SMZ(JJ)**2)
	+ FLEL=-FAC2(TT3JZMIX(JJ,2)-TANW(TT3J-EJ)
	+ & ZMIX(JJ,1))
	+ FREL=FAC2TANWEJ*ZMIX(JJ,1)
	+ TNN3=TNN3+FLEKFREKFLELFRELDKDLSMZ(II)*SMZ(JJ)
	+ 110 CONTINUE
	+ 120 CONTINUE
	+ TNN=(UHTH-SQM3SQM4)(A12TNN1*2POLL+
	+ & A2*2TNN2*2POLR)
	+ TNN=(TNN+SHA1A2TNN3((1D0-PARJ(131))*(1D0-PARJ(132))+
	+ & (1D0+PARJ(131))(1D0+PARJ(132))))/4D0/XW*2
	+ TZN=(UHTH-SQM3SQM4)(XLQ+XRQ)
	+ & (TNN1XLFA1POLL+TNN2XRFA2POLR)
	+ TZN=TZN/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)
	+ & (1D0-SQMZ/SH)/SH
	+ TZN=TZN/XW**2/XW1
	+ TAN=EIEJ(UHTH-SQM3SQM4)/SH(A1TNN1*POLL+
	+ & A2TNN2POLR)/XW
	+ ENDIF
	+ FACQQ1=COMFACAEM2(TAA+TZZ+TAZ)*FCOL/3D0
	+ FACQQ1=FACQQ1( UHTH-SQM3SQM4 )/SH*2
	+ FACQQ2=COMFACAEM2(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*2POLL+XRF*2POLR)(XLQ-XRQ)*2
	+ & /XW2/XW12A1A2
	+ 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(TT3IZMIX(II,2)-TANW(TT3I-EI)
	+ & ZMIX(II,1))
	+ FREK=FAC2TANWEI*ZMIX(II,1)
	+ TNN1=TNN1+FLEK*2DK
	+ TNN2=TNN2+FREK*2DK
	+ DO 140 JJ=1,4
	+ DL=1D0/(TH-SMZ(JJ)**2)
	+ FLEL=-FAC2(TT3JZMIX(JJ,2)-TANW(TT3J-EJ)
	+ & ZMIX(JJ,1))
	+ FREL=FAC2TANWEJ*ZMIX(JJ,1)
	+ TNN3=TNN3+FLEKFREKFLELFRELDKDLSMZ(II)*SMZ(JJ)
	+ 140 CONTINUE
	+ 150 CONTINUE
	+ TNN=(UHTH-SQM3SQM4)A1A2(TNN22POLR+TNN1*2POLL)
	+ TNNA=(TNN+SH(A12POLLL+A2*2POLRR)*TNN3)/4D0
	+ TNNB=(TNN+SH(A12POLRR+A2*2POLLL)*TNN3)/4D0
	+ TZN=(UHTH-SQM3SQM4)A1A2
	+ TZN=TZN(XLQ-XRQ)(XLFTNN1POLL-XRFTNN2POLR)/XW1
	+ TZN=TZN/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)
	+ & (1D0-SQMZ/SH)/SH
	+ ENDIF
	+ FACQQ0=COMFACAEM2TZZFCOL/3D0(UHTH-SQM3SQM4)/SH2
	+ FACQQ2=COMFACAEM2/XW2(TNNA+TZN)*FCOL/3D0
	+ FACQQ1=COMFACAEM2/XW2(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=RKFCOMFACAEM2/XW2/12D0
	+ FAC1=(THUH-SQM3SQM4)/((SH-SQMW)2+WWID2*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)=FAC0FAC1FCKM*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+ZWID2*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)-2D0EIXW)/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)/PROPZ2XLQ*XLL
	+ ENDIF
	+ FACQQ1=(XLQ2+XRQ2)(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(UHTH-SQM3SQM4)*COMFAC
	+ & AEM2FCOL/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=COMFACWIDS(PYCOMP(KFPR(ISUBSV,1)),2)
	+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
	+ ENDIF
	+ FACXX=COMFACAEM2/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 + SQMZZWID**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=(T3IZMIXC(IZID1,2)-TANW(T3I-EI)ZMIXC(IZID1,1))
	+ & DCONJG(T3IZMIXC(IZID2,2)-TANW(T3I-EI)*ZMIXC(IZID2,1))
	+ GRIJ=ZMIXC(IZID1,1)DCONJG(ZMIXC(IZID2,1))(EITANW)*2
	+ QLL=DCMPLX((T3I-EIXW)/XW1)OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
	+ QLR=-DCMPLX((T3I-EIXW)/XW1)ORPP*PROPZ+DCONJG(GLIJ)
	+ & /DCMPLX(TH-XML2)
	+ QRL=-DCMPLX((EIXW)/XW1)OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
	+ QRR=DCMPLX((EIXW)/XW1)ORPP*PROPZ
	+ & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
	+ FCOL=1D0
	+ IF(IABS(I).GE.11) FCOL=3D0
	+ FACGG1=(ABS(QLL)*2POLL+ABS(QRR)*2POLR)*WU2+
	+ & (ABS(QRL)*2POLR+ABS(QLR)*2POLL)*WT2+
	+ & 2D0DBLE(QLRDCONJG(QLL)*POLL+
	+ & QRLDCONJG(QRR)POLR)*WS2
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACXXFACGG1FCOL
	+ 210 CONTINUE
	+ ENDIF
	+
	+ ELSEIF(ISUB.LE.230) THEN
	+ IF(ISUB.EQ.226) THEN
	+C...f + fbar -> ~chi+_1 + ~chi-_1
	+ FACXX=COMFACAEM*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 + SQMZZWID**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(XWDIFF)
	+ ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
	+ & UMIXC(IZID1,2)DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XWDIFF)
	+ 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/SHDIFF)-DCMPLX(EI/XW1)PROPZ*ORP
	+ QLL=DCMPLX(-EI/SHDIFF)+DCMPLX((T3I-XWEI)/XW/XW1)PROPZORP
	+ QRR=DCMPLX(-EI/SHDIFF)-DCMPLX(EI/XW1)PROPZ*OLP
	+ IF(MOD(I,2).EQ.0) THEN
	+ XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
	+ QLR=DCMPLX(-EI/SHDIFF)+DCMPLX((T3I-XWEI)/XW/XW1)*
	+ & PROPZOLP-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/SHDIFF)+DCMPLX((T3I-XWEI)/XW/XW1)*
	+ & PROPZOLP-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)*2POLL+ABS(QRR)*2POLR)*WU2+
	+ & (ABS(QRL)*2POLR+ABS(QLR)*2POLL)*WT2+
	+ & 2D0DBLE(QLRDCONJG(QLL)*POLL+
	+ & QRLDCONJG(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)=FACSUMWIDS(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)=FACSUMWIDS(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=COMFACAEM2/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+WWID2*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)2WU2+ABS(QLR)*2WT2+
	+ & 2D0ZINTRWS2)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACGG1FCKMWIDS(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=COMFACWIDS(PYCOMP(KFPR(ISUBSV,1)),2)
	+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
	+ ASYUK=RMSS(42)*AS
	+ FAC0=COMFACASYUKAEM*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 = -TANWEIZMIX(IZID,1)
	+ XRQC =(SIGN(1D0,EI)ZMIX(IZID,2)-TANW
	+ & (SIGN(1D0,EI)-2D0EI)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-2D0ATUKIN)
	+ 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-2D0ATUKIN)
	+ 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=COMFACASAEM/XW*2D0/9D0
	+ GM2=SQM3
	+ ZM2=SQM4
	+ FAC01=2D0UMIX(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)=FACWGFCKM(FAC0ATKIN+FAC1AUKIN-
	+ & FAC01ATUKIN)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=COMFACAS28D0/3D0( (XMT2+XMU*2+
	+ & 2D0SQM3SH)/SH2 + RMSS(42)*2(4D0/9D0(XMT2/XST*2+
	+ & XMU2/XSU2) + SQM3SH/XST/XSU/9D0) - RMSS(42)(
	+ & (XMT*2+SHSQM3)/SH/XST + (XMU*2+SHSQM3)/SH/XSU ))
	+ XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
	+ XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
	+ FACGG2=COMFACAS28D0/3D0( (XMT2+XMU*2+
	+ & 2D0SQM3SH)/SH2 + RMSS(42)*2(4D0/9D0(XMT2/XST*2+
	+ & XMU2/XSU2) + SQM3SH/XST/XSU/9D0) - RMSS(42)(
	+ & (XMT*2+SHSQM3)/SH/XST + (XMU*2+SHSQM3)/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=COMFACAS29D0/4D0*(
	+ & (XMTXMU-2D0SQM3(TH+SQM3))/XMT*2 -
	+ & (XMTXMU+SQM3(UH-TH))/SH/XMT )
	+ FACQQ2=COMFACAS29D0/4D0*(
	+ & (XMUXMT-2D0SQM3(UH+SQM3))/XMU*2 -
	+ & (XMUXMT+SQM3(TH-UH))/SH/XMU )
	+ FACQQ3=COMFACAS29D0/4D0(2D0XMT*XMU/SH2 +
	+ & SQM3(SH-4D0SQM3)/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=COMFACASAEM/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 = -TANWEIZMIX(IZID,1)
	+ XLQZ =(SIGN(1D0,EI)ZMIX(IZID,2)-TANW
	+ & (SIGN(1D0,EI)-2D0EI)ZMIX(IZID,1))/2D0
	+ IF(ILR.EQ.0) THEN
	+ BS=XLQZ*2SFMIX(IA,1)2+XRQZ2SFMIX(IA,2)*2
	+ ELSE
	+ BS=XLQZ*2SFMIX(IA,3)2+XRQZ2SFMIX(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)=FACZQRKFWIDS(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=COMFACASAEM/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=FACZQSFMIX(KFNSQ1,1+2ILR)**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)=FACZQRKFWIDS(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.5D04D0/9D0XMT/SH + (XMTSH+2D0XG2XST)/XMT*2 -
	+ & ( (SH-XQ2+XG2)(-XST)-SHXG2 )/SH/(-XMT) +
	+ & 0.5D01D0/2D0( XST(TH+2D0UH+XG2)-XMT(SH-2D0XST) +
	+ & (-XMU)(TH+XG2+2D0XQ2) )/2D0/XMT/XSU
	+ FACQG2= 4D0/9D0(-XMU)(UH+XQ2)/XSU*2 + 1D0/18D0
	+ & (SH*(UH+XG2)
	+ & +2D0(XQ2-XG2)XMU)/SH/(-XSU) + 0.5D04D0/9D0XMT/SH +
	+ & 0.5D01D0/2D0(XST(TH+2D0UH+XG2)-XMT(SH-2D0XST)+
	+ & (-XMU)(TH+XG2+2D0XQ2))/2D0/XMT/XSU
	+ ASYUK=RMSS(42)*AS
	+ FACQG1=COMFACASASYUK*FACQG1/2D0
	+ FACQG2=COMFACASASYUK*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=RKFWIDS(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( (UHTH-SQM3SQM4)/ SH2 )
	+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
	+ KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
	+ FAC0=AS*24D0/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-EJXW)SFMIX(KFNSQ,2ILR+1)**2
	+ XRQ=2D0(-EJXW)SFMIX(KFNSQ,2ILR+2)**2
	+ XLF=2D0(T3I-EIXW)
	+ XRF=2D0(-EIXW)
	+ TAA=0.5D0(EIEJ)**2
	+ TZZ=(XLF2+XRF2)(XLQ+XRQ)2/64D0/XW2/XW1*2
	+ TZZ=TZZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)**2)
	+ TAZ=EIEJ(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
	+ TAZ=TAZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)(1D0-SQMZ/SH)
	+ FAC0=AEM*212D0*(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-EJXW)
	+ XRQ=2D0(-EJXW)
	+ XLF=2D0(TT3I-EIXW)
	+ XRF=2D0(-EIXW)
	+ TZZ=(XLF2+XRF2)(XLQ-XRQ)2/64D0/XW2/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=COMFACAEM2TZZFCOL4D0
	+ FACQQ1=FACQQ1( UHTH-SQM3*SQM4 )/SH2
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACQQ1WIDS(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)=FACQQ1WIDS(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=COMFACAS2(7D0/48D0+3D0(UH-TH)2/16D0/SH2 )0.5D0*
	+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
	+ FACQQ1=FAC0(0.5D0+2D0SQM3TH/XST2 + 2D0SQM3**2/XSU/XST)
	+ FACQQ2=FAC0(0.5D0+2D0SQM3UH/XSU2 + 2D0SQM3**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=COMFACASYUK24D0/9D0( -(XST1XST2+SHTH)/XMT*2 )
	+ FACQQ2=COMFACASYUK24D0/9D0( -(XSU1XSU2+SHUH)/XMU*2 )
	+ FACQQB=0.0D0
	+ ELSE
	+ FACQQ1=0.5D0COMFACASYUK*24D0/9D0( SHXMG2/XMT**2 )
	+ FACQQ2=0.5D0COMFACASYUK*24D0/9D0( SHXMG2/XMU**2 )
	+ FACQQB=0.5D0COMFACASYUK*24D0/9D0( -2D0SH*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)=FACQQ1RKFWIDS(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.5D0FACQQB)RKF
	+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
	+ ELSE
	+ SIGH(NCHN)=0.5D0FACQQ1RKF*
	+ & 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.5D0FACQQB)RKF
	+ & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
	+ ELSE
	+ SIGH(NCHN)=0.5D0FACQQ2RKF*
	+ & 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=COMFACAS22D0/9D0*(
	+ & (UHTH-SQM3SQM4)/XMT*2 )RMSS(42)**2
	+ FACQQB=COMFACAS24D0/9D0*(
	+ & (UHTH-SQM3SQM4)/SH2 )
	+C...Mrenna..Switched sign to agree with Eichten, Dawson, etc.
	+ FACQQI=COMFACAS24D0/27D0*(
	+ & (UHTH-SQM3SQM4)/SH/XMT )*RMSS(42)
	+ FACQQB=FACQQB+FACQQ1+FACQQI
	+ ELSE
	+ FACQQ1=COMFACAS24D0/9D0( XMG2SH/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)=FACQQ1RKFWIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
	+ & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
	+ IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQBRKF
	+ & 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( (UHTH-SQM3SQM4)/ 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-EJXW)*SFMIX(KFNSQ,1)
	+ XRQ=2D0(-EJXW)*SFMIX(KFNSQ,2)
	+ ELSE
	+ XLQ=2D0(T3J-EJXW)*SFMIX(KFNSQ,3)
	+ XRQ=2D0(-EJXW)*SFMIX(KFNSQ,4)
	+ ENDIF
	+ XLF=2D0(T3I-EIXW)
	+ XRF=2D0(-EIXW)
	+ IF(ILR.EQ.0) THEN
	+ XRQ=0D0
	+ ELSE
	+ XLQ=0D0
	+ ENDIF
	+ TAA=0.5D0(EIEJ)**2
	+ TZZ=(XLF2+XRF2)(XLQ+XRQ)2/64D0/XW2/XW1*2
	+ TZZ=TZZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)**2)
	+ TAZ=EIEJ(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
	+ TAZ=TAZ/((1D0-SQMZ/SH)*2+SQMZ(ZWID/SH)*2)(1D0-SQMZ/SH)
	+ FAC0=AEM*212D0*(TAA+TZZ+TAZ)
	+ ELSEIF(IA.LE.6) THEN
	+ FAC0=AS*28D0/9D0/2D0
	+ ENDIF
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACQQ1FAC0RKF*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=RKFCOMFACAS*2( 7D0/48D0+3D0(UH-TH)*2/16D0/SH2 )
	+ FACQQ1=FAC0(0.5D0+2D0SQM3TH/XST2 + 2D0SQM3**2/XSU/XST)
	+ FACQQ2=FAC0(0.5D0+2D0SQM3UH/XSU2 + 2D0SQM3**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-2D0XW)/(2D0XW/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=2D0SQRT(XWXW1)
	+ 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=2D0QUPDCSXI
	+ VZGP=QUPDCSXI(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=2D0Q2UDCSXIP
	+ VZGP=CSXIP/SN2W(1D0-4D0XW*Q2UD)
	+C... Z pi_tc
	+ ELSEIF(ISUB.EQ.366) THEN
	+ KFA=23
	+ KFB=KTECHN+111
	+ ISUB=361
	+ VOGP=CSXI*CT2W/RTCM(12)
	+ VRGP=-QUPDCSXITANW/RTCM(12)
	+ VAGP=QUPDCSXI(1D0-4D0*XW)/SN2W
	+ VZGP=-QUPDCSXICS2W/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=-QUPDCSXIPTANW/RTCM(12)
	+ VAGP=CSXIP(1D0-4D0Q2UD*XW)/SN2W
	+ VZGP=2D0CSXIP(CS2W+4D0Q2UDXW2)/SN2W2
	+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=QUPDCSXI/(2D0SQRT(XW))
	+ VZGP=-QUPDCSXI/(2D0SQRT(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=QUPDCSXI/(2D0SQRT(XW))
	+ AXGP=-CSXI/RTCM(49)
	+C... Z_T pi_tc+
	+ ELSEIF(ISUB.EQ.375) THEN
	+ KFA=KTECHN+211
	+ KFB=23
	+ ISUB=370
	+ VRGP=-QUPDCSXITANW/RTCM(12)
	+ ARGP=CSXI/(2D0SQRT(XWXW1))/RTCM(13)
	+ VWGP=-QUPDCSXI/(2D0SQRT(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=-QUPDRTCM(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=2D0TANT3/(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=X12RTCM(28)2SIN2T
	+ SM1121=-X21RTCM(28)2SIN2T
	+ SM2212=-SM1112
	+ SM2221=-SM1121
	+ SM1221=-.5D0((1D0-RTCM(29)2)SIN(2D0*RTCM(30))+
	+ & (1D0-RTCM(31)*2)SIN(2D0RTCM(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,-SHRWDTP(0))
	+ CALL PYWIDT(3100113,SH,WDTP,WDTE)
	+ ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)*2,-SHRWDTP(0))
	+ CALL PYWIDT(3400113,SH,WDTP,WDTE)
	+ ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)*2,-SHRWDTP(0))
	+ CALL PYWIDT(3200113,SH,WDTP,WDTE)
	+ ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)*2,-SHRWDTP(0))
	+ CALL PYWIDT(3300113,SH,WDTP,WDTE)
	+ ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)*2,-SHRWDTP(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(SHXIGX11,0D0)
	+ ZTC(2,4)=DCMPLX(SHXIGX22,0D0)
	+ ZTC(2,5)=DCMPLX(SHXIGX12,0D0)
	+ ZTC(2,6)=DCMPLX(SHXIGX21,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(THXIGX11,0D0)
	+ ZTC(2,4)=DCMPLX(THXIGX22,0D0)
	+ ZTC(2,5)=DCMPLX(THXIGX12,0D0)
	+ ZTC(2,6)=DCMPLX(THXIGX21,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(UHXIGX11,0D0)
	+ ZTC(2,4)=DCMPLX(UHXIGX22,0D0)
	+ ZTC(2,5)=DCMPLX(UHXIGX12,0D0)
	+ ZTC(2,6)=DCMPLX(UHXIGX21,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+DVVSDCMPLX(TANT32)-DGVSDCMPLX(2D0*TANT3)
	+ DQQT=DGGT+DVVTDCMPLX(TANT32)-DGVTDCMPLX(2D0*TANT3)
	+ DQQU=DGGU+DVVUDCMPLX(TANT32)-DGVUDCMPLX(2D0*TANT3)
	+ DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
	+ DQGS=DGGS-DGVS*DCMPLX(TANT3)
	+ DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
	+ ELSE
	+ DQQS=DGGS+DVVSDCMPLX(1D0/TANT32)+DGVSDCMPLX(2D0/TANT3)
	+ DQQT=DGGT+DVVTDCMPLX(1D0/TANT32)+DGVTDCMPLX(2D0/TANT3)
	+ DQQU=DGGU+DVVUDCMPLX(1D0/TANT32)+DGVUDCMPLX(2D0/TANT3)
	+ DQTS=DGGS+DVVSDCMPLX(1D0/TANT32)+DGVSDCMPLX(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=COMFAC0.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)=HIFACBWHF
	+ 250 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.165) THEN
	+C...q + qbar -> l+ + l- (including contact term for compositeness)
	+ ZRATR=XWCSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	+ ZRATI=XWCSHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ KFF=IABS(KFPR(ISUB,1))
	+ EF=KCHG(KFF,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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-4D0EIXWV
	+ 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=(EIEF+VALIVALFZRATR+RTCM(42)SH/
	+ & (AEMRTCM(41)2))2+(VALIVALFZRATI)*2+
	+ & (EIEF+VARIVARFZRATR)2+(VARIVARFZRATI)*2
	+ ELSE
	+ FGZA=(EIEF+VALIVALFZRATR)2+(VALIVALFZRATI)*2+
	+ & (EIEF+VARIVARFZRATR)2+(VARIVARFZRATI)*2
	+ ENDIF
	+ FGZB=(EIEF+VALIVARFZRATR)2+(VALIVARFZRATI)*2+
	+ & (EIEF+VARIVALFZRATR)2+(VARIVALFZRATI)*2
	+ FGZAB=AEM*2(FGZAUH2/SH2+FGZBTH2/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/(2D0RTCM(41)*4)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=COMFACFCOIFCOFFGZABWID2
	+ 260 CONTINUE
	+
	+ ELSEIF(ISUB.EQ.166) THEN
	+C...q + q'bar -> l + nu_l (including contact term for compositeness)
	+ WFAC=(1D0/4D0)(AEM/XW)2UH2/((SH-SQMW)2+GMMW2)
	+ WCIFAC=WFAC+SH2/(4D0RTCM(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)=COMFACFCOIFCOFWFACWID2
	+ IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
	+ & SIGH(NCHN)=COMFACFCOIFCOFWCIFACWID2
	+ 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=12D0COMFAC/((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)(AEM2/ALPRHT)(SQMRHT**2/SH)
	+ XWRHT=(1D0-2D0XW)/(4D0XW*(1D0-XW))
	+ BWZR=XWRHTSH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	+ BWZI=XWRHTSHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ 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-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ HI=HP((EI+VALIBWZR)*2+(VALIBWZI)**2+
	+ & (EI+VARIBWZR)2+(VARIBWZI)**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)=HIFACBWHF
	+ 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=12D0COMFAC/((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)(AEM2/ALPRHT)(SQMRHT*2/SH)
	+ & (0.25D0/XW*2)SH2/((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=HIVCKM((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)=HIFACBWHF
	+ 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=12D0COMFAC/((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)(AEM2/ALPRHT)(SQMOMT*2/SH)
	+ & (2D0RTCM(2)-1D0)*2
	+ BWZR=(0.5D0/(1D0-XW))SH(SH-SQMZ)/((SH-SQMZ)2+GMMZ2)
	+ BWZI=(0.5D0/(1D0-XW))SHGMMZ/((SH-SQMZ)2+GMMZ2)
	+ 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-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ HI=HP((EI-VALIBWZR)*2+(VALIBWZI)**2+
	+ & (EI-VARIBWZR)2+(VARIBWZI)**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)=HIFACBWHF
	+ 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*2COMFAC
	+
	+ SN2W=2D0SQRT(XWXW1)
	+C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
	+C CT2W=(1D0-2D0PARU(102))/(2D0PARU(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=(FARFZO-FAOFZR)*2+SSMZSSMRSSMO-SFZRSSMO-
	+ $ SFZOSSMR-SFARSSMOSSMZ-SFAOSSMR*SSMZ
	+C...Add in techni-a contribution
	+ DETD=SSMXDETD-SFZX(SSMRSSMO-SFAOSSMR-SFAR*SSMO)
	+ DAA=(-SSMX(SFZOSSMR+SFZRSSMO-SSMOSSMR*SSMZ)-
	+ $ SFZXSSMRSSMO)/DETD/SH
	+ DZZ=-(SFAOSSMR+SFARSSMO-SSMOSSMR)/DETD/SHSSMX
	+ DAZ=(FARFZRSSMO+FAOFZOSSMR)/DETD/SH*SSMX
	+
	+ XWRHT=1D0/(4D0XW(1D0-XW))
	+ KFF=IABS(KFPR(ISUB,1))
	+ EF=KCHG(KFF,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFXWV
	+ 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-4D0EIXWV
	+ VALI=0.5D0*(VI+AI)
	+ VARI=0.5D0*(VI-AI)
	+ FCOI=FCOF
	+ IF(IABS(I).LE.10) FCOI=FCOI/3D0
	+ DIFLL=ABS(EIEFDAA+VALIVALFDZZ+DAZ(EIVALF+EFVALI))*2
	+ DIFRR=ABS(EIEFDAA+VARIVARFDZZ+DAZ(EIVARF+EFVARI))*2
	+ DIFLR=ABS(EIEFDAA+VALIVARFDZZ+DAZ(EIVARF+EFVALI))*2
	+ DIFRL=ABS(EIEFDAA+VARIVALFDZZ+DAZ(EIVALF+EFVARI))*2
	+ FACSIG=(DIFLL+DIFRR)((UH-SQM4)2+SHSQM4)+
	+ & (DIFLR+DIFRL)((TH-SQM3)2+SHSQM3)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=HPFCOIFACSIG*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(AEM2/12D0/XW2)(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(SSMZSSMR-DCMPLX(FWR**2,0D0))-
	+ & DCMPLX(FWX*2,0D0)SSMR
	+ DWW=SSMR*SSMX/DETD/SH
	+ FCOF=1D0
	+ IF(KFA.LE.8) FCOF=3D0
	+ HP=FACTCABS(DWW)2FCOF
	+
	+ 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)=HIWIDS(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=(FARFZO-FAOFZR)*2+SSMZSSMRSSMO-SFZRSSMO-
	+ $ SFZOSSMR-SFARSSMOSSMZ-SFAOSSMR*SSMZ
	+C...Add in techni-a contribution
	+ DETD=SSMXDETD-SFZX(SSMRSSMO-SFAOSSMR-SFAR*SSMO)
	+ DARHO=-(SSMX(-FARSFZO+FAOFZOFZR+FARSSMOSSMZ)-
	+ $ SFZXFARSSMO)/DETD/SH
	+ DZRHO=-(-FZRSFAO+FAOFZOFAR+FZRSSMO)/DETD/SH*SSMX
	+ DAOME=-(SSMX(-FAOSFZR+FARFZOFZR+FAOSSMRSSMZ)-
	+ $ SFZXFAOSSMR)/DETD/SH
	+ DZOME=-(-FZOSFAR+FARFAOFZR+FZOSSMR)/DETD/SH*SSMX
	+ DAAST=-FZX(FAOFZOSSMR+FARFZR*SSMO)/DETD/SH
	+ DZAST=-FZX(SSMRSSMO-SFAOSSMR-SFARSSMO)/DETD/SH
	+ DAA=(-SSMX(SFZOSSMR+SFZRSSMO-SSMOSSMR*SSMZ)-
	+ $ SFZXSSMRSSMO)/DETD/SH
	+ DZZ=-(SFAOSSMR+SFARSSMO-SSMOSSMR)/DETD/SHSSMX
	+ DAZ=(FARFZRSSMO+FAOFZOSSMR)/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*2BE342-(TH-UH)2)
	+ VFAC=(TH2+UH2-2D0SQM3SQM4)
	+ AFAC=(TH2+UH2-2D0SQM3SQM4+4D0SHSQM3)
	+ FANOM=SQRT(PARU(1)AEM)ITCM(1)/PARU(2)**2/RTCM(1)
	+ HP=(1D0/24D0)AEM2COMFAC3D0SH
	+ 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-4D0EIXWV
	+ 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=(EIDARHO+VALIDZRHO/SQRT(XWXW1))VRGP
	+ F2L=F2L+(EIDAOME+VALIDZOME/SQRT(XWXW1))VOGP
	+ F2L=F2L+(EIDAAST+VALIDZAST/SQRT(XWXW1))VXGP
	+ F2L=F2L+FANOM(VAGP(EIDAA+VALIDAZ/SQRT(XW*XW1))+
	+ $ VZGP(EIDAZ+VALIDZZ/SQRT(XWXW1)))
	+ F2R=(EIDARHO+VARIDZRHO/SQRT(XWXW1))VRGP
	+ F2R=F2R+(EIDAOME+VARIDZOME/SQRT(XWXW1))VOGP
	+ F2R=F2R+(EIDAAST+VARIDZAST/SQRT(XWXW1))VXGP
	+ F2R=F2R+FANOM(VAGP(EIDAA+VARIDAZ/SQRT(XW*XW1))+
	+ $ VZGP(EIDAZ+VARIDZZ/SQRT(XWXW1)))
	+ HI=(ABS(F2L)2+ABS(F2R)2)*VFAC
	+C...........Eqs. (5) and (7) in LSTC-rates.pdf
	+ F2L=(EIDARHO+VALIDZRHO/SQRT(XWXW1))ARGP
	+ F2L=F2L+(EIDAOME+VALIDZOME/SQRT(XWXW1))AOGP
	+ F2L=F2L+(EIDAAST+VALIDZAST/SQRT(XWXW1))AXGP
	+ F2R=(EIDARHO+VARIDZRHO/SQRT(XWXW1))ARGP
	+ F2R=F2R+(EIDAOME+VARIDZOME/SQRT(XWXW1))AOGP
	+ F2R=F2R+(EIDAAST+VARIDZAST/SQRT(XWXW1))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+CT2WDAZ))+
	+c$$$ $ VALI(CT2WDZRHO/FZR+(CT2WDZZ+DAZ))/SQRT(XWXW1)
	+c$$$ F2R=EI(DARHO/FAR+(DAA+CT2WDAZ))+
	+c$$$ $ VARI(CT2WDZRHO/FZR+(CT2WDZZ+DAZ))/SQRT(XWXW1)
	+ F2L=EIDARHO/FAR + VALICT2WDZRHO/FZR/SQRT(XWXW1)
	+ F2R=EIDARHO/FAR + VARICT2WDZRHO/FZR/SQRT(XWXW1)
	+ HK=(ABS(F2L)2+ABS(F2R)2)2D0FACA*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)=HIHPWIDS(PYCOMP(KFA),1)
	+ ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
	+ SIGH(NCHN)=HIHPWIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=2
	+ SIGH(NCHN)=HIHPWIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
	+ ELSE
	+ SIGH(NCHN)=HIHPWIDS(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*2BE342-(TH-UH)2)
	+ FANOM=SQRT(PARU(1)AEM)ITCM(1)/PARU(2)**2/RTCM(1)
	+ VFAC=(TH2+UH2-2D0SQM3SQM4)
	+ AFAC=(TH2+UH2-2D0SQM3SQM4+4D0SHSQM3)
	+ ALPRHT=2.16D0*(3D0/ITCM(1))
	+ FACHP=(1D0/48D0)AEM2/XWCOMFAC3D0SH
	+ 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(SSMZSSMR-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(AFACABS(DWRHOARGP+DWASTAXGP)**2+
	+ $ VFACABS(FANOMDWWVWGP+DWRHOVRGP+DWASTVXGP)*2)
	+C
	+C...........Eq. (25) in PRD67-115011 with DWW term dropped.
	+C
	+c$$$ HP=HP+.5D0FACHPCAB2FACA/XW/SHABS(DWW + DWRHO/FWR)**2
	+ HP=HP+.5D0FACHPCAB2FACA/XW/SHABS(DWRHO/FWR)**2
	+C...Add in W_L Z_T axial and vector contributions.
	+ IF(ISUBSV.EQ.370) HP=HP+FACHPRTCM(3)2(
	+ $ (TH2+UH2-2D0SQM3SQM4+4D0SHSQM4)* !AFAC w/ switched masses.
	+ $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)CS2W)2/SN2W*2+
	+ $ VFACQUPD2XW/XW1ABS(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)=HIWIDS(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=COMFACAS24D0/9D0(SH2+UH2)SQDQQT
	+ FACQQB=COMFACAS24D0/9D0((SH2+UH2)SQDQQT*FACA-
	+ & MSTP(34)2D0/3D0UH2*REDQST)
	+ FACQQ2=COMFACAS24D0/9D0(SH2+TH2)SQDQQU
	+ FACQQI=-COMFACAS24D0/9D0MSTP(34)2D0/3D0SH2/(THUH)
	+ 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)(ASRTCM(42)/RTCM(41)2)
	+ & (UH2/TH+UH2/SH)+COMFAC(5D0/3D0)(UH2/RTCM(41)**4)
	+ FACCI2=FACQQ2+COMFAC(8D0/9D0)(ASRTCM(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.5D0FACQQ1RATQQI
	+ SIGH(NCHN)=0.5D0FACQQ2RATQQI
	+ ELSE
	+ SIGH(NCHN-1)=0.5D0FACCI1RATCII
	+ SIGH(NCHN)=0.5D0FACCI2RATCII
	+ 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=COMFACAS24D0/9D0*(TH2+UH2)
	+ FACQQB=FACQQFSQDQQS(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=FACQQFSQDQQS(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
	+ & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
	+ FACCIB=FACQQFSQDQTS(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=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2+9D0/4D0THUH/SH2*SQDLGS)
	+ FACGG2=COMFACAS232D0/27D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	+ & TH2/SH2+9D0/4D0THUH/SH2*SQDLGS)
	+ IF(ITCM(5).EQ.5) THEN
	+ FACGG3=COMFACAS232D0/27D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2+9D0/4D0THUH/SH2*SQDHGS)
	+ FACGG4=COMFACAS232D0/27D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	+ & TH2/SH2+9D0/4D0THUH/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=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*UH2/TH2-
	+ & UH/SH-9D0/4D0SHUH/TH2SQDLGT)FACA
	+ FACQG2=COMFACAS24D0/9D0((2D0+MSTP(34)1D0/4D0)*SH2/TH2-
	+ & SH/UH-9D0/4D0SHUH/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-4D0PMAS(1,1)*2/SH))
	+ IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
	+ & SQRT(MAX(0D0,1D0-4D0PMAS(2,1)*2/SH))
	+ IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
	+ & SQRT(MAX(0D0,1D0-4D0PMAS(3,1)*2/SH))
	+ FACQQ1=COMFACAS21D0/6D0(UH/TH-(2D0+MSTP(34)1D0/4D0)*
	+ & UH2/SH2+9D0/4D0THUH/SH2SQDLGS)FLAVWT*FACA
	+ FACQQ2=COMFACAS21D0/6D0(TH/UH-(2D0+MSTP(34)1D0/4D0)*
	+ & TH2/SH2+9D0/4D0THUH/SH2SQDLGS)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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ THUHQ=THQUHQ-SQMAVGSH
	+ IF(MSTP(34).EQ.0) THEN
	+ FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	+ FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	+ ELSE
	+ FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	+ FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	+ ENDIF
	+ IF(ITCM(5).GE.5) THEN
	+ IF(IFL.EQ.4) THEN
	+ FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDLGS+
	+ & 2.25D0THQUHQ/SH2*SQDLGS
	+ FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDLGS+
	+ & 2.25D0THQUHQ/SH2*SQDLGS
	+ ELSE
	+ FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDHGS+
	+ & 2.25D0THQUHQ/SH2*SQDHGS
	+ FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDHGS+
	+ & 2.25D0THQUHQ/SH2*SQDHGS
	+ ENDIF
	+ ENDIF
	+ FACQQ1=COMFACFACAAS*2(1D0/6D0)FACQQ1BE34
	+ FACQQ2=COMFACFACAAS*2(1D0/6D0)FACQQ2BE34
	+ 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=COMFACAS29D0/4D0(SH2/TH2+2D0SH/TH+3D0+
	+ & 2D0TH/SH+TH2/SH2)FACA
	+ FACGG2=COMFACAS29D0/4D0(UH2/SH2+2D0UH/SH+3D0+
	+ & 2D0SH/UH+SH2/UH2)FACA
	+ FACGG3=COMFACAS29D0/4D0(TH2/UH2+2D0TH/UH+3D0+
	+ & 2D0*UH/TH+UH2/TH2)
	+ ELSE
	+ GST= (12D0 + 40D0TH/SH + 56D0TH2/SH2 + 32D0TH3/SH*3 +
	+ & 16D0TH4/SH4 + SQDGGS(4D0SH2 + 16D0SHTH + 16D0TH2)+
	+ & 4D0REDGST(SH + 2D0TH)
	+ & (2D0SH3 - 3D0SH2TH - 2D0SHTH2 + 2D0TH**3)/SH2 +
	+ & 2D0REDGGS(2D0SH - 12D0TH2/SH - 8D0TH*3/SH2) +
	+ & 2D0REDGGT(4D0SH - 22D0TH - 68D0TH2/SH - 60D0TH**3/SH2-
	+ & 32D0TH4/SH3 - 16D0TH5/SH4) +
	+ & SQDGGT(16D0SH2 + 16D0SHTH + 68D0TH2 + 144D0TH**3/SH +
	+ & 96D0TH4/SH2 + 32D0TH5/SH3 + 16D0TH6/SH*4))/16D0
	+ GSU= (12D0 + 40D0UH/SH + 56D0UH2/SH2 + 32D0UH3/SH*3 +
	+ & 16D0UH4/SH4 + SQDGGS(4D0SH2 + 16D0SHUH + 16D0UH2)+
	+ & 4D0REDGSU(SH + 2D0UH)
	+ & (2D0SH3 - 3D0SH2UH - 2D0SHUH2 + 2D0UH**3)/SH2 +
	+ & 2D0REDGGS(2D0SH - 12D0UH2/SH - 8D0UH*3/SH2) +
	+ & 2D0REDGGU(4D0SH - 22D0UH - 68D0UH2/SH - 60D0UH**3/SH2-
	+ & 32D0UH4/SH3 - 16D0UH5/SH4) +
	+ & SQDGGU(16D0SH2 + 16D0SHUH + 68D0UH2 + 144D0UH**3/SH +
	+ & 96D0UH4/SH2 + 32D0UH5/SH3 + 16D0UH6/SH*4))/16D0
	+ GUT= (12D0 - 16D0TH(TH - UH)*2UH/SH**4 +
	+ & 4D0REDGGU(2D0TH5 - 15D0TH*4UH - 48D0TH3UH2 -
	+ & 58D0TH2UH*3 - 10D0THUH4 + UH5)/SH*4 +
	+ & 4D0REDGGT(TH*5 - 10D0TH*4UH - 58D0TH3UH2 -
	+ & 48D0TH2UH*3 - 15D0THUH4 + 2D0UH5)/SH4 +
	+ & 4D0SQDGGU(4D0TH6 + 20D0TH*5UH + 57D0TH4UH2 +
	+ & 72D0TH3UH*3+ 38D0TH2UH4+4D0THUH5 +UH6)/SH*4+
	+ & 4D0SQDGGT(4D0UH6 + 4D0TH*5UH + 38D0TH4UH2 +
	+ & 72D0TH3UH*3 +57D0TH2UH4+20D0THUH5+TH6)/SH*4+
	+ & 2D0REDGTU((TH - UH)*2 (TH*4 + 20D0TH*3UH +
	+ & 30D0TH2UH2 + 20D0THUH3 + UH4) +
	+ & SH2(7D0TH*4 + 52D0TH*3UH + 274D0TH2UH2 +
	+ & 52D0THUH*3 + 7D0UH*4))/(2D0SH**4))/16D0
	+ FACGG1=COMFACAS29D0/4D0GSTFACA
	+ FACGG2=COMFACAS29D0/4D0GSUFACA
	+ FACGG3=COMFACAS29D0/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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ FACQQB=COMFACAS24D0/9D0((THQ2+UHQ*2)/SH2+
	+ & 2D0*SQMAVG/SH)
	+ IF(ITCM(5).GE.5) THEN
	+ IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
	+ FACQQB=FACQQBSH2SQDQTS
	+ ELSE
	+ FACQQB=FACQQBSH2SQDQQS
	+ 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.5D0SH(1D0-BE34*CTH)
	+ UHQ=-0.5D0SH(1D0+BE34*CTH)
	+ THUHQ=THQUHQ-SQMAVGSH
	+ IF(MSTP(34).EQ.0) THEN
	+ FACQQ1=UHQ/THQ-2D0UHQ2/SH2+4D0(SQMAVG/SH)THUHQ/THQ*2
	+ FACQQ2=THQ/UHQ-2D0THQ2/SH2+4D0(SQMAVG/SH)THUHQ/UHQ*2
	+ ELSE
	+ FACQQ1=UHQ/THQ-2.25D0UHQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & THQ*2+0.5D0SQMAVG(THQ+SQMAVG)/THQ2-SQMAVG2/(SHTHQ)
	+ FACQQ2=THQ/UHQ-2.25D0THQ2/SH2+4.5D0(SQMAVG/SH)*THUHQ/
	+ & UHQ*2+0.5D0SQMAVG(UHQ+SQMAVG)/UHQ2-SQMAVG2/(SHUHQ)
	+ ENDIF
	+ IF(ITCM(5).GE.5) THEN
	+ IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
	+ FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDHGS+
	+ & 2.25D0THQUHQ/SH2*SQDHGS
	+ FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDHGS+
	+ & 2.25D0THQUHQ/SH2*SQDHGS
	+ ELSE
	+ FACQQ1=FACQQ1+2.25D0SQMAVG(THQ-UHQ)/(SHTHQ)REDLGS+
	+ & 2.25D0THQUHQ/SH2*SQDLGS
	+ FACQQ2=FACQQ2+2.25D0SQMAVG(UHQ-THQ)/(SHUHQ)REDLGS+
	+ & 2.25D0THQUHQ/SH2*SQDLGS
	+ ENDIF
	+ ENDIF
	+ FACQQ1=COMFACFACAAS*2(1D0/6D0)*FACQQ1
	+ FACQQ2=COMFACFACAAS*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/3D0XWCSH
	+ HP2=HP1
	+ HS=SHR*VINT(117)
	+ HSP=SHR*WDTP(0)
	+ FACZP=4D0COMFAC3D0
	+ 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-4D0EIXWV
	+ 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=SHRWDTP(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)=HIFACZPHF/((SH-SQMZP)2+HSP2)
	+ ELSE
	+C...Normal cross section.
	+ SIGH(NCHN)=FACZP(EI2/SH2HI0HP0VINT(111)+EIVI
	+ & (1D0-SQMZ/SH)/((SH-SQMZ)2+HS2)(HI0HP1+HI1HP0)
	+ & VINT(112)+EIVPI(1D0-SQMZP/SH)/((SH-SQMZP)2+HSP2)*
	+ & (HI0HP2+HI2HP0)VINT(113)+(VI2+AI*2)/
	+ & ((SH-SQMZ)2+HS2)HI1HP1VINT(114)+(VIVPI+AIAPI)
	+ & ((SH-SQMZ)(SH-SQMZP)+HSHSP)/(((SH-SQMZ)2+HS2)*
	+ & ((SH-SQMZP)2+HSP2))(HI1HP2+HI2HP1)VINT(115)+
	+ & (VPI2+API2)/((SH-SQMZP)2+HSP2)HI2HP2*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=4D0COMFAC/((SH-SQMWP)2+HS2)3D0
	+ HP=AEM/(24D0XW)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)=HIFACBWHF
	+ 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=4D0COMFAC/((SH-SQMR)2+HS2)3D0
	+ HP=AEM/(12D0XW)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)=HIFACBWHF
	+ 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=4D0COMFAC/((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(IJ.NE.KFLQQKFLQL) 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)=HIFACBWHF
	+ 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=FACBWAEMQF*2SH/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)=HIFACBWHF
	+ 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=FACBWASRTCM(45)*2SH/(3D0RTCM(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)=HIFACBWHF
	+ 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=COMFACFACAPARU(151)(ASAEM/6D0)(-TH/SH)
	+ & (UH2+SQMLQ2)/(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=COMFACFACAWIDS(42,1)(AS2/2D0)
	+ & (7D0/48D0+3D0(UH-TH)2/(16D0SH2))(1D0+2D0SQMLQ*TH/
	+ & (TH-SQMLQ)*2+2D0SQMLQUH/(UH-SQMLQ)2+4D0SQMLQ**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=COMFACWIDS(42,1)(AS*2/9D0)
	+ & (SH(SH-4D0SQMLQ)-(UH-TH)**2)/SH2
	+ FACLQS=COMFACWIDS(42,1)((PARU(151)*2AEM*2/8D0)
	+ & (-SHTH-(SQMLQ-TH)2)/TH2+(PARU(151)AEMAS/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=COMFAC0.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)FACQSABRPOS
	+ IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)FACQSABRNEG
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=2
	+ IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)FACQSABRPOS
	+ IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)FACQSABRNEG
	+ 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)FACQSBBRPOS
	+ IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)FACQSBBRNEG
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=J
	+ ISIG(NCHN,3)=2
	+ IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)FACQSBBRPOS
	+ IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)FACQSBBRNEG
	+ 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=8D0COMFAC/((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=SHPARP(181+3((IA-11)/2)+(JA-11)/2)*2/(8D0PARU(1))
	+ HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
	+ SIGH(NCHN)=HIFACBWHF
	+ 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=COMFACAEMHBW3C/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((2D0SQM3-3D0SQML)SQM4+(SQML-2D0SQM4)TH-
	+ & (TH-SQM4)SH)/(TH-SQM4)*2
	+ SMM3=2D0((2D0SQM3-3D0SQM4+TH)SQML-(2D0SQML-SQM4+TH)
	+ & SH)/(SH-SQML)**2
	+ SMM12=4D0((2D0SQML-SQM4-2D0SQM3+TH)SH+(TH-3D0*SQM3-
	+ & 3D0SQM4)TH+(2D0SQM3-2D0SQML+3D0SQM4)SQM3)/
	+ & ((UH-SQM3)*(TH-SQM4))
	+ SMM13=-4D0((TH+SQML-2D0SQM4)TH-(SQM3+3D0SQML-2D0SQM4)
	+ & SQM3+(SQM3+3D0SQML+TH)SH-(TH-SQM3+SH)**2)/
	+ & ((UH-SQM3)*(SH-SQML))
	+ SMM23=-4D0((SQML-SQM4+SQM3)TH-SQM3*2+SQM3(SQML+SQM4)-
	+ & 3D0SQMLSQM4-(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/(4D0PARU(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)=FHCCSMMWIDSC
	+ 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+GMMH2)
	+ CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
	+ GMMH3=SQRT(SQM3)*WDTP(0)
	+ HBW3C=GMMH3/((SQM3-SQMH)2+GMMH32)
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
	+ GMMH4=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	+C...Kinematical and coupling functions
	+ FACHH=COMFAC(HBW3C/HBW3)(HBW4C/HBW4)(THUH-SQM3*SQM4)
	+ XWHH=(1D0-2D0XWV)/(8D0XWV*(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-4D0EIXWV
	+ FCOI=1D0
	+ IF(IABS(I).LE.10) FCOI=FACA/3D0
	+ IF(ISUB.EQ.349) THEN
	+ HBWZ=1D0/((SH-SQMZ)2+GMMZ2)
	+ IF(IABS(I).LT.10) THEN
	+ DSIGHH=8D0AEM2(EI**2/SH2+
	+ & 2D0EIVIXWHH(SH-SQMZ)*HBWZ/SH+
	+ & (VI2+AI2)XWHH2HBWZ)
	+ ELSE
	+ IAOFF=181+3*((IABS(I)-11)/2)
	+ HSUM=(PARP(IAOFF)2+PARP(IAOFF+1)2+PARP(IAOFF+2)**2)/
	+ & (4D0*PARU(1))
	+ DSIGHH=8D0AEM2(EI**2/SH2+
	+ & 2D0EIVIXWHH(SH-SQMZ)*HBWZ/SH+
	+ & (VI2+AI2)XWHH2HBWZ)+
	+ & 8D0AEM(EIHSUM/(SHTH)+
	+ & (VI+AI)XWHHHSUM(SH-SQMZ)HBWZ/TH)+
	+ & 4D0HSUM*2/TH2
	+ ENDIF
	+ ELSE
	+ IF(IABS(I).LT.10) THEN
	+ DSIGHH=8D0AEM2EI**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=8D0AEM2EI*2/SH2+8D0AEMEIHSUM/(SH*TH)+
	+ & 4D0HSUM*2/TH2
	+ ENDIF
	+ ENDIF
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=FACHHFCOIDSIGHH
	+ 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)*8PARP(192)**2
	+ IF(ISUB.EQ.352) FACNOR=PARP(191)*62D0*
	+ & PMAS(PYCOMP(9900024),1)**2
	+ FACWW=COMFACFACNORTAUPVINT(2)VINT(219)
	+ FACPRT=1D0/((VINT(204)*2-VINT(215))
	+ & (VINT(209)**2-VINT(216)))
	+ FACPRU=1D0/((VINT(204)*2+2D0VINT(217))*
	+ & (VINT(209)*2+2D0VINT(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-2MOD(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-2MOD(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)=FACLRFACWWFACPRPFACBWHF
	+ 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=4D0COMFAC/((SH-SQMZR)2+HS2)3D0
	+ HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
	+ HP=(AEM/(3D0(1D0-2D0XW)))XWCSH
	+ 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-2D0XW)
	+ VI=SIGN(1D0,EI+0.1D0)-4D0EIXW
	+ ELSE
	+ AI=-(1D0-2D0*XW)
	+ VI=-1D0+4D0*XW
	+ ENDIF
	+ HI=HP(VI2+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)=HIFACBWHF
	+ 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=4D0COMFAC/((SH-SQMWR)2+HS2)3D0
	+ HP=AEM/(24D0XW)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=HIVCKM((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)=HIFACBWHF
	+ 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=COMFACPARP(50)2/(16D0PARU(1))SHHF/
	+ & ((SH-PMAS(KCGSTR,1)2)2+HS**2)
	+C...Modify cross section in wings of peak.
	+ FACG = FACG * SH2 / 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=COMFACPARP(50)2/(32D0PARU(1))SHHF/
	+ & ((SH-PMAS(KCGSTR,1)2)2+HS**2)
	+C...Modify cross section in wings of peak.
	+ FACG = FACG * SH2 / 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=COMFACPARP(50)2ASSH/(72D0PARU(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)+
	+ & 2D0SH2/(THUH))
	+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=-COMFACPARP(50)2ASSH/(192D0PARU(1)SQM4)
	+ & (4D0(SH2+UH2)/(THSH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
	+ & 3D0TH(4D0+SH/UH+UH/SH)/SH+4D0TH2(1D0/UH+1D0/SH)/SH+
	+ & 2D0TH2TH/(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=COMFAC3D0PARP(50)*2ASSH/(32D0PARU(1)SQM4)
	+ & ((TH2+THUH+UH2)2/(SH2THUH)+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+HS2)
	+ 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+GMMH2)
	+ CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
	+ GMMH3=SQRT(SQM3)*WDTP(0)
	+ HBW3C=GMMH3/((SQM3-SQMH)2+GMMH32)
	+ SQMH=PMAS(KCF2,1)**2
	+ GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
	+ HBW4=GMMH/((SQM4-SQMH)2+GMMH2)
	+ CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
	+ GMMH4=SQRT(SQM4)*WDTP(0)
	+ HBW4C=GMMH4/((SQM4-SQMH)2+GMMH42)
	+ 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(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
	+ &XPDIR(-6:6)
	+ COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
	+ COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
	+ & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
	+ & XMI(2,240),PT2MI(240),IMISEP(0:240)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
	+ &/PYINT9/,/PYINTM/
	+C...Local arrays.
	+ DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
	+ &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
	+ SAVE PPAR
	+
	+C...Interface to PDFLIB.
	+ COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
	+ SAVE /W50513/
	+ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
	+ &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
	+ CHARACTER*20 PARM(20)
	+ DATA VALUE/200D0/,PARM/20' '/
	+
	+C...Data related to Schuler-Sjostrand photon distributions.
	+ DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
	+
	+C...Valence PDF momentum integral parametrizations PER PARTON!
	+ DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
	+ DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
	+ PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
	+ &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
	+
	+C...Reset parton distributions.
	+ MINT(92)=0
	+ DO 100 KFL=-25,25
	+ XPQ(KFL)=0D0
	+ 100 CONTINUE
	+ DO 110 KFL=-6,6
	+ XPVAL(KFL)=0D0
	+ 110 CONTINUE
	+
	+C...Check x and particle species.
	+ IF(X.LE.0D0.OR.X.GE.1D0) THEN
	+ WRITE(MSTU(11),5000) X
	+ GOTO 9999
	+ ENDIF
	+ KFA=IABS(KF)
	+ IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
	+ &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
	+ &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
	+ &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
	+ &KFA.NE.310.AND.KFA.NE.130) THEN
	+ WRITE(MSTU(11),5100) KF
	+ GOTO 9999
	+ ENDIF
	+
	+C...Electron (or muon or tau) parton distribution call.
	+ IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
	+ CALL PYPDEL(KFA,X,Q2,XPEL)
	+ DO 120 KFL=-25,25
	+ XPQ(KFL)=XPEL(KFL)
	+ 120 CONTINUE
	+
	+C...Photon parton distribution call (VDM+anomalous).
	+ ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
	+ IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
	+ CALL PYPDGA(X,Q2,XPGA)
	+ DO 130 KFL=-6,6
	+ XPQ(KFL)=XPGA(KFL)
	+ 130 CONTINUE
	+ XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
	+ XPVAL(1)=XPVU/4D0
	+ XPVAL(2)=XPVU
	+ XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
	+ XPVAL(4)=MIN(XPQ(4),XPVU)
	+ XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
	+ XPVAL(-1)=XPVAL(1)
	+ XPVAL(-2)=XPVAL(2)
	+ XPVAL(-3)=XPVAL(3)
	+ XPVAL(-4)=XPVAL(4)
	+ XPVAL(-5)=XPVAL(5)
	+ ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
	+ Q2MX=Q2
	+ P2MX=0.36D0
	+ IF(MSTP(55).GE.7) P2MX=4.0D0
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ P2=0D0
	+ IF(VINT(120).LT.0D0) P2=VINT(120)**2
	+ CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
	+ DO 140 KFL=-6,6
	+ XPQ(KFL)=XPGA(KFL)
	+ XPVAL(KFL)=VXPDGM(KFL)
	+ 140 CONTINUE
	+ VINT(231)=P2MX
	+ ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
	+ Q2MX=Q2
	+ P2MX=0.36D0
	+ IF(MSTP(55).GE.11) P2MX=4.0D0
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ P2=0D0
	+ IF(VINT(120).LT.0D0) P2=VINT(120)**2
	+ CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
	+ DO 150 KFL=-6,6
	+ XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
	+ XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
	+ 150 CONTINUE
	+ VINT(231)=P2MX
	+ ELSEIF(MSTP(56).EQ.2) THEN
	+C...Call PDFLIB parton distributions.
	+ PARM(1)='NPTYPE'
	+ VALUE(1)=3
	+ PARM(2)='NGROUP'
	+ VALUE(2)=MSTP(55)/1000
	+ PARM(3)='NSET'
	+ VALUE(3)=MOD(MSTP(55),1000)
	+ IF(MINT(93).NE.3000000+MSTP(55)) THEN
	+ CALL PDFSET(PARM,VALUE)
	+ MINT(93)=3000000+MSTP(55)
	+ ENDIF
	+ XX=X
	+ QQ2=MAX(0D0,Q2MIN,Q2)
	+ IF(MSTP(57).EQ.0) QQ2=Q2MIN
	+ P2=0D0
	+ IF(VINT(120).LT.0D0) P2=VINT(120)**2
	+ IP2=MSTP(60)
	+ IF(MSTP(55).EQ.5004) THEN
	+ IF(5D0*P2.LT.QQ2.AND.
	+ & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
	+ & P2.GE.0D0.AND.P2.LT.10D0.AND.
	+ & XX.GT.1D-4.AND.XX.LT.1D0) THEN
	+ CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
	+ & BOT,TOP,GLU)
	+ ELSE
	+ UPV=0D0
	+ DNV=0D0
	+ USEA=0D0
	+ DSEA=0D0
	+ STR=0D0
	+ CHM=0D0
	+ BOT=0D0
	+ TOP=0D0
	+ GLU=0D0
	+ ENDIF
	+ ELSE
	+ IF(P2.LT.QQ2) THEN
	+ CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
	+ & BOT,TOP,GLU)
	+ ELSE
	+ UPV=0D0
	+ DNV=0D0
	+ USEA=0D0
	+ DSEA=0D0
	+ STR=0D0
	+ CHM=0D0
	+ BOT=0D0
	+ TOP=0D0
	+ GLU=0D0
	+ ENDIF
	+ ENDIF
	+ VINT(231)=Q2MIN
	+ XPQ(0)=GLU
	+ XPQ(1)=DNV
	+ XPQ(-1)=DNV
	+ XPQ(2)=UPV
	+ XPQ(-2)=UPV
	+ XPQ(3)=STR
	+ XPQ(-3)=STR
	+ XPQ(4)=CHM
	+ XPQ(-4)=CHM
	+ XPQ(5)=BOT
	+ XPQ(-5)=BOT
	+ XPQ(6)=TOP
	+ XPQ(-6)=TOP
	+ XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
	+ XPVAL(1)=XPVU/4D0
	+ XPVAL(2)=XPVU
	+ XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
	+ XPVAL(4)=MIN(XPQ(4),XPVU)
	+ XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
	+ XPVAL(-1)=XPVAL(1)
	+ XPVAL(-2)=XPVAL(2)
	+ XPVAL(-3)=XPVAL(3)
	+ XPVAL(-4)=XPVAL(4)
	+ XPVAL(-5)=XPVAL(5)
	+ ELSE
	+ WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
	+ ENDIF
	+
	+C...Pion/gammaVDM parton distribution call.
	+ ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
	+ &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
	+ IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
	+ & MSTP(55).LE.12) THEN
	+ ISET=1+MOD(MSTP(55)-1,4)
	+ Q2MX=Q2
	+ P2MX=0.36D0
	+ IF(ISET.GE.3) P2MX=4.0D0
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ P2=0D0
	+ IF(VINT(120).LT.0D0) P2=VINT(120)**2
	+ CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
	+ DO 160 KFL=-6,6
	+ XPQ(KFL)=XPVMD(KFL)
	+ XPVAL(KFL)=VXPVMD(KFL)
	+ 160 CONTINUE
	+ VINT(231)=P2MX
	+ ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
	+ CALL PYPDPI(X,Q2,XPPI)
	+ DO 170 KFL=-6,6
	+ XPQ(KFL)=XPPI(KFL)
	+ 170 CONTINUE
	+ XPVAL(2)=XPQ(2)-XPQ(-2)
	+ XPVAL(-1)=XPQ(-1)-XPQ(1)
	+ ELSEIF(MSTP(54).EQ.2) THEN
	+C...Call PDFLIB parton distributions.
	+ PARM(1)='NPTYPE'
	+ VALUE(1)=2
	+ PARM(2)='NGROUP'
	+ VALUE(2)=MSTP(53)/1000
	+ PARM(3)='NSET'
	+ VALUE(3)=MOD(MSTP(53),1000)
	+ IF(MINT(93).NE.2000000+MSTP(53)) THEN
	+ CALL PDFSET(PARM,VALUE)
	+ MINT(93)=2000000+MSTP(53)
	+ ENDIF
	+ XX=X
	+ QQ=SQRT(MAX(0D0,Q2MIN,Q2))
	+ IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
	+ CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
	+ VINT(231)=Q2MIN
	+ XPQ(0)=GLU
	+ XPQ(1)=DSEA
	+ XPQ(-1)=UPV+DSEA
	+ XPQ(2)=UPV+USEA
	+ XPQ(-2)=USEA
	+ XPQ(3)=STR
	+ XPQ(-3)=STR
	+ XPQ(4)=CHM
	+ XPQ(-4)=CHM
	+ XPQ(5)=BOT
	+ XPQ(-5)=BOT
	+ XPQ(6)=TOP
	+ XPQ(-6)=TOP
	+ XPVAL(2)=UPV
	+ XPVAL(-1)=UPV
	+ ELSE
	+ WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
	+ ENDIF
	+
	+C...Anomalous photon parton distribution call.
	+ ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
	+ Q2MX=Q2
	+ P2MX=PARP(15)**2
	+ IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
	+ IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
	+ IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ P2=0D0
	+ IF(VINT(120).LT.0D0) P2=VINT(120)**2
	+ CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
	+ DO 180 KFL=-6,6
	+ XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
	+ XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
	+ 180 CONTINUE
	+ VINT(231)=P2MX
	+ ELSEIF(MSTP(56).EQ.1) THEN
	+ IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
	+ IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ P2=0D0
	+ IF(VINT(120).LT.0D0) P2=VINT(120)**2
	+ CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
	+ DO 190 KFL=-6,6
	+ XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
	+ XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
	+ 190 CONTINUE
	+ VINT(231)=P2MX
	+ ELSEIF(MSTP(56).EQ.2) THEN
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
	+ DO 200 KFL=-6,6
	+ XPQ(KFL)=XPGA(KFL)
	+ XPVAL(KFL)=VXPGA(KFL)
	+ 200 CONTINUE
	+ VINT(231)=P2MX
	+ ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
	+ DO 210 KFL=-6,6
	+ XPQ(KFL)=XPGA(KFL)
	+ XPVAL(KFL)=VXPGA(KFL)
	+ 210 CONTINUE
	+ VINT(231)=P2MX
	+ ELSE
	+ 220 RKF=11D0*PYR(0)
	+ KFR=1
	+ IF(RKF.GT.1D0) KFR=2
	+ IF(RKF.GT.5D0) KFR=3
	+ IF(RKF.GT.6D0) KFR=4
	+ IF(RKF.GT.10D0) KFR=5
	+ IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
	+ IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
	+ IF(MSTP(57).EQ.0) Q2MX=P2MX
	+ CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
	+ DO 230 KFL=-6,6
	+ XPQ(KFL)=XPGA(KFL)
	+ XPVAL(KFL)=VXPGA(KFL)
	+ 230 CONTINUE
	+ VINT(231)=P2MX
	+ ENDIF
	+
	+C...Proton parton distribution call.
	+ ELSE
	+ IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
	+ CALL PYPDPR(X,Q2,XPPR)
	+ DO 240 KFL=-6,6
	+ XPQ(KFL)=XPPR(KFL)
	+ 240 CONTINUE
	+C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
	+ XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
	+ XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
	+ ELSEIF(MSTP(52).EQ.2) THEN
	+C...Call PDFLIB parton distributions.
	+ PARM(1)='NPTYPE'
	+ VALUE(1)=1
	+ PARM(2)='NGROUP'
	+ VALUE(2)=MSTP(51)/1000
	+ PARM(3)='NSET'
	+ VALUE(3)=MOD(MSTP(51),1000)
	+ IF(MINT(93).NE.1000000+MSTP(51)) THEN
	+ CALL PDFSET(PARM,VALUE)
	+ MINT(93)=1000000+MSTP(51)
	+ ENDIF
	+ XX=X
	+ QQ=SQRT(MAX(0D0,Q2MIN,Q2))
	+ IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
	+ CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
	+ VINT(231)=Q2MIN
	+ XPQ(0)=GLU
	+ XPQ(1)=DNV+DSEA
	+ XPQ(-1)=DSEA
	+ XPQ(2)=UPV+USEA
	+ XPQ(-2)=USEA
	+ XPQ(3)=STR
	+ XPQ(-3)=STR
	+ XPQ(4)=CHM
	+ XPQ(-4)=CHM
	+ XPQ(5)=BOT
	+ XPQ(-5)=BOT
	+ XPQ(6)=TOP
	+ XPQ(-6)=TOP
	+ XPVAL(1)=DNV
	+ XPVAL(2)=UPV
	+ ELSE
	+ WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
	+ ENDIF
	+ ENDIF
	+
	+C...Isospin average for pi0/gammaVDM.
	+ IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
	+ IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
	+ XPV=XPQ(2)-XPQ(1)
	+ XPQ(2)=XPQ(1)
	+ XPQ(-2)=XPQ(-1)
	+ ELSE
	+ XPS=0.5D0*(XPQ(1)+XPQ(-2))
	+ XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
	+ XPQ(2)=XPS
	+ XPQ(-1)=XPS
	+ ENDIF
	+ XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
	+ & XPVAL(3)+XPVAL(4)+XPVAL(5)
	+ DO 250 KFL=-6,6
	+ XPVAL(KFL)=0D0
	+ 250 CONTINUE
	+ IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
	+ XPQ(1)=XPQ(1)+0.2D0*XPV
	+ XPQ(2)=XPQ(2)+0.8D0*XPV
	+ XPVAL(1)=0.2D0*XPVL
	+ XPVAL(2)=0.8D0*XPVL
	+ ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
	+ XPQ(3)=XPQ(3)+XPV
	+ XPVAL(3)=XPVL
	+ ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
	+ XPQ(4)=XPQ(4)+XPV
	+ XPVAL(4)=XPVL
	+ IF(MSTP(55).GE.9) THEN
	+ DO 260 KFL=-6,6
	+ XPQ(KFL)=0D0
	+ 260 CONTINUE
	+ ENDIF
	+ ELSE
	+ XPQ(1)=XPQ(1)+0.5D0*XPV
	+ XPQ(2)=XPQ(2)+0.5D0*XPV
	+ XPVAL(1)=0.5D0*XPVL
	+ XPVAL(2)=0.5D0*XPVL
	+ ENDIF
	+ DO 270 KFL=1,6
	+ XPQ(-KFL)=XPQ(KFL)
	+ XPVAL(-KFL)=XPVAL(KFL)
	+ 270 CONTINUE
	+
	+C...Rescale for gammaVDM by effective gamma -> rho coupling.
	+C+++Do not rescale?
	+ IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
	+ & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
	+ DO 280 KFL=-6,6
	+ XPQ(KFL)=VINT(281)*XPQ(KFL)
	+ XPVAL(KFL)=VINT(281)*XPVAL(KFL)
	+ 280 CONTINUE
	+ VINT(232)=VINT(281)*XPV
	+ ENDIF
	+
	+C...Simple recipes for kaons.
	+ ELSEIF(KFA.EQ.321) THEN
	+ XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
	+ XPQ(-1)=XPQ(1)
	+ XPVAL(-3)=XPVAL(-1)
	+ XPVAL(-1)=0D0
	+ ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
	+ XPS=0.5D0*(XPQ(1)+XPQ(-2))
	+ XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
	+ XPQ(2)=XPS
	+ XPQ(-1)=XPS
	+ XPQ(1)=XPQ(1)+0.5D0*XPV
	+ XPQ(-1)=XPQ(-1)+0.5D0*XPV
	+ XPQ(3)=XPQ(3)+0.5D0*XPV
	+ XPQ(-3)=XPQ(-3)+0.5D0*XPV
	+ XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
	+ XPVAL(2)=0D0
	+ XPVAL(-1)=0D0
	+ XPVAL(1)=0.5D0*XPV
	+ XPVAL(-1)=0.5D0*XPV
	+ XPVAL(3)=0.5D0*XPV
	+ XPVAL(-3)=0.5D0*XPV
	+
	+C...Isospin conjugation for neutron.
	+ ELSEIF(KFA.EQ.2112) THEN
	+ XPSV=XPQ(1)
	+ XPQ(1)=XPQ(2)
	+ XPQ(2)=XPSV
	+ XPSV=XPQ(-1)
	+ XPQ(-1)=XPQ(-2)
	+ XPQ(-2)=XPSV
	+ XPSV=XPVAL(1)
	+ XPVAL(1)=XPVAL(2)
	+ XPVAL(2)=XPSV
	+
	+C...Simple recipes for hyperon (average valence parton distribution).
	+ ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
	+ & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
	+ XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
	+ XPS=0.5D0*(XPQ(-1)+XPQ(-2))
	+ XPQ(1)=XPS
	+ XPQ(2)=XPS
	+ XPQ(-1)=XPS
	+ XPQ(-2)=XPS
	+ XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
	+ XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
	+ XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
	+ XPV=(XPVAL(1)+XPVAL(2))/3D0
	+ XPVAL(1)=0D0
	+ XPVAL(2)=0D0
	+ XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
	+ XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
	+ XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
	+ ENDIF
	+
	+C...Charge conjugation for antiparticle.
	+ IF(KF.LT.0) THEN
	+ DO 290 KFL=1,25
	+ IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
	+ XPSV=XPQ(KFL)
	+ XPQ(KFL)=XPQ(-KFL)
	+ XPQ(-KFL)=XPSV
	+ 290 CONTINUE
	+ DO 300 KFL=1,6
	+ XPSV=XPVAL(KFL)
	+ XPVAL(KFL)=XPVAL(-KFL)
	+ XPVAL(-KFL)=XPSV
	+ 300 CONTINUE
	+ ENDIF
	+
	+C...MULTIPLE INTERACTIONS - PDF RESHAPING.
	+C...Set side.
	+ JS=MINT(30)
	+C...Only reshape PDFs for the non-first interactions;
	+C...But need valence/sea separation already from first interaction.
	+ IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
	+ KFVSEL=KFIVAL(JS,1)
	+C...If valence quark kicked out of pi0 or gamma then that decides
	+C...whether we should consider state as d dbar, u ubar, s sbar, etc.
	+ IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
	+ XPVL=0D0
	+ DO 310 KFL=1,6
	+ XPVL=XPVL+XPVAL(KFL)
	+ XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
	+ XPVAL(KFL)=0D0
	+ 310 CONTINUE
	+ XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
	+ XPVAL(IABS(KFVSEL))=XPVL
	+ DO 320 KFL=1,6
	+ XPQ(-KFL)=XPQ(KFL)
	+ XPVAL(-KFL)=XPVAL(KFL)
	+ 320 CONTINUE
	+
	+C...If valence quark kicked out of K0S or K0S then that decides whether
	+C...we should consider state as d sbar or s dbar.
	+ ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
	+ KFS=1
	+ IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
	+ XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
	+ XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
	+ XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
	+ XPVAL(-KFS)=0D0
	+ KFS=-3*KFS
	+ XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
	+ XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
	+ XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
	+ XPVAL(-KFS)=0D0
	+ ENDIF
	+
	+C...XPQ distributions are nominal for a (signed) beam particle
	+C...of KF type, with 1-Sum(x_prev) rescaled to 1.
	+ CMPFAC=1D0
	+ NRESC=0
	+ 345 NRESC=NRESC+1
	+ PVCTOT(JS,-1)=0D0
	+ PVCTOT(JS, 0)=0D0
	+ PVCTOT(JS, 1)=0D0
	+ DO 350 IFL=-6,6
	+ IF(IFL.EQ.0) GOTO 350
	+
	+C...Count up number of original IFL valence quarks.
	+ IVORG=0
	+ IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
	+ IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
	+ IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
	+C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
	+C...bookkeep as if d dbar (for total momentum sum in valence sector).
	+ IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
	+C...Count down number of remaining IFL valence quarks. Skip current
	+C...interaction initiator.
	+ IVREM=IVORG
	+ DO 330 I1=1,NMI(JS)
	+ IF (I1.EQ.MINT(36)) GOTO 330
	+ IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
	+ & IVREM=IVREM-1
	+ 330 CONTINUE
	+
	+C...Separate out original VALENCE and SEA content.
	+ VAL=XPVAL(IFL)
	+ SEA=MAX(0D0,XPQ(IFL)-VAL)
	+ XPSVC(IFL,0)=VAL
	+ XPSVC(IFL,-1)=SEA
	+
	+C...Rescale valence content if changed.
	+ IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
	+ & (VAL*IVREM)/IVORG
	+
	+C...Momentum integrals of original and removed valence quarks.
	+ IF(IVORG.NE.0) THEN
	+C...For p/n/pbar/nbar beams can split into d_val and u_val.
	+C...Isospin conjugation for neutrons
	+ IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
	+ IAFLP=IABS(IFL)
	+ IF (KFA.EQ.2112) IAFLP=3-IAFLP
	+ VPAVG=PAVG(IAFLP,Q2)
	+C...For other baryons average d_val and u_val, like for PDFs.
	+ ELSEIF(KFA.GT.1000) THEN
	+ VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
	+C...For mesons and photon average d_val and u_val and scale by 3/2.
	+C...Very crude, especially for photon.
	+ ELSE
	+ VPAVG=0.5D0(PAVG(1,Q2)+2D0PAVG(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*2EXP(3.56D0SQRT(MAX(0D0,-LOG(3D0X))))
	+ XMN=EXP(-(LOG((Q2MN-2D0)/0.052D02)/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)+FVWTV1VINT(232)
	+ XPQ(-KFV1)=XPQ(-KFV1)+FVWTV1VINT(232)
	+ XPQ(KFV2)=XPQ(KFV2)+FVWTV2VINT(232)
	+ XPQ(-KFV2)=XPQ(-KFV2)+FVWTV2VINT(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.45D0FLA
	+ 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)=FSAXPA(KFL)+FBXPB(KFL)
	+ 130 CONTINUE
	+ IF(KFA.NE.22) THEN
	+ XPQ(KFV1)=XPQ(KFV1)+(FVAXFVA1+FBXFVB1)
	+ XPQ(KFV2)=XPQ(KFV2)+(FVAXFVA2+FBXFVB2)
	+ ELSE
	+ XPQ(KFV1)=XPQ(KFV1)+WTV1(FVAVI232A+FB*VI232B)
	+ XPQ(-KFV1)=XPQ(-KFV1)+WTV1(FVAVI232A+FB*VI232B)
	+ XPQ(KFV2)=XPQ(KFV2)+WTV2(FVAVI232A+FB*VI232B)
	+ XPQ(-KFV2)=XPQ(-KFV2)+WTV2(FVAVI232A+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)/(XMNQ2MN)
	+ FA=1D0-FB
	+ FVC=(X/XMN)*0.45D0(Q2/(Q2+RMR))**0.55D0
	+ FVA=FVCFA((Q2MN+RMR)/Q2MN)**0.55D0
	+ FVB=FVCFB1.10D0XMN0.45D00.11D0
	+ FSC=(X/XMN)*(-0.08D0)(Q2/(Q2+RMP))**1.08D0
	+ FSA=FSCFA((Q2MN+RMP)/Q2MN)**1.08D0
	+ FSB=FSCFB0.21D0XMN(-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)+(FVAXFV1+FVBNV1)
	+ XPQ(KFV2)=XPQ(KFV2)+(FVAXFV2+FVBNV2)
	+ ELSE
	+ DO 160 KFL=-3,3
	+ XPQ(KFL)=XPQ(KFL)+VINT(281)FSBWTSB(KFL)
	+ 160 CONTINUE
	+ XPQ(KFV1)=XPQ(KFV1)+WTV1(FVAVINT(232)+FVB*VINT(281))
	+ XPQ(-KFV1)=XPQ(-KFV1)+WTV1(FVAVINT(232)+FVB*VINT(281))
	+ XPQ(KFV2)=XPQ(KFV2)+WTV2(FVAVINT(232)+FVB*VINT(281))
	+ XPQ(-KFV2)=XPQ(-KFV2)+WTV2(FVAVINT(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/200D0/,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.5D0HLE+1.289868D0)+(AEM/PARU(1))*2
	+ & (-2.164868D0HLE2+9.840808D0HLE-10.130464D0)
	+ HEE=HBE2(1D0-X)(HBE2-1D0)SQRT(MAX(0D0,HDE))-
	+ & 0.5D0HBE2(1D0+X)+HBE2*2/8D0((1D0+X)(-4D0X1L+3D0*XL)-
	+ & 4D0*XL/(1D0-X)-5D0-X)
	+ ELSE
	+ HEE=HBE2(1D0-X)(HBE2-1D0)EXP(0.172784D0*HBE2)/
	+ & PYGAMM(1D0+HBE2)-0.5D0HBE2(1D0+X)+HBE2*2/8D0((1D0+X)*
	+ & (-4D0X1L+3D0XL)-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=HEE1000D0HBE2/(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)=AEMPHLG(1D0+(1D0-X)**2)
	+ HLW=LOG(1D0+Q2/PMAS(24,1)*2)/(4D0PARU(102))
	+ XPEL(-24)=AEMPHLW(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-4D0X**3/3D0+
	+ & 2D0X(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=XPGPLOG(MAX(1D0,(PARP(13)/PME2)(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)+WTSTPXPGPXPGA(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)+WTSTPXPGPGLU
	+ SXP(1)=SXP(1)+WTSTPXPGPDNV
	+ SXP(2)=SXP(2)+WTSTPXPGPUPV
	+ SXP(3)=SXP(3)+WTSTPXPGPSTR
	+ SXP(4)=SXP(4)+WTSTPXPGPCHM
	+ SXP(5)=SXP(5)+WTSTPXPGPBOT
	+ SXP(6)=SXP(6)+WTSTPXPGPTOP
	+ ENDIF
	+ 150 CONTINUE
	+ SUMXPP=SXP(0)+2D0SXP(1)+2D0SXP(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)TDGAG(2,NFE)+DGAG(3,NFE)T**(-DGAG(4,NFE))
	+ DGB=DGBG(1,NFE)TDGBG(2,NFE)+DGBG(3,NFE)T**(-DGBG(4,NFE))
	+ DGC=DGCG(1,NFE)TDGCG(2,NFE)+DGCG(3,NFE)T**(-DGCG(4,NFE))
	+ XPGL=DGAXDGBX1**DGC
	+
	+C...Evaluate up- and down-type quark content.
	+ DGA=DGAN(1,NFE)TDGAN(2,NFE)+DGAN(3,NFE)T**(-DGAN(4,NFE))
	+ DGB=DGBN(1,NFE)TDGBN(2,NFE)+DGBN(3,NFE)T**(-DGBN(4,NFE))
	+ DGC=DGCN(1,NFE)TDGCN(2,NFE)+DGCN(3,NFE)T**(-DGCN(4,NFE))
	+ DGD=DGDN(1,NFE)TDGDN(2,NFE)+DGDN(3,NFE)T**(-DGDN(4,NFE))
	+ DGE=DGEN(1,NFE)TDGEN(2,NFE)+DGEN(3,NFE)T**(-DGEN(4,NFE))
	+ XPQN=X(X2+X12)/(DGA-DGBLOG(X1))+DGCXDGDX1**DGE
	+ DGA=DGAS(1,NFE)TDGAS(2,NFE)+DGAS(3,NFE)T**(-DGAS(4,NFE))
	+ DGB=DGBS(1,NFE)TDGBS(2,NFE)+DGBS(3,NFE)T**(-DGBS(4,NFE))
	+ DGC=DGCS(1,NFE)TDGCS(2,NFE)+DGCS(3,NFE)T**(-DGCS(4,NFE))
	+ DGD=DGDS(1,NFE)TDGDS(2,NFE)+DGDS(3,NFE)T**(-DGDS(4,NFE))
	+ DGE=DGES(1,NFE)TDGES(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=DGFX(X2+X12)/(DGA-DGBLOG(X1))+DGCX*DGDX1**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/(4pi).
	+ 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=Q023/(Q02+P2)/(Q022-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)(PMRHO2/(PMRHO2+P2))**2
	+ FACS=AEM(1D0/FPHI)(PMPHI2/(PMPHI2+P2))**2
	+ DO 110 KFL=-5,5
	+ XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
	+ 110 CONTINUE
	+ XPVMD(1)=XPVMD(1)+(1D0-FRACU)FACUDXFVAL
	+ XPVMD(2)=XPVMD(2)+FRACUFACUDXFVAL
	+ XPVMD(3)=XPVMD(3)+FACS*XFVAL
	+ XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)FACUDXFVAL
	+ XPVMD(-2)=XPVMD(-2)+FRACUFACUDXFVAL
	+ XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
	+ VXPVMD(1)=(1D0-FRACU)FACUDXFVAL
	+ VXPVMD(2)=FRACUFACUDXFVAL
	+ VXPVMD(3)=FACS*XFVAL
	+ VXPVMD(-1)=(1D0-FRACU)FACUDXFVAL
	+ VXPVMD(-2)=FRACUFACUDXFVAL
	+ 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))2FACNOR
	+ 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.2D0ALAM3*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/ALAM32)/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/ALAM2)/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/ALAM52)/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 * (X2+X12)
	+ XGLU = 0D0
	+ XSEA = 0D0
	+ ELSE
	+ XVAL = (1.5D0/(1D0-0.197D0S+4.33D0S2)X*2 +
	+ & (1.5D0+2.10D0S)/(1D0+3.29D0S)X1*2 +
	+ & 5.23D0S/(1D0+1.17D0S+19.9D0S3)XX1)
	+ & X*(1D0/(1D0+1.5D0S)) * (1D0-X2)(2.667D0*S)
	+ XGLU = 4D0S/(1D0+4.76D0S+15.2D0S2+29.3D0S4) *
	+ & X*(-2.03D0S/(1D0+2.44D0S)) (X1XL)(1.333D0S) *
	+ & ((4D0X2+7D0X+4D0)X1/3D0 - 2D0X(1D0+X)XL)
	+ XSEA = S2/(1D0+4.54D0S+8.19D0S2+8.05D0S3)
	+ & X*(-1.54D0S/(1D0+1.29D0S)) X1*(2.667D0S) *
	+ & ((8D0-73D0X+62D0X*2)X1/9D0 + (3D0-8D0X2/3D0)X*XL +
	+ & (2D0X-1D0)XXL*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.252D0S+3.079D0S2) *
	+ & X*(0.80D0-0.13D0S) * X1*(0.76D0+0.667D0S) * XL*(2D0S)
	+ XGLU = 7.90D0S/(1D0+5.50D0S) * EXP(-5.16D0S)
	+ & X*(-1.90D0S/(1D0+3.60D0S)) X1*1.30D0
	+ & XL*(0.50D0+3D0S) + 1.273D0 * EXP(-10D0S)
	+ & X*0.40D0 X1*(1.76D0+3D0S)
	+ XSEA = (0.1D0-0.397D0S2+1.121D0S3)/
	+ & (1D0+5.61D0S2+5.26D0S3) * X*(-7.32D0S2/(1D0+10.3D0S2))
	+ & X1*((3.76D0+15D0S+12D0S2)/(1D0+4D0S))
	+ 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.37D0S+2.18D0S2+3.73D0S3)
	+ & X*(0.51D0+0.21D0S) * X1*1.37D0 XL*(2.667D0S)
	+ XGLU = 24D0S/(1D0+9.6D0S+0.92D0S2+14.34D0S3) *
	+ & EXP(-5.94D0S) X*((-0.013D0-1.80D0S)/(1D0+3.14D0S))
	+ & X1*(2.37D0+0.4D0S) * XL*(0.32D0+3.6D0S) + 3.42D0 *
	+ & EXP(-12D0S) X*0.255D0 X1*(2.37D0+3D0S)
	+ XSEA = 0.842D0S/(1D0+21.3D0S-33.2D0S2+229D0S3) *
	+ & X*((0.13D0-2.90D0S)/(1D0+5.44D0S)) X1*(3.45D0+0.5D0S) *
	+ & XL*(2.8D0S)
	+ 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.186D0S)/(1D0-0.209D0S+1.495D0S2)
	+ & X*(0.46D0+0.25D0S) *
	+ & X1*((0.64D0+0.14D0S+5D0S2)/(1D0+S)) XL*(1.9D0S) +
	+ & (0.76D0+0.4D0S) X * X1*(2.667D0S)
	+ XGLU = (1.925D0+5.55D0S+147D0S2)/(1D0-3.59D0S+3.32D0S2) *
	+ & EXP(-18.67D0S)
	+ & X*((-5.81D0S-5.34D0S2)/(1D0+29D0S-4.26D0*S2))
	+ & * X1*((2D0-5.9D0S)/(1D0+1.7D0S))
	+ & XL*(9.3D0S/(1D0+1.7D0*S))
	+ XSEA = (0.242D0-0.252D0S+1.19D0S2)/
	+ & (1D0-0.607D0S+21.95D0S2) *
	+ & X*(-12.1D0S2/(1D0+2.62D0S+16.7D0S2)) * 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.771D0S+29.35D0S2) * EXP(-5.776D0S)
	+ & X*((0.5D0+0.208D0S)/(1D0-0.794D0S+1.516D0S2)) *
	+ & X1*((2.6D0+7.6D0S)/(1D0+5D0S))
	+ & XL*(5.15D0S/(1D0+2D0*S)) +
	+ & (0.965D0+22.35D0S)/(1D0+18.4D0S) * X * X1*(2.667D0S)
	+ XGLU = (1.808D0+29.9D0S)/(1D0+26.4D0S) * EXP(-5.28D0S)
	+ & X*((-5.35D0S-10.11D0S2)/(1D0+31.71D0S)) *
	+ & X1*((2D0-7.3D0S+4D0S2)/(1D0+2.5D0S)) *
	+ & XL*(10.9D0S/(1D0+2.5D0*S))
	+ XSEA = (0.209D0+0.644D0S2)/(1D0+0.319D0S+17.6D0S2)
	+ & X*((-0.373D0S-7.71D0S2)/(1D0+0.815D0S+11.0D0S2))
	+ & X1*(4D0+S) XL*(0.45D0S)
	+ XSEA0 = 0.209D0 * X1**4
	+ ENDIF
	+ ENDIF
	+
	+C...Threshold factors for c and b sea.
	+ SLL=LOG(LOG(Q2EFF/ALAM2)/LOG(P2EFF/ALAM2))
	+ XCHM=0D0
	+ IF(Q2.GT.PMC*2.AND.Q2.GT.1.001D0P2EFF) THEN
	+ SCH=MAX(0D0,LOG(LOG(PMC2/ALAM2)/LOG(P2EFF/ALAM**2)))
	+ IF(ISET.EQ.0) THEN
	+ XCHM=XSEA(1D0-(SCH/SLL)*2)
	+ ELSE
	+ XCHM=MAX(0D0,XSEA-XSEA0X1(2.667D0S))*(1D0-SCH/SLL)
	+ ENDIF
	+ ENDIF
	+ XBOT=0D0
	+ IF(Q2.GT.PMB*2.AND.Q2.GT.1.001D0P2EFF) THEN
	+ SBT=MAX(0D0,LOG(LOG(PMB2/ALAM2)/LOG(P2EFF/ALAM**2)))
	+ IF(ISET.EQ.0) THEN
	+ XBOT=XSEA(1D0-(SBT/SLL)*2)
	+ ELSE
	+ XBOT=MAX(0D0,XSEA-XSEA0X1(2.667D0S))*(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-2D0NFQ))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-2D0NFQ))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-2D04))LOG(LOG(Q2DIV/ALAMSQ(4))/
	+ & LOG(P2EFF/ALAMSQ(4)))
	+ SNF3=(6D0/(33D0-2D03))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-2D0NFQ))LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
	+ & LOG(P2EFF/ALAMSQ(NFQ)))
	+ IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
	+ Q2DIV=PMB**2
	+ SNFQ=(6D0/(33D0-2D0NFQ))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-2D0NFQ))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=AEM2PI2D0CHSQ*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.49D0S+26.9D0S*2)/(1D0+32.3D0S*2)X**2 +
	+ & (1.5D0-0.49D0S+7.83D0S*2)/(1D0+7.68D0S*2)(1D0-X)**2 +
	+ & 1.5D0S/(1D0-3.2D0S+7D0S2)X(1D0-X))
	+ & X*(1D0/(1D0+0.58D0S)) * (1D0-X2)(2.5D0S/(1D0+10D0S))
	+ XGLU= 2D0S/(1D0+4D0S+7D0S2)
	+ & X*(-1.67D0S/(1D0+2D0S)) (1D0-X2)(1.2D0S)
	+ & ((4D0X2+7D0X+4D0)(1D0-X)/3D0 - 2D0X(1D0+X)XL)
	+ XSEA= 0.333D0S2/(1D0+4.90D0S+4.69D0S2+21.4D0S*3)
	+ & X*(-1.18D0S/(1D0+1.22D0S)) (1D0-X)*(1.2D0S) *
	+ & ((8D0-73D0X+62D0X*2)(1D0-X)/9D0 +
	+ & (3D0-8D0X2/3D0)XXL + (2D0X-1D0)XXL**2)
	+
	+C...Threshold factors for c and b sea.
	+ SLL=LOG(LOG(Q2EFF/ALAM2)/LOG(P2EFF/ALAM2))
	+ XCHM=0D0
	+ IF(Q2.GT.PMC*2.AND.Q2.GT.1.001D0P2EFF) THEN
	+ SCH=MAX(0D0,LOG(LOG(PMC2/ALAM2)/LOG(P2EFF/ALAM**2)))
	+ XCHM=XSEA(1D0-(SCH/SLL)*3)
	+ ENDIF
	+ XBOT=0D0
	+ IF(Q2.GT.PMB*2.AND.Q2.GT.1.001D0P2EFF) THEN
	+ SBT=MAX(0D0,LOG(LOG(PMB2/ALAM2)/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)*2W2/(4D0*PM2))
	+ ENDIF
	+ SIGBH=BETA(8D0X(1D0-X)-1D0-RMQX*(1D0-X))+
	+ & XBL(X2+(1D0-X)2+RMQX(1D0-3D0X)-0.5D0RMQ2X**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-4D0X2P2/Q2
	+ IF(RPQ.GT.1D-10) THEN
	+ RPBE=SQRT(RPQ*BETA2)
	+ IF(RPBE.LT.0.99D0) THEN
	+ XBL=LOG((1D0+RPBE)/(1D0-RPBE))
	+ XBI=2D0RPBE/(1D0-RPBE*2)
	+ ELSE
	+ RPBESN=4D0PM2/W2+(4D0X*2P2/Q2)*BETA2
	+ XBL=LOG((1D0+RPBE)**2/RPBESN)
	+ XBI=2D0*RPBE/RPBESN
	+ ENDIF
	+ SIGBH=BETA(6D0X*(1D0-X)-1D0)+
	+ & XBL(X2+(1D0-X)2+RMQX(1D0-3D0X)-0.5D0RMQ2X**2)+
	+ & XBI(2D0X/Q2)(PM2X(2D0-RMQ)-P2X)
	+ 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=3D0CHSQAEM2PIXSIGBH
	+
	+ 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 = (X2+(1D0-X)2) * (-LOG(X)) - 1D0
	+ CGAM = 3D0AEM2PIX * (XTMP(1D0+P2/(P2+Q02)) + 6D0X*(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/ALAM2)/LOG(4D0/ALAM2))
	+ 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)XTS(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.232D02)/LOG(0.25D0/0.232D02))
	+ ENDIF
	+ SD2=SD**2
	+ XL=-LOG(X)
	+ XS=SQRT(X)
	+
	+C...Evaluate valence, gluon and sea distributions.
	+ XFVAL=(0.519D0+0.180D0SD-0.011D0SD2)X(0.499D0-0.027D0SD)*
	+ & (1D0+(0.381D0-0.419D0SD)XS)(1D0-X)(0.367D0+0.563D0SD)
	+ XFGLU=(X*(0.482D0+0.341D0SQRT(SD))((0.678D0+0.877D0
	+ & SD-0.175D0*SD2)+
	+ & (0.338D0-1.597D0SD)XS+(-0.233D0SD+0.406D0SD2)*X)+
	+ & SD*0.599D0EXP(-(0.618D0+2.070D0SD)+SQRT(3.676D0SD*1.263D0
	+ & XL)))*
	+ & (1D0-X)*(0.390D0+1.053D0SD)
	+ XFSEA=SD*0.55D0(1D0-0.748D0XS+(0.313D0+0.935D0SD)X)(1D0-
	+ & X)*3.359D0
	+ & EXP(-(4.433D0+1.301D0SD)+SQRT((9.30D0-0.887D0SD)SD0.56D0
	+ & XL))/
	+ & XL*(2.538D0-0.763D0SD)
	+ IF(SD.LE.0.888D0) THEN
	+ XFCHM=0D0
	+ ELSE
	+ XFCHM=(SD-0.888D0)*1.02D0(1D0+1.008D0X)(1D0-X)**(1.208D0+
	+ & 0.771D0SD)
	+ & EXP(-(4.40D0+1.493D0SD)+SQRT((2.032D0+1.901D0SD)SD0.39D0
	+ & XL))
	+ ENDIF
	+ IF(SD.LE.1.351D0) THEN
	+ XFBOT=0D0
	+ ELSE
	+ XFBOT=(SD-1.351D0)*1.03D0(1D0-X)*(0.697D0+0.855D0SD)*
	+ & EXP(-(4.51D0+1.490D0SD)+SQRT((3.056D0+1.694D0SD)SD0.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)=XINSUMUDBRATUDB/(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)=XINSUMUDBRATUDB/(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-01SB +0.2752D+00SB2-
	+ & 0.3171D+00*SB3)
	+ A1= 0.4611D+00+0.2331D-01SB -0.3403D-01SB2+0.3174D-01*SB3
	+ A2= 0.3504D+01+0.5739D+00SB +0.2676D+00SB2-0.1553D+00*SB3
	+ A3= 0.7452D+01-0.6742D+01SB +0.2849D+01SB2-0.1964D+00*SB3
	+ A4= 0.1116D+01-0.3435D+00SB +0.2865D+00SB2-0.1288D+00*SB3
	+ A5= 0.6659D-01+0.2714D+00SB -0.2688D+00SB2+0.2763D+00*SB3
	+ ELSEIF(IPRT .EQ. 1) THEN
	+ A0=Exp( 0.1141D+00+0.4764D+00SB -0.1745D+01SB2+
	+ & 0.7728D+00*SB3)
	+ A1= 0.4275D+00-0.1290D+00SB +0.3609D+00SB2-0.1689D+00*SB3
	+ A2= 0.3000D+01+0.2946D+01SB -0.4117D+01SB2+0.1989D+01*SB3
	+ A3=-0.1302D+01+0.2322D+01SB -0.4258D+01SB2+0.2109D+01*SB3
	+ A4= 0.2586D+01-0.1920D+00SB -0.3754D+00SB2+0.2731D+00*SB3
	+ A5=-0.2251D+00-0.5374D+00SB +0.2245D+01SB2-0.1034D+01*SB3
	+ ELSEIF(IPRT .EQ. 0) THEN
	+ A0=Exp(-0.7631D+00-0.7241D+00SB -0.1170D+01SB2+
	+ & 0.5343D+00*SB3)
	+ A1=-0.3573D+00+0.3469D+00SB -0.3396D+00SB2+0.9188D-01*SB3
	+ A2= 0.5604D+01+0.7458D+00SB -0.5082D+00SB2+0.1844D+00*SB3
	+ A3= 0.1549D+02-0.1809D+02SB +0.1162D+02SB2-0.3483D+01*SB3
	+ A4= 0.9881D+00+0.1364D+00SB -0.4421D+00SB2+0.2051D+00*SB3
	+ A5=-0.9505D-01+0.3259D+01SB -0.1547D+01SB2+0.2918D+00*SB3
	+ ELSEIF(IPRT .EQ. -1) THEN
	+ A0=Exp(-0.2449D+01-0.3513D+01SB +0.4529D+01SB2-
	+ & 0.2031D+01*SB3)
	+ A1=-0.4050D+00+0.3411D+00SB -0.3669D+00SB2+0.1109D+00*SB3
	+ A2= 0.7470D+01-0.2982D+01SB +0.5503D+01SB2-0.2419D+01*SB3
	+ A3= 0.1503D+02+0.1638D+01SB -0.8772D+01SB2+0.3852D+01*SB3
	+ A4= 0.1137D+01-0.1006D+01SB +0.1485D+01SB2-0.6389D+00*SB3
	+ A5=-0.5299D+00+0.3160D+01SB -0.3104D+01SB2+0.1219D+01*SB3
	+ ELSEIF(IPRT .EQ. -2) THEN
	+ A0=Exp(-0.2740D+01-0.7987D-01SB -0.9015D+00SB2-
	+ & 0.9872D-01*SB3)
	+ A1=-0.3909D+00+0.1244D+00SB -0.4487D-01SB2+0.1277D-01*SB3
	+ A2= 0.9163D+01+0.2823D+00SB -0.7720D+00SB2-0.9360D-02*SB3
	+ A3= 0.1080D+02-0.3915D+01SB -0.1153D+01SB2+0.2649D+01*SB3
	+ A4= 0.9894D+00-0.1647D+00SB -0.9426D-02SB2+0.2945D-02*SB3
	+ A5=-0.3395D+00+0.6998D+00SB +0.7000D+00SB2-0.6730D-01*SB3
	+ ELSEIF(IPRT .EQ. -3) THEN
	+ A0=Exp(-0.3640D+01+0.1250D+01SB -0.2914D+01SB2+
	+ & 0.8390D+00*SB3)
	+ A1=-0.3595D+00-0.5259D-01SB +0.3122D+00SB2-0.1642D+00*SB3
	+ A2= 0.7305D+01+0.9727D+00SB -0.9788D+00SB2-0.5193D-01*SB3
	+ A3= 0.1198D+02-0.1799D+02SB +0.2614D+02SB2-0.1091D+02*SB3
	+ A4= 0.9882D+00-0.6101D+00SB +0.9737D+00SB2-0.4935D+00*SB3
	+ A5=-0.1186D+00-0.3231D+00SB +0.3074D+01SB2-0.1274D+01*SB3
	+ ELSEIF(IPRT .EQ. -4) THEN
	+ A0=SB** 0.1122D+01Exp(-0.3718D+01-0.1335D+01SB +
	+ & 0.1651D-01*SB2)
	+ A1=-0.4719D+00+0.7509D+00SB -0.8420D+00SB2+0.2901D+00*SB3
	+ A2= 0.6194D+01-0.1641D+01SB +0.4907D+01SB2-0.2523D+01*SB3
	+ A3= 0.4426D+01-0.4270D+01SB +0.6581D+01SB2-0.3474D+01*SB3
	+ A4= 0.2683D+00+0.9876D+00SB -0.7612D+00SB2+0.1780D+00*SB3
	+ A5=-0.4547D+00+0.4410D+01SB -0.3712D+01SB2+0.1245D+01*SB3
	+ ELSEIF(IPRT .EQ. -5) THEN
	+ A0=SB** 0.9838D+00Exp(-0.2548D+01-0.7660D+01SB +
	+ & 0.3702D+01*SB2)
	+ A1=-0.3122D+00-0.2120D+00SB +0.5716D+00SB2-0.3773D+00*SB3
	+ A2= 0.6257D+01-0.8214D-01SB -0.2537D+01SB2+0.2981D+01*SB3
	+ A3=-0.6723D+00+0.2131D+01SB +0.9599D+01SB2-0.7910D+01*SB3
	+ A4= 0.9169D-01+0.4295D-01SB -0.5017D+00SB2+0.3811D+00*SB3
	+ A5= 0.2402D+00+0.2656D+01SB -0.1586D+01SB2+0.2880D+00*SB3
	+ ELSEIF(IPRT .EQ. -6) THEN
	+ A0=SB** 0.1001D+01Exp(-0.6934D+01+0.3050D+01SB -
	+ & 0.6943D+00*SB2)
	+ A1=-0.1713D+00-0.5167D+00SB +0.1241D+01SB2-0.1703D+01*SB3
	+ A2= 0.6169D+01+0.3023D+01SB -0.1972D+02SB2+0.1069D+02*SB3
	+ A3= 0.4439D+01-0.1746D+02SB +0.1225D+02SB2+0.8350D+00*SB3
	+ A4= 0.5458D+00-0.4586D+00SB +0.9089D+00SB2-0.4049D+00*SB3
	+ A5= 0.3207D+01-0.3362D+01SB +0.5877D+01SB2-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+00SB +0.3035D+00SB2-
	+ & 0.2935D+00*SB3)
	+ A1= 0.5085D+00+0.1651D-01SB -0.3592D-01SB2+0.2782D-01*SB3
	+ A2= 0.3732D+01+0.4901D+00SB +0.2218D+00SB2-0.1116D+00*SB3
	+ A3= 0.7011D+01-0.6620D+01SB +0.2557D+01SB2-0.1360D+00*SB3
	+ A4= 0.8969D+00-0.2429D+00SB +0.1811D+00SB2-0.6888D-01*SB3
	+ A5= 0.8636D-01+0.2558D+00SB -0.3082D+00SB2+0.2535D+00*SB3
	+ ELSEIF(IPRT .EQ. 1) THEN
	+ A0=Exp(-0.7266D+00-0.1584D+01SB +0.1259D+01SB2-
	+ & 0.4305D-01*SB3)
	+ A1= 0.5285D+00-0.3721D+00SB +0.5150D+00SB2-0.1697D+00*SB3
	+ A2= 0.4075D+01+0.8282D+00SB -0.4496D+00SB2+0.2107D+00*SB3
	+ A3= 0.3279D+01+0.5066D+01SB -0.9134D+01SB2+0.2897D+01*SB3
	+ A4= 0.4399D+00-0.5888D+00SB +0.4802D+00SB2-0.1664D+00*SB3
	+ A5= 0.3678D+00-0.8929D+00SB +0.1592D+01SB2-0.5713D+00*SB3
	+ ELSEIF(IPRT .EQ. 0) THEN
	+ A0=Exp(-0.2318D+00-0.9779D+00SB -0.3783D+00SB2+
	+ & 0.1037D-01*SB3)
	+ A1=-0.2916D+00+0.1754D+00SB -0.1884D+00SB2+0.6116D-01*SB3
	+ A2= 0.5349D+01+0.7460D+00SB +0.2319D+00SB2-0.2622D+00*SB3
	+ A3= 0.6920D+01-0.3454D+01SB +0.2027D+01SB2-0.7626D+00*SB3
	+ A4= 0.1013D+01+0.1423D+00SB -0.1798D+00SB2+0.1872D-01*SB3
	+ A5=-0.5465D-01+0.2303D+01SB -0.9584D+00SB2+0.3098D+00*SB3
	+ ELSEIF(IPRT .EQ. -1) THEN
	+ A0=Exp(-0.2328D+01-0.3061D+01SB +0.3620D+01SB2-
	+ & 0.1602D+01*SB3)
	+ A1=-0.3358D+00+0.3198D+00SB -0.4210D+00SB2+0.1571D+00*SB3
	+ A2= 0.8478D+01-0.3112D+01SB +0.5243D+01SB2-0.2255D+01*SB3
	+ A3= 0.1971D+02+0.3389D+00SB -0.5268D+01SB2+0.2099D+01*SB3
	+ A4= 0.1128D+01-0.4701D+00SB +0.7779D+00SB2-0.3506D+00*SB3
	+ A5=-0.4708D+00+0.3341D+01SB -0.3375D+01SB2+0.1353D+01*SB3
	+ ELSEIF(IPRT .EQ. -2) THEN
	+ A0=Exp(-0.2906D+01-0.1069D+00SB -0.1055D+01SB2+
	+ & 0.2496D+00*SB3)
	+ A1=-0.2875D+00+0.6571D-01SB -0.1987D-01SB2-0.1800D-02*SB3
	+ A2= 0.9854D+01-0.2715D+00SB -0.7407D+00SB2+0.2888D+00*SB3
	+ A3= 0.1583D+02-0.7687D+01SB +0.3428D+01SB2-0.3327D+00*SB3
	+ A4= 0.9763D+00+0.7599D-01SB -0.2128D+00SB2+0.6852D-01*SB3
	+ A5=-0.8444D-02+0.9434D+00SB +0.4152D+00SB2-0.1481D+00*SB3
	+ ELSEIF(IPRT .EQ. -3) THEN
	+ A0=Exp(-0.3780D+01+0.2499D+01SB -0.4962D+01SB2+
	+ & 0.1936D+01*SB3)
	+ A1=-0.2639D+00-0.1575D+00SB +0.3584D+00SB2-0.1646D+00*SB3
	+ A2= 0.8082D+01+0.2794D+01SB -0.5438D+01SB2+0.2321D+01*SB3
	+ A3= 0.1811D+02-0.2000D+02SB +0.1951D+02SB2-0.6904D+01*SB3
	+ A4= 0.9822D+00+0.4972D+00SB -0.8690D+00SB2+0.3415D+00*SB3
	+ A5= 0.1772D+00-0.6078D+00SB +0.3341D+01SB2-0.1473D+01*SB3
	+ ELSEIF(IPRT .EQ. -4) THEN
	+ A0=SB** 0.1122D+01Exp(-0.4232D+01-0.1808D+01SB +
	+ & 0.5348D+00*SB2)
	+ A1=-0.2824D+00+0.5846D+00SB -0.7230D+00SB2+0.2419D+00*SB3
	+ A2= 0.5683D+01-0.2948D+01SB +0.5916D+01SB2-0.2560D+01*SB3
	+ A3= 0.2051D+01+0.4795D+01SB -0.4271D+01SB2+0.4174D+00*SB3
	+ A4= 0.1737D+00+0.1717D+01SB -0.1978D+01SB2+0.6643D+00*SB3
	+ A5= 0.8689D+00+0.3500D+01SB -0.3283D+01SB2+0.1026D+01*SB3
	+ ELSEIF(IPRT .EQ. -5) THEN
	+ A0=SB** 0.9906D+00Exp(-0.1496D+01-0.6576D+01SB +
	+ & 0.1569D+01*SB2)
	+ A1=-0.2140D+00-0.6419D-01SB -0.2741D-02SB2+0.3185D-02*SB3
	+ A2= 0.5781D+01+0.1049D+00SB -0.3930D+00SB2+0.5174D+00*SB3
	+ A3=-0.9420D+00+0.5511D+00SB +0.8817D+00SB2+0.1903D+01*SB3
	+ A4= 0.2418D-01+0.4232D-01SB -0.1244D-01SB2-0.2365D-01*SB3
	+ A5= 0.7664D+00+0.1794D+01SB -0.4917D+00SB2-0.1284D+00*SB3
	+ ELSEIF(IPRT .EQ. -6) THEN
	+ A0=SB** 0.1000D+01Exp(-0.8460D+01+0.1154D+01SB +
	+ & 0.8838D+01*SB2)
	+ A1=-0.4316D-01-0.2976D+00SB +0.3174D+00SB2-0.1429D+01*SB3
	+ A2= 0.4910D+01+0.2273D+01SB +0.5631D+01SB2-0.1994D+02*SB3
	+ A3= 0.1190D+02-0.2000D+02SB -0.2000D+02SB2+0.1292D+02*SB3
	+ A4= 0.5771D+00-0.2552D+00SB +0.7510D+00SB2+0.6923D+00*SB3
	+ A5= 0.4402D+01-0.1627D+01SB -0.2085D+01SB2-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-01SB +0.2734D+00SB2-
	+ & 0.2902D+00*SB3)
	+ A1= 0.4810D+00+0.1657D-01SB -0.3800D-01SB2+0.3125D-01*SB3
	+ A2= 0.3509D+01+0.3923D+00SB +0.4010D+00SB2-0.1932D+00*SB3
	+ A3= 0.7055D+01-0.6552D+01SB +0.3466D+01SB2-0.5657D+00*SB3
	+ A4= 0.1061D+01-0.3453D+00SB +0.4089D+00SB2-0.1817D+00*SB3
	+ A5= 0.8687D-01+0.2548D+00SB -0.2967D+00SB2+0.2647D+00*SB3
	+ ELSEIF(IPRT .EQ. 1) THEN
	+ A0=Exp( 0.3961D+00+0.4914D+00SB -0.1728D+01SB2+
	+ & 0.7257D+00*SB3)
	+ A1= 0.4162D+00-0.1419D+00SB +0.3680D+00SB2-0.1618D+00*SB3
	+ A2= 0.3248D+01+0.3028D+01SB -0.4307D+01SB2+0.1920D+01*SB3
	+ A3=-0.1100D+01+0.2184D+01SB -0.3820D+01SB2+0.1717D+01*SB3
	+ A4= 0.2082D+01-0.2756D+00SB +0.3043D+00SB2-0.1260D+00*SB3
	+ A5=-0.4822D+00-0.5706D+00SB +0.2243D+01SB2-0.9760D+00*SB3
	+ ELSEIF(IPRT .EQ. 0) THEN
	+ A0=Exp(-0.4665D+00-0.7554D+00SB -0.3323D+00SB2-
	+ & 0.2734D-04*SB3)
	+ A1=-0.3359D+00+0.2395D+00SB -0.2377D+00SB2+0.7059D-01*SB3
	+ A2= 0.5451D+01+0.6086D+00SB +0.8606D-01SB2-0.1425D+00*SB3
	+ A3= 0.1026D+02-0.9352D+01SB +0.4879D+01SB2-0.1150D+01*SB3
	+ A4= 0.9935D+00-0.5017D-01SB -0.1707D-01SB2-0.1464D-02*SB3
	+ A5=-0.4160D-01+0.2305D+01SB -0.1063D+01SB2+0.3211D+00*SB3
	+ ELSEIF(IPRT .EQ. -1) THEN
	+ A0=Exp(-0.2714D+01-0.2868D+01SB +0.3700D+01SB2-
	+ & 0.1671D+01*SB3)
	+ A1=-0.3893D+00+0.3341D+00SB -0.3897D+00SB2+0.1420D+00*SB3
	+ A2= 0.8359D+01-0.3267D+01SB +0.5327D+01SB2-0.2245D+01*SB3
	+ A3= 0.2359D+02-0.5669D+01SB -0.4602D+01SB2+0.3153D+01*SB3
	+ A4= 0.1106D+01-0.4745D+00SB +0.7739D+00SB2-0.3417D+00*SB3
	+ A5=-0.5557D+00+0.3433D+01SB -0.3390D+01SB2+0.1354D+01*SB3
	+ ELSEIF(IPRT .EQ. -2) THEN
	+ A0=Exp(-0.3323D+01+0.2296D+00SB -0.1109D+01SB2+
	+ & 0.2223D+00*SB3)
	+ A1=-0.3410D+00+0.8847D-01SB -0.1111D-01SB2-0.5927D-02*SB3
	+ A2= 0.9753D+01-0.5182D+00SB -0.4670D+00SB2+0.1921D+00*SB3
	+ A3= 0.1977D+02-0.1600D+02SB +0.9481D+01SB2-0.1864D+01*SB3
	+ A4= 0.9818D+00+0.2839D-02SB -0.1188D+00SB2+0.3584D-01*SB3
	+ A5=-0.7934D-01+0.1004D+01SB +0.3704D+00SB2-0.1220D+00*SB3
	+ ELSEIF(IPRT .EQ. -3) THEN
	+ A0=Exp(-0.3985D+01+0.2855D+01SB -0.5208D+01SB2+
	+ & 0.1937D+01*SB3)
	+ A1=-0.3337D+00-0.1150D+00SB +0.3691D+00SB2-0.1709D+00*SB3
	+ A2= 0.7968D+01+0.3641D+01SB -0.6599D+01SB2+0.2642D+01*SB3
	+ A3= 0.1873D+02-0.1999D+02SB +0.1734D+02SB2-0.5813D+01*SB3
	+ A4= 0.9731D+00+0.5082D+00SB -0.8780D+00SB2+0.3231D+00*SB3
	+ A5=-0.5542D-01-0.4189D+00SB +0.3309D+01SB2-0.1439D+01*SB3
	+ ELSEIF(IPRT .EQ. -4) THEN
	+ A0=SB** 0.1105D+01Exp(-0.3952D+01-0.1901D+01SB +
	+ & 0.5137D+00*SB2)
	+ A1=-0.3543D+00+0.6055D+00SB -0.6941D+00SB2+0.2278D+00*SB3
	+ A2= 0.5955D+01-0.2629D+01SB +0.5337D+01SB2-0.2300D+01*SB3
	+ A3= 0.1933D+01+0.4882D+01SB -0.3810D+01SB2+0.2290D+00*SB3
	+ A4= 0.1806D+00+0.1655D+01SB -0.1893D+01SB2+0.6395D+00*SB3
	+ A5= 0.4790D+00+0.3612D+01SB -0.3152D+01SB2+0.9684D+00*SB3
	+ ELSEIF(IPRT .EQ. -5) THEN
	+ A0=SB** 0.9818D+00Exp(-0.1825D+01-0.7464D+01SB +
	+ & 0.2143D+01*SB2)
	+ A1=-0.2604D+00-0.1400D+00SB +0.1702D+00SB2-0.8476D-01*SB3
	+ A2= 0.6005D+01+0.6275D+00SB -0.2535D+01SB2+0.2219D+01*SB3
	+ A3=-0.9067D+00+0.1149D+01SB +0.1974D+01SB2+0.4716D+01*SB3
	+ A4= 0.3915D-01+0.5945D-01SB -0.9844D-01SB2+0.2783D-01*SB3
	+ A5= 0.5500D+00+0.1994D+01SB -0.6727D+00SB2-0.1510D+00*SB3
	+ ELSEIF(IPRT .EQ. -6) THEN
	+ A0=SB** 0.1002D+01Exp(-0.8553D+01+0.3793D+00SB +
	+ & 0.9998D+01*SB2)
	+ A1=-0.5870D-01-0.2792D+00SB +0.6526D+00SB2-0.1984D+01*SB3
	+ A2= 0.4716D+01+0.4473D+00SB +0.1128D+02SB2-0.1937D+02*SB3
	+ A3= 0.1289D+02-0.1742D+02SB -0.1983D+02SB2-0.9274D+00*SB3
	+ A4= 0.5647D+00-0.2732D+00SB +0.1074D+01SB2+0.5981D+00*SB3
	+ A5= 0.4390D+01-0.1262D+01SB -0.9026D+00SB2-0.9394D+01*SB3
	+ ENDIF
	+ ENDIF
	+
	+C...Calculation of x * f(x, Q).
	+ PYCTEQ = MAX(0D0, A0 (XA1) ((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+ AXBK + X (B + CDX))
	+ & (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 + XC)) LXBK + SAL
	+ & * 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 / LXAK * (1D0+ AGDX + BX) *
	+ & (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)
	+C...JRR: Catching arithmetic exception
	+ IF(MEXVEC(IFL) .GE. I) THEN
	+ AF(I) = AF(I) + SBX*AM(I,K,IFL)
	+ ENDIF
	+ SBX = SB1*SBX
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+ Y = -LOG(X)
	+ U = LOG(X/0.00001D0)
	+
	+ PART1 = AF(1)Y(1.D0+0.01D0AF(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)
	+C...JRR: Catching arithmetic exception
	+ IF (MEXVEC(IFL) .GE. I) THEN
	+ AF(I) = AF(I) + SBX*AM(I,K,IFL)
	+ ENDIF
	+ SBX = SB1*SBX
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+ Y = -LOG(X)
	+ U = LOG(X/0.00001D0)
	+
	+ PART1 = AF(1)Y(1.D0+0.01D0AF(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.232D02)/LOG(0.25D0/0.232D02))
	+ SD2=SD**2
	+ XL=-LOG(X)
	+ XS=SQRT(X)
	+
	+C...Evaluate valence, gluon and sea distributions.
	+ XFVUD=(0.663D0+0.191D0SD-0.041D0SD2+0.031D0SD3)
	+ & X*0.326D0(1D0+(-1.97D0+6.74D0SD-1.96D0SD2)*XS+
	+ & (24.4D0-20.7D0SD+4.08D0SD2)X)
	+ & (1D0-X)*(2.86D0+0.70D0SD-0.02D0*SD2)
	+ XFVDD=(0.579D0+0.283D0SD+0.047D0SD2)X(0.523D0-0.015D0SD)*
	+ & (1D0+(2.22D0-0.59D0SD-0.27D0SD2)XS+(5.95D0-6.19D0SD+
	+ & 1.55D0SD2)X)(1D0-X)(3.57D0+0.94D0SD-0.16D0*SD2)
	+ XFGLU=(X*(1.00D0-0.17D0SD)((4.879D0SD-1.383D0*SD2)+
	+ & (25.92D0-28.97D0SD+5.596D0SD2)X+(-25.69D0+23.68D0SD-
	+ & 1.975D0SD2)X2)+SD0.558D0EXP(-(0.595D0+2.138D0SD)+
	+ & SQRT(4.066D0SD1.218D0XL)))*
	+ & (1D0-X)*(2.537D0+1.718D0SD+0.353D0*SD2)
	+ XFSEA=(X*(0.412D0-0.171D0SD)(0.363D0-1.196D0X+(1.029D0+
	+ & 1.785D0SD-0.459D0SD2)X2)XL*(0.566D0-0.496D0SD)+
	+ & SD*1.396D0EXP(-(3.838D0+1.944D0SD)+SQRT(2.845D0SD*1.331D0
	+ & XL)))(1D0-X)(4.696D0+2.109D0SD)
	+ XFSTR=SD*0.803D0(1D0+(-3.055D0+1.024D0SD0.67D0)XS+
	+ & (27.4D0-20.0D0SD0.154D0)X)(1D0-X)6.22D0
	+ & EXP(-(4.33D0+1.408D0SD)+SQRT((8.27D0-0.437D0SD)*
	+ & SD*0.563D0XL))/XL*(2.082D0-0.577D0SD)
	+ IF(SD.LE.0.888D0) THEN
	+ XFCHM=0D0
	+ ELSE
	+ XFCHM=(SD-0.888D0)*1.01D0(1.+(4.24D0-0.804D0SD)X)*
	+ & (1D0-X)*(3.46D0+1.076D0SD)EXP(-(4.61D0+1.49D0SD)+
	+ & SQRT((2.555D0+1.961D0SD)SD*0.37D0XL))
	+ ENDIF
	+ IF(SD.LE.1.351D0) THEN
	+ XFBOT=0D0
	+ ELSE
	+ XFBOT=(SD-1.351D0)(1D0+1.848D0X)(1D0-X)*(2.929D0+
	+ & 1.396D0SD)EXP(-(4.71D0+1.514D0*SD)+
	+ & SQRT((4.02D0+1.239D0SD)SD*0.51D0XL))
	+ 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)=2D0VX*2-1D0
	+ TX(4)=4D0VX3-3D0VX
	+ TX(5)=8D0VX4-8D0VX**2+1D0
	+ TX(6)=16D0VX5-20D0VX*3+5D0VX
	+ TT(1)=1D0
	+ TT(2)=VT
	+ TT(3)=2D0VT*2-1D0
	+ TT(4)=4D0VT3-3D0VT
	+ TT(5)=8D0VT4-8D0VT**2+1D0
	+ TT(6)=16D0VT5-20D0VT*3+5D0VT
	+
	+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)=2D0VT*2-1D0
	+ TT(4)=4D0VT3-3D0VT
	+ TT(5)=8D0VT4-8D0VT**2+1D0
	+ TT(6)=16D0VT5-20D0VT*3+5D0VT
	+ 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)=2D0VT*2-1D0
	+ TT(4)=4D0VT3-3D0VT
	+ TT(5)=8D0VT4-8D0VT**2+1D0
	+ TT(6)=16D0VT5-20D0VT*3+5D0VT
	+ 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/ALAM2)/LOG(4D0/ALAM2))
	+
	+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)XTS(2)(1D0-X)*TS(3)(1D0+TS(4)*X+
	+ & TS(5)X2+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)-2D0SQRT(SQM))**2+
	+ & PARP(36)**2)))
	+ ALSSG=PYALPS(Q2BN)
	+ MSTU(115)=MST115
	+ ENDIF
	+
	+C...Evaluate attractive and repulsive factors.
	+ XATTR=4D0PARU(1)ALSSG/(3D0SQRT(MAX(1D-20,1D0-4D0SQM/SH)))
	+ FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
	+ XREPU=PARU(1)ALSSG/(6D0SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
	+ FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
	+ PYHFTH=FRATTFATTR+(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)
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ ELSEIF((KFA.EQ.111.OR.KFA.EQ.113)) THEN
	+ IF(PYR(0).GT.0.5D0) THEN
	+ KFL(2)=2
	+ KFL(3)=2
	+ ENDIF
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ ELSEIF(KFA.EQ.223) THEN
	+ IF(PYR(0).GT.0.5D0) THEN
	+ KFL(2)=1
	+ KFL(3)=1
	+ ENDIF
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ ELSEIF((KFA.EQ.130.OR.KFA.EQ.310)) THEN
	+ IF(PYR(0).GT.0.5D0) THEN
	+ KFL(2)=MOD(KFA/10,10)
	+ KFL(3)=MOD(KFA/100,10)
	+ ENDIF
	+ 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)
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ ELSEIF(KFLR.EQ.21) THEN
	+ IF(PYR(0).GT.0.5D0) THEN
	+ KFLSP=KFL(2)
	+ KFLCH=KFL(3)
	+ ENDIF
	+ 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
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ IF(IAGR.NE.3) THEN
	+ IF(PYR(0).GT.0.25D0) KSP=1
	+ ENDIF
	+ 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=1000KFL(ID1)+100KFL(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=2D0SQRT(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=2D0SQRT(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=-4D0PARU(1)ACOSH(SQRT(1D0/EPS))
	+ ELSE
	+ IF(IAUX.EQ.1) WRE=2D0SQRT(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+RATEPS))
	+ 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.25D0EPS/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)-
	+ & PYSPEN((1D0-0.25D0EPS)/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)+
	+ & PYSPEN(0.25D0(RAT+1D0)EPS/(1D0+0.25D0RATEPS),0D0,1)-
	+ & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0(LOG(1D0+0.25D0RATEPS)*2-
	+ & LOG(0.25D0RATEPS)*2)+LOG(1D0-0.25D0EPS)*
	+ & LOG((1D0+0.25D0(RAT-1D0)EPS)/(1D0+0.25D0RATEPS))+
	+ & LOG(-0.25D0EPS)LOG(0.25D0RATEPS/(1D0+0.25D0(RAT-1D0)
	+ & EPS))
	+ ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
	+ F3RE=PYSPEN(-0.25D0EPS/(BE-0.25D0EPS),0D0,1)-
	+ & PYSPEN((1D0-0.25D0EPS)/(BE-0.25D0EPS),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.25D0EPS)LOG((BE-0.25D0*EPS)/BE)+
	+ & LOG(-0.25D0EPS)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.25D0RATEPS),0D0,1)-
	+ & PYSPEN(GA/(GA+0.25D0RATEPS),0D0,1)+
	+ & PYSPEN((1D0+0.25D0RATEPS-GA)/(1D0+0.25D0RATEPS),0D0,1)-
	+ & PYSPEN((1D0+0.25D0RATEPS-GA)/(0.25D0RATEPS),0D0,1)+
	+ & 0.5D0(LOG(1D0+0.25D0RATEPS)2-LOG(0.25D0RATEPS)*2)+
	+ & LOG(GA)LOG((GA+0.25D0RATEPS)/(1D0+0.25D0RAT*EPS))+
	+ & LOG(GA-1D0)LOG(0.25D0RATEPS/(GA+0.25D0RAT*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.25D0EPS/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)-
	+ & PYSPEN((1D0-0.25D0EPS)/(1D0+0.25D0(RAT-1D0)*EPS),0D0,1)+
	+ & PYSPEN((1D0-0.25D0EPS)/(-0.25D0(RAT+1D0)*EPS),0D0,1)-
	+ & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
	+ & (0.25D0EPS))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.25D0EPS/(BE-0.25D0EPS),0D0,1)-
	+ & PYSPEN((1D0-0.25D0EPS)/(BE-0.25D0EPS),0D0,1)+
	+ & PYSPEN((1D0-0.25D0EPS)/(1D0-0.25D0EPS-BE),0D0,1)-
	+ & PYSPEN(-0.25D0EPS/(1D0-0.25D0EPS-BE),0D0,1)+
	+ & LOG((1D0-0.25D0EPS)/(0.25D0EPS))*
	+ & LOG((BE-0.25D0EPS)/(BE-1D0+0.25D0EPS))
	+ F3IM=-PARU(1)LOG((BE-0.25D0EPS)/(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.25D0RATEPS),0D0,1)-
	+ & PYSPEN(GA/(GA+0.25D0RATEPS),0D0,1)+
	+ & PYSPEN(GA/(GA-1D0-0.25D0RATEPS),0D0,1)-
	+ & PYSPEN((GA-1D0)/(GA-1D0-0.25D0RATEPS),0D0,1)+
	+ & LOG(GA/(1D0-GA))LOG((GA+0.25D0RAT*EPS)/
	+ & (1D0+0.25D0RATEPS-GA))
	+ F3IM=-PARU(1)LOG((GA+0.25D0RAT*EPS)/
	+ & (1D0+0.25D0RATEPS-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+(2D0BE-1D0)*2)
	+ RCTHE=RSQ(1D0-2D0BE/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/(2D0BE-1D0)F3RE
	+ Y3IM=2D0/(2D0BE-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(XRE2+XIM2)
	+ 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-(ALGXRE2-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(XRE2+XIM2)
	+ XARG=SIGN(ACOS(XRE/XMOD),XIM)
	+ ALGYRE=LOG(XMOD)
	+ ALGYIM=XARG
	+ SP0RE=SP0RE+SGN(PARU(1)2/6D0-(ALGXREALGYRE-ALGXIM*ALGYIM))
	+ SP0IM=SP0IM-SGN(ALGXREALGYIM+ALGXIM*ALGYRE)
	+ SGN=-SGN
	+ ENDIF
	+
	+ XRE=1D0-XRE
	+ XIM=-XIM
	+ XMOD=SQRT(XRE2+XIM2)
	+ 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=(SAVEREZRE-SAVEIMZIM)/DBLE(I+1)
	+ TERMIM=(SAVEREZIM+SAVEIMZRE)/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)=PTCOS(VINT(198+5I))
	+ PP(I,2)=PTSIN(VINT(198+5I))
	+ 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.5D0SHPR(-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)=64PQ6+16PQ*4PH*2+32PQ*4(X1+2X2+X4+X9+2
	+ & X7+X5)+8PQ2PH*2(-X1-X4+2X7)+16PQ*2(X2X9+4X2*
	+ & X7+X2X5-2X4X7-2X9X7)+8PH*2X4X7-16X2X9X7
	+ FM(1,2)=16PQ6+8PQ*4(-2X1+X2-2X3-2X4-4X10+X9-X8+2
	+ & X7-4X6+X5)+8PQ2(-2X1X2-2X2X4-2X2X10+X2X7-2
	+ & X2X6-2X3X7+2X4X7+4X10X7-X9X7-X8X7)+16X2X7(X4+
	+ & X10)
	+ FM(1,3)=16PQ6-4PQ*4PH*2+8PQ*4(-2X1+2X2-2X3-4
	+ & X4-8X10+X9+X8-2X7-4X6+2X5)-(4PQ2PH*2)(X1+X4+X10
	+ & +X6)+8PQ2(-2X1X2-2X1X10+X1X9+X1X8-2X1X5+X2**2
	+ & -4X2X4-5X2X10+X2X8-X2X7-3X2X6+X2X5+X3X9+2X3X7
	+ & -X3X5+X4X8+2X4X6-3X4X5-5X10X5+X9X8+X9X6+X9*X5+
	+ & X8X7-4X6X5+X52)-(16X2X5)(X1+X4+X10+X6)
	+ FM(1,4)=16PQ6+4PQ*4PH*2+16PQ*4(-X1+X2-X3-X4+X10-
	+ & X9-X8+2X7+2X6-X5)+4PQ2PH*2(X1+X3+X4+X10+2X7+2X6
	+ & )+8PQ2(4X1X10+4X1X7+4X1X6+2X2X10-X2X9-X2X8+
	+ & 4X2X7+4X2X6-X2X5+4X10X5+4X7X5+4X6X5)-(8PH*2
	+ & X1)(X10+X7+X6)+16X2X5(X10+X7+X6)
	+ FM(1,5)=8PQ4(-2X1-2X4+X10-X9)+4PQ2(4X12-2X1*
	+ & X2+8X1X3+6X1X10-2X1X9+4X1X8+4X1X7+4X1X6+2X1
	+ & X5+X2X10+4X3X4-X3X9+2X3X7+3X4X8-2X4X6+2X4X5-4
	+ & X10X7+3X10X5-3X9X6+3X8X7-4X72+4X7X5)+8(X1**
	+ & 2X9-X12X8-X1X2X7+X1X2X6+X1X3X9+X1X3X5-X1X4
	+ & X8-X1X4X5+X1X10X9+X1X9X7+X1X9X6-X1X8X7-X2X3X7
	+ & +X2X4X6-X2X10X7-X2X72+X3X7X5-X4X10X5-X4X7*X5-
	+ & X4X6X5)
	+ FM(1,6)=16PQ4(-4X1-X4+X9-X7)+4PQ*2PH*2(-2*X1-X4-
	+ & X7)+16PQ2(-2X12-3X1X2-2X1X4-3X1X9-2X1X7-3
	+ & X1X5-2X2X4-2X7X5)-8PH*2X4X7+8(-X1X2X9-2X1X2
	+ & X5-X1X9*2-X1X9X5+X22X7-X2X4X5+X2X9X7-X2X7X5
	+ & +X4X9X5+X4X5*2)
	+ FM(1,7)=8PQ4(2X3+X4+3X10+X9+2X8+3X7+6X6)+2PQ*2
	+ & PH*2(-2X3-X4+3X10+3X7+6X6)+4PQ2(4X1X10+4X1
	+ & X7+8X1X6+6X2X10+X2X9+2X2X8+6X2X7+12X2X6-8X3*
	+ & X7+4X4X7+4X4X6+4X10X5+4X9X7+4X9X6-8X8X7+4X7
	+ & X5+8X6X5)+4PH2(-X1X10-X1X7-2X1X6+2X3X7-X4*X7-
	+ & X4X6)+8X2(X10X5+X9X7+X9X6-2X8X7+X7X5+2X6*X5)
	+ FM(1,8)=8PQ4(2X3+X4+3X10+2X9+X8+3X7+6X6)+2PQ*2
	+ & PH*2(-2X3-X4+2X10+X7+2X6)+4PQ*2(4X1X10-2X1X9+
	+ & 2X1X8+4X1X7+8X1X6+5X2X10+2X2X9+X2X8+4X2X7+8
	+ & X2X6-X3X9-8X3X7+2X3X5+2X4X9-X4X8+4X4X7+4X4*X6
	+ & +4X4X5+5X10X5+X9*2-X9X8+2X9X7+5X9X6+X9X5-7X8*
	+ & X7+2X8X5+2X7X5+10X6X5)+2PH2(-X1X10+X3X7-2X4
	+ & X7+X4X6)+4(-X1X92+X1X9X8-2X1X9X5-X1X8X5+2X2
	+ & X10X5+X2X9X7+X2X9X6-2X2X8X7+3X2X6X5+X3X9*X5+
	+ & X3X52+X4X9X5-2X4X8X5+2X4X5**2)
	+ FM(2,2)=16PQ6+16PQ*4(-X1+X3-X4-X10+X7-X6)+16PQ2(
	+ & X3X10+X3X7+X3X6+X4X7+X10X7)-16X3X10X7
	+ FM(2,3)=16PQ6+8PQ*4(-2X1+X2+2X3-4X4-4X10-X9+X8-2
	+ & X7-2X6+X5)+8PQ2(-2X1X5+4X3X10-X3X9-X3X8-2X3
	+ & X7+2X3X6+X3X5-2X4X5-2X10X5-2X6X5)+16X3X5(X10+
	+ & X6)
	+ FM(2,4)=8PQ4(-2X1-2X3+X10-X8)+4PQ2(4X12-2X1*
	+ & X2+8X1X4+6X1X10+4X1X9-2X1X8+4X1X7+4X1X6+2X1
	+ & X5+X2X10+4X3X4+3X3X9-2X3X7+2X3X5-X4X8+2X4X6-4
	+ & X10X6+3X10X5+3X9X6-3X8X7-4X62+4X6X5)+8(-X1
	+ & *2X9+X1*2X8+X1X2X7-X1X2X6-X1X3X9-X1X3X5+X1*X4
	+ & X8+X1X4X5+X1X10X8-X1X9X6+X1X8X7+X1X8X6+X2X3*
	+ & X7-X2X4X6-X2X10X6-X2X62-X3X10X5-X3X7X5-X3X6*
	+ & X5+X4X6X5)
	+ FM(2,5)=16PQ4X10+8PQ2(2X12+2X1X3+2X1X4+2X1
	+ & X10+2X1X7+2X1X6+X3X7+X4X6)+8(-2X13-2X1*2X3-
	+ & 2X12X4-2X12X10-2X12X7-2X12X6-2X1X3*X4-
	+ & X1X3X10-2X1X3X6-X1X4X10-2X1X4X7-X1X102-X1
	+ & X10X7-X1X10X6-2X1X7X6+X3*2X7-X3X4X7-X3X4X6+X3
	+ & X10X7+X3X72-X3X7X6+X42X6+X4X10X6-X4X7X6+X4*
	+ & X6**2)
	+ FM(2,6)=8PQ4(-2X1+X10-X9-2X7)+4PQ2(4X12+2X1*
	+ & X2+4X1X3+4X1X4+6X1X10-2X1X9+4X1X8+8X1X6-2X1
	+ & X5+4X2X4+3X2X10+2X2X7-3X3X9-2X3X7-4X42-4X4*
	+ & X10+3X4X8+2X4X6+X10X5-X9X6+3X8X7+4X7X6)+8(X1*
	+ & 2X9-X12X8-X1X2X7+X1X2X6+X1X3X9+X1X3X5+X1X4
	+ & X9-X1X4X8-X1X4X5+X1X10X9+X1X9X6-X1X8X7-X2X3X7
	+ & -X2X4X7+X2X4X6-X2X10X7+X3X7X5-X4*2X5-X4X10X5-
	+ & X4X6X5)
	+ FM(2,7)=8PQ4(X3+2X4+3X10+X7+2X6)+4PQ*2(-4X1X3-
	+ & 2X1X4-2X1X10+X1X9-X1X8-4X1X7-2X1X6+X2X3+2X2*
	+ & X4+3X2X10+X2X7+2X2X6-6X3X4-6X3X10-2X3X9-2X3*
	+ & X7-4X3X6-X3X5-6X4*2-6X4X10-3X4X9-X4X8-4X4X7-2
	+ & X4X6-2X4X5-3X10X9-3X10X8-6X10X7-6X10X6+X10*X5
	+ & +X9X7-2X8X7-2X8X6-6X7X6+X7X5-6X62+2X6X5)+4(
	+ & -X1*2X9+X1*2X8-2X1X2X10-3X1X2X7-3X1X2X6+X1
	+ & X3X9-X1X3X5+X1X4X9+X1X4X8+X1X4X5+X1X10X9+X1
	+ & X10X8-X1X9X6+X1X8X6+X2X3X7-3X2X4X7-X2X4X6-3*
	+ & X2X10X7-3X2X10X6-3X2X7X6-3X2X6*2-2X3X4X5-X3
	+ & X10X5-X3X6X5-X4*2X5-X4X10X5+X4X6X5)
	+ FM(2,8)=8PQ4(X3+2X4+3X10+X7+2X6)+4PQ*2(-4X1X3-
	+ & 2X1X4-2X1X10-X1X9+X1X8-4X1X7-2X1X6+X2X3+2X2*
	+ & X4+X2X10-X2X7-2X2X6-6X3X4-6X3X10-2X3X9+X3X8-2
	+ & X3X7-4X3X6+X3X5-6X42-6X4X10-2X4X9-4X4X7-2X4
	+ & X6+2X4X5-3X10X9-3X10X8-6X10X7-6X10X6+3X10*X5-
	+ & X9X6-2X8X7-3X8X6-6X7X6+X7X5-6X62+2X6X5)+4(
	+ & X1*2X9-X1*2X8-X1X2X7+X1X2X6-3X1X3X5+X1X4*X9-
	+ & X1X4X8-3X1X4X5+X1X10X9+X1X10X8-2X1X10X5+X1*X9
	+ & X6+X1X8X7+X1X8X6-X2X4X7+X2X4X6-X2X10X7-X2X10*
	+ & X6-2X2X7X6-X2X6*2-3X3X4X5-3X3X10X5+X3X7X5-3
	+ & X3X6X5-3X42X5-3X4X10X5-X4X6*X5)
	+ FM(3,3)=64PQ6+16PQ*4PH*2+32PQ*4(X1+X2+2*X3+X8+X6
	+ & +2X5)+8PQ*2PH*2(-X1+2X3-X6)+16PQ*2(X2X5-2X3*
	+ & X8-2X3X6+4X3X5+X8X5)+8PH*2X3X6-16X3X8X5
	+ FM(3,4)=16PQ4(-4X1-X3+X8-X6)+4PQ*2PH*2(-2*X1-X3-
	+ & X6)+16PQ2(-2X12-3X1X2-2X1X3-3X1X8-2X1X6-3
	+ & X1X5-2X2X3-2X6X5)-8PH*2X3X6+8(-X1X2X8-2X1X2
	+ & X5-X1X8*2-X1X8X5+X22X6-X2X3X5+X2X8X6-X2X6X5
	+ & +X3X8X5+X3X5*2)
	+ FM(3,5)=8PQ4(-2X1+X10-X8-2X6)+4PQ2(4X12+2X1*
	+ & X2+4X1X3+4X1X4+6X1X10+4X1X9-2X1X8+8X1X7-2X1
	+ & X5+4X2X3+3X2X10+2X2X6-4X32-4X3X10+3X3X9+2X3
	+ & X7-3X4X8-2X4X6+X10X5+3X9X6-X8X7+4X7X6)+8(-X1
	+ & *2X9+X1*2X8+X1X2X7-X1X2X6-X1X3X9+X1X3X8-X1*X3
	+ & X5+X1X4X8+X1X4X5+X1X10X8-X1X9X6+X1X8X7+X2X3*
	+ & X7-X2X3X6-X2X4X6-X2X10X6-X3*2X5-X3X10X5-X3X7
	+ & X5+X4X6X5)
	+ FM(3,6)=16PQ6+4PQ*4PH*2+16PQ*4(-X1-X2+2X3+2X4+
	+ & X10-X9-X8-X7-X6+X5)+4PQ2PH*2(X1+2X3+2X4+X10+X7+X6
	+ & )+8PQ2(4X1X3+4X1X4+4X1X10+4X2X3+4X2X4+4X2
	+ & X10-X2X5+4X3X5+4X4X5+2X10X5-X9X5-X8X5)-(8PH*2
	+ & X1)(X3+X4+X10)+16X2X5(X3+X4+X10)
	+ FM(3,7)=8PQ4(3X3+6X4+3X10+X9+2X8+2X7+X6)+2PQ*2
	+ & PH*2(X3+2X4+2X10-2X7-X6)+4PQ*2(4X1X3+8X1X4+4*
	+ & X1X10+2X1X9-2X1X8+2X2X3+10X2X4+5X2X10+2X2*X9+
	+ & X2X8+2X2X7+4X2X6-7X3X9+2X3X8-8X3X7+4X3X6+4
	+ & X3X5+5X4X8+4X4X6+8X4X5+5X10X5-X9X8-X9X6+X9X5+
	+ & X8*2-X8X7+2X8X6+2X8X5)+2PH2(-X1X10+X3X7-2X3
	+ & X6+X4X6)+4(-X1X2X9-2X1X2X8+X1X9X8-X1X82+X22
	+ & X7+2X2*2X6+3X2X4X5+2X2X10X5-2X2X9X6+X2X8*X7
	+ & +X2X8X6-2X3X9X5+X3X8X5+X4X8*X5)
	+ FM(3,8)=8PQ4(3X3+6X4+3X10+2X9+X8+2X7+X6)+2PQ*2
	+ & PH*2(3X3+6X4+3X10-2X7-X6)+4PQ2(4X1X3+8X1X4+
	+ & 4X1X10+4X2X3+8X2X4+4X2X10-8X3X9+4X3X8-8X3X7
	+ & +4X3X6+6X3X5+4X4X8+4X4X6+12X4X5+6X10X5+2X9
	+ & X5+X8X5)+4PH*2(-X1X3-2X1X4-X1X10+2X3X7-X3*X6-X4
	+ & X6)+8X5(X2X3+2X2X4+X2X10-2X3X9+X3X8+X4*X8)
	+ FM(4,4)=64PQ6+16PQ*4PH*2+32PQ*4(X1+2X2+X3+X8+2
	+ & X6+X5)+8PQ2PH*2(-X1-X3+2X6)+16PQ*2(X2X8+4X2*
	+ & X6+X2X5-2X3X6-2X8X6)+8PH*2X3X6-16X2X8X6
	+ FM(4,5)=16PQ6+8PQ*4(-2X1+X2-2X3-2X4-4X10-X9+X8-4
	+ & X7+2X6+X5)+8PQ2(-2X1X2-2X2X3-2X2X10-2X2X7+
	+ & X2X6+2X3X6-2X4X6+4X10X6-X9X6-X8X6)+16X2X6(X3+
	+ & X10)
	+ FM(4,6)=16PQ6-4PQ*4PH*2+8PQ*4(-2X1+2X2-4X3-2
	+ & X4-8X10+X9+X8-4X7-2X6+2X5)-(4PQ2PH*2)(X1+X3+X10
	+ & +X7)+8PQ2(-2X1X2-2X1X10+X1X9+X1X8-2X1X5+X2**2
	+ & -4X2X3-5X2X10+X2X9-3X2X7-X2X6+X2X5+X3X9+2X3X7
	+ & -3X3X5+X4X8+2X4X6-X4X5-5X10X5+X9X8+X9X6+X8*X7+
	+ & X8X5-4X7X5+X52)-(16X2X5)(X1+X3+X10+X7)
	+ FM(4,7)=8PQ4(-X3-2X4-3X10-2X9-X8-6X7-3X6)+2PQ**2
	+ & PH2(X3+2X4-3X10-6X7-3X6)+4PQ2(-4X1X10-8X1
	+ & X7-4X1X6-6X2X10-2X2X9-X2X8-12X2X7-6X2X6-4X3*
	+ & X7-4X3X6+8X4X6-4X10X5+8X9X6-4X8X7-4X8X6-8X7
	+ & X5-4X6X5)+4PH2(X1X10+2X1X7+X1X6+X3X7+X3X6-2*
	+ & X4X6)+8X2(-X10X5+2X9X6-X8X7-X8X6-2X7X5-X6*X5)
	+ FM(4,8)=8PQ4(-X3-2X4-3X10-X9-2X8-6X7-3X6)+2PQ**2
	+ & PH2(X3+2X4-2X10-2X7-X6)+4PQ*2(-4X1X10-2X1X9
	+ & +2X1X8-8X1X7-4X1X6-5X2X10-X2X9-2X2X8-8X2*X7-4
	+ & X2X6+X3X9-2X3X8-4X3X7-4X3X6-4X3X5+X4X8+8X4
	+ & X6-2X4X5-5X10X5+X9X8+7X9X6-2X9X5-X82-5X8*X7-2
	+ & X8X6-X8X5-10X7X5-2X6X5)+2PH*2(X1X10-X3X7+2*X3
	+ & X6-X4X6)+4(-X1X9X8+X1X9X5+X1X8*2+2X1X8X5-2*X2
	+ & X10X5+2X2X9X6-X2X8X7-X2X8X6-3X2X7X5+2X3X9*
	+ & X5-X3X8X5-2X3X5*2-X4X8X5-X4X5**2)
	+ FM(5,5)=16PQ6+16PQ*4(-X1-X3+X4-X10-X7+X6)+16PQ2(
	+ & X3X6+X4X10+X4X7+X4X6+X10X6)-16X4X10X6
	+ FM(5,6)=16PQ6+8PQ*4(-2X1+X2-4X3+2X4-4X10+X9-X8-2
	+ & X7-2X6+X5)+8PQ2(-2X1X5-2X3X5+4X4X10-X4X9-X4
	+ & X8+2X4X7-2X4X6+X4X5-2X10X5-2X7X5)+16X4X5(X10+
	+ & X7)
	+ FM(5,7)=8PQ4(-2X3-X4-3X10-2X7-X6)+4PQ*2(2X1X3+
	+ & 4X1X4+2X1X10+X1X9-X1X8+2X1X7+4X1X6-2X2X3-X2*
	+ & X4-3X2X10-2X2X7-X2X6+6X3*2+6X3X4+6X3X10+X3X9+
	+ & 3X3X8+2X3X7+4X3X6+2X3X5+6X4X10+2X4X8+4X4X7+
	+ & 2X4X6+X4X5+3X10X9+3X10X8+6X10X7+6X10X6-X10X5+
	+ & 2X9X7+2X9X6-X8X6+6X7*2+6X7X6-2X7X5-X6X5)+4*(-
	+ & X1*2X9+X1*2X8+2X1X2X10+3X1X2X7+3X1X2X6-X1X3
	+ & X9-X1X3X8-X1X3X5-X1X4X8+X1X4X5-X1X10X9-X1X10*
	+ & X8-X1X9X7+X1X8X7+X2X3X7+3X2X3X6-X2X4X6+3X2*
	+ & X10X7+3X2X10X6+3X2X7*2+3X2X7X6+X3*2X5+2X3X4
	+ & X5+X3X10X5-X3X7X5+X4X10X5+X4X7*X5)
	+ FM(5,8)=8PQ4(-2X3-X4-3X10-2X7-X6)+4PQ*2(2X1X3+
	+ & 4X1X4+2X1X10-X1X9+X1X8+2X1X7+4X1X6-2X2X3-X2*
	+ & X4-X2X10+2X2X7+X2X6+6X32+6X3X4+6X3X10+2X3*X8+
	+ & 2X3X7+4X3X6-2X3X5+6X4X10-X4X9+2X4X8+4X4X7+2
	+ & X4X6-X4X5+3X10X9+3X10X8+6X10X7+6X10X6-3X10X5+
	+ & 3X9X7+2X9X6+X8X7+6X7*2+6X7X6-2X7X5-X6X5)+4*(
	+ & X1*2X9-X1*2X8-X1X2X7+X1X2X6+X1X3X9-X1X3X8+3*
	+ & X1X3X5+3X1X4X5-X1X10X9-X1X10X8+2X1X10X5-X1*X9
	+ & X7-X1X9X6-X1X8X7-X2X3X7+X2X3X6+X2X10X7+X2X10*
	+ & X6+X2X72+2X2X7X6+3X32X5+3X3X4X5+3X3X10X5+
	+ & X3X7X5+3X4X10X5+3X4X7X5-X4X6X5)
	+ FM(6,6)=64PQ6+16PQ*4PH*2+32PQ*4(X1+X2+2*X4+X9+X7
	+ & +2X5)+8PQ*2PH*2(-X1+2X4-X7)+16PQ*2(X2X5-2X4*
	+ & X9-2X4X7+4X4X5+X9X5)+8PH*2X4X7-16X4X9X5
	+ FM(6,7)=8PQ4(-6X3-3X4-3X10-2X9-X8-X7-2X6)+2PQ**2
	+ & PH2(-2X3-X4-2X10+X7+2X6)+4PQ*2(-8X1X3-4X1X4
	+ & -4X1X10+2X1X9-2X1X8-10X2X3-2X2X4-5X2X10-X2*X9
	+ & -2X2X8-4X2X7-2X2X6-5X3X9-4X3X7-8X3X5-2X4X9+
	+ & 7X4X8-4X4X7+8X4X6-4X4X5-5X10X5-X9*2+X9X8-2*X9
	+ & X7+X9X6-2X9X5+X8X7-X8X5)+2PH2(X1X10-X3X7+2*X4
	+ & X7-X4X6)+4(2X1X2X9+X1X2X8+X1X92-X1X9X8-2X2
	+ & *2X7-X2*2X6-3X2X3X5-2X2X10X5-X2X9X7-X2X9X6+
	+ & 2X2X8X7-X3X9X5-X4X9X5+2X4X8X5)
	+ FM(6,8)=8PQ4(-6X3-3X4-3X10-X9-2X8-X7-2X6)+2PQ**2
	+ & PH2(-6X3-3X4-3X10+X7+2X6)+4PQ2(-8X1X3-4X1
	+ & X4-4X1X10-8X2X3-4X2X4-4X2X10-4X3X9-4X3X7-12*
	+ & X3X5-4X4X9+8X4X8-4X4X7+8X4X6-6X4X5-6X10*X5-X9
	+ & X5-2X8X5)+4PH*2(2X1X3+X1X4+X1X10+X3X7+X4X7-2*
	+ & X4X6)+8X5(-2X2X3-X2X4-X2X10-X3X9-X4X9+2X4*X8)
	+ FM(7,7)=72PQ4X10+18PQ2PH*2X10+8PQ2(X1X10+9
	+ & X2X10+7X3X7+2X3X6+2X4X7+7X4X6+X10X5+2X9X7+7*
	+ & X9X6+7X8X7+2X8X6)+2PH*2(-X1X10-7X3X7-2X3*X6-2
	+ & X4X7-7X4X6)+4X2(X10X5+2X9X7+7X9X6+7X8X7+2X8
	+ & *X6)
	+ FM(7,8)=72PQ4X10+2PQ2PH*2X10+4PQ2(2X1X10+
	+ & 10X2X10+7X3X9+2X3X8+14X3X7+4X3X6+2X4X9+7X4
	+ & X8+4X4X7+14X4X6+10X10X5+X9*2+7X9X8+2X9X7+7X9*
	+ & X6+X8*2+7X8X7+2X8X6)+2PH*2(7X1X10-7X3X7-2X3
	+ & X6-2X4X7-7X4X6)+2(-2X1X92-14X1X9X8-2X1X8**2
	+ & +2X2X10X5+2X2X9X7+7X2X9X6+7X2X8X7+2X2X8*X6+
	+ & 7X3X9X5+2X3X8X5+2X4X9X5+7X4X8X5)
	+ FM(8,8)=72PQ4X10+18PQ2PH*2X10+8PQ2(X1*X10+X2
	+ & X10+7X3X9+2X3X8+7X3X7+2X3X6+2X4X9+7X4X8+2X4
	+ & X7+7X4X6+9X10X5)+2PH*2(-X1X10-7X3X7-2X3X6-2
	+ & X4X7-7X4X6)+4X5(X2X10+7X3X9+2X3X8+2X4X9+7X4
	+ & X8)
	+ FM(9,9)=-4PQ4X10-PQ*2PH*2X10+4PQ2(-X1X10-X2X10+
	+ & X3X7+X4X6-X10X5+X9X6+X8X7)+PH2(X1X10-X3X7-X4*X6
	+ & )+2X2(-X10X5+X9X6+X8*X7)
	+ FM(9,10)=-4PQ4X10-PQ*2PH*2X10+2PQ2(-2X1X10-2X2
	+ & X10+2X3X9+2X3X7+2X4X6-2X10X5+X9X8+2X8X7)+PH*2
	+ & (X1X10-X3X7-X4X6)+2(-X1X9X8-X2X10X5+X2X8X7+X3
	+ & X9*X5)
	+ FMXX=-4PQ4X10-PQ*2PH*2X10+2PQ2(-2X1X10-2X2
	+ & X10+2X4X8+2X4X6+2X3X7-2X10X5+X9X8+2X9X6)+PH*2
	+ & (X1X10-X3X7-X4X6)+2(-X1X9X8-X2X10X5+X2X9X6+X4
	+ & X8*X5)
	+ FM(9,10)=0.5D0*(FMXX+FM(9,10))
	+ FM(10,10)=-4PQ4X10-PQ*2PH*2X10+4PQ2(-X1X10-X2X10+
	+ & X3X7+X4X6-X10X5+X9X3+X8X4)+PH2(X1X10-X3X7-X4*X6
	+ & )+2X5(-X10X2+X9X3+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)FACCLR(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=-8D0PQ4X10-2D0PQ2PH*2X10-(8D0PQ2)(X2*X10+X3
	+ & X7+X4X6+X9X6+X8X7)+2D0PH2(X3X7+X4X6)-(4D0X2)(X9
	+ & X6+X8X7)
	+ A12=-8D0PQ4X10+4D0PQ2(-X2X10-X3X9-2D0X3X7-X4*X8-
	+ & 2D0X4X6-X10X5-X9X8-X9X6-X8X7)+2D0PH2(-X1X10+X3X7
	+ & +X4X6)+2D0(2D0X1X9X8-X2X9X6-X2X8X7-X3X9X5-X4X8*
	+ & X5)
	+ A22=-8D0PQ4X10-2D0PQ2PH*2X10-(8D0PQ2)(X3X9+X3
	+ & X7+X4X8+X4X6+X10X5)+2D0PH*2(X3X7+X4X6)-(4D0X5)(X3
	+ & X9+X4X8)
	+
	+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+2D0A12)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)=PTCOS(VINT(198+5I))
	+ PP(2,I)=PTSIN(VINT(198+5I))
	+ 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*2ALPHA/(16SW2)MT/XWBETW
	+ & (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*2ALPHA/(16SW2)MT/XWBETW
	+ & (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(MHPMB/MT2)2 )
	+ GAMTBH= ALPHA/SW2/8.D0VTB2KFUN/MT *
	+ & (V*2((MT+MB)2-MHP2)+A*2((MT-MB)2-MHP2))
	+ 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.D08.D0 2.D0*2.D0)
	+C COUPLING CONSTANT (OVERALL NORMALIZATION)
	+ FACT=(4.D0PIALPHA)(4.D0PIALPHAS)*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)GFSW2MW*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 -2P1Q1 -2P1Q2
	+ A1 =A1INV/(A1INV*2+ (GAMTMT)**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+ (GAMTMT)**2)
	+ A2 =1.D0/(S +2P2Q1 +2P2Q2)
	+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= 640A1/3+640A2/3+32A1A2MB2-368A12MBMT-
	+ &512A1A2MBMT/3-
	+ &368A22MBMT+32A1A2MT*2+496A12*P1P2/3+
	+ &320A1A2P1P2+496A2*2P1P2/3+128A1MBMT3/(3P1Q1**2)+
	+ &128A1MT*4/(3P1Q1*2)-256A12MBMT*5/(3P1Q1**2)+
	+ &256A1MT*2P1P2/(3P1Q12)-256A12MT4P1P2/(3P1Q1*2)+
	+ &8/(3P1Q1)-32A1MBMT/P1Q1-56A2MBMT/(3P1Q1)+
	+ &88A1MT*2/(3P1Q1)+72A2MT**2/P1Q1+
	+ &704A12MBMT3/(3P1Q1)-224A1A2MBMT*3/(3P1Q1)+
	+ &104A1P1P2/(3P1Q1)+48A2*P1P2/P1Q1+
	+ &128A1A2MBMTP1P2/(3P1Q1)+512A12MT*2P1P2/(3*P1Q1)-
	+ &448A1A2MT2P1P2/(3P1Q1)-32A1A2P1P2**2/P1Q1-
	+ &656A1A2P1Q1/3-224A2*2P1Q1+128A1MBMT3/(3P1Q2**2)+
	+ &128A1MT*4/(3P1Q2*2)-256A12MBMT*5/(3P1Q2**2)+
	+ &256A1MT*2P1P2/(3P1Q22)-256A12MT4P1P2/(3P1Q2*2)+
	+ &256A1MT*2P1Q1/(3P1Q22)+256A12MBMT*3P1Q1/(3P1Q2*2)+
	+ &8/(3P1Q2)-32A1MBMT/P1Q2-56A2MBMT/(3P1Q2)
	+ V18=V18+88A1MT*2/(3P1Q2)+72A2MT**2/P1Q2+
	+ &704A12MBMT3/(3P1Q2)-224A1A2MBMT*3/(3P1Q2)+
	+ &104A1P1P2/(3P1Q2)+48A2*P1P2/P1Q2+
	+ &128A1A2MBMTP1P2/(3P1Q2)+512A12MT*2P1P2/(3*P1Q2)-
	+ &448A1A2MT2P1P2/(3P1Q2)-32A1A2P1P2**2/P1Q2-
	+ &32A1MBMT3/(3P1Q1P1Q2)-32A1MT4/(3P1Q1*P1Q2)+
	+ &64A12MBMT5/(3P1Q1P1Q2)+16P1P2/(3P1Q1P1Q2)-
	+ &64A1MT*2P1P2/(3P1Q1P1Q2)+64A12MT*4P1P2/(3P1Q1P1Q2)+
	+ &112A1P1Q1/P1Q2+272A2P1Q1/(3*P1Q2)-
	+ &272A1A2MB2P1Q1/(3P1Q2)+208A12MBMTP1Q1/(3P1Q2)-
	+ &400A1A2MBMTP1Q1/(3P1Q2)-80A1A2MT2P1Q1/P1Q2+
	+ &96A12P1P2P1Q1/P1Q2-320A1A2P1P2*P1Q1/P1Q2-
	+ &544A1A2P1Q12/(3P1Q2)-656A1A2P1Q2/3-224A2*2P1Q2+
	+ &256A1MT*2P1Q2/(3P1Q12)+256A12MBMT*3P1Q2/(3P1Q1*2)+
	+ &112A1P1Q2/P1Q1+272A2P1Q2/(3*P1Q1)-
	+ &272A1A2MB2P1Q2/(3P1Q1)+208A12MBMTP1Q2/(3P1Q1)-
	+ &400A1A2MBMTP1Q2/(3P1Q1)-80A1A2MT2P1Q2/P1Q1
	+ V18=V18+96A12P1P2P1Q2/P1Q1-320A1A2P1P2*P1Q2/P1Q1-
	+ &544A1A2P1Q22/(3P1Q1)+128A2MB*4/(3P2Q1**2)+
	+ &128A2MB*3MT/(3P2Q12)-256A2*2MB*5MT/(3P2Q1*2)+
	+ &256A2MB*2P1P2/(3P2Q12)-256A2*2MB*4P1P2/(3P2Q1*2)+
	+ &256A2MB*2P1Q1/(3P2Q12)-256A2*2MB*4P1Q1/(3P2Q1*2)-
	+ &64MB3MT*3/(3P1Q2*2P2Q1**2)-
	+ &64MB2MT*2P1P2/(3P1Q22P2Q1**2)-
	+ &64MB2MT*2P1Q1/(3P1Q22P2Q1**2)+
	+ &64MB3MT/(3P1Q2P2Q1**2)+
	+ &256A2MB*3MTP1P2/(3P1Q2P2Q1*2)+
	+ &256A2MB*2P1P2*2/(3P1Q2P2Q1*2)+
	+ &256A2MB*3MTP1Q1/(3P1Q2P2Q1*2)+
	+ &512A2MB*2P1P2P1Q1/(3P1Q2P2Q1*2)+
	+ &256A2MB*2P1Q1*2/(3P1Q2P2Q1*2)-
	+ &256A22MB*4P1Q2/(3P2Q12)-8/(3P2Q1)-72A1MB**2/P2Q1-
	+ &88A2MB*2/(3P2Q1)+56A1MBMT/(3P2Q1)+32A2MB*MT/P2Q1+
	+ &224A1A2MB3MT/(3P2Q1)-704A2*2MB*3MT/(3*P2Q1)
	+ V18=V18-48A1P1P2/P2Q1-104A2P1P2/(3*P2Q1)+
	+ &448A1A2MB2P1P2/(3P2Q1)-512A2*2MB*2P1P2/(3*P2Q1)-
	+ &128A1A2MBMTP1P2/(3P2Q1)+32A1A2P1P2*2/P2Q1-
	+ &16P1P2/(3P1Q1P2Q1)-32A1MBMTP1P2/(3P1Q1*P2Q1)-
	+ &32A2MBMTP1P2/(3P1Q1P2Q1)-
	+ &64A1A2MBMTP1P22/(3P1Q1*P2Q1)-
	+ &64A1A2P1P23/(3P1Q1P2Q1)-256A2P1Q1/(3P2Q1)+
	+ &448A1A2MB2P1Q1/(3P2Q1)-368A2*2MB*2P1Q1/(3*P2Q1)+
	+ &224A1A2MBMTP1Q1/(3P2Q1)+304A1A2P1P2P1Q1/(3*P2Q1)-
	+ &64MBMT*3/(3P1Q2*2P2Q1)-
	+ &256A1MBMT3P1P2/(3P1Q22P2Q1)-
	+ &256A1MT*2P1P2*2/(3P1Q2*2P2Q1)+
	+ &64MT2P1Q1/(3P1Q22P2Q1)-
	+ &128A1MB*2MT*2P1Q1/(3P1Q22P2Q1)-
	+ &128A1MBMT3P1Q1/(3P1Q22P2Q1)-
	+ &256A1MT*2P1P2P1Q1/(3P1Q2*2P2Q1)-4MB2/(3P1Q2*P2Q1)+
	+ &64MBMT/(3P1Q2P2Q1)-128A2MB*3MT/(3P1Q2P2Q1)
	+ V18=V18-4MT2/(3P1Q2P2Q1)-128A1MB2MT*2/(3P1Q2*P2Q1)-
	+ &128A2MB*2MT*2/(3P1Q2P2Q1)-128A1MBMT*3/(3P1Q2*P2Q1)-
	+ &112A2MB*2P1P2/(3P1Q2P2Q1)-32A1MBMTP1P2/(3P1Q2P2Q1)-
	+ &32A2MBMTP1P2/(3P1Q2P2Q1)-112A1MT*2P1P2/(3P1Q2P2Q1)-
	+ &48A1P1P2*2/(P1Q2P2Q1)-48A2P1P2*2/(P1Q2P2Q1)+
	+ &512A1A2MBMTP1P22/(3P1Q2*P2Q1)+
	+ &512A1A2P1P23/(3P1Q2P2Q1)-8MBMTP1P2/(3P1Q1P1Q2*P2Q1)-
	+ &8MT2P1P2/(3P1Q1P1Q2*P2Q1)+
	+ &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q1)-
	+ &16P1P22/(3P1Q1P1Q2P2Q1)+
	+ &32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q1)+8P1Q1/(3P1Q2*P2Q1)-
	+ &160A1MB*2P1Q1/(3P1Q2P2Q1)-272A2MB*2P1Q1/(3P1Q2P2Q1)+
	+ &56A1MBMTP1Q1/(3P1Q2P2Q1)+200A2MBMTP1Q1/(3P1Q2P2Q1)-
	+ &48A1P1P2P1Q1/(P1Q2P2Q1)-256A2P1P2P1Q1/(3P1Q2*P2Q1)+
	+ &256A1A2MB2P1P2P1Q1/(3P1Q2*P2Q1)+
	+ &256A1A2MBMTP1P2P1Q1/(P1Q2*P2Q1)+
	+ &1024A1A2P1P22P1Q1/(3P1Q2P2Q1)
	+ V18=V18-272A2P1Q1*2/(3P1Q2*P2Q1)+
	+ &256A1A2MB2P1Q1*2/(3P1Q2*P2Q1)+
	+ &256A1A2MBMTP1Q12/(3P1Q2*P2Q1)+
	+ &512A1A2P1P2P1Q1*2/(3P1Q2P2Q1)+16A2P1Q2/(3P2Q1)+
	+ &64A1A2MB2P1Q2/P2Q1+32A22MB*2P1Q2/(3*P2Q1)+
	+ &112A1A2MBMTP1Q2/(3P2Q1)+368A1A2P1P2P1Q2/(3*P2Q1)+
	+ &32A2P1P2P1Q2/(3P1Q1*P2Q1)-
	+ &32A1A2MB2P1P2P1Q2/(3P1Q1*P2Q1)-
	+ &32A1A2MBMTP1P2P1Q2/(3P1Q1P2Q1)-
	+ &64A1A2P1P22P1Q2/(3P1Q1P2Q1)+224A12P2Q1+
	+ &656A1A2P2Q1/3-256A1MT2P2Q1/(3P1Q1*2)+
	+ &256A12MT*4P2Q1/(3P1Q12)-256A1P2Q1/(3P1Q1)+
	+ &224A1A2MBMTP2Q1/(3P1Q1)-368A12MT*2P2Q1/(3*P1Q1)+
	+ &448A1A2MT2P2Q1/(3P1Q1)+304A1A2P1P2P2Q1/(3P1Q1)+
	+ &256A12MT*4P2Q1/(3P1Q2*2)+
	+ &256A12MT*2P1Q1P2Q1/(3P1Q2*2)+16A1P2Q1/(3P1Q2)+
	+ &112A1A2MBMTP2Q1/(3P1Q2)+32A12MT*2P2Q1/(3*P1Q2)
	+ V18=V18+64A1A2MT2P2Q1/P1Q2+368A1A2P1P2P2Q1/(3*P1Q2)+
	+ &16A1MT*2P2Q1/(3P1Q1P1Q2)-64A12MT*4P2Q1/(3P1Q1P1Q2)+
	+ &640A12P1Q1P2Q1/(3P1Q2)+544A1A2P1Q1P2Q1/(3*P1Q2)+
	+ &32A12P1Q2P2Q1/P1Q1+944A1A2P1Q2P2Q1/(3P1Q1)+
	+ &128A2MB*4/(3P2Q2*2)+128A2MB3MT/(3P2Q2*2)-
	+ &256A22MB*5MT/(3P2Q22)+256A2MB2P1P2/(3P2Q2*2)-
	+ &256A22MB*4P1P2/(3P2Q2*2)-
	+ &64MB3MT*3/(3P1Q1*2P2Q2**2)-
	+ &64MB2MT*2P1P2/(3P1Q12P2Q2**2)+
	+ &64MB3MT/(3P1Q1P2Q2**2)+
	+ &256A2MB*3MTP1P2/(3P1Q1P2Q2*2)+
	+ &256A2MB*2P1P2*2/(3P1Q1P2Q2*2)-
	+ &256A22MB*4P1Q1/(3P2Q22)+256A2MB2P1Q2/(3P2Q2*2)-
	+ &256A22MB*4P1Q2/(3P2Q2*2)-
	+ &64MB2MT*2P1Q2/(3P1Q12P2Q2**2)+
	+ &256A2MB*3MTP1Q2/(3P1Q1P2Q2*2)+
	+ &512A2MB*2P1P2P1Q2/(3P1Q1P2Q2*2)
	+ V18=V18+256A2MB*2P1Q2*2/(3P1Q1P2Q2*2)-
	+ &256A2MB*2P2Q1/(3P2Q22)-256A2*2MB*3MTP2Q1/(3P2Q2**2)+
	+ &64MB2MT*2P2Q1/(3P1Q12P2Q2**2)+
	+ &64MB2P2Q1/(3P1Q1P2Q2**2)-
	+ &128A2MB*3MTP2Q1/(3P1Q1P2Q2*2)-
	+ &128A2MB*2MT*2P2Q1/(3P1Q1P2Q2**2)-
	+ &256A2MB*2P1P2P2Q1/(3P1Q1P2Q2*2)+
	+ &256A22MB*2P1Q1P2Q1/(3P2Q2**2)-
	+ &256A2MB*2P1Q2P2Q1/(3P1Q1P2Q22)-8/(3P2Q2)-
	+ &72A1MB*2/P2Q2-88A2MB2/(3P2Q2)+56A1MBMT/(3P2Q2)+
	+ &32A2MBMT/P2Q2+224A1A2MB*3MT/(3*P2Q2)-
	+ &704A22MB*3MT/(3P2Q2)-48A1*P1P2/P2Q2-
	+ &104A2P1P2/(3P2Q2)+448A1A2MB*2P1P2/(3*P2Q2)-
	+ &512A22MB*2P1P2/(3P2Q2)-128A1A2MBMTP1P2/(3*P2Q2)+
	+ &32A1A2P1P22/P2Q2-64MBMT3/(3P1Q1*2P2Q2)-
	+ &256A1MBMT3P1P2/(3P1Q12P2Q2)-
	+ &256A1MT*2P1P2*2/(3P1Q1*2P2Q2)-4MB2/(3P1Q1*P2Q2)
	+ V18=V18+64MBMT/(3P1Q1P2Q2)-128A2MB*3MT/(3P1Q1P2Q2)-
	+ &4MT2/(3P1Q1P2Q2)-128A1MB2MT*2/(3P1Q1*P2Q2)-
	+ &128A2MB*2MT*2/(3P1Q1P2Q2)-128A1MBMT*3/(3P1Q1*P2Q2)-
	+ &112A2MB*2P1P2/(3P1Q1P2Q2)-32A1MBMTP1P2/(3P1Q1P2Q2)-
	+ &32A2MBMTP1P2/(3P1Q1P2Q2)-112A1MT*2P1P2/(3P1Q1P2Q2)-
	+ &48A1P1P2*2/(P1Q1P2Q2)-48A2P1P2*2/(P1Q1P2Q2)+
	+ &512A1A2MBMTP1P22/(3P1Q1*P2Q2)+
	+ &512A1A2P1P23/(3P1Q1P2Q2)+16A2P1Q1/(3P2Q2)+
	+ &64A1A2MB2P1Q1/P2Q2+32A22MB*2P1Q1/(3*P2Q2)+
	+ &112A1A2MBMTP1Q1/(3P2Q2)+368A1A2P1P2P1Q1/(3*P2Q2)-
	+ &16P1P2/(3P1Q2P2Q2)-32A1MBMTP1P2/(3P1Q2*P2Q2)-
	+ &32A2MBMTP1P2/(3P1Q2P2Q2)-
	+ &64A1A2MBMTP1P22/(3P1Q2*P2Q2)-
	+ &64A1A2P1P23/(3P1Q2P2Q2)-8MBMTP1P2/(3P1Q1P1Q2*P2Q2)-
	+ &8MT2P1P2/(3P1Q1P1Q2*P2Q2)+
	+ &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q2)-
	+ &16P1P22/(3P1Q1P1Q2P2Q2)
	+ V18=V18+32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q2)+
	+ &32A2P1P2P1Q1/(3P1Q2*P2Q2)-
	+ &32A1A2MB2P1P2P1Q1/(3P1Q2*P2Q2)-
	+ &32A1A2MBMTP1P2P1Q1/(3P1Q2P2Q2)-
	+ &64A1A2P1P22P1Q1/(3P1Q2P2Q2)-256A2P1Q2/(3*P2Q2)+
	+ &448A1A2MB2P1Q2/(3P2Q2)-368A2*2MB*2P1Q2/(3*P2Q2)+
	+ &224A1A2MBMTP1Q2/(3P2Q2)+304A1A2P1P2P1Q2/(3*P2Q2)+
	+ &64MT2P1Q2/(3P1Q12P2Q2)-
	+ &128A1MB*2MT*2P1Q2/(3P1Q12P2Q2)-
	+ &128A1MBMT3P1Q2/(3P1Q12P2Q2)-
	+ &256A1MT*2P1P2P1Q2/(3P1Q1*2P2Q2)+8P1Q2/(3P1Q1*P2Q2)-
	+ &160A1MB*2P1Q2/(3P1Q1P2Q2)-272A2MB*2P1Q2/(3P1Q1P2Q2)+
	+ &56A1MBMTP1Q2/(3P1Q1P2Q2)+200A2MBMTP1Q2/(3P1Q1P2Q2)-
	+ &48A1P1P2P1Q2/(P1Q1P2Q2)-256A2P1P2P1Q2/(3P1Q1*P2Q2)+
	+ &256A1A2MB2P1P2P1Q2/(3P1Q1*P2Q2)+
	+ &256A1A2MBMTP1P2P1Q2/(P1Q1*P2Q2)+
	+ &1024A1A2P1P22P1Q2/(3P1Q1P2Q2)
	+ V18=V18-272A2P1Q2*2/(3P1Q1*P2Q2)+
	+ &256A1A2MB2P1Q2*2/(3P1Q1*P2Q2)+
	+ &256A1A2MBMTP1Q22/(3P1Q1*P2Q2)+
	+ &512A1A2P1P2P1Q2*2/(3P1Q1P2Q2)-32A2MB4/(3P2Q1*P2Q2)-
	+ &32A2MB*3MT/(3P2Q1P2Q2)+64A22MB*5MT/(3P2Q1P2Q2)+
	+ &16P1P2/(3P2Q1P2Q2)-64A2MB2P1P2/(3P2Q1P2Q2)+
	+ &64A22MB*4P1P2/(3P2Q1P2Q2)+8MB2P1P2/(3P1Q1P2Q1*P2Q2)+
	+ &8MBMTP1P2/(3P1Q1P2Q1P2Q2)-
	+ &32A2MB*3MTP1P2/(3P1Q1P2Q1P2Q2)+
	+ &16P1P22/(3P1Q1P2Q1P2Q2)-
	+ &32A2MB*2P1P2*2/(3P1Q1P2Q1P2Q2)-
	+ &16A2MB*2P1Q1/(3P2Q1P2Q2)+64A22MB*4P1Q1/(3P2Q1P2Q2)+
	+ &8MB2P1P2/(3P1Q2P2Q1P2Q2)+8MBMTP1P2/(3P1Q2P2Q1*P2Q2)-
	+ &32A2MB*3MTP1P2/(3P1Q2P2Q1P2Q2)+
	+ &16P1P22/(3P1Q2P2Q1P2Q2)-
	+ &32A2MB*2P1P2*2/(3P1Q2P2Q1P2Q2)+
	+ &16MBMTP1P22/(3P1Q1P1Q2P2Q1*P2Q2)
	+ V18=V18+16P1P23/(3P1Q1P1Q2P2Q1*P2Q2)-
	+ &32A2MB*2P1P2P1Q1/(3P1Q2P2Q1P2Q2)-
	+ &16A2MB*2P1Q2/(3P2Q1P2Q2)+64A22MB*4P1Q2/(3P2Q1P2Q2)-
	+ &32A2MB*2P1P2P1Q2/(3P1Q1P2Q1P2Q2)+272A1P2Q1/(3*P2Q2)+
	+ &112A2P2Q1/P2Q2-80A1A2MB2P2Q1/P2Q2-
	+ &400A1A2MBMTP2Q1/(3P2Q2)+208A22MBMTP2Q1/(3*P2Q2)-
	+ &272A1A2MT2P2Q1/(3P2Q2)-320A1A2P1P2*P2Q1/P2Q2+
	+ &96A22P1P2P2Q1/P2Q2+256A1MBMT*3P2Q1/(3P1Q12P2Q2)+
	+ &512A1MT*2P1P2P2Q1/(3P1Q1*2P2Q2)-8P2Q1/(3P1Q1*P2Q2)-
	+ &200A1MBMTP2Q1/(3P1Q1P2Q2)-56A2MBMTP2Q1/(3P1Q1P2Q2)+
	+ &272A1MT*2P2Q1/(3P1Q1P2Q2)+160A2MT*2P2Q1/(3P1Q1P2Q2)+
	+ &256A1P1P2P2Q1/(3P1Q1P2Q2)+48A2P1P2P2Q1/(P1Q1*P2Q2)-
	+ &256A1A2MBMTP1P2P2Q1/(P1Q1*P2Q2)-
	+ &256A1A2MT2P1P2P2Q1/(3P1Q1*P2Q2)-
	+ &1024A1A2P1P22P2Q1/(3P1Q1P2Q2)-
	+ &544A1A2P1Q1P2Q1/(3P2Q2)-640A2*2P1Q1P2Q1/(3P2Q2)-
	+ &32A1P1P2P2Q1/(3P1Q2*P2Q2)
	+ V18=V18+32A1A2MBMTP1P2P2Q1/(3P1Q2P2Q2)+
	+ &32A1A2MT2P1P2P2Q1/(3P1Q2*P2Q2)+
	+ &64A1A2P1P22P2Q1/(3P1Q2P2Q2)-
	+ &32A1MT*2P1P2P2Q1/(3P1Q1P1Q2P2Q2)+
	+ &64A1A2P1P2P1Q1P2Q1/(3P1Q2*P2Q2)-
	+ &944A1A2P1Q2P2Q1/(3P2Q2)-32A2*2P1Q2*P2Q1/P2Q2+
	+ &256A1MT*2P1Q2P2Q1/(3P1Q1*2P2Q2)+
	+ &96A1P1Q2P2Q1/(P1Q1P2Q2)+96A2P1Q2P2Q1/(P1Q1P2Q2)-
	+ &128A1A2MB2P1Q2P2Q1/(3P1Q1*P2Q2)-
	+ &256A1A2MBMTP1Q2P2Q1/(P1Q1*P2Q2)-
	+ &128A1A2MT2P1Q2P2Q1/(3P1Q1*P2Q2)-
	+ &512A1A2P1P2P1Q2P2Q1/(P1Q1P2Q2)-
	+ &512A1A2P1Q22P2Q1/(3P1Q1P2Q2)+544A1A2P2Q12/(3P2Q2)-
	+ &256A1MT*2P2Q1*2/(3P1Q1*2P2Q2)-
	+ &272A1P2Q1*2/(3P1Q1*P2Q2)+
	+ &256A1A2MBMTP2Q12/(3P1Q1*P2Q2)+
	+ &256A1A2MT2P2Q1*2/(3P1Q1*P2Q2)
	+ V18=V18+512A1A2P1P2P2Q1*2/(3P1Q1*P2Q2)+
	+ &512A1A2P1Q2P2Q1*2/(3P1Q1P2Q2)+224A12*P2Q2+
	+ &656A1A2P2Q2/3+256A12MT4P2Q2/(3P1Q1*2)+
	+ &16A1P2Q2/(3P1Q1)+112A1A2MBMTP2Q2/(3*P1Q1)+
	+ &32A12MT*2P2Q2/(3P1Q1)+64A1A2MT*2P2Q2/P1Q1+
	+ &368A1A2P1P2P2Q2/(3P1Q1)-256A1MT2P2Q2/(3P1Q2*2)+
	+ &256A12MT*4P2Q2/(3P1Q22)-256A1P2Q2/(3P1Q2)+
	+ &224A1A2MBMTP2Q2/(3P1Q2)-368A12MT*2P2Q2/(3*P1Q2)+
	+ &448A1A2MT2P2Q2/(3P1Q2)+304A1A2P1P2P2Q2/(3P1Q2)+
	+ &16A1MT*2P2Q2/(3P1Q1P1Q2)-64A12MT*4P2Q2/(3P1Q1P1Q2)+
	+ &32A12P1Q1P2Q2/P1Q2+944A1A2P1Q1P2Q2/(3P1Q2)+
	+ &256A12MT*2P1Q2P2Q2/(3P1Q1**2)+
	+ &640A12P1Q2P2Q2/(3P1Q1)+544A1A2P1Q2P2Q2/(3*P1Q1)-
	+ &256A2MB*2P2Q2/(3P2Q12)-256A2*2MB*3MTP2Q2/(3P2Q1**2)+
	+ &64MB2MT*2P2Q2/(3P1Q22P2Q1**2)+
	+ &64MB2P2Q2/(3P1Q2P2Q1**2)-
	+ &128A2MB*3MTP2Q2/(3P1Q2P2Q1*2)
	+ V18=V18-128A2MB*2MT*2P2Q2/(3P1Q2P2Q1**2)-
	+ &256A2MB*2P1P2P2Q2/(3P1Q2P2Q1*2)-
	+ &256A2MB*2P1Q1P2Q2/(3P1Q2P2Q1*2)+
	+ &256A22MB*2P1Q2P2Q2/(3P2Q1*2)+272A1P2Q2/(3P2Q1)+
	+ &112A2P2Q2/P2Q1-80A1A2MB2P2Q2/P2Q1-
	+ &400A1A2MBMTP2Q2/(3P2Q1)+208A22MBMTP2Q2/(3*P2Q1)-
	+ &272A1A2MT2P2Q2/(3P2Q1)-320A1A2P1P2*P2Q2/P2Q1+
	+ &96A22P1P2P2Q2/P2Q1-32A1P1P2P2Q2/(3P1Q1P2Q1)+
	+ &32A1A2MBMTP1P2P2Q2/(3P1Q1P2Q1)+
	+ &32A1A2MT2P1P2P2Q2/(3P1Q1*P2Q1)+
	+ &64A1A2P1P22P2Q2/(3P1Q1P2Q1)-944A1A2P1Q1P2Q2/(3*P2Q1)-
	+ &32A22P1Q1P2Q2/P2Q1+256A1MBMT*3P2Q2/(3P1Q22P2Q1)+
	+ &512A1MT*2P1P2P2Q2/(3P1Q2*2P2Q1)+
	+ &256A1MT*2P1Q1P2Q2/(3P1Q2*2P2Q1)-8P2Q2/(3P1Q2*P2Q1)-
	+ &200A1MBMTP2Q2/(3P1Q2P2Q1)-56A2MBMTP2Q2/(3P1Q2P2Q1)+
	+ &272A1MT*2P2Q2/(3P1Q2P2Q1)+160A2MT*2P2Q2/(3P1Q2P2Q1)+
	+ &256A1P1P2P2Q2/(3P1Q2P2Q1)+48A2P1P2P2Q2/(P1Q2*P2Q1)
	+ V18=V18-256A1A2MBMTP1P2P2Q2/(P1Q2*P2Q1)-
	+ &256A1A2MT2P1P2P2Q2/(3P1Q2*P2Q1)-
	+ &1024A1A2P1P22P2Q2/(3P1Q2P2Q1)-
	+ &32A1MT*2P1P2P2Q2/(3P1Q1P1Q2P2Q1)+
	+ &96A1P1Q1P2Q2/(P1Q2P2Q1)+96A2P1Q1P2Q2/(P1Q2P2Q1)-
	+ &128A1A2MB2P1Q1P2Q2/(3P1Q2*P2Q1)-
	+ &256A1A2MBMTP1Q1P2Q2/(P1Q2*P2Q1)-
	+ &128A1A2MT2P1Q1P2Q2/(3P1Q2*P2Q1)-
	+ &512A1A2P1P2P1Q1P2Q2/(P1Q2P2Q1)-
	+ &512A1A2P1Q12P2Q2/(3P1Q2P2Q1)-544A1A2P1Q2P2Q2/(3*P2Q1)-
	+ &640A22P1Q2P2Q2/(3P2Q1)+
	+ &64A1A2P1P2P1Q2P2Q2/(3P1Q1P2Q1)+544A1A2P2Q2*2/(3P2Q1)-
	+ &256A1MT*2P2Q2*2/(3P1Q2*2P2Q1)-
	+ &272A1P2Q2*2/(3P1Q2*P2Q1)+
	+ &256A1A2MBMTP2Q22/(3P1Q2*P2Q1)+
	+ &256A1A2MT2P2Q2*2/(3P1Q2*P2Q1)+
	+ &512A1A2P1P2P2Q2*2/(3P1Q2*P2Q1)
	+ V18=V18+512A1A2P1Q1P2Q2*2/(3P1Q2*P2Q1)+
	+ &384A12MBMTP1Q12/S2+
	+ &384A12P1P2P1Q12/S2+2688A12MBMTP1Q1P1Q2/S**2+
	+ &2688A12P1P2P1Q1P1Q2/S*2+384A12MBMTP1Q22/S*2+
	+ &384A12P1P2P1Q22/S2+768A1A2MBMTP1Q1P2Q1/S*2+
	+ &768A1A2P1P2P1Q1P2Q1/S2+2688A1A2MBMTP1Q2P2Q1/S*2+
	+ &2688A1A2P1P2P1Q2P2Q1/S2-960A12P1Q1P1Q2P2Q1/S*2-
	+ &960A1A2P1Q1P1Q2P2Q1/S2+960A12P1Q22P2Q1/S**2+
	+ &960A1A2P1Q22P2Q1/S*2+384A2*2MBMTP2Q12/S2+
	+ &384A22P1P2P2Q12/S2-960A1A2P1Q2P2Q12/S*2-
	+ &960A22P1Q2P2Q12/S2+2688A1A2MBMTP1Q1P2Q2/S*2+
	+ &2688A1A2P1P2P1Q1P2Q2/S2+960A12P1Q12P2Q2/S**2+
	+ &960A1A2P1Q12P2Q2/S*2+768A1A2MBMTP1Q2P2Q2/S*2+
	+ &768A1A2P1P2P1Q2P2Q2/S2-960A12P1Q1P1Q2P2Q2/S*2-
	+ &960A1A2P1Q1P1Q2P2Q2/S2+2688A2*2MBMTP2Q1P2Q2/S*2+
	+ &2688A22P1P2P2Q1P2Q2/S*2+960A1A2P1Q1P2Q1P2Q2/S**2+
	+ &960A22P1Q1P2Q1P2Q2/S*2+960A1A2P1Q2P2Q1P2Q2/S**2+
	+ &960A22P1Q2P2Q1P2Q2/S*2+384A2*2MBMTP2Q22/S2
	+ V18=V18+384A22P1P2P2Q22/S2-960A1A2P1Q1P2Q22/S*2-
	+ &960A22P1Q1P2Q22/S2+96A1MBMT/S+96A2MB*MT/S-
	+ &768A22MB*3MT/S-768A12MBMT3/S-192A1*P1P2/S-
	+ &192A2P1P2/S-768A22MB*2P1P2/S-2304A1A2MBMT*P1P2/S-
	+ &768A12MT*2P1P2/S-2304A1A2P1P2*2/S-
	+ &96A1MBMT3/(P1Q1S)-192A2MBMTP1P2/(P1Q1*S)-
	+ &96A1MT*2P1P2/(P1Q1S)-192A2P1P22/(P1Q1S)-192A1P1Q1/S-
	+ &144A2P1Q1/S-384A1A2MB2P1Q1/S-480A22MB*2P1Q1/S-
	+ &480A12MBMTP1Q1/S+96A1A2MBMT*P1Q1/S-
	+ &864A12P1P2P1Q1/S-672A1A2P1P2P1Q1/S-96A1A2P1Q1**2/S-
	+ &96A1MBMT3/(P1Q2S)-192A2MBMTP1P2/(P1Q2*S)-
	+ &96A1MT*2P1P2/(P1Q2S)-192A2P1P22/(P1Q2S)-
	+ &48A1MBMTP1Q1/(P1Q2S)+96A2MBMTP1Q1/(P1Q2S)-
	+ &48A1MT*2P1Q1/(P1Q2S)-192A1P1P2P1Q1/(P1Q2*S)-
	+ &192A2P1P2P1Q1/(P1Q2S)+192A1A2MBMTP1P2P1Q1/(P1Q2*S)+
	+ &192A1A2P1P22P1Q1/(P1Q2S)-192A1P1Q12/(P1Q2S)-
	+ &192A2P1Q1*2/(P1Q2S)+192A1A2MB2P1Q1*2/(P1Q2S)
	+ V18=V18-192A12MBMTP1Q1*2/(P1Q2S)+
	+ &96A1A2MBMTP1Q12/(P1Q2S)+
	+ &192A1A2P1P2P1Q1*2/(P1Q2S)-192A1P1Q2/S-144A2P1Q2/S-
	+ &384A1A2MB2P1Q2/S-480A22MB*2P1Q2/S-
	+ &480A12MBMTP1Q2/S+96A1A2MBMT*P1Q2/S-
	+ &864A12P1P2P1Q2/S-672A1A2P1P2*P1Q2/S-
	+ &48A1MBMTP1Q2/(P1Q1S)+96A2MBMTP1Q2/(P1Q1S)-
	+ &48A1MT*2P1Q2/(P1Q1S)-192A1P1P2P1Q2/(P1Q1*S)-
	+ &192A2P1P2P1Q2/(P1Q1S)+192A1A2MBMTP1P2P1Q2/(P1Q1*S)+
	+ &192A1A2P1P22P1Q2/(P1Q1S)-576A1A2P1Q1*P1Q2/S-
	+ &96A1A2P1Q22/S-192A1P1Q22/(P1Q1S)-
	+ &192A2P1Q2*2/(P1Q1S)+192A1A2MB2P1Q2*2/(P1Q1S)-
	+ &192A12MBMTP1Q2*2/(P1Q1S)+96A1A2MBMTP1Q22/(P1Q1S)+
	+ &192A1A2P1P2P1Q2*2/(P1Q1S)+96A2MB*3MT/(P2Q1*S)+
	+ &96A2MB*2P1P2/(P2Q1S)+192A1MBMTP1P2/(P2Q1S)+
	+ &192A1P1P2*2/(P2Q1S)+96A1MB*2P1Q1/(P2Q1*S)+
	+ &192A2MB*2P1Q1/(P2Q1S)+96A1MBMTP1Q1/(P2Q1S)+
	+ &192A1A2MB3MTP1Q1/(P2Q1S)+192A1P1P2P1Q1/(P2Q1S)
	+ V18=V18+192A1A2MB2P1P2P1Q1/(P2Q1S)+
	+ &96A1A2MB2P1Q1*2/(P2Q1S)+
	+ &192A2MB*3MTP1Q1/(P1Q2P2Q1*S)+
	+ &192A2MB*2P1P2P1Q1/(P1Q2P2Q1*S)+
	+ &96A1MBMTP1P2P1Q1/(P1Q2P2Q1*S)+
	+ &96A1P1P2*2P1Q1/(P1Q2P2Q1S)+
	+ &96A1MB*2P1Q1*2/(P1Q2P2Q1*S)+
	+ &192A2MB*2P1Q1*2/(P1Q2P2Q1*S)+
	+ &48A1MBMTP1Q1*2/(P1Q2P2Q1*S)+
	+ &96A1P1P2P1Q12/(P1Q2P2Q1S)+96A1MB2P1Q2/(P2Q1*S)+
	+ &48A2MB*2P1Q2/(P2Q1S)-192A1A2MB*3MTP1Q2/(P2Q1S)-
	+ &192A1A2MB2P1P2P1Q2/(P2Q1S)-
	+ &96A1A2MB2P1Q2*2/(P2Q1S)+144A1P2Q1/S+192A2P2Q1/S-
	+ &96A1A2MBMTP2Q1/S+480A2*2MBMTP2Q1/S+
	+ &480A12MT*2P2Q1/S+384A1A2MT2P2Q1/S+
	+ &672A1A2P1P2P2Q1/S+864A22P1P2*P2Q1/S+
	+ &96A2MBMTP2Q1/(P1Q1S)+192A1MT2P2Q1/(P1Q1*S)
	+ V18=V18+96A2MT*2P2Q1/(P1Q1*S)+
	+ &192A1A2MBMT*3P2Q1/(P1Q1*S)+
	+ &192A2P1P2P2Q1/(P1Q1S)+192A1A2MT2P1P2P2Q1/(P1Q1S)-
	+ &192A12P1Q1P2Q1/S-192A2*2P1Q1*P2Q1/S+
	+ &48A1MT*2P2Q1/(P1Q2S)+96A2MT2P2Q1/(P1Q2*S)-
	+ &192A1A2MBMT*3P2Q1/(P1Q2*S)-
	+ &192A1A2MT2P1P2P2Q1/(P1Q2S)-
	+ &96A1A2MBMTP1Q1P2Q1/(P1Q2*S)-
	+ &192A12MT*2P1Q1P2Q1/(P1Q2S)-
	+ &96A1A2MT2P1Q1P2Q1/(P1Q2S)-
	+ &384A1A2P1P2P1Q1P2Q1/(P1Q2S)-384A12P1Q1*2P2Q1/(P1Q2*S)-
	+ &384A1A2P1Q12P2Q1/(P1Q2S)-480A12P1Q2P2Q1/S-
	+ &960A1A2P1Q2P2Q1/S-480A22P1Q2*P2Q1/S+
	+ &144A1P1Q2P2Q1/(P1Q1S)+96A2P1Q2P2Q1/(P1Q1S)-
	+ &384A1A2MBMTP1Q2P2Q1/(P1Q1*S)-
	+ &96A12MT*2P1Q2P2Q1/(P1Q1S)+
	+ &96A1A2MT2P1Q2P2Q1/(P1Q1S)-
	+ &576A1A2P1P2P1Q2P2Q1/(P1Q1S)-192A12P1Q2*2P2Q1/(P1Q1*S)
	+ V18=V18-384A1A2P1Q22P2Q1/(P1Q1S)-96A1A2P2Q1**2/S-
	+ &96A1A2MT2P2Q1*2/(P1Q1S)+96A1A2MT2P2Q1*2/(P1Q2S)+
	+ &288A1A2P1Q2P2Q1*2/(P1Q1S)+96A2MB*3MT/(P2Q2*S)+
	+ &96A2MB*2P1P2/(P2Q2S)+192A1MBMTP1P2/(P2Q2S)+
	+ &192A1P1P2*2/(P2Q2S)+96A1MB*2P1Q1/(P2Q2*S)+
	+ &48A2MB*2P1Q1/(P2Q2S)-192A1A2MB*3MTP1Q1/(P2Q2S)-
	+ &192A1A2MB2P1P2P1Q1/(P2Q2S)-
	+ &96A1A2MB2P1Q1*2/(P2Q2S)+96A1MB*2P1Q2/(P2Q2*S)+
	+ &192A2MB*2P1Q2/(P2Q2S)+96A1MBMTP1Q2/(P2Q2S)+
	+ &192A1A2MB3MTP1Q2/(P2Q2S)+192A1P1P2P1Q2/(P2Q2S)+
	+ &192A1A2MB2P1P2P1Q2/(P2Q2S)+
	+ &192A2MB*3MTP1Q2/(P1Q1P2Q2*S)+
	+ &192A2MB*2P1P2P1Q2/(P1Q1P2Q2*S)+
	+ &96A1MBMTP1P2P1Q2/(P1Q1P2Q2*S)+
	+ &96A1P1P2*2P1Q2/(P1Q1P2Q2S)+96A1A2MB2P1Q2*2/(P2Q2S)+
	+ &96A1MB*2P1Q2*2/(P1Q1P2Q2*S)+
	+ &192A2MB*2P1Q2*2/(P1Q1P2Q2*S)
	+ V18=V18+48A1MBMTP1Q2*2/(P1Q1P2Q2*S)+
	+ &96A1P1P2P1Q22/(P1Q1P2Q2S)-48A2MB2P2Q1/(P2Q2*S)+
	+ &96A1MBMTP2Q1/(P2Q2S)-48A2MBMTP2Q1/(P2Q2S)-
	+ &192A1P1P2P2Q1/(P2Q2S)-192A2P1P2P2Q1/(P2Q2S)+
	+ &192A1A2MBMTP1P2P2Q1/(P2Q2*S)+
	+ &192A1A2P1P22P2Q1/(P2Q2*S)-
	+ &192A1MBMT3P2Q1/(P1Q1P2Q2S)-
	+ &96A2MBMTP1P2P2Q1/(P1Q1P2Q2*S)-
	+ &192A1MT*2P1P2P2Q1/(P1Q1P2Q2*S)-
	+ &96A2P1P2*2P2Q1/(P1Q1P2Q2S)+
	+ &96A1A2MB2P1Q1P2Q1/(P2Q2S)+
	+ &192A22MB*2P1Q1P2Q1/(P2Q2S)+
	+ &96A1A2MBMTP1Q1P2Q1/(P2Q2*S)+
	+ &384A1A2P1P2P1Q1P2Q1/(P2Q2S)-96A1P1Q2P2Q1/(P2Q2S)-
	+ &144A2P1Q2P2Q1/(P2Q2S)-96A1A2MB2P1Q2P2Q1/(P2Q2S)+
	+ &96A22MB*2P1Q2P2Q1/(P2Q2S)+
	+ &384A1A2MBMTP1Q2P2Q1/(P2Q2*S)
	+ V18=V18+576A1A2P1P2P1Q2P2Q1/(P2Q2S)-
	+ &96A2MB*2P1Q2P2Q1/(P1Q1P2Q2*S)+
	+ &48A1MBMTP1Q2P2Q1/(P1Q1P2Q2*S)+
	+ &48A2MBMTP1Q2P2Q1/(P1Q1P2Q2*S)-
	+ &96A1MT*2P1Q2P2Q1/(P1Q1P2Q2*S)-
	+ &96A1P1P2P1Q2P2Q1/(P1Q1P2Q2S)-
	+ &96A2P1P2P1Q2P2Q1/(P1Q1P2Q2S)+
	+ &96A1A2P1Q1P1Q2P2Q1/(P2Q2S)+288A1A2P1Q22P2Q1/(P2Q2*S)-
	+ &96A1P1Q2*2P2Q1/(P1Q1P2Q2S)-96A2P1Q2*2P2Q1/(P1Q1P2Q2S)+
	+ &192A1P2Q1*2/(P2Q2S)+192A2P2Q1*2/(P2Q2S)-
	+ &96A1A2MBMTP2Q12/(P2Q2S)+192A22MBMTP2Q1*2/(P2Q2S)-
	+ &192A1A2MT2P2Q1*2/(P2Q2S)-192A1A2P1P2P2Q1*2/(P2Q2S)+
	+ &48A2MBMTP2Q1*2/(P1Q1P2Q2*S)+
	+ &192A1MT*2P2Q1*2/(P1Q1P2Q2*S)+
	+ &96A2MT*2P2Q1*2/(P1Q1P2Q2*S)+
	+ &96A2P1P2P2Q12/(P1Q1P2Q2S)-384A1A2P1Q1P2Q12/(P2Q2S)-
	+ &384A22P1Q1P2Q12/(P2Q2S)-384A1A2P1Q2P2Q1*2/(P2Q2S)
	+ V18=V18-192A22P1Q2P2Q12/(P2Q2S)+
	+ &96A1P1Q2P2Q12/(P1Q1P2Q2*S)+
	+ &96A2P1Q2P2Q12/(P1Q1P2Q2S)+144A1P2Q2/S+192A2*P2Q2/S-
	+ &96A1A2MBMTP2Q2/S+480A2*2MBMTP2Q2/S+
	+ &480A12MT*2P2Q2/S+384A1A2MT2P2Q2/S+
	+ &672A1A2P1P2P2Q2/S+864A22P1P2*P2Q2/S+
	+ &48A1MT*2P2Q2/(P1Q1S)+96A2MT2P2Q2/(P1Q1*S)-
	+ &192A1A2MBMT*3P2Q2/(P1Q1*S)-
	+ &192A1A2MT2P1P2P2Q2/(P1Q1S)-480A12P1Q1*P2Q2/S-
	+ &960A1A2P1Q1P2Q2/S-480A22P1Q1*P2Q2/S+
	+ &96A2MBMTP2Q2/(P1Q2S)+192A1MT2P2Q2/(P1Q2*S)+
	+ &96A2MT*2P2Q2/(P1Q2S)+192A1A2MBMT3P2Q2/(P1Q2*S)+
	+ &192A2P1P2P2Q2/(P1Q2S)+192A1A2MT2P1P2P2Q2/(P1Q2S)+
	+ &144A1P1Q1P2Q2/(P1Q2S)+96A2P1Q1P2Q2/(P1Q2S)-
	+ &384A1A2MBMTP1Q1P2Q2/(P1Q2*S)-
	+ &96A12MT*2P1Q1P2Q2/(P1Q2S)+
	+ &96A1A2MT2P1Q1P2Q2/(P1Q2S)
	+ V18=V18-576A1A2P1P2P1Q1P2Q2/(P1Q2S)-
	+ &192A12P1Q1*2P2Q2/(P1Q2*S)-
	+ &384A1A2P1Q12P2Q2/(P1Q2S)-192A12P1Q2P2Q2/S-
	+ &192A22P1Q2P2Q2/S-96A1A2MBMTP1Q2P2Q2/(P1Q1S)-
	+ &192A12MT*2P1Q2P2Q2/(P1Q1S)-
	+ &96A1A2MT2P1Q2P2Q2/(P1Q1S)-
	+ &384A1A2P1P2P1Q2P2Q2/(P1Q1S)-384A12P1Q2*2P2Q2/(P1Q1*S)-
	+ &384A1A2P1Q22P2Q2/(P1Q1S)-48A2MB2P2Q2/(P2Q1*S)+
	+ &96A1MBMTP2Q2/(P2Q1S)-48A2MBMTP2Q2/(P2Q1S)-
	+ &192A1P1P2P2Q2/(P2Q1S)-192A2P1P2P2Q2/(P2Q1S)+
	+ &192A1A2MBMTP1P2P2Q2/(P2Q1*S)+
	+ &192A1A2P1P22P2Q2/(P2Q1S)-96A1P1Q1P2Q2/(P2Q1*S)-
	+ &144A2P1Q1P2Q2/(P2Q1S)-96A1A2MB2P1Q1P2Q2/(P2Q1S)+
	+ &96A22MB*2P1Q1P2Q2/(P2Q1S)+
	+ &384A1A2MBMTP1Q1P2Q2/(P2Q1*S)+
	+ &576A1A2P1P2P1Q1P2Q2/(P2Q1S)+288A1A2P1Q12P2Q2/(P2Q1*S)-
	+ &192A1MBMT3P2Q2/(P1Q2P2Q1S)
	+ V18=V18-96A2MBMTP1P2P2Q2/(P1Q2P2Q1*S)-
	+ &192A1MT*2P1P2P2Q2/(P1Q2P2Q1*S)-
	+ &96A2P1P2*2P2Q2/(P1Q2P2Q1S)-
	+ &96A2MB*2P1Q1P2Q2/(P1Q2P2Q1*S)+
	+ &48A1MBMTP1Q1P2Q2/(P1Q2P2Q1*S)
	+
	+ V18BIS=
	+ &48A2MBMTP1Q1P2Q2/(P1Q2P2Q1*S)-
	+ &96A1MT*2P1Q1P2Q2/(P1Q2P2Q1*S)-
	+ &96A1P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	+ &96A2P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	+ &96A1P1Q1*2P2Q2/(P1Q2P2Q1S)-96A2P1Q1*2P2Q2/(P1Q2P2Q1S)+
	+ &96A1A2MB2P1Q2P2Q2/(P2Q1S)+
	+ &192A22MB*2P1Q2P2Q2/(P2Q1S)+
	+ &96A1A2MBMTP1Q2P2Q2/(P2Q1*S)+
	+ &384A1A2P1P2P1Q2P2Q2/(P2Q1S)+
	+ &96A1A2P1Q1P1Q2P2Q2/(P2Q1S)-576A1A2P2Q1P2Q2/S+
	+ &96A1A2P1Q1P2Q1P2Q2/(P1Q2S)+96A1A2P1Q2P2Q1P2Q2/(P1Q1S)-
	+ &96A1A2P2Q22/S+96A1A2MT*2P2Q2*2/(P1Q1S)-
	+ &96A1A2MT2P2Q2*2/(P1Q2S)+288A1A2P1Q1P2Q2*2/(P1Q2S)+
	+ &192A1P2Q2*2/(P2Q1S)+192A2P2Q2*2/(P2Q1S)-
	+ &96A1A2MBMTP2Q22/(P2Q1S)+192A22MBMTP2Q2*2/(P2Q1S)-
	+ &192A1A2MT2P2Q2*2/(P2Q1S)-192A1A2P1P2P2Q2*2/(P2Q1S)
	+ V18BIS=V18BIS-384A1A2P1Q1P2Q2*2/(P2Q1S)-
	+ &192A22P1Q1P2Q22/(P2Q1S)+
	+ &48A2MBMTP2Q2*2/(P1Q2P2Q1*S)+
	+ &192A1MT*2P2Q2*2/(P1Q2P2Q1*S)+
	+ &96A2MT*2P2Q2*2/(P1Q2P2Q1*S)+
	+ &96A2P1P2P2Q22/(P1Q2P2Q1S)+96A1P1Q1P2Q2*2/(P1Q2P2Q1*S)+
	+ &96A2P1Q1P2Q22/(P1Q2P2Q1S)-384A1A2P1Q2P2Q22/(P2Q1S)-
	+ &384A22P1Q2P2Q22/(P2Q1S)+512A1A2*S/3-
	+ &128A1MT*2S/(3P1Q12)-128A12MBMT*3S/(3P1Q1*2)-
	+ &152A1S/(3P1Q1)+152A12MBMTS/(3P1Q1)+
	+ &128A1A2MBMTS/(3P1Q1)+112A1A2MT2S/(3*P1Q1)-
	+ &16A12P1P2S/P1Q1+152A1A2P1P2S/(3P1Q1)-
	+ &128A1MT*2S/(3P1Q22)-128A12MBMT*3S/(3P1Q2*2)-
	+ &152A1S/(3P1Q2)+152A12MBMTS/(3P1Q2)+
	+ &128A1A2MBMTS/(3P1Q2)+112A1A2MT2S/(3*P1Q2)-
	+ &16A12P1P2S/P1Q2+152A1A2P1P2S/(3P1Q2)-
	+ &16A1MBMTS/(3P1Q1P1Q2)+32A12MBMT3S/(3P1Q1P1Q2)
	+ V18BIS=V18BIS-16A1P1P2S/(3P1Q1*P1Q2)+
	+ &272A1A2P1Q1S/(3*P1Q2)+
	+ &272A1A2P1Q2S/(3P1Q1)-128A2MB2S/(3P2Q1*2)-
	+ &128A22MB*3MTS/(3P2Q1**2)+
	+ &32MB2MT*2S/(3P1Q22P2Q1*2)+32MB*2S/(3P1Q2P2Q1**2)-
	+ &64A2MB*3MTS/(3P1Q2P2Q1*2)-
	+ &64A2MB*2MT*2S/(3P1Q2P2Q1**2)-
	+ &128A2MB*2P1P2S/(3P1Q2P2Q1*2)-
	+ &128A2MB*2P1Q1S/(3P1Q2P2Q1*2)+
	+ &128A22MB*2P1Q2S/(3P2Q1*2)+152A2S/(3P2Q1)-
	+ &112A1A2MB2S/(3P2Q1)-128A1A2MBMTS/(3*P2Q1)-
	+ &152A22MBMTS/(3P2Q1)-152A1A2P1P2S/(3P2Q1)+
	+ &16A22P1P2S/P2Q1+8A1A2MB*3MTS/(3P1Q1*P2Q1)+
	+ &16A1A2MB2MT*2S/(3P1Q1P2Q1)+
	+ &8A1A2MBMT*3S/(3P1Q1P2Q1)-8A1P1P2S/(3P1Q1*P2Q1)-
	+ &8A2P1P2S/(3P1Q1P2Q1)+8A1A2MB*2P1P2S/(3P1Q1*P2Q1)+
	+ &16A1A2MBMTP1P2S/(3P1Q1P2Q1)
	+ V18BIS=V18BIS+8A1A2MT2P1P2S/(3P1Q1*P2Q1)+
	+ &32A1A2P1P22S/(3P1Q1P2Q1)-32A22P1Q1S/(3P2Q1)-
	+ &32MT2S/(3P1Q22P2Q1)+64A1MB*2MT*2S/(3P1Q22P2Q1)+
	+ &64A1MBMT3S/(3P1Q22P2Q1)+
	+ &128A1MT*2P1P2S/(3P1Q2*2P2Q1)-12S/(P1Q2P2Q1)+
	+ &24A1MB*2S/(P1Q2P2Q1)-64A1A2MB*3MTS/(3P1Q2*P2Q1)+
	+ &24A2MT*2S/(P1Q2P2Q1)-128A1A2MB*2MT*2S/(3P1Q2P2Q1)-
	+ &64A1A2MBMT*3S/(3P1Q2P2Q1)+56A1P1P2S/(3P1Q2*P2Q1)+
	+ &56A2P1P2S/(3P1Q2P2Q1)-64A1A2MB*2P1P2S/(3P1Q2*P2Q1)-
	+ &128A1A2MBMTP1P2S/(3P1Q2P2Q1)-
	+ &64A1A2MT2P1P2S/(3P1Q2*P2Q1)-
	+ &256A1A2P1P22S/(3P1Q2P2Q1)+4P1P2S/(3P1Q1P1Q2*P2Q1)+
	+ &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q1)-
	+ &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q1)+136A2P1Q1S/(3P1Q2*P2Q1)-
	+ &128A1A2MB2P1Q1S/(3P1Q2*P2Q1)-
	+ &128A1A2MBMTP1Q1S/(3P1Q2P2Q1)-
	+ &256A1A2P1P2P1Q1S/(3P1Q2P2Q1)-160A2*2P1Q2S/(3P2Q1)
	+ V18BIS=V18BIS+16A1A2P1P2P1Q2S/(3P1Q1*P2Q1)-
	+ &32A12P2Q1S/(3P1Q1)-
	+ &128A12MT*2P2Q1S/(3P1Q2*2)-160A12P2Q1S/(3*P1Q2)-
	+ &128A2MB*2S/(3P2Q22)-128A2*2MB*3MTS/(3P2Q2**2)+
	+ &32MB2MT*2S/(3P1Q12P2Q2*2)+32MB*2S/(3P1Q1P2Q2**2)-
	+ &64A2MB*3MTS/(3P1Q1P2Q2*2)-
	+ &64A2MB*2MT*2S/(3P1Q1P2Q2**2)-
	+ &128A2MB*2P1P2S/(3P1Q1P2Q2*2)+
	+ &128A22MB*2P1Q1S/(3P2Q2**2)-
	+ &128A2MB*2P1Q2S/(3P1Q1P2Q22)+152A2S/(3P2Q2)-
	+ &112A1A2MB2S/(3P2Q2)-128A1A2MBMTS/(3*P2Q2)-
	+ &152A22MBMTS/(3P2Q2)-152A1A2P1P2S/(3P2Q2)+
	+ &16A22P1P2S/P2Q2-32MT*2S/(3P1Q12P2Q2)+
	+ &64A1MB*2MT*2S/(3P1Q12P2Q2)+
	+ &64A1MBMT3S/(3P1Q12P2Q2)+
	+ &128A1MT*2P1P2S/(3P1Q1*2P2Q2)-12S/(P1Q1P2Q2)+
	+ &24A1MB*2S/(P1Q1P2Q2)-64A1A2MB*3MTS/(3P1Q1*P2Q2)
	+ V18BIS=V18BIS+24A2MT*2S/(P1Q1*P2Q2)-
	+ &128A1A2MB2MT*2S/(3P1Q1P2Q2)-
	+ &64A1A2MBMT*3S/(3P1Q1P2Q2)+56A1P1P2S/(3P1Q1*P2Q2)+
	+ &56A2P1P2S/(3P1Q1P2Q2)-64A1A2MB*2P1P2S/(3P1Q1*P2Q2)-
	+ &128A1A2MBMTP1P2S/(3P1Q1P2Q2)-
	+ &64A1A2MT2P1P2S/(3P1Q1*P2Q2)-
	+ &256A1A2P1P22S/(3P1Q1P2Q2)-160A22P1Q1S/(3P2Q2)+
	+ &8A1A2MB3MTS/(3P1Q2*P2Q2)+
	+ &16A1A2MB2MT*2S/(3P1Q2P2Q2)+
	+ &8A1A2MBMT*3S/(3P1Q2P2Q2)-8A1P1P2S/(3P1Q2*P2Q2)-
	+ &8A2P1P2S/(3P1Q2P2Q2)+8A1A2MB*2P1P2S/(3P1Q2*P2Q2)+
	+ &16A1A2MBMTP1P2S/(3P1Q2P2Q2)+
	+ &8A1A2MT2P1P2S/(3P1Q2*P2Q2)+
	+ &32A1A2P1P22S/(3P1Q2P2Q2)+4P1P2S/(3P1Q1P1Q2*P2Q2)+
	+ &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q2)-
	+ &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q2)+
	+ &16A1A2P1P2P1Q1S/(3P1Q2P2Q2)-32A2*2P1Q2S/(3P2Q2)
	+ V18BIS=V18BIS+136A2P1Q2S/(3P1Q1*P2Q2)-
	+ &128A1A2MB2P1Q2S/(3P1Q1*P2Q2)-
	+ &128A1A2MBMTP1Q2S/(3P1Q1P2Q2)-
	+ &256A1A2P1P2P1Q2S/(3P1Q1P2Q2)-16A2MBMTS/(3P2Q1*P2Q2)+
	+ &32A22MB*3MTS/(3P2Q1P2Q2)-16A2P1P2S/(3P2Q1P2Q2)-
	+ &4P1P2S/(3P1Q1P2Q1P2Q2)+8A2MB2P1P2S/(3P1Q1P2Q1P2Q2)-
	+ &8A2MBMTP1P2S/(3P1Q1P2Q1P2Q2)-4P1P2S/(3P1Q2P2Q1*P2Q2)+
	+ &8A2MB*2P1P2S/(3P1Q2P2Q1P2Q2)-
	+ &8A2MBMTP1P2S/(3P1Q2P2Q1P2Q2)+
	+ &2MB3MTS/(3P1Q1P1Q2P2Q1*P2Q2)+
	+ &4MB2MT*2S/(3P1Q1P1Q2P2Q1P2Q2)+
	+ &2MBMT*3S/(3P1Q1P1Q2P2Q1P2Q2)-
	+ &2MB2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)-
	+ &4MBMTP1P2S/(3P1Q1P1Q2P2Q1P2Q2)-
	+ &2MT2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)-
	+ &8P1P22S/(3P1Q1P1Q2P2Q1P2Q2)+
	+ &8A2P1P2P1Q1S/(3P1Q2P2Q1*P2Q2)
	+ V18BIS=V18BIS+8A2P1P2P1Q2S/(3P1Q1P2Q1*P2Q2)+
	+ &272A1A2P2Q1S/(3*P2Q2)-
	+ &128A1MT*2P2Q1S/(3P1Q1*2P2Q2)-136A1P2Q1S/(3P1Q1*P2Q2)+
	+ &128A1A2MBMTP2Q1S/(3P1Q1P2Q2)+
	+ &128A1A2MT2P2Q1S/(3P1Q1*P2Q2)+
	+ &256A1A2P1P2P2Q1S/(3P1Q1*P2Q2)-
	+ &16A1A2P1P2P2Q1S/(3P1Q2*P2Q2)+
	+ &8A1P1P2P2Q1S/(3P1Q1P1Q2*P2Q2)+
	+ &256A1A2P1Q2P2Q1S/(3P1Q1*P2Q2)-
	+ &128A12MT*2P2Q2S/(3P1Q1*2)-160A12P2Q2S/(3*P1Q1)-
	+ &32A12P2Q2S/(3P1Q2)+272A1A2P2Q2S/(3*P2Q1)-
	+ &16A1A2P1P2P2Q2S/(3P1Q1*P2Q1)-
	+ &128A1MT*2P2Q2S/(3P1Q2*2P2Q1)-136A1P2Q2S/(3P1Q2*P2Q1)+
	+ &128A1A2MBMTP2Q2S/(3P1Q2P2Q1)+
	+ &128A1A2MT2P2Q2S/(3P1Q2*P2Q1)+
	+ &256A1A2P1P2P2Q2S/(3P1Q2*P2Q1)+
	+ &8A1P1P2P2Q2S/(3P1Q1P1Q2*P2Q1)
	+ V18BIS=V18BIS+256A1A2P1Q1P2Q2S/(3P1Q2*P2Q1)+
	+ &8A12MBMTS*2/(3P1Q1P1Q2)+16A12P1P2S*2/(3P1Q1*P1Q2)-
	+ &8A1A2P1P2S*2/(3P1Q1P2Q1)+4A1P1P2S*2/(3P1Q1P1Q2P2Q1)-
	+ &8A1A2P1P2S*2/(3P1Q2P2Q2)+4A1P1P2S*2/(3P1Q1P1Q2P2Q2)+
	+ &8A22MBMTS*2/(3P2Q1P2Q2)+16A2*2P1P2S2/(3P2Q1*P2Q2)-
	+ &4A2P1P2S2/(3P1Q1P2Q1P2Q2)-
	+ &4A2P1P2S2/(3P1Q2P2Q1P2Q2)+
	+ &2P1P2S*2/(3P1Q1P1Q2P2Q1*P2Q2)
	+C
	+
	+ A18 = 640A1/3+640A2/3+32A1A2MB2+368A12MBMT+
	+ &512A1A2MBMT/3+
	+ &368A22MBMT+32A1A2MT*2+496A12*P1P2/3+
	+ &320A1A2P1P2+496A2*2P1P2/3-128A1MBMT3/(3P1Q1**2)+
	+ &128A1MT*4/(3P1Q1*2)+256A12MBMT*5/(3P1Q1**2)+
	+ &256A1MT*2P1P2/(3P1Q12)-256A12MT4P1P2/(3P1Q1*2)+
	+ &8/(3P1Q1)+32A1MBMT/P1Q1+56A2MBMT/(3P1Q1)+
	+ &88A1MT*2/(3P1Q1)+72A2MT**2/P1Q1-
	+ &704A12MBMT3/(3P1Q1)+224A1A2MBMT*3/(3P1Q1)+
	+ &104A1P1P2/(3P1Q1)+48A2*P1P2/P1Q1-
	+ &128A1A2MBMTP1P2/(3P1Q1)+512A12MT*2P1P2/(3*P1Q1)-
	+ &448A1A2MT2P1P2/(3P1Q1)-32A1A2P1P2**2/P1Q1-
	+ &656A1A2P1Q1/3-224A2*2P1Q1-128A1MBMT3/(3P1Q2**2)+
	+ &128A1MT*4/(3P1Q2*2)+256A12MBMT*5/(3P1Q2**2)+
	+ &256A1MT*2P1P2/(3P1Q22)-256A12MT4P1P2/(3P1Q2*2)+
	+ &256A1MT*2P1Q1/(3P1Q22)-256A12MBMT*3P1Q1/(3P1Q2*2)+
	+ &8/(3P1Q2)+32A1MBMT/P1Q2+56A2MBMT/(3P1Q2)
	+ A18=A18+88A1MT*2/(3P1Q2)+72A2MT**2/P1Q2-
	+ &704A12MBMT3/(3P1Q2)+224A1A2MBMT*3/(3P1Q2)+
	+ &104A1P1P2/(3P1Q2)+48A2*P1P2/P1Q2-
	+ &128A1A2MBMTP1P2/(3P1Q2)+512A12MT*2P1P2/(3*P1Q2)-
	+ &448A1A2MT2P1P2/(3P1Q2)-32A1A2P1P2**2/P1Q2+
	+ &32A1MBMT3/(3P1Q1P1Q2)-32A1MT4/(3P1Q1*P1Q2)-
	+ &64A12MBMT5/(3P1Q1P1Q2)+16P1P2/(3P1Q1P1Q2)-
	+ &64A1MT*2P1P2/(3P1Q1P1Q2)+64A12MT*4P1P2/(3P1Q1P1Q2)+
	+ &112A1P1Q1/P1Q2+272A2P1Q1/(3*P1Q2)-
	+ &272A1A2MB2P1Q1/(3P1Q2)-208A12MBMTP1Q1/(3P1Q2)+
	+ &400A1A2MBMTP1Q1/(3P1Q2)-80A1A2MT2P1Q1/P1Q2+
	+ &96A12P1P2P1Q1/P1Q2-320A1A2P1P2*P1Q1/P1Q2-
	+ &544A1A2P1Q12/(3P1Q2)-656A1A2P1Q2/3-224A2*2P1Q2+
	+ &256A1MT*2P1Q2/(3P1Q12)-256A12MBMT*3P1Q2/(3P1Q1*2)+
	+ &112A1P1Q2/P1Q1+272A2P1Q2/(3*P1Q1)-
	+ &272A1A2MB2P1Q2/(3P1Q1)-208A12MBMTP1Q2/(3P1Q1)+
	+ &400A1A2MBMTP1Q2/(3P1Q1)-80A1A2MT2P1Q2/P1Q1
	+ A18=A18+96A12P1P2P1Q2/P1Q1-320A1A2P1P2*P1Q2/P1Q1-
	+ &544A1A2P1Q22/(3P1Q1)+128A2MB*4/(3P2Q1**2)-
	+ &128A2MB*3MT/(3P2Q12)+256A2*2MB*5MT/(3P2Q1*2)+
	+ &256A2MB*2P1P2/(3P2Q12)-256A2*2MB*4P1P2/(3P2Q1*2)+
	+ &256A2MB*2P1Q1/(3P2Q12)-256A2*2MB*4P1Q1/(3P2Q1*2)+
	+ &64MB3MT*3/(3P1Q2*2P2Q1**2)-
	+ &64MB2MT*2P1P2/(3P1Q22P2Q1**2)-
	+ &64MB2MT*2P1Q1/(3P1Q22P2Q1**2)-
	+ &64MB3MT/(3P1Q2P2Q1**2)-
	+ &256A2MB*3MTP1P2/(3P1Q2P2Q1*2)+
	+ &256A2MB*2P1P2*2/(3P1Q2P2Q1*2)-
	+ &256A2MB*3MTP1Q1/(3P1Q2P2Q1*2)+
	+ &512A2MB*2P1P2P1Q1/(3P1Q2P2Q1*2)+
	+ &256A2MB*2P1Q1*2/(3P1Q2P2Q1*2)-
	+ &256A22MB*4P1Q2/(3P2Q12)-8/(3P2Q1)-72A1MB**2/P2Q1-
	+ &88A2MB*2/(3P2Q1)-56A1MBMT/(3P2Q1)-32A2MB*MT/P2Q1-
	+ &224A1A2MB3MT/(3P2Q1)+704A2*2MB*3MT/(3*P2Q1)
	+ A18=A18-48A1P1P2/P2Q1-104A2P1P2/(3*P2Q1)+
	+ &448A1A2MB2P1P2/(3P2Q1)-512A2*2MB*2P1P2/(3*P2Q1)+
	+ &128A1A2MBMTP1P2/(3P2Q1)+32A1A2P1P2*2/P2Q1-
	+ &16P1P2/(3P1Q1P2Q1)+32A1MBMTP1P2/(3P1Q1*P2Q1)+
	+ &32A2MBMTP1P2/(3P1Q1P2Q1)+
	+ &64A1A2MBMTP1P22/(3P1Q1*P2Q1)-
	+ &64A1A2P1P23/(3P1Q1P2Q1)-256A2P1Q1/(3P2Q1)+
	+ &448A1A2MB2P1Q1/(3P2Q1)-368A2*2MB*2P1Q1/(3*P2Q1)-
	+ &224A1A2MBMTP1Q1/(3P2Q1)+304A1A2P1P2P1Q1/(3*P2Q1)+
	+ &64MBMT*3/(3P1Q2*2P2Q1)+
	+ &256A1MBMT3P1P2/(3P1Q22P2Q1)-
	+ &256A1MT*2P1P2*2/(3P1Q2*2P2Q1)+
	+ &64MT2P1Q1/(3P1Q22P2Q1)-
	+ &128A1MB*2MT*2P1Q1/(3P1Q22P2Q1)+
	+ &128A1MBMT3P1Q1/(3P1Q22P2Q1)-
	+ &256A1MT*2P1P2P1Q1/(3P1Q2*2P2Q1)-4MB2/(3P1Q2*P2Q1)-
	+ &64MBMT/(3P1Q2P2Q1)+128A2MB*3MT/(3P1Q2P2Q1)
	+ A18=A18-4MT2/(3P1Q2P2Q1)-128A1MB2MT*2/(3P1Q2*P2Q1)-
	+ &128A2MB*2MT*2/(3P1Q2P2Q1)+128A1MBMT*3/(3P1Q2*P2Q1)-
	+ &112A2MB*2P1P2/(3P1Q2P2Q1)+32A1MBMTP1P2/(3P1Q2P2Q1)+
	+ &32A2MBMTP1P2/(3P1Q2P2Q1)-112A1MT*2P1P2/(3P1Q2P2Q1)-
	+ &48A1P1P2*2/(P1Q2P2Q1)-48A2P1P2*2/(P1Q2P2Q1)-
	+ &512A1A2MBMTP1P22/(3P1Q2*P2Q1)+
	+ &512A1A2P1P23/(3P1Q2P2Q1)+8MBMTP1P2/(3P1Q1P1Q2*P2Q1)-
	+ &8MT2P1P2/(3P1Q1P1Q2*P2Q1)-
	+ &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q1)-
	+ &16P1P22/(3P1Q1P1Q2P2Q1)+
	+ &32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q1)+8P1Q1/(3P1Q2*P2Q1)-
	+ &160A1MB*2P1Q1/(3P1Q2P2Q1)-272A2MB*2P1Q1/(3P1Q2P2Q1)-
	+ &56A1MBMTP1Q1/(3P1Q2P2Q1)-200A2MBMTP1Q1/(3P1Q2P2Q1)-
	+ &48A1P1P2P1Q1/(P1Q2P2Q1)-256A2P1P2P1Q1/(3P1Q2*P2Q1)+
	+ &256A1A2MB2P1P2P1Q1/(3P1Q2*P2Q1)-
	+ &256A1A2MBMTP1P2P1Q1/(P1Q2*P2Q1)+
	+ &1024A1A2P1P22P1Q1/(3P1Q2P2Q1)
	+ A18=A18-272A2P1Q1*2/(3P1Q2*P2Q1)+
	+ &256A1A2MB2P1Q1*2/(3P1Q2*P2Q1)-
	+ &256A1A2MBMTP1Q12/(3P1Q2*P2Q1)+
	+ &512A1A2P1P2P1Q1*2/(3P1Q2P2Q1)+16A2P1Q2/(3P2Q1)+
	+ &64A1A2MB2P1Q2/P2Q1+32A22MB*2P1Q2/(3*P2Q1)-
	+ &112A1A2MBMTP1Q2/(3P2Q1)+368A1A2P1P2P1Q2/(3*P2Q1)+
	+ &32A2P1P2P1Q2/(3P1Q1*P2Q1)-
	+ &32A1A2MB2P1P2P1Q2/(3P1Q1*P2Q1)+
	+ &32A1A2MBMTP1P2P1Q2/(3P1Q1P2Q1)-
	+ &64A1A2P1P22P1Q2/(3P1Q1P2Q1)+224A12P2Q1+
	+ &656A1A2P2Q1/3-256A1MT2P2Q1/(3P1Q1*2)+
	+ &256A12MT*4P2Q1/(3P1Q12)-256A1P2Q1/(3P1Q1)-
	+ &224A1A2MBMTP2Q1/(3P1Q1)-368A12MT*2P2Q1/(3*P1Q1)+
	+ &448A1A2MT2P2Q1/(3P1Q1)+304A1A2P1P2P2Q1/(3P1Q1)+
	+ &256A12MT*4P2Q1/(3P1Q2*2)+
	+ &256A12MT*2P1Q1P2Q1/(3P1Q2*2)+16A1P2Q1/(3P1Q2)-
	+ &112A1A2MBMTP2Q1/(3P1Q2)+32A12MT*2P2Q1/(3*P1Q2)
	+ A18=A18+64A1A2MT2P2Q1/P1Q2+368A1A2P1P2P2Q1/(3*P1Q2)+
	+ &16A1MT*2P2Q1/(3P1Q1P1Q2)-64A12MT*4P2Q1/(3P1Q1P1Q2)+
	+ &640A12P1Q1P2Q1/(3P1Q2)+544A1A2P1Q1P2Q1/(3*P1Q2)+
	+ &32A12P1Q2P2Q1/P1Q1+944A1A2P1Q2P2Q1/(3P1Q1)+
	+ &128A2MB*4/(3P2Q2*2)-128A2MB3MT/(3P2Q2*2)+
	+ &256A22MB*5MT/(3P2Q22)+256A2MB2P1P2/(3P2Q2*2)-
	+ &256A22MB*4P1P2/(3P2Q2*2)+
	+ &64MB3MT*3/(3P1Q1*2P2Q2**2)-
	+ &64MB2MT*2P1P2/(3P1Q12P2Q2**2)-
	+ &64MB3MT/(3P1Q1P2Q2**2)-
	+ &256A2MB*3MTP1P2/(3P1Q1P2Q2*2)+
	+ &256A2MB*2P1P2*2/(3P1Q1P2Q2*2)-
	+ &256A22MB*4P1Q1/(3P2Q22)+256A2MB2P1Q2/(3P2Q2*2)-
	+ &256A22MB*4P1Q2/(3P2Q2*2)-
	+ &64MB2MT*2P1Q2/(3P1Q12P2Q2**2)-
	+ &256A2MB*3MTP1Q2/(3P1Q1P2Q2*2)+
	+ &512A2MB*2P1P2P1Q2/(3P1Q1P2Q2*2)
	+ A18=A18+256A2MB*2P1Q2*2/(3P1Q1P2Q2*2)-
	+ &256A2MB*2P2Q1/(3P2Q22)+256A2*2MB*3MTP2Q1/(3P2Q2**2)+
	+ &64MB2MT*2P2Q1/(3P1Q12P2Q2**2)+
	+ &64MB2P2Q1/(3P1Q1P2Q2**2)+
	+ &128A2MB*3MTP2Q1/(3P1Q1P2Q2*2)-
	+ &128A2MB*2MT*2P2Q1/(3P1Q1P2Q2**2)-
	+ &256A2MB*2P1P2P2Q1/(3P1Q1P2Q2*2)+
	+ &256A22MB*2P1Q1P2Q1/(3P2Q2**2)-
	+ &256A2MB*2P1Q2P2Q1/(3P1Q1P2Q22)-8/(3P2Q2)-
	+ &72A1MB*2/P2Q2-88A2MB2/(3P2Q2)-56A1MBMT/(3P2Q2)-
	+ &32A2MBMT/P2Q2-224A1A2MB*3MT/(3*P2Q2)+
	+ &704A22MB*3MT/(3P2Q2)-48A1*P1P2/P2Q2-
	+ &104A2P1P2/(3P2Q2)+448A1A2MB*2P1P2/(3*P2Q2)-
	+ &512A22MB*2P1P2/(3P2Q2)+128A1A2MBMTP1P2/(3*P2Q2)+
	+ &32A1A2P1P22/P2Q2+64MBMT3/(3P1Q1*2P2Q2)+
	+ &256A1MBMT3P1P2/(3P1Q12P2Q2)-
	+ &256A1MT*2P1P2*2/(3P1Q1*2P2Q2)-4MB2/(3P1Q1*P2Q2)
	+ A18=A18-64MBMT/(3P1Q1P2Q2)+128A2MB*3MT/(3P1Q1P2Q2)-
	+ &4MT2/(3P1Q1P2Q2)-128A1MB2MT*2/(3P1Q1*P2Q2)-
	+ &128A2MB*2MT*2/(3P1Q1P2Q2)+128A1MBMT*3/(3P1Q1*P2Q2)-
	+ &112A2MB*2P1P2/(3P1Q1P2Q2)+32A1MBMTP1P2/(3P1Q1P2Q2)+
	+ &32A2MBMTP1P2/(3P1Q1P2Q2)-112A1MT*2P1P2/(3P1Q1P2Q2)-
	+ &48A1P1P2*2/(P1Q1P2Q2)-48A2P1P2*2/(P1Q1P2Q2)-
	+ &512A1A2MBMTP1P22/(3P1Q1*P2Q2)+
	+ &512A1A2P1P23/(3P1Q1P2Q2)+16A2P1Q1/(3P2Q2)+
	+ &64A1A2MB2P1Q1/P2Q2+32A22MB*2P1Q1/(3*P2Q2)-
	+ &112A1A2MBMTP1Q1/(3P2Q2)+368A1A2P1P2P1Q1/(3*P2Q2)-
	+ &16P1P2/(3P1Q2P2Q2)+32A1MBMTP1P2/(3P1Q2*P2Q2)+
	+ &32A2MBMTP1P2/(3P1Q2P2Q2)+
	+ &64A1A2MBMTP1P22/(3P1Q2*P2Q2)-
	+ &64A1A2P1P23/(3P1Q2P2Q2)+8MBMTP1P2/(3P1Q1P1Q2*P2Q2)-
	+ &8MT2P1P2/(3P1Q1P1Q2*P2Q2)-
	+ &32A1MBMT3P1P2/(3P1Q1P1Q2*P2Q2)-
	+ &16P1P22/(3P1Q1P1Q2P2Q2)
	+ A18=A18+32A1MT*2P1P2*2/(3P1Q1P1Q2P2Q2)+
	+ &32A2P1P2P1Q1/(3P1Q2*P2Q2)-
	+ &32A1A2MB2P1P2P1Q1/(3P1Q2*P2Q2)+
	+ &32A1A2MBMTP1P2P1Q1/(3P1Q2P2Q2)-
	+ &64A1A2P1P22P1Q1/(3P1Q2P2Q2)-256A2P1Q2/(3*P2Q2)+
	+ &448A1A2MB2P1Q2/(3P2Q2)-368A2*2MB*2P1Q2/(3*P2Q2)-
	+ &224A1A2MBMTP1Q2/(3P2Q2)+304A1A2P1P2P1Q2/(3*P2Q2)+
	+ &64MT2P1Q2/(3P1Q12P2Q2)-
	+ &128A1MB*2MT*2P1Q2/(3P1Q12P2Q2)+
	+ &128A1MBMT3P1Q2/(3P1Q12P2Q2)-
	+ &256A1MT*2P1P2P1Q2/(3P1Q1*2P2Q2)+8P1Q2/(3P1Q1*P2Q2)-
	+ &160A1MB*2P1Q2/(3P1Q1P2Q2)-272A2MB*2P1Q2/(3P1Q1P2Q2)-
	+ &56A1MBMTP1Q2/(3P1Q1P2Q2)-200A2MBMTP1Q2/(3P1Q1P2Q2)-
	+ &48A1P1P2P1Q2/(P1Q1P2Q2)-256A2P1P2P1Q2/(3P1Q1*P2Q2)+
	+ &256A1A2MB2P1P2P1Q2/(3P1Q1*P2Q2)-
	+ &256A1A2MBMTP1P2P1Q2/(P1Q1*P2Q2)+
	+ &1024A1A2P1P22P1Q2/(3P1Q1P2Q2)
	+ A18=A18-272A2P1Q2*2/(3P1Q1*P2Q2)+
	+ &256A1A2MB2P1Q2*2/(3P1Q1*P2Q2)-
	+ &256A1A2MBMTP1Q22/(3P1Q1*P2Q2)+
	+ &512A1A2P1P2P1Q2*2/(3P1Q1P2Q2)-32A2MB4/(3P2Q1*P2Q2)+
	+ &32A2MB*3MT/(3P2Q1P2Q2)-64A22MB*5MT/(3P2Q1P2Q2)+
	+ &16P1P2/(3P2Q1P2Q2)-64A2MB2P1P2/(3P2Q1P2Q2)+
	+ &64A22MB*4P1P2/(3P2Q1P2Q2)+8MB2P1P2/(3P1Q1P2Q1*P2Q2)-
	+ &8MBMTP1P2/(3P1Q1P2Q1P2Q2)+
	+ &32A2MB*3MTP1P2/(3P1Q1P2Q1P2Q2)+
	+ &16P1P22/(3P1Q1P2Q1P2Q2)-
	+ &32A2MB*2P1P2*2/(3P1Q1P2Q1P2Q2)-
	+ &16A2MB*2P1Q1/(3P2Q1P2Q2)+64A22MB*4P1Q1/(3P2Q1P2Q2)+
	+ &8MB2P1P2/(3P1Q2P2Q1P2Q2)-8MBMTP1P2/(3P1Q2P2Q1*P2Q2)+
	+ &32A2MB*3MTP1P2/(3P1Q2P2Q1P2Q2)+
	+ &16P1P22/(3P1Q2P2Q1P2Q2)-
	+ &32A2MB*2P1P2*2/(3P1Q2P2Q1P2Q2)-
	+ &16MBMTP1P22/(3P1Q1P1Q2P2Q1*P2Q2)
	+ A18=A18+16P1P23/(3P1Q1P1Q2P2Q1*P2Q2)-
	+ &32A2MB*2P1P2P1Q1/(3P1Q2P2Q1P2Q2)-
	+ &16A2MB*2P1Q2/(3P2Q1P2Q2)+64A22MB*4P1Q2/(3P2Q1P2Q2)-
	+ &32A2MB*2P1P2P1Q2/(3P1Q1P2Q1P2Q2)+272A1P2Q1/(3*P2Q2)+
	+ &112A2P2Q1/P2Q2-80A1A2MB2P2Q1/P2Q2+
	+ &400A1A2MBMTP2Q1/(3P2Q2)-208A22MBMTP2Q1/(3*P2Q2)-
	+ &272A1A2MT2P2Q1/(3P2Q2)-320A1A2P1P2*P2Q1/P2Q2+
	+ &96A22P1P2P2Q1/P2Q2-256A1MBMT*3P2Q1/(3P1Q12P2Q2)+
	+ &512A1MT*2P1P2P2Q1/(3P1Q1*2P2Q2)-8P2Q1/(3P1Q1*P2Q2)+
	+ &200A1MBMTP2Q1/(3P1Q1P2Q2)+56A2MBMTP2Q1/(3P1Q1P2Q2)+
	+ &272A1MT*2P2Q1/(3P1Q1P2Q2)+160A2MT*2P2Q1/(3P1Q1P2Q2)+
	+ &256A1P1P2P2Q1/(3P1Q1P2Q2)+48A2P1P2P2Q1/(P1Q1*P2Q2)+
	+ &256A1A2MBMTP1P2P2Q1/(P1Q1*P2Q2)-
	+ &256A1A2MT2P1P2P2Q1/(3P1Q1*P2Q2)-
	+ &1024A1A2P1P22P2Q1/(3P1Q1P2Q2)-
	+ &544A1A2P1Q1P2Q1/(3P2Q2)-640A2*2P1Q1P2Q1/(3P2Q2)-
	+ &32A1P1P2P2Q1/(3P1Q2*P2Q2)
	+ A18=A18-32A1A2MBMTP1P2P2Q1/(3P1Q2P2Q2)+
	+ &32A1A2MT2P1P2P2Q1/(3P1Q2*P2Q2)+
	+ &64A1A2P1P22P2Q1/(3P1Q2P2Q2)-
	+ &32A1MT*2P1P2P2Q1/(3P1Q1P1Q2P2Q2)+
	+ &64A1A2P1P2P1Q1P2Q1/(3P1Q2*P2Q2)-
	+ &944A1A2P1Q2P2Q1/(3P2Q2)-32A2*2P1Q2*P2Q1/P2Q2+
	+ &256A1MT*2P1Q2P2Q1/(3P1Q1*2P2Q2)+
	+ &96A1P1Q2P2Q1/(P1Q1P2Q2)+96A2P1Q2P2Q1/(P1Q1P2Q2)-
	+ &128A1A2MB2P1Q2P2Q1/(3P1Q1*P2Q2)+
	+ &256A1A2MBMTP1Q2P2Q1/(P1Q1*P2Q2)-
	+ &128A1A2MT2P1Q2P2Q1/(3P1Q1*P2Q2)-
	+ &512A1A2P1P2P1Q2P2Q1/(P1Q1P2Q2)-
	+ &512A1A2P1Q22P2Q1/(3P1Q1P2Q2)+544A1A2P2Q12/(3P2Q2)-
	+ &256A1MT*2P2Q1*2/(3P1Q1*2P2Q2)-
	+ &272A1P2Q1*2/(3P1Q1*P2Q2)-
	+ &256A1A2MBMTP2Q12/(3P1Q1*P2Q2)+
	+ &256A1A2MT2P2Q1*2/(3P1Q1*P2Q2)
	+ A18=A18+512A1A2P1P2P2Q1*2/(3P1Q1*P2Q2)+
	+ &512A1A2P1Q2P2Q1*2/(3P1Q1P2Q2)+224A12*P2Q2+
	+ &656A1A2P2Q2/3+256A12MT4P2Q2/(3P1Q1*2)+
	+ &16A1P2Q2/(3P1Q1)-112A1A2MBMTP2Q2/(3*P1Q1)+
	+ &32A12MT*2P2Q2/(3P1Q1)+64A1A2MT*2P2Q2/P1Q1+
	+ &368A1A2P1P2P2Q2/(3P1Q1)-256A1MT2P2Q2/(3P1Q2*2)+
	+ &256A12MT*4P2Q2/(3P1Q22)-256A1P2Q2/(3P1Q2)-
	+ &224A1A2MBMTP2Q2/(3P1Q2)-368A12MT*2P2Q2/(3*P1Q2)+
	+ &448A1A2MT2P2Q2/(3P1Q2)+304A1A2P1P2P2Q2/(3P1Q2)+
	+ &16A1MT*2P2Q2/(3P1Q1P1Q2)-64A12MT*4P2Q2/(3P1Q1P1Q2)+
	+ &32A12P1Q1P2Q2/P1Q2+944A1A2P1Q1P2Q2/(3P1Q2)+
	+ &256A12MT*2P1Q2P2Q2/(3P1Q1**2)+
	+ &640A12P1Q2P2Q2/(3P1Q1)+544A1A2P1Q2P2Q2/(3*P1Q1)-
	+ &256A2MB*2P2Q2/(3P2Q12)+256A2*2MB*3MTP2Q2/(3P2Q1**2)+
	+ &64MB2MT*2P2Q2/(3P1Q22P2Q1**2)+
	+ &64MB2P2Q2/(3P1Q2P2Q1**2)+
	+ &128A2MB*3MTP2Q2/(3P1Q2P2Q1*2)
	+ A18=A18-128A2MB*2MT*2P2Q2/(3P1Q2P2Q1**2)-
	+ &256A2MB*2P1P2P2Q2/(3P1Q2P2Q1*2)-
	+ &256A2MB*2P1Q1P2Q2/(3P1Q2P2Q1*2)+
	+ &256A22MB*2P1Q2P2Q2/(3P2Q1*2)+272A1P2Q2/(3P2Q1)+
	+ &112A2P2Q2/P2Q1-80A1A2MB2P2Q2/P2Q1+
	+ &400A1A2MBMTP2Q2/(3P2Q1)-208A22MBMTP2Q2/(3*P2Q1)-
	+ &272A1A2MT2P2Q2/(3P2Q1)-320A1A2P1P2*P2Q2/P2Q1+
	+ &96A22P1P2P2Q2/P2Q1-32A1P1P2P2Q2/(3P1Q1P2Q1)-
	+ &32A1A2MBMTP1P2P2Q2/(3P1Q1P2Q1)+
	+ &32A1A2MT2P1P2P2Q2/(3P1Q1*P2Q1)+
	+ &64A1A2P1P22P2Q2/(3P1Q1P2Q1)-944A1A2P1Q1P2Q2/(3*P2Q1)-
	+ &32A22P1Q1P2Q2/P2Q1-256A1MBMT*3P2Q2/(3P1Q22P2Q1)+
	+ &512A1MT*2P1P2P2Q2/(3P1Q2*2P2Q1)+
	+ &256A1MT*2P1Q1P2Q2/(3P1Q2*2P2Q1)-8P2Q2/(3P1Q2*P2Q1)+
	+ &200A1MBMTP2Q2/(3P1Q2P2Q1)+56A2MBMTP2Q2/(3P1Q2P2Q1)+
	+ &272A1MT*2P2Q2/(3P1Q2P2Q1)+160A2MT*2P2Q2/(3P1Q2P2Q1)+
	+ &256A1P1P2P2Q2/(3P1Q2P2Q1)+48A2P1P2P2Q2/(P1Q2*P2Q1)
	+ A18=A18+256A1A2MBMTP1P2P2Q2/(P1Q2*P2Q1)-
	+ &256A1A2MT2P1P2P2Q2/(3P1Q2*P2Q1)-
	+ &1024A1A2P1P22P2Q2/(3P1Q2P2Q1)-
	+ &32A1MT*2P1P2P2Q2/(3P1Q1P1Q2P2Q1)+
	+ &96A1P1Q1P2Q2/(P1Q2P2Q1)+96A2P1Q1P2Q2/(P1Q2P2Q1)-
	+ &128A1A2MB2P1Q1P2Q2/(3P1Q2*P2Q1)+
	+ &256A1A2MBMTP1Q1P2Q2/(P1Q2*P2Q1)-
	+ &128A1A2MT2P1Q1P2Q2/(3P1Q2*P2Q1)-
	+ &512A1A2P1P2P1Q1P2Q2/(P1Q2P2Q1)-
	+ &512A1A2P1Q12P2Q2/(3P1Q2P2Q1)-544A1A2P1Q2P2Q2/(3*P2Q1)-
	+ &640A22P1Q2P2Q2/(3P2Q1)+
	+ &64A1A2P1P2P1Q2P2Q2/(3P1Q1P2Q1)+544A1A2P2Q2*2/(3P2Q1)-
	+ &256A1MT*2P2Q2*2/(3P1Q2*2P2Q1)-
	+ &272A1P2Q2*2/(3P1Q2*P2Q1)-
	+ &256A1A2MBMTP2Q22/(3P1Q2*P2Q1)+
	+ &256A1A2MT2P2Q2*2/(3P1Q2*P2Q1)+
	+ &512A1A2P1P2P2Q2*2/(3P1Q2*P2Q1)
	+ A18=A18+512A1A2P1Q1P2Q2*2/(3P1Q2*P2Q1)-
	+ &384A12MBMTP1Q12/S2+
	+ &384A12P1P2P1Q12/S2-2688A12MBMTP1Q1P1Q2/S**2+
	+ &2688A12P1P2P1Q1P1Q2/S*2-384A12MBMTP1Q22/S*2+
	+ &384A12P1P2P1Q22/S2-768A1A2MBMTP1Q1P2Q1/S*2+
	+ &768A1A2P1P2P1Q1P2Q1/S2-2688A1A2MBMTP1Q2P2Q1/S*2+
	+ &2688A1A2P1P2P1Q2P2Q1/S2-960A12P1Q1P1Q2P2Q1/S*2-
	+ &960A1A2P1Q1P1Q2P2Q1/S2+960A12P1Q22P2Q1/S**2+
	+ &960A1A2P1Q22P2Q1/S*2-384A2*2MBMTP2Q12/S2+
	+ &384A22P1P2P2Q12/S2-960A1A2P1Q2P2Q12/S*2-
	+ &960A22P1Q2P2Q12/S2-2688A1A2MBMTP1Q1P2Q2/S*2+
	+ &2688A1A2P1P2P1Q1P2Q2/S2+960A12P1Q12P2Q2/S**2+
	+ &960A1A2P1Q12P2Q2/S*2-768A1A2MBMTP1Q2P2Q2/S*2+
	+ &768A1A2P1P2P1Q2P2Q2/S2-960A12P1Q1P1Q2P2Q2/S*2-
	+ &960A1A2P1Q1P1Q2P2Q2/S2-2688A2*2MBMTP2Q1P2Q2/S*2+
	+ &2688A22P1P2P2Q1P2Q2/S*2+960A1A2P1Q1P2Q1P2Q2/S**2+
	+ &960A22P1Q1P2Q1P2Q2/S*2+960A1A2P1Q2P2Q1P2Q2/S**2
	+ A18=A18+960A22P1Q2P2Q1P2Q2/S**2-
	+ &384A22MBMTP2Q22/S2+
	+ &384A22P1P2P2Q22/S2-960A1A2P1Q1P2Q22/S*2-
	+ &960A22P1Q1P2Q22/S2-96A1MBMT/S-96A2MB*MT/S+
	+ &768A22MB*3MT/S+768A12MBMT3/S-192A1*P1P2/S-
	+ &192A2P1P2/S-768A22MB*2P1P2/S+2304A1A2MBMT*P1P2/S-
	+ &768A12MT*2P1P2/S-2304A1A2P1P2*2/S+
	+ &96A1MBMT3/(P1Q1S)+192A2MBMTP1P2/(P1Q1*S)-
	+ &96A1MT*2P1P2/(P1Q1S)-192A2P1P22/(P1Q1S)-192A1P1Q1/S-
	+ &144A2P1Q1/S-384A1A2MB2P1Q1/S-480A22MB*2P1Q1/S+
	+ &480A12MBMTP1Q1/S-96A1A2MBMT*P1Q1/S-
	+ &864A12P1P2P1Q1/S-672A1A2P1P2P1Q1/S-96A1A2P1Q1**2/S+
	+ &96A1MBMT3/(P1Q2S)+192A2MBMTP1P2/(P1Q2*S)-
	+ &96A1MT*2P1P2/(P1Q2S)-192A2P1P22/(P1Q2S)+
	+ &48A1MBMTP1Q1/(P1Q2S)-96A2MBMTP1Q1/(P1Q2S)-
	+ &48A1MT*2P1Q1/(P1Q2S)-192A1P1P2P1Q1/(P1Q2*S)-
	+ &192A2P1P2P1Q1/(P1Q2S)-192A1A2MBMTP1P2P1Q1/(P1Q2*S)
	+ A18=A18+192A1A2P1P22P1Q1/(P1Q2S)-192A1P1Q12/(P1Q2S)-
	+ &192A2P1Q1*2/(P1Q2S)+192A1A2MB2P1Q1*2/(P1Q2S)+
	+ &192A12MBMTP1Q1*2/(P1Q2S)-96A1A2MBMTP1Q12/(P1Q2S)+
	+ &192A1A2P1P2P1Q1*2/(P1Q2S)-192A1P1Q2/S-144A2P1Q2/S-
	+ &384A1A2MB2P1Q2/S-480A22MB*2P1Q2/S+
	+ &480A12MBMTP1Q2/S-96A1A2MBMT*P1Q2/S-
	+ &864A12P1P2P1Q2/S-672A1A2P1P2*P1Q2/S+
	+ &48A1MBMTP1Q2/(P1Q1S)-96A2MBMTP1Q2/(P1Q1S)-
	+ &48A1MT*2P1Q2/(P1Q1S)-192A1P1P2P1Q2/(P1Q1*S)-
	+ &192A2P1P2P1Q2/(P1Q1S)-192A1A2MBMTP1P2P1Q2/(P1Q1*S)+
	+ &192A1A2P1P22P1Q2/(P1Q1S)-576A1A2P1Q1*P1Q2/S-
	+ &96A1A2P1Q22/S-192A1P1Q22/(P1Q1S)-
	+ &192A2P1Q2*2/(P1Q1S)+192A1A2MB2P1Q2*2/(P1Q1S)+
	+ &192A12MBMTP1Q2*2/(P1Q1S)-96A1A2MBMTP1Q22/(P1Q1S)+
	+ &192A1A2P1P2P1Q2*2/(P1Q1S)-96A2MB*3MT/(P2Q1*S)+
	+ &96A2MB*2P1P2/(P2Q1S)-192A1MBMTP1P2/(P2Q1S)+
	+ &192A1P1P2*2/(P2Q1S)+96A1MB*2P1Q1/(P2Q1*S)
	+ A18=A18+192A2MB*2P1Q1/(P2Q1S)-96A1MBMTP1Q1/(P2Q1S)-
	+ &192A1A2MB3MTP1Q1/(P2Q1S)+192A1P1P2P1Q1/(P2Q1S)+
	+ &192A1A2MB2P1P2P1Q1/(P2Q1S)+
	+ &96A1A2MB2P1Q1*2/(P2Q1S)-
	+ &192A2MB*3MTP1Q1/(P1Q2P2Q1*S)+
	+ &192A2MB*2P1P2P1Q1/(P1Q2P2Q1*S)-
	+ &96A1MBMTP1P2P1Q1/(P1Q2P2Q1*S)+
	+ &96A1P1P2*2P1Q1/(P1Q2P2Q1S)+
	+ &96A1MB*2P1Q1*2/(P1Q2P2Q1*S)+
	+ &192A2MB*2P1Q1*2/(P1Q2P2Q1*S)-
	+ &48A1MBMTP1Q1*2/(P1Q2P2Q1*S)+
	+ &96A1P1P2P1Q12/(P1Q2P2Q1S)+96A1MB2P1Q2/(P2Q1*S)+
	+ &48A2MB*2P1Q2/(P2Q1S)+192A1A2MB*3MTP1Q2/(P2Q1S)-
	+ &192A1A2MB2P1P2P1Q2/(P2Q1S)-
	+ &96A1A2MB2P1Q2*2/(P2Q1S)+144A1P2Q1/S+192A2P2Q1/S+
	+ &96A1A2MBMTP2Q1/S-480A2*2MBMTP2Q1/S+
	+ &480A12MT*2P2Q1/S+384A1A2MT2P2Q1/S
	+ A18=A18+672A1A2P1P2P2Q1/S+864A22P1P2*P2Q1/S-
	+ &96A2MBMTP2Q1/(P1Q1S)+192A1MT2P2Q1/(P1Q1*S)+
	+ &96A2MT*2P2Q1/(P1Q1S)-192A1A2MBMT3P2Q1/(P1Q1*S)+
	+ &192A2P1P2P2Q1/(P1Q1S)+192A1A2MT2P1P2P2Q1/(P1Q1S)-
	+ &192A12P1Q1P2Q1/S-192A2*2P1Q1*P2Q1/S+
	+ &48A1MT*2P2Q1/(P1Q2S)+96A2MT2P2Q1/(P1Q2*S)+
	+ &192A1A2MBMT*3P2Q1/(P1Q2*S)-
	+ &192A1A2MT2P1P2P2Q1/(P1Q2S)+
	+ &96A1A2MBMTP1Q1P2Q1/(P1Q2*S)-
	+ &192A12MT*2P1Q1P2Q1/(P1Q2S)-
	+ &96A1A2MT2P1Q1P2Q1/(P1Q2S)-
	+ &384A1A2P1P2P1Q1P2Q1/(P1Q2S)-384A12P1Q1*2P2Q1/(P1Q2*S)-
	+ &384A1A2P1Q12P2Q1/(P1Q2S)-480A12P1Q2P2Q1/S-
	+ &960A1A2P1Q2P2Q1/S-480A22P1Q2*P2Q1/S+
	+ &144A1P1Q2P2Q1/(P1Q1S)+96A2P1Q2P2Q1/(P1Q1S)+
	+ &384A1A2MBMTP1Q2P2Q1/(P1Q1*S)-
	+ &96A12MT*2P1Q2P2Q1/(P1Q1S)
	+ A18=A18+96A1A2MT2P1Q2P2Q1/(P1Q1S)-
	+ &576A1A2P1P2P1Q2P2Q1/(P1Q1S)-192A12P1Q2*2P2Q1/(P1Q1*S)-
	+ &384A1A2P1Q22P2Q1/(P1Q1S)-96A1A2P2Q1**2/S-
	+ &96A1A2MT2P2Q1*2/(P1Q1S)+96A1A2MT2P2Q1*2/(P1Q2S)+
	+ &288A1A2P1Q2P2Q1*2/(P1Q1S)-96A2MB*3MT/(P2Q2*S)+
	+ &96A2MB*2P1P2/(P2Q2S)-192A1MBMTP1P2/(P2Q2S)+
	+ &192A1P1P2*2/(P2Q2S)+96A1MB*2P1Q1/(P2Q2*S)+
	+ &48A2MB*2P1Q1/(P2Q2S)+192A1A2MB*3MTP1Q1/(P2Q2S)-
	+ &192A1A2MB2P1P2P1Q1/(P2Q2S)-
	+ &96A1A2MB2P1Q1*2/(P2Q2S)+96A1MB*2P1Q2/(P2Q2*S)+
	+ &192A2MB*2P1Q2/(P2Q2S)-96A1MBMTP1Q2/(P2Q2S)-
	+ &192A1A2MB3MTP1Q2/(P2Q2S)+192A1P1P2P1Q2/(P2Q2S)+
	+ &192A1A2MB2P1P2P1Q2/(P2Q2S)-
	+ &192A2MB*3MTP1Q2/(P1Q1P2Q2*S)+
	+ &192A2MB*2P1P2P1Q2/(P1Q1P2Q2*S)-
	+ &96A1MBMTP1P2P1Q2/(P1Q1P2Q2*S)+
	+ &96A1P1P2*2P1Q2/(P1Q1P2Q2S)+96A1A2MB2P1Q2*2/(P2Q2S)
	+ A18=A18+96A1MB*2P1Q2*2/(P1Q1P2Q2*S)+
	+ &192A2MB*2P1Q2*2/(P1Q1P2Q2*S)-
	+ &48A1MBMTP1Q2*2/(P1Q1P2Q2*S)+
	+ &96A1P1P2P1Q22/(P1Q1P2Q2S)-48A2MB2P2Q1/(P2Q2*S)-
	+ &96A1MBMTP2Q1/(P2Q2S)+48A2MBMTP2Q1/(P2Q2S)-
	+ &192A1P1P2P2Q1/(P2Q2S)-192A2P1P2P2Q1/(P2Q2S)-
	+ &192A1A2MBMTP1P2P2Q1/(P2Q2*S)+
	+ &192A1A2P1P22P2Q1/(P2Q2*S)+
	+ &192A1MBMT3P2Q1/(P1Q1P2Q2S)+
	+ &96A2MBMTP1P2P2Q1/(P1Q1P2Q2*S)-
	+ &192A1MT*2P1P2P2Q1/(P1Q1P2Q2*S)-
	+ &96A2P1P2*2P2Q1/(P1Q1P2Q2S)+
	+ &96A1A2MB2P1Q1P2Q1/(P2Q2S)+
	+ &192A22MB*2P1Q1P2Q1/(P2Q2S)-
	+ &96A1A2MBMTP1Q1P2Q1/(P2Q2*S)+
	+ &384A1A2P1P2P1Q1P2Q1/(P2Q2S)-96A1P1Q2P2Q1/(P2Q2S)-
	+ &144A2P1Q2P2Q1/(P2Q2S)-96A1A2MB2P1Q2P2Q1/(P2Q2S)
	+ A18=A18+96A22MB*2P1Q2P2Q1/(P2Q2S)-
	+ &384A1A2MBMTP1Q2P2Q1/(P2Q2*S)+
	+ &576A1A2P1P2P1Q2P2Q1/(P2Q2S)-
	+ &96A2MB*2P1Q2P2Q1/(P1Q1P2Q2*S)-
	+ &48A1MBMTP1Q2P2Q1/(P1Q1P2Q2*S)-
	+ &48A2MBMTP1Q2P2Q1/(P1Q1P2Q2*S)-
	+ &96A1MT*2P1Q2P2Q1/(P1Q1P2Q2*S)-
	+ &96A1P1P2P1Q2P2Q1/(P1Q1P2Q2S)-
	+ &96A2P1P2P1Q2P2Q1/(P1Q1P2Q2S)+
	+ &96A1A2P1Q1P1Q2P2Q1/(P2Q2S)+288A1A2P1Q22P2Q1/(P2Q2*S)-
	+ &96A1P1Q2*2P2Q1/(P1Q1P2Q2S)-96A2P1Q2*2P2Q1/(P1Q1P2Q2S)+
	+ &192A1P2Q1*2/(P2Q2S)+192A2P2Q1*2/(P2Q2S)+
	+ &96A1A2MBMTP2Q12/(P2Q2S)-192A22MBMTP2Q1*2/(P2Q2S)-
	+ &192A1A2MT2P2Q1*2/(P2Q2S)-192A1A2P1P2P2Q1*2/(P2Q2S)-
	+ &48A2MBMTP2Q1*2/(P1Q1P2Q2*S)+
	+ &192A1MT*2P2Q1*2/(P1Q1P2Q2*S)+
	+ &96A2MT*2P2Q1*2/(P1Q1P2Q2*S)
	+ A18=A18+96A2P1P2P2Q12/(P1Q1P2Q2*S)-
	+ &384A1A2P1Q1P2Q1*2/(P2Q2S)-
	+ &384A22P1Q1P2Q12/(P2Q2S)-384A1A2P1Q2P2Q1*2/(P2Q2S)-
	+ &192A22P1Q2P2Q12/(P2Q2S)+96A1P1Q2P2Q12/(P1Q1P2Q2*S)+
	+ &96A2P1Q2P2Q12/(P1Q1P2Q2S)+144A1P2Q2/S+192A2*P2Q2/S+
	+ &96A1A2MBMTP2Q2/S-480A2*2MBMTP2Q2/S+
	+ &480A12MT*2P2Q2/S+384A1A2MT2P2Q2/S+
	+ &672A1A2P1P2P2Q2/S+864A22P1P2*P2Q2/S+
	+ &48A1MT*2P2Q2/(P1Q1S)+96A2MT2P2Q2/(P1Q1*S)+
	+ &192A1A2MBMT*3P2Q2/(P1Q1*S)-
	+ &192A1A2MT2P1P2P2Q2/(P1Q1S)-480A12P1Q1*P2Q2/S-
	+ &960A1A2P1Q1P2Q2/S-480A22P1Q1*P2Q2/S-
	+ &96A2MBMTP2Q2/(P1Q2S)+192A1MT2P2Q2/(P1Q2*S)+
	+ &96A2MT*2P2Q2/(P1Q2S)-192A1A2MBMT3P2Q2/(P1Q2*S)+
	+ &192A2P1P2P2Q2/(P1Q2S)+192A1A2MT2P1P2P2Q2/(P1Q2S)+
	+ &144A1P1Q1P2Q2/(P1Q2S)+96A2P1Q1P2Q2/(P1Q2S)+
	+ &384A1A2MBMTP1Q1P2Q2/(P1Q2*S)
	+ A18=A18-96A12MT*2P1Q1P2Q2/(P1Q2S)+
	+ &96A1A2MT2P1Q1P2Q2/(P1Q2S)-
	+ &576A1A2P1P2P1Q1P2Q2/(P1Q2S)-192A12P1Q1*2P2Q2/(P1Q2*S)-
	+ &384A1A2P1Q12P2Q2/(P1Q2S)-192A12P1Q2P2Q2/S-
	+ &192A22P1Q2P2Q2/S+96A1A2MBMTP1Q2P2Q2/(P1Q1S)-
	+ &192A12MT*2P1Q2P2Q2/(P1Q1S)-
	+ &96A1A2MT2P1Q2P2Q2/(P1Q1S)-
	+ &384A1A2P1P2P1Q2P2Q2/(P1Q1S)-384A12P1Q2*2P2Q2/(P1Q1*S)-
	+ &384A1A2P1Q22P2Q2/(P1Q1S)-48A2MB2P2Q2/(P2Q1*S)-
	+ &96A1MBMTP2Q2/(P2Q1S)+48A2MBMTP2Q2/(P2Q1S)-
	+ &192A1P1P2P2Q2/(P2Q1S)-192A2P1P2P2Q2/(P2Q1S)-
	+ &192A1A2MBMTP1P2P2Q2/(P2Q1*S)+
	+ &192A1A2P1P22P2Q2/(P2Q1S)-96A1P1Q1P2Q2/(P2Q1*S)-
	+ &144A2P1Q1P2Q2/(P2Q1S)-96A1A2MB2P1Q1P2Q2/(P2Q1S)+
	+ &96A22MB*2P1Q1P2Q2/(P2Q1S)-
	+ &384A1A2MBMTP1Q1P2Q2/(P2Q1*S)+
	+ &576A1A2P1P2P1Q1P2Q2/(P2Q1S)+288A1A2P1Q12P2Q2/(P2Q1*S)
	+ A18=A18+192A1MBMT3P2Q2/(P1Q2P2Q1S)+
	+ &96A2MBMTP1P2P2Q2/(P1Q2P2Q1*S)-
	+ &192A1MT*2P1P2P2Q2/(P1Q2P2Q1*S)-
	+ &96A2P1P2*2P2Q2/(P1Q2P2Q1S)-
	+ &96A2MB*2P1Q1P2Q2/(P1Q2P2Q1*S)-
	+ &48A1MBMTP1Q1P2Q2/(P1Q2P2Q1*S)-
	+ &48A2MBMTP1Q1P2Q2/(P1Q2P2Q1*S)-
	+ &96A1MT*2P1Q1P2Q2/(P1Q2P2Q1*S)-
	+ &96A1P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	+ &96A2P1P2P1Q1P2Q2/(P1Q2P2Q1S)-
	+ &96A1P1Q1*2P2Q2/(P1Q2P2Q1S)-96A2P1Q1*2P2Q2/(P1Q2P2Q1S)+
	+ &96A1A2MB2P1Q2P2Q2/(P2Q1S)+
	+ &192A22MB*2P1Q2P2Q2/(P2Q1S)-
	+ &96A1A2MBMTP1Q2P2Q2/(P2Q1*S)+
	+ &384A1A2P1P2P1Q2P2Q2/(P2Q1S)+
	+ &96A1A2P1Q1P1Q2P2Q2/(P2Q1S)-576A1A2P2Q1P2Q2/S+
	+ &96A1A2P1Q1P2Q1P2Q2/(P1Q2S)+96A1A2P1Q2P2Q1P2Q2/(P1Q1S)
	+ A18=A18-96A1A2P2Q22/S+96A1A2MT*2P2Q2*2/(P1Q1S)-
	+ &96A1A2MT2P2Q2*2/(P1Q2S)+288A1A2P1Q1P2Q2*2/(P1Q2S)+
	+ &192A1P2Q2*2/(P2Q1S)+192A2P2Q2*2/(P2Q1S)+
	+ &96A1A2MBMTP2Q22/(P2Q1S)-192A22MBMTP2Q2*2/(P2Q1S)-
	+ &192A1A2MT2P2Q2*2/(P2Q1S)-192A1A2P1P2P2Q2*2/(P2Q1S)-
	+ &384A1A2P1Q1P2Q2*2/(P2Q1S)-192A22P1Q1P2Q22/(P2Q1S)-
	+ &48A2MBMTP2Q2*2/(P1Q2P2Q1*S)+
	+ &192A1MT*2P2Q2*2/(P1Q2P2Q1*S)+
	+ &96A2MT*2P2Q2*2/(P1Q2P2Q1*S)+
	+ &96A2P1P2P2Q22/(P1Q2P2Q1S)+96A1P1Q1P2Q2*2/(P1Q2P2Q1*S)+
	+ &96A2P1Q1P2Q22/(P1Q2P2Q1S)-384A1A2P1Q2P2Q22/(P2Q1S)-
	+ &384A22P1Q2P2Q22/(P2Q1S)+512A1A2*S/3-
	+ &128A1MT*2S/(3P1Q12)+128A12MBMT*3S/(3P1Q1*2)-
	+ &152A1S/(3P1Q1)-152A12MBMTS/(3P1Q1)-
	+ &128A1A2MBMTS/(3P1Q1)+112A1A2MT2S/(3*P1Q1)-
	+ &16A12P1P2S/P1Q1+152A1A2P1P2S/(3P1Q1)-
	+ &128A1MT*2S/(3P1Q22)+128A12MBMT*3S/(3P1Q2*2)
	+ A18=A18-152A1S/(3P1Q2)-152A12MBMTS/(3P1Q2)-
	+ &128A1A2MBMTS/(3P1Q2)+112A1A2MT2S/(3*P1Q2)-
	+ &16A12P1P2S/P1Q2+152A1A2P1P2S/(3P1Q2)+
	+ &16A1MBMTS/(3P1Q1P1Q2)-32A12MBMT3S/(3P1Q1P1Q2)-
	+ &16A1P1P2S/(3P1Q1P1Q2)+272A1A2P1Q1S/(3P1Q2)+
	+ &272A1A2P1Q2S/(3P1Q1)-128A2MB2S/(3P2Q1*2)+
	+ &128A22MB*3MTS/(3P2Q1**2)+
	+ &32MB2MT*2S/(3P1Q22P2Q1*2)+32MB*2S/(3P1Q2P2Q1**2)
	+
	+ A18BIS=
	+ &64A2MB*3MTS/(3P1Q2P2Q1*2)-
	+ &64A2MB*2MT*2S/(3P1Q2P2Q1**2)-
	+ &128A2MB*2P1P2S/(3P1Q2P2Q1*2)-
	+ &128A2MB*2P1Q1S/(3P1Q2P2Q1*2)+
	+ &128A22MB*2P1Q2S/(3P2Q1*2)+152A2S/(3P2Q1)-
	+ &112A1A2MB2S/(3P2Q1)+128A1A2MBMTS/(3*P2Q1)+
	+ &152A22MBMTS/(3P2Q1)-152A1A2P1P2S/(3P2Q1)+
	+ &16A22P1P2S/P2Q1-8A1A2MB*3MTS/(3P1Q1*P2Q1)+
	+ &16A1A2MB2MT*2S/(3P1Q1P2Q1)-
	+ &8A1A2MBMT*3S/(3P1Q1P2Q1)-8A1P1P2S/(3P1Q1*P2Q1)-
	+ &8A2P1P2S/(3P1Q1P2Q1)+8A1A2MB*2P1P2S/(3P1Q1*P2Q1)-
	+ &16A1A2MBMTP1P2S/(3P1Q1P2Q1)+
	+ &8A1A2MT2P1P2S/(3P1Q1*P2Q1)+
	+ &32A1A2P1P22S/(3P1Q1P2Q1)-32A22P1Q1S/(3P2Q1)-
	+ &32MT2S/(3P1Q22P2Q1)+64A1MB*2MT*2S/(3P1Q22P2Q1)-
	+ &64A1MBMT3S/(3P1Q22P2Q1)
	+ A18BIS=A18BIS+128A1MT*2P1P2S/(3P1Q2*2P2Q1)-
	+ &12S/(P1Q2P2Q1)+
	+ &24A1MB*2S/(P1Q2P2Q1)+64A1A2MB*3MTS/(3P1Q2*P2Q1)+
	+ &24A2MT*2S/(P1Q2P2Q1)-128A1A2MB*2MT*2S/(3P1Q2P2Q1)+
	+ &64A1A2MBMT*3S/(3P1Q2P2Q1)+56A1P1P2S/(3P1Q2*P2Q1)+
	+ &56A2P1P2S/(3P1Q2P2Q1)-64A1A2MB*2P1P2S/(3P1Q2*P2Q1)+
	+ &128A1A2MBMTP1P2S/(3P1Q2P2Q1)-
	+ &64A1A2MT2P1P2S/(3P1Q2*P2Q1)-
	+ &256A1A2P1P22S/(3P1Q2P2Q1)+4P1P2S/(3P1Q1P1Q2*P2Q1)-
	+ &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q1)-
	+ &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q1)+136A2P1Q1S/(3P1Q2*P2Q1)-
	+ &128A1A2MB2P1Q1S/(3P1Q2*P2Q1)+
	+ &128A1A2MBMTP1Q1S/(3P1Q2P2Q1)-
	+ &256A1A2P1P2P1Q1S/(3P1Q2P2Q1)-160A2*2P1Q2S/(3P2Q1)+
	+ &16A1A2P1P2P1Q2S/(3P1Q1P2Q1)-32A12P2Q1S/(3*P1Q1)-
	+ &128A12MT*2P2Q1S/(3P1Q2*2)-160A12P2Q1S/(3*P1Q2)-
	+ &128A2MB*2S/(3P2Q22)+128A2*2MB*3MTS/(3P2Q2**2)
	+ A18BIS=A18BIS+32MB2MT*2S/(3P1Q12P2Q2**2)+
	+ &32MB2S/(3P1Q1P2Q2**2)+
	+ &64A2MB*3MTS/(3P1Q1P2Q2*2)-
	+ &64A2MB*2MT*2S/(3P1Q1P2Q2**2)-
	+ &128A2MB*2P1P2S/(3P1Q1P2Q2*2)+
	+ &128A22MB*2P1Q1S/(3P2Q2**2)-
	+ &128A2MB*2P1Q2S/(3P1Q1P2Q22)+152A2S/(3P2Q2)-
	+ &112A1A2MB2S/(3P2Q2)+128A1A2MBMTS/(3*P2Q2)+
	+ &152A22MBMTS/(3P2Q2)-152A1A2P1P2S/(3P2Q2)+
	+ &16A22P1P2S/P2Q2-32MT*2S/(3P1Q12P2Q2)+
	+ &64A1MB*2MT*2S/(3P1Q12P2Q2)-
	+ &64A1MBMT3S/(3P1Q12P2Q2)+
	+ &128A1MT*2P1P2S/(3P1Q1*2P2Q2)-12S/(P1Q1P2Q2)+
	+ &24A1MB*2S/(P1Q1P2Q2)+64A1A2MB*3MTS/(3P1Q1*P2Q2)+
	+ &24A2MT*2S/(P1Q1P2Q2)-128A1A2MB*2MT*2S/(3P1Q1P2Q2)+
	+ &64A1A2MBMT*3S/(3P1Q1P2Q2)+56A1P1P2S/(3P1Q1*P2Q2)+
	+ &56A2P1P2S/(3P1Q1P2Q2)-64A1A2MB*2P1P2S/(3P1Q1*P2Q2)
	+ A18BIS=A18BIS+128A1A2MBMTP1P2S/(3P1Q1P2Q2)-
	+ &64A1A2MT2P1P2S/(3P1Q1*P2Q2)-
	+ &256A1A2P1P22S/(3P1Q1P2Q2)-160A22P1Q1S/(3P2Q2)-
	+ &8A1A2MB3MTS/(3P1Q2*P2Q2)+
	+ &16A1A2MB2MT*2S/(3P1Q2P2Q2)-
	+ &8A1A2MBMT*3S/(3P1Q2P2Q2)-8A1P1P2S/(3P1Q2*P2Q2)-
	+ &8A2P1P2S/(3P1Q2P2Q2)+8A1A2MB*2P1P2S/(3P1Q2*P2Q2)-
	+ &16A1A2MBMTP1P2S/(3P1Q2P2Q2)+
	+ &8A1A2MT2P1P2S/(3P1Q2*P2Q2)+
	+ &32A1A2P1P22S/(3P1Q2P2Q2)+4P1P2S/(3P1Q1P1Q2*P2Q2)-
	+ &8A1MBMTP1P2S/(3P1Q1P1Q2P2Q2)-
	+ &8A1MT*2P1P2S/(3P1Q1P1Q2P2Q2)+
	+ &16A1A2P1P2P1Q1S/(3P1Q2P2Q2)-32A2*2P1Q2S/(3P2Q2)+
	+ &136A2P1Q2S/(3P1Q1P2Q2)-128A1A2MB*2P1Q2S/(3P1Q1*P2Q2)+
	+ &128A1A2MBMTP1Q2S/(3P1Q1P2Q2)-
	+ &256A1A2P1P2P1Q2S/(3P1Q1P2Q2)+16A2MBMTS/(3P2Q1*P2Q2)-
	+ &32A22MB*3MTS/(3P2Q1P2Q2)-16A2P1P2S/(3P2Q1P2Q2)
	+ A18BIS=A18BIS-4P1P2S/(3P1Q1P2Q1*P2Q2)+
	+ &8A2MB*2P1P2S/(3P1Q1P2Q1P2Q2)+
	+ &8A2MBMTP1P2S/(3P1Q1P2Q1P2Q2)-4P1P2S/(3P1Q2P2Q1*P2Q2)+
	+ &8A2MB*2P1P2S/(3P1Q2P2Q1P2Q2)+
	+ &8A2MBMTP1P2S/(3P1Q2P2Q1P2Q2)-
	+ &2MB3MTS/(3P1Q1P1Q2P2Q1*P2Q2)+
	+ &4MB2MT*2S/(3P1Q1P1Q2P2Q1P2Q2)-
	+ &2MBMT*3S/(3P1Q1P1Q2P2Q1P2Q2)-
	+ &2MB2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)+
	+ &4MBMTP1P2S/(3P1Q1P1Q2P2Q1P2Q2)-
	+ &2MT2P1P2S/(3P1Q1P1Q2P2Q1*P2Q2)-
	+ &8P1P22S/(3P1Q1P1Q2P2Q1P2Q2)+
	+ &8A2P1P2P1Q1S/(3P1Q2P2Q1*P2Q2)+
	+ &8A2P1P2P1Q2S/(3P1Q1P2Q1P2Q2)+272A1A2P2Q1S/(3P2Q2)-
	+ &128A1MT*2P2Q1S/(3P1Q1*2P2Q2)-136A1P2Q1S/(3P1Q1*P2Q2)-
	+ &128A1A2MBMTP2Q1S/(3P1Q1P2Q2)+
	+ &128A1A2MT2P2Q1S/(3P1Q1*P2Q2)
	+ A18BIS=A18BIS+256A1A2P1P2P2Q1S/(3P1Q1*P2Q2)-
	+ &16A1A2P1P2P2Q1S/(3P1Q2*P2Q2)+
	+ &8A1P1P2P2Q1S/(3P1Q1P1Q2*P2Q2)+
	+ &256A1A2P1Q2P2Q1S/(3P1Q1*P2Q2)-
	+ &128A12MT*2P2Q2S/(3P1Q1*2)-160A12P2Q2S/(3*P1Q1)-
	+ &32A12P2Q2S/(3P1Q2)+272A1A2P2Q2S/(3*P2Q1)-
	+ &16A1A2P1P2P2Q2S/(3P1Q1*P2Q1)-
	+ &128A1MT*2P2Q2S/(3P1Q2*2P2Q1)-136A1P2Q2S/(3P1Q2*P2Q1)-
	+ &128A1A2MBMTP2Q2S/(3P1Q2P2Q1)+
	+ &128A1A2MT2P2Q2S/(3P1Q2*P2Q1)+
	+ &256A1A2P1P2P2Q2S/(3P1Q2*P2Q1)+
	+ &8A1P1P2P2Q2S/(3P1Q1P1Q2*P2Q1)+
	+ &256A1A2P1Q1P2Q2S/(3P1Q2*P2Q1)-
	+ &8A12MBMTS*2/(3P1Q1P1Q2)+16A12P1P2S*2/(3P1Q1*P1Q2)-
	+ &8A1A2P1P2S*2/(3P1Q1P2Q1)+4A1P1P2S*2/(3P1Q1P1Q2P2Q1)-
	+ &8A1A2P1P2S*2/(3P1Q2P2Q2)+4A1P1P2S*2/(3P1Q1P1Q2P2Q2)-
	+ &8A22MBMTS*2/(3P2Q1P2Q2)+16A2*2P1P2S2/(3P2Q1*P2Q2)
	+ A18BIS=A18BIS-4A2P1P2S2/(3P1Q1P2Q1P2Q2)-
	+ &4A2P1P2S2/(3P1Q2P2Q1P2Q2)+
	+ &2P1P2S*2/(3P1Q1P1Q2P2Q1*P2Q2)
	+C
	+ V18=V18+V18BIS
	+ A18=A18+A18BIS
	+ V910 =-48A12MBMT-48A2*2MBMT-48A12P1P2-48A2*2P1P2-
	+ &384A12MBMTP1Q1P1Q2/S2-384A12P1P2P1Q1P1Q2/S*2-
	+ &384A1A2MBMTP1Q2P2Q1/S*2-384A1A2P1P2P1Q2P2Q1/S**2+
	+ &192A12P1Q1P1Q2P2Q1/S*2+192A1A2P1Q1P1Q2P2Q1/S**2-
	+ &192A12P1Q2*2P2Q1/S*2-192A1A2P1Q2*2P2Q1/S**2+
	+ &192A1A2P1Q2P2Q12/S2+192A22P1Q2P2Q12/S*2-
	+ &384A1A2MBMTP1Q1P2Q2/S*2-384A1A2P1P2P1Q1P2Q2/S**2-
	+ &192A12P1Q1*2P2Q2/S*2-192A1A2P1Q1*2P2Q2/S**2+
	+ &192A12P1Q1P1Q2P2Q2/S*2+192A1A2P1Q1P1Q2P2Q2/S**2-
	+ &384A22MBMTP2Q1P2Q2/S2-384A2*2P1P2P2Q1P2Q2/S**2-
	+ &192A1A2P1Q1P2Q1P2Q2/S2-192A2*2P1Q1P2Q1P2Q2/S**2-
	+ &192A1A2P1Q2P2Q1P2Q2/S2-192A2*2P1Q2P2Q1P2Q2/S**2+
	+ &192A1A2P1Q1P2Q22/S2+192A22P1Q1P2Q22/S*2+
	+ &96A12MBMTP1Q1/S-96A1A2MBMT*P1Q1/S+
	+ &96A12P1P2P1Q1/S-96A1A2P1P2P1Q1/S+96A12MBMT*P1Q2/S-
	+ &96A1A2MBMTP1Q2/S+96A12P1P2P1Q2/S-96A1A2P1P2P1Q2/S+
	+ &96A1A2MBMTP2Q1/S-96A2*2MBMTP2Q1/S
	+ V910=V910+96A1A2P1P2P2Q1/S-
	+ &96A22P1P2P2Q1/S+96A12P1Q2P2Q1/S+
	+ &192A1A2P1Q2P2Q1/S+96A22P1Q2*P2Q1/S+
	+ &96A1A2MBMTP2Q2/S-96A2*2MBMTP2Q2/S+
	+ &96A1A2P1P2P2Q2/S-96A22P1P2P2Q2/S+96A12P1Q1P2Q2/S+
	+ &192A1A2P1Q1P2Q2/S+96A22P1Q1*P2Q2/S
	+C
	+ A910 = 48A12MBMT+48A2*2MBMT-48A12P1P2-48A2*2P1P2+
	+ &384A12MBMTP1Q1P1Q2/S2-384A12P1P2P1Q1P1Q2/S*2+
	+ &384A1A2MBMTP1Q2P2Q1/S*2-384A1A2P1P2P1Q2P2Q1/S**2+
	+ &192A12P1Q1P1Q2P2Q1/S*2+192A1A2P1Q1P1Q2P2Q1/S**2-
	+ &192A12P1Q2*2P2Q1/S*2-192A1A2P1Q2*2P2Q1/S**2+
	+ &192A1A2P1Q2P2Q12/S2+192A22P1Q2P2Q12/S*2+
	+ &384A1A2MBMTP1Q1P2Q2/S*2-384A1A2P1P2P1Q1P2Q2/S**2-
	+ &192A12P1Q1*2P2Q2/S*2-192A1A2P1Q1*2P2Q2/S**2+
	+ &192A12P1Q1P1Q2P2Q2/S*2+192A1A2P1Q1P1Q2P2Q2/S**2+
	+ &384A22MBMTP2Q1P2Q2/S2-384A2*2P1P2P2Q1P2Q2/S**2-
	+ &192A1A2P1Q1P2Q1P2Q2/S2-192A2*2P1Q1P2Q1P2Q2/S**2-
	+ &192A1A2P1Q2P2Q1P2Q2/S2-192A2*2P1Q2P2Q1P2Q2/S**2+
	+ &192A1A2P1Q1P2Q22/S2+192A22P1Q1P2Q22/S*2-
	+ &96A12MBMTP1Q1/S+96A1A2MBMT*P1Q1/S+
	+ &96A12P1P2P1Q1/S-96A1A2P1P2P1Q1/S-96A12MBMT*P1Q2/S+
	+ &96A1A2MBMTP1Q2/S+96A12P1P2P1Q2/S-96A1A2P1P2P1Q2/S-
	+ &96A1A2MBMTP2Q1/S+96A2*2MBMTP2Q1/S
	+ A910=A910+96A1A2P1P2P2Q1/S-
	+ &96A22P1P2P2Q1/S+96A12P1Q2P2Q1/S+
	+ &192A1A2P1Q2P2Q1/S+96A22P1Q2*P2Q1/S-
	+ &96A1A2MBMTP2Q2/S+96A2*2MBMTP2Q2/S+
	+ &96A1A2P1P2P2Q2/S-96A22P1P2P2Q2/S+96A12P1Q1P2Q2/S+
	+ &192A1A2P1Q1P2Q2/S+96A22P1Q1*P2Q2/S
	+C
	+C FINAL RESULT;
	+C
	+ AMP2= FACTPSVTB*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.D03.D0 2.D0*2.D0)
	+C COUPLING CONSTANT (OVERALL NORMALIZATION)
	+ FACT=(4.D0PIALPHA)(4.D0PIALPHAS)*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)GFSW2MW*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 -2P1Q1 -2P1Q2
	+ A1 =A1INV/(A1INV*2+ (GAMTMT)**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+ (GAMTMT)**2)
	+ A2 =1.D0/(S +2P2Q1 +2P2Q2)
	+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) = -16A2A2*2MB*MT+
	+ &64A2A2*2P1Q2P2Q12/S*2+
	+ &128A2A2*2MBMTP2Q1P2Q2/S*2-
	+ &128A2A2*2P1P2P2Q1P2Q2/S**2-
	+ &64A2A2*2P1Q1P2Q1P2Q2/S**2-
	+ &64A2A2*2P1Q2P2Q1P2Q2/S**2+
	+ &64A2A2*2P1Q1P2Q22/S*2-
	+ &32A2A2*2MB*3MT/S+32A2A2*2MB*2P1P2/S+
	+ &32A2A2*2MB*2P1Q1/S+32A2A2*2MB*2P1Q2/S-
	+ &32A2A2*2P1P2P2Q1/S-32A*2A2*2P1Q1*P2Q1/S-
	+ &32A2A2*2P1P2P2Q2/S-32A*2A2*2P1Q2*P2Q2/S+
	+ &16A22MBMTV*2+64A2*2P1Q2P2Q12V2/S2-
	+ &128A22MBMTP2Q1P2Q2V2/S2-
	+ &128A22P1P2P2Q1P2Q2V2/S*2-
	+ &64A22P1Q1P2Q1P2Q2V2/S*2-
	+ &64A22P1Q2P2Q1P2Q2V2/S*2+
	+ &64A22P1Q1P2Q22V2/S2
	+ YY(1, 1)=YY(1, 1)+32A22MB*3MTV*2/S+
	+ &32A22MB*2P1P2V*2/S+
	+ &32A22MB*2P1Q1V2/S+32A2*2MB*2P1Q2V*2/S-
	+ &32A22P1P2P2Q1V*2/S-32A2*2P1Q1P2Q1V**2/S-
	+ &32A22P1P2P2Q2V*2/S-32A2*2P1Q2P2Q2V**2/S
	+ YY(1, 1)=2*YY(1, 1)
	+
	+ YY(1, 2) = -32A2A1A2MB*MT+
	+ &128A2A1A2MBMTP1Q2P2Q1/S*2-
	+ &128A2A1A2P1P2P1Q2P2Q1/S**2+
	+ &64A2A1A2P1Q1P1Q2P2Q1/S**2-
	+ &64A2A1A2P1Q2*2P2Q1/S**2+
	+ &64A2A1A2P1Q2P2Q12/S*2+
	+ &128A2A1A2MBMTP1Q1P2Q2/S*2-
	+ &128A2A1A2P1P2P1Q1P2Q2/S**2-
	+ &64A2A1A2P1Q1*2P2Q2/S**2+
	+ &64A2A1A2P1Q1P1Q2P2Q2/S**2-
	+ &64A2A1A2P1Q1P2Q1P2Q2/S**2-
	+ &64A2A1A2P1Q2P2Q1P2Q2/S**2+
	+ &64A2A1A2P1Q1P2Q22/S*2-
	+ &64A2A1A2MBMTP1P2/S+
	+ &64A2A1A2P1P2*2/S+32A*2A1A2MB*2P1Q1/S+
	+ &32A2A1A2P1P2P1Q1/S+32A*2A1A2MB*2P1Q2/S+
	+ &32A2A1A2P1P2P1Q2/S-32A*2A1A2MT*2P2Q1/S
	+ YY(1, 2)=YY(1, 2)-32A2A1A2P1P2*P2Q1/S-
	+ &64A2A1A2P1Q1*P2Q1/S-
	+ &32A2A1A2MT*2P2Q2/S-32A2A1A2P1P2*P2Q2/S-
	+ &64A2A1A2P1Q2P2Q2/S+32A1A2MBMTV**2-
	+ &128A1A2MBMTP1Q2P2Q1V2/S*2 -
	+ &128A1A2P1P2P1Q2P2Q1V2/S2+
	+ &64A1A2P1Q1P1Q2P2Q1V2/S2-
	+ &64A1A2P1Q22P2Q1V2/S*2+
	+ &64A1A2P1Q2P2Q1*2V2/S2-
	+ &128A1A2MBMTP1Q1P2Q2V2/S*2-
	+ &128A1A2P1P2P1Q1P2Q2V2/S2-
	+ &64A1A2P1Q12P2Q2V2/S*2+
	+ &64A1A2P1Q1P1Q2P2Q2V2/S2-
	+ &64A1A2P1Q1P2Q1P2Q2V2/S2-
	+ &64A1A2P1Q2P2Q1P2Q2V2/S2+
	+ &64A1A2P1Q1P2Q2*2V2/S2+
	+ &64A1A2MBMTP1P2V*2/S+64A1A2P1P2*2V**2/S
	+ YY(1, 2)=YY(1, 2)+32A1A2MB2P1Q1V*2/S+
	+ &32A1A2P1P2P1Q1V*2/S+
	+ &32A1A2MB2P1Q2V2/S+32A1A2P1P2P1Q2V**2/S-
	+ &32A1A2MT2P2Q1V2/S-32A1A2P1P2P2Q1V**2/S-
	+ &64A1A2P1Q1P2Q1V2/S-32A1A2MT*2P2Q2V*2/S-
	+ &32A1A2P1P2P2Q2V2/S-64A1A2P1Q2P2Q2V**2/S
	+
	+
	+ YY(2, 2) =-16A2A12MBMT+
	+ &128A2A12MBMTP1Q1P1Q2/S**2-
	+ &128A2A12P1P2P1Q1P1Q2/S*2+
	+ &64A2A12P1Q1P1Q2P2Q1/S*2-
	+ &64A2A12P1Q22P2Q1/S*2-64A*2A12P1Q12P2Q2/S**2+
	+ &64A2A12P1Q1P1Q2P2Q2/S2-32A*2A12MBMT**3/S+
	+ &32A2A12MT2P1P2/S+32A2A12P1P2P1Q1/S+
	+ &32A2A12P1P2P1Q2/S-32A2A12MT2P2Q1/S-
	+ &32A2A12P1Q1P2Q1/S-32A2A12MT2P2Q2/S-
	+ &32A2A12P1Q2P2Q2/S+16A12MBMTV**2-
	+ &128A12MBMTP1Q1P1Q2V2/S2-
	+ &128A12P1P2P1Q1P1Q2V2/S*2+
	+ &64A12P1Q1P1Q2P2Q1V2/S*2-
	+ &64A12P1Q2*2P2Q1V2/S2-64A12P1Q12P2Q2V2/S*2+
	+ &64A12P1Q1P1Q2P2Q2V2/S2+32A12MBMT*3V**2/S+
	+ &32A12MT*2P1P2V2/S+32A12P1P2P1Q1V*2/S+
	+ &32A12P1P2P1Q2V*2/S-32A12MT2P2Q1V*2/S
	+ YY(2, 2)=YY(2, 2)-32A12P1Q1P2Q1V**2/S-
	+ &32A12MT*2P2Q2V*2/S-
	+ &32A12P1Q2P2Q2V**2/S
	+ YY(2, 2)=2*YY(2, 2)
	+
	+ RES=YY(1,1)+2*YY(1,2)+YY(2,2)
	+ AMP2= FACTPSVTB*2RES
	+
	+ 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-(2D0XMW2+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+(4D0XMW2-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)2ABS(COS(2D0BETA))
	+ 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=RDY-4D0/33D0(1D0-R)DX+(1D0-R)/33D0DS
	+ 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+2D0DX/3D0+2D0DS/3D0
	+ DHD2=-DY/2D0-2D0*DX/3D0+DS
	+ DMU2=(-DY/2D0-2D0/3D0DX+(COSB2-2D0SINB*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)=SGNMUSQRT(RMSS(4)*2+DMU2)
	+ ARG=RMSS(10)*2SIGN(1D0,RMSS(10))+DQ2
	+ RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
	+ ARG=RMSS(11)*2SIGN(1D0,RMSS(11))+DD2
	+ RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
	+ ARG=RMSS(12)*2SIGN(1D0,RMSS(12))+DU2
	+ RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
	+ ARG=RMSS(13)*2SIGN(1D0,RMSS(13))+DL2
	+ RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
	+ ARG=RMSS(14)*2SIGN(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=COSB2-SINB2
	+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(2D0AL)COS(BE+AL)-2D0SIN(2D0AL)*SIN(BE+AL)
	+ ELSE
	+ HHH(3)=HHH(3)+HHH(4)+HHH(5)
	+ PARU(176)=-3D0/HHH(1)(HHH(1)SINA*2COSB*COSA+
	+ 1 HHH(2)COSA2SINBSINA+HHH(3)(SINA*3SINB+COSA*3COSB-
	+ 2 2D0/3D0CBMA)-HHH(6)SINA(COSBC2A+COSA*CAPB)+
	+ 3 HHH(7)COSA(SINBC2A+SINACAPB))
	+ ENDIF
	+C...Coupling to H+
	+C...Define later
	+ IF(IMSS(4).GE.2) THEN
	+ PARU(168)=-SBMA-COS(2D0BE)SAPB/2D0/(1D0-XW)
	+ ELSE
	+ PARU(168)=1D0/HHH(1)(HHH(1)SINB*2COSB*SINA-
	+ 1 HHH(2)COSB2SINBCOSA-HHH(3)(SINB*3COSA-COSB*3SINA)+
	+ 2 2D0HHH(5)SBMA-HHH(6)SINB(COSBSAPB+SINAC2B)-
	+ 3 HHH(7)COSB(COSAC2B-SINBSAPB)-(HHH(5)-HHH(4))*SBMA)
	+ ENDIF
	+C...Coupling to A
	+ IF(IMSS(4).GE.2) THEN
	+ PARU(177)=COS(2D0BE)COS(BE+AL)
	+ ELSE
	+ PARU(177)=-1D0/HHH(1)(HHH(1)SINB*2COSB*COSA+
	+ 1 HHH(2)COSB2SINBSINA+HHH(3)(SINB*3SINA+COSB*3COSA)-
	+ 2 2D0HHH(5)CBMA-HHH(6)SINB(COSBCAPB+COSAC2B)+
	+ 3 HHH(7)COSB(SINBCAPB+SINAC2B))
	+ 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+2IRI,1)PMAS(9+2IRJ,1)
	+ & PMAS(9+2IRK,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+2IRI,1)0.5D0(PMAS(2IRJ,1)+
	+ & PMAS(2IRJ-1,1))PMAS(2IRK-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(2IRI,1)PMAS(2IRJ-1,1)*
	+ & PMAS(2IRK-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 CPRO12,CVER12,CHNLIN*6
	+ CHARACTER DOC11, CHDUM120, CHBLCK*60
	+ CHARACTER CHINL120,CHKF9,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
	+C DATA NQNUM /0/ C Change by WHIZARD due to nagfor error
	+ 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
	+C... Also store gravitino mass in RMSS(21), translated to eV unit
	+ IF (KF.EQ.1000039) RMSS(21) = 1D9 * 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
	+C MDME(NDC,1)=1
	+ IF(MDME(NDC,1).LT.0.AND.MDME(NDC,1).GE.-5) THEN
	+ MDME(NDC,1)=-MDME(NDC,1)
	+ ELSE
	+ MDME(NDC,1)=1
	+ ENDIF
	+
	+C...Switch off decay channels with < 0 branching fraction
	+ IF (BRAT(NDC).LE.0D0) THEN
	+ MDME(NDC,1)=0
	+C...Else check if decays to gravitinos should be switched on
	+ ELSE
	+ DO 345 IDA=1,NDA
	+ IF (IDC(IDA).EQ.1000039) THEN
	+C... Inform user
	+ IF (IMSS(11).LE.0) WRITE(MSTU(11),*)
	+ & '* (PYSLHA:) Switching on decays to gravitinos'
	+ IMSS(11) = 2
	+ ENDIF
	+ 345 CONTINUE
	+ ENDIF
	+
	+C...Store decay products ordered in decreasing ABS(KF)
	+ 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=XMZ2COS(2D0BETA)
	+ XMER=SQRT(XM02+0.15D0XMG2-XWDTERM)
	+ XMEL=SQRT(XM02+0.52D0XMG2-(0.5D0-XW)DTERM)
	+ RMSS(6)=XMEL
	+ RMSS(7)=XMER
	+ XMUR=SQRT(PYRNMQ(2,2D0/3D0XWDTERM))
	+ XMDR=SQRT(PYRNMQ(3,-1D0/3D0XWDTERM))
	+ XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0XW)DTERM))
	+ XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0XW)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-XMW2ABS(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(.9D0XM02+2.1D0XMG2+
	+ &(1D0-(RMT/190D0/SINB)*3)(.24D0AT2+ATXMG))
	+ RMB=PYMRUN(5,PMAS(6,1)**2)
	+ XBOT=(RMB/150D0/COSB)*2(.9D0XM02+2.1D0XMG2+
	+ &(1D0-(RMB/190D0/COSB)*3)(.24D0AT2+ATXMG))
	+ XTAU=1D-4/COSB*2(XM02+0.15D0XMG2+AT*2/3D0)
	+ ATP=AT(1D0-(RMT/190D0/SINB)2)+XMG(3.47D0-1.9D0*(RMT/190D0/
	+ &SINB)**2)
	+ RMSS(16)=-ATP
	+ XMU2=-.5D0XMZ2+(SINB2(XM02+.52D0*XMG2-XTOP)-
	+ &COSB*2(XM02+.52D0XMG2-XBOT-XTAU/3D0))/(COSB2-SINB*2)
	+ XMA2=2D0(XM02+.52D0XMG2+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.15D0XMG2-2D0XTAU/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.52D0XMG2-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=M0MHFXCMGV/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.5D0BX)
	+ CX=MAX(2000D0*2,2D0BX)
	+
	+ 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=RX1+CX3
	+ 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=RX2+CX0
	+ 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=CTT2XM12+STT2XM22
	+ XMQR2=STT2XM12+CTT2XM22
	+ XMF2=PYMRUN(6,PMAS(6,1)2)2
	+ ATOP=-XMU/TANB+CTTSTT(XM12-XM22)/SQRT(XMF2)
	+ RMSS(16)=ATOP
	+C......SUBTRACT OUT D-TERM AND FERMION MASS
	+ XMQL2=XMQL2-XMF2-(4D0XMW2-XMZ2)COS2B/6D0
	+ XMQR2=XMQR2-XMF2+(XMW2-XMZ2)COS2B2D0/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))-(2D0XMW2+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=STT2XM12+CTT2XM22
	+ ABOT=-XMUTANB+CTTSTT*(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=CTT2XM12+STT2XM22
	+ XMQR2=STT2XM12+CTT2XM22
	+ XMFR=PMAS(15,1)
	+ XMF2=XMFR**2
	+ ATAU=-XMUTANB+CTTSTT*(XM12-XM22)/SQRT(XMF2)
	+ RMSS(17)=ATAU
	+C......SUBTRACT OUT D-TERM AND FERMION MASS
	+ XMQL2=XMQL2-XMF2+(-.5D0XMZ2+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)-(2D0XMW2+XMZ2)COS2B/6D0
	+ AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
	+ AM2(1,2)=XMF(ATR+XMUTANB)
	+ ELSEIF(L.EQ.2) THEN
	+ AM2(1,1)=AM2(1,1)+(4D0XMW2-XMZ2)COS2B/6D0
	+ AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)COS2B2D0/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)-(-.5D0XMZ2+XMW2)COS2B
	+ AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
	+ AM2(1,2)=XMF(ATR+XMUTANB)
	+ 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.5D0SQRT((AM2(1,1)-AM2(2,2))2+4D0AM2(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)A15D0/3D0
	+ IF(IOPT.EQ.1) THEN
	+ XM2=XM1A2/A13D0/5D0
	+ RMSS(2)=XM2
	+ ELSEIF(IOPT.EQ.3) THEN
	+ XM1=XM25D0/3D0A1/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(ILRKSUSY1+I),1)2/XM3*2
	+ AQ=AQ+0.5D0((2D0-RM1)(RM1*LOG(RM1)-1D0)
	+ & +(1D0-RM1)*2LOG(ABS(1D0-RM1)))
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+ DO 130 I=5,6
	+ DO 120 ILR=1,2
	+ RM1=PMAS(PYCOMP(ILRKSUSY1+I),1)2/XM3*2
	+ RM2=PMAS(I,1)2/XM32
	+ ARG=(RM1-RM2-1D0)*2-4D0RM2**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.5D0LOG(ABS(1D0-X0))(1D0-X0**2)+
	+ & 0.5D0X02LOG(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.5D0LOG(ABS(1D0-X1))(1D0-X1*2)+0.5D0
	+ & X1*2LOG(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(X02+Y02)
	+ AM1X0=SQRT((1D0-X0)2+Y02)
	+ 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.5D0LOG(AM1X0)(1D0-X0*2+3D0Y0**2)
	+ & +0.5D0(X02-Y02)LOG(AMGX0)
	+ BT=(-1D0-2D0X0)/4D0+X0Y0*( AR1X0-ARGX0 )
	+ AT=AT+0.5D0LOG(AM1X1)(1D0-X1*2+3D0Y1**2)
	+ & +0.5D0(X12-Y12)LOG(AMGX1)
	+ BT=BT+(-1D0-2D0X1)/4D0+X1Y1*( AR1X1-ARGX1 )
	+ AQ=AQ+AT+BT
	+ ENDIF
	+ 120 CONTINUE
	+ 130 CONTINUE
	+ PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)(1D0+PYALPS(XM3*2)
	+ & /(2D0PARU(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) = -XMZSINWCOSB
	+ AR(3,1) = AR(1,3)
	+ AR(1,4) = XMZSINWSINB
	+ AR(4,1) = AR(1,4)
	+ AR(2,3) = XMZCOSWCOSB
	+ AR(3,2) = AR(2,3)
	+ AR(2,4) = -XMZCOSWSINB
	+ 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+2D0XMW*2SINB**2
	+ AR(2,2) = XMU*2+2D0XMW*2COSB**2
	+ AR(1,2) = SQRT(2D0)XMW(XM2COS(RMSS(31))COSB+
	+ &XMUCOS(RMSS(33))SINB)
	+ AI(1,2) = SQRT(2D0)XMW(XM2SIN(RMSS(31))COSB-
	+ &XMUSIN(RMSS(33))SINB)
	+ AR(2,1) = SQRT(2D0)XMW(XM2COS(RMSS(31))COSB+
	+ &XMUCOS(RMSS(33))SINB)
	+ AI(2,1) = SQRT(2D0)XMW(-XM2SIN(RMSS(31))COSB+
	+ &XMUSIN(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+2D0XMW*2COSB**2
	+ AR(2,2) = XMU*2+2D0XMW*2SINB**2
	+ AR(1,2) = SQRT(2D0)XMW(XM2COS(RMSS(31))SINB+
	+ &XMUCOS(RMSS(33))COSB)
	+ AI(1,2) = SQRT(2D0)XMW(-XM2SIN(RMSS(31))SINB+
	+ &XMUSIN(RMSS(33))COSB)
	+ AR(2,1) = SQRT(2D0)XMW(XM2COS(RMSS(31))SINB+
	+ &XMUCOS(RMSS(33))COSB)
	+ AI(2,1) = SQRT(2D0)XMW(XM2SIN(RMSS(31))SINB-
	+ &XMUSIN(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)XMWSINB
	+ AR(2,1) = SQRT(2D0)XMWCOSB
	+ 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)XMWSINB*CMPLX(1D0,0D0)
	+ CAR(2,1) = SQRT(2D0)XMWCOSB*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)=TEMPRDBLE(CA1)-TEMPIDIMAG(CA1)
	+ VMIXI(1,1)=TEMPIDBLE(CA1)+TEMPRDIMAG(CA1)
	+ TEMPR=VMIX(1,2)
	+ TEMPI=VMIXI(1,2)
	+ VMIX(1,2)=TEMPRDBLE(CA1)-TEMPIDIMAG(CA1)
	+ VMIXI(1,2)=TEMPIDBLE(CA1)+TEMPRDIMAG(CA1)
	+ TEMPR=VMIX(2,1)
	+ TEMPI=VMIXI(2,1)
	+ VMIX(2,1)=TEMPRDBLE(CA2)-TEMPIDIMAG(CA2)
	+ VMIXI(2,1)=TEMPIDBLE(CA2)+TEMPRDIMAG(CA2)
	+ TEMPR=VMIX(2,2)
	+ TEMPI=VMIXI(2,2)
	+ VMIX(2,2)=TEMPRDBLE(CA2)-TEMPIDIMAG(CA2)
	+ VMIXI(2,2)=TEMPIDBLE(CA2)+TEMPRDIMAG(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(DIMAG(CA1)).GT.1D-3.OR.ABS(DIMAG(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=RGUTPYALPS(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=RX1+CX3
	+ F1=F2
	+ AS2=PYALPS(X2**2)
	+ F2=ABS(X2-RGUT*AS2)
	+ ELSE
	+ X3=X2
	+ X2=X1
	+ X1=RX2+CX0
	+ 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=B1B3-4D0B0
	+ C0=-B1*2-B0B3*2+4D0B0*B2
	+ CQ=C1/3D0-C2**2/9D0
	+ CR=C1C2/6D0-C0/2D0-C2*3/27D0
	+ CQR=CQ3+CR2
	+
	+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(P1Q1+P2Q2-B1).LT.ABS(P1Q2+P2Q1-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...(STOP12 - STOP22)/(STOP22 + STOP12) < 0.5
	+C...(SBOT12 - SBOT22)/(SBOT22 + SBOT22) < 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_SUSY2 = (STOP12 + STOP2**2)/2. The sbottom
	+C...masses have been assumed to be of order of the stop ones
	+C...M_SUSY2 = (MQ2 + 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/PIALPH3Z
	+ &LOG(XMTOP2/XMZ2))
	+
	+C...RMTOP= RUNNING TOP QUARK MASS
	+ RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
	+ XMS = ((XMQ2 + XMUR2)/2D0 + XMTOP2)0.5D0
	+ T = LOG(XMS2/XMTOP2)
	+ SINB = TANB/((1D0 + TANB2)0.5D0)
	+ COSB = SINB/TANB
	+C...IF(MA.LE.XMTOP) TANBA = TANBT
	+ IF(XMA.GT.XMTOP)
	+ &TANBA = TANBT(1D0-3D0/32D0/PI2
	+ &(RMTOP2/V2/SINB2-XMB2/V2/COSB2)*
	+ &LOG(XMA2/XMTOP2))
	+
	+ SINBT = TANBT/SQRT(1D0 + TANBT**2)
	+ COSBT = 1D0/SQRT(1D0 + TANBT**2)
	+C COS2BT = (TANBT2 - 1D0)/(TANBT2 + 1D0)
	+ G1 = SQRT(ALP14D0PI)
	+ G2 = SQRT(ALP24D0PI)
	+ G3 = SQRT(ALP34D0PI)
	+ 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 = (2D0AU2/XMS2)(1D0 - AU2/12D0/XMS2)
	+ XAD = (2D0AD2/XMS2)(1D0 - AD2/12D0/XMS2)
	+ AUD = (-6D0XMU2/XMS2 - ( XMU2- ADAU)**2/XMS4
	+ &+ 3D0(AU + AD)*2/XMS2)/6D0
	+ XLAM1 = ((G12 + G22)/4D0)(1D0-3D0HD2*T/8D0/PI2)
	+ &+(3D0HD4/8D0/PI2) (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
	+ &- 8D0G32) (XADT + T*2)/16D0/PI2)
	+ &-(3D0HU4 XMU*4/96D0/PI2/XMS4) (1+ (9D0HU2 -5D0 HD2
	+ &- 16D0G32) T/16D0/PI2)
	+ XLAM2 = ((G12 + G22)/4D0)(1D0-3D0HU2*T/8D0/PI2)
	+ &+(3D0HU4/8D0/PI2) (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
	+ &- 8D0G32) (XAUT + T*2)/16D0/PI2)
	+ &-(3D0HD4 XMU*4/96D0/PI2/XMS4) (1+ (9D0HD2 -5D0 HU2
	+ &- 16D0G32) T/16D0/PI2)
	+ XLAM3 = ((G22 - G12)/4D0)(1D0-3D0
	+ &(HU2 + HD2)*T/16D0/PI2)
	+ &+(6D0HU2HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
	+ &- 8D0G32) (AUDT + T*2)/16D0/PI2)
	+ &+(3D0HU4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AU2/
	+ &XMS4)* (1D0+ (6D0HU2 -2D0 HD2/2D0
	+ &- 16D0G32) T/16D0/PI2)
	+ &+(3D0HD4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AD2/
	+ &XMS4)(1D0+ (6D0HD2 -2D0* HU2
	+ &- 16D0G32) T/16D0/PI2)
	+ XLAM4 = (- G2*2/2D0)(1D0-3D0(HU2 + HD2)T/16D0/PI2)
	+ &-(6D0HU2HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
	+ &- 8D0G32) (AUDT + T*2)/16D0/PI2)
	+ &+(3D0HU4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AU2/
	+ &XMS4)*
	+ &(1+ (6D0HU2 -2D0 HD2
	+ &- 16D0G32) T/16D0/PI2)
	+ &+(3D0HD4/96D0/PI2) (3D0XMU2/XMS2 - XMU2AD2/
	+ &XMS4)*
	+ &(1+ (6D0HD2 -2D0 HU2/2D0
	+ &- 16D0G32) T/16D0/PI2)
	+ XLAM5 = -(3D0HU4 XMU2AU2/96D0/PI2/XMS4)
	+ &(1- (2D0HD2 -6D0 HU2 + 16D0G32) T/16D0/PI2)
	+ &-(3D0HD4 XMU2AD2/96D0/PI2/XMS4)
	+ &(1- (2D0HU2 -6D0 HD2 + 16D0G32) T/16D0/PI2)
	+ XLAM6 = (3D0HU4 XMU*3AU/96D0/PI2/XMS4) *
	+ &(1- (7D0HD2/2D0 -15D0 HU2/2D0 + 16D0G32) T/16D0/PI2)
	+ &+(3D0HD4 XMU (AD3/XMS3 - 6D0AD/XMS )/96D0/PI2/XMS) *
	+ &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0G32) T/16D0/PI2)
	+ XLAM7 = (3D0HD4 XMU*3AD/96D0/PI2/XMS4) *
	+ &(1- (7D0HU2/2D0 -15D0 HD2/2D0 + 16D0G32) T/16D0/PI2)
	+ &+(3D0HU4 XMU (AU3/XMS3 - 6D0AU/XMS )/96D0/PI2/XMS) *
	+ &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0G32) 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 + 2D0V*2 (XLAM1* COSBT**2 +
	+ &2D0* XLAM6SINBTCOSBT
	+ &+ XLAM5SINBT2 + XLAM2 SINBT*2 + 2D0 XLAM7SINBTCOSBT
	+ &+ XLAM5COSBT*2)
	+ DETM2 = 4D0V4(-(SINBTCOSBT(XLAM3 + XLAM4) +
	+ &XLAM6COSBT*2
	+ &+ XLAM7* SINBT2)2 + (XLAM1* COSBT**2 +
	+ &2D0* XLAM6* COSBT*SINBT
	+ &+ XLAM5SINBT2)(XLAM2* SINBT*2 +2D0 XLAM7* COSBT*SINBT
	+ &+ XLAM5COSBT2)) + XMA22D0V2
	+ &((XLAM1* COSBT*2 +2D0
	+ &XLAM6* COSBTSINBT + XLAM5SINBT*2)COSBT**2 +
	+ &(XLAM2* SINBT*2 +2D0 XLAM7* COSBTSINBT + XLAM5COSBT**2)
	+ &SINBT*2
	+ &+2D0SINBTCOSBT* (SINBTCOSBT(XLAM3
	+ &+ XLAM4) + XLAM6COSBT*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) -
	+ &((2D0V2(XLAM1* COSBT*2 + 2D0
	+ &XLAM6* COSBT*SINBT
	+ &+ XLAM5SINBT2) + XMA2SINBT**2)
	+ &- (2D0V2(XLAM2* SINBT*2 +2D0 XLAM7* COSBT*SINBT
	+ &+ XLAM5COSBT2) + XMA2COSBT**2)))/
	+ &SQRT(((TRM2*2 - 4D0 DETM2)0.5D0))/2D00.5D0
	+
	+ COSALP = (2D0(2D0V*2(SINBTCOSBT(XLAM3 + XLAM4) +
	+ &XLAM6COSBT2 + XLAM7 SINBT**2) -
	+ &XMA*2SINBTCOSBT))/2D0*0.5D0/
	+ &SQRT(((TRM2*2 - 4D0 DETM2)*0.5D0)
	+ &(((TRM2*2 - 4D0 DETM2)**0.5D0) -
	+ &((2D0V2(XLAM1* COSBT*2 + 2D0
	+ &XLAM6* COSBT*SINBT
	+ &+ XLAM5SINBT2) + XMA2SINBT**2)
	+ &- (2D0V2(XLAM2* SINBT*2 +2D0 XLAM7* COSBT*SINBT
	+ &+ XLAM5COSBT2) + XMA2COSBT**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/(TANB2+1D0)0.5D0
	+ COSB = 1D0/(TANB2+1D0)0.5D0
	+ COS2B = SINB2 - COSB2
	+ SINBPA = SINBCA + COSBSA
	+ COSBPA = COSBCA - SINBSA
	+ 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.35D0XMZ*2COS2B
	+ XMST22 = RXMT*2 + XMUR2 - 0.15D0XMZ*2COS2B
	+ IF(XMST11.LT.0D0) GOTO 500
	+ IF(XMST22.LT.0D0) GOTO 500
	+ XMSB11 = RMBOT*2 + XMQ2 + 0.42D0XMZ*2COS2B
	+ XMSB22 = RMBOT*2 + XMDR2 + 0.08D0XMZ*2COS2B
	+ 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 - XMUTANB)
	+
	+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	+C...STOP EIGENVALUES CALCULATION
	+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	+
	+ STOP12 = 0.5D0*(XMST11+XMST22) +
	+ &0.5D0((XMST11+XMST22)*2 -
	+ &4D0(XMST11XMST22 - XMST122))0.5D0
	+ STOP22 = 0.5D0*(XMST11+XMST22) -
	+ &0.5D0((XMST11+XMST22)2 - 4D0(XMST11*XMST22 -
	+ &XMST122))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/(XMST122+(XMST11-STOP12)2)**0.5D0
	+ XST12 = - (XMST11-STOP12)/(XMST122+(XMST11-STOP12)2)**0.5D0
	+ XST21 = XMST12/(XMST122+(XMST11-STOP22)2)**0.5D0
	+ XST22 = - (XMST11-STOP22)/(XMST122+(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(XMSB11XMSB22 - XMSB122))0.5D0
	+ SBOT22 = 0.5D0*(XMSB11+XMSB22) -
	+ &0.5D0((XMSB11+XMSB22)2 - 4D0(XMSB11*XMSB22 -
	+ &XMSB122))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/(XMSB122+(XMSB11-SBOT12)2)**0.5D0
	+ XSB12 = - (XMSB11-SBOT12)/(XMSB122+(XMSB11-SBOT12)2)**0.5D0
	+ XSB21 = XMSB12/(XMSB122+(XMSB11-SBOT22)2)**0.5D0
	+ XSB22 = - (XMSB11-SBOT22)/(XMSB122+(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) =
	+ & SINTXMZ22D0SQR/174.1D0/3D0SINBPA*(DELTA(I,J) +
	+ & (3D0 - 8D0SINT)/4D0/SINTT(1,I)*T(1,J))
	+ & -RXMT2/174.1D02VP/SINBCA*DELTA(I,J)
	+ & -RXMT/VP/SINB(ATCA + XMUSA)(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) =
	+ & -SINTXMZ22D0SQR/174.1D0/6D0SINBPA*(DELTA(I,J) +
	+ & (3D0 - 4D0SINT)/2D0/SINTB(1,I)*B(1,J))
	+ & +RMBOT2/174.1D02VP/COSBSA*DELTA(I,J)
	+ & +RMBOT/VP/COSB(ABSA + XMUCA)(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)*23D0*
	+ & 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)*23D0*
	+ & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
	+ 210 CONTINUE
	+ 220 CONTINUE
	+C RXMT2 = RXMT**2
	+ XMT2=XMT**2
	+
	+ POLTT =
	+ & 3D0RXMT2/8D0/PI2/ V 2
	+ & CA2/SINB2 *
	+ & (-2D0XMT2+0.5D0P2)*
	+ & 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) =
	+ & -SINTXMZ22D0SQR/174.1D0/3D0COSBPA*(DELTA(I,J) +
	+ & (3D0 - 8D0SINT)/4D0/SINTT(1,I)*T(1,J))
	+ & -RXMT2/174.1D02VP/SINBSA*DELTA(I,J)
	+ & -RXMT/VP/SINB(ATSA - XMUCA)(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) =
	+ & SINTXMZ22D0SQR/174.1D0/6D0COSBPA*(DELTA(I,J) +
	+ & (3D0 - 4D0SINT)/2D0/SINTB(1,I)*B(1,J))
	+ & -RMBOT2/174.1D02VP/COSBCA*DELTA(I,J)
	+ & -RMBOT/VP/COSB(ABCA - XMUSA)(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)*23D0*
	+ & 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)*23D0*
	+ & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
	+ 330 CONTINUE
	+ 340 CONTINUE
	+
	+C RXMT2 = RXMT**2
	+ XMT2 = XMT**2
	+
	+ HPOLTT =
	+ & 3D0RXMT2/8D0/PI2/ V 2
	+ & SA2/SINB2 *
	+ & (-2D0XMT2+0.5D0HP2)*
	+ & 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(ATCOSB + XMUSINB)
	+ & (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(ABSINB + XMUCOSB)
	+ & (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)*23D0*
	+ & 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)*23D0*
	+ & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
	+ 450 CONTINUE
	+ 460 CONTINUE
	+C RXMT2 = RXMT**2
	+ XMT2=XMT**2
	+ APOLTT =
	+ & 3D0RXMT2/8D0/PI2/ V 2
	+ & COSB2/SINB2 *
	+ & (-0.5D0AP2)
	+ & 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/PIALPHA3Z
	+ LOG(MTOP2/MZ*2))
	+C RMTOP= RUNNING TOP QUARK MASS
	+ RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
	+ TQ = LOG((MQ2+MTOP2)/MTOP**2)
	+ TU = LOG((MUR2 + MTOP2)/MTOP**2)
	+ TD = LOG((MD2 + MTOP2)/MTOP**2)
	+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	+C
	+C NEW DEFINITION, TGLU.
	+C
	+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	+ TGLU = LOG(MGLU2/MTOP2)
	+ SINB = TANB/DSQRT(1D0 + TANB**2)
	+ COSB = SINB/TANB
	+ IF(MA.GT.MTOP)
	+ TANBA = TANB(1D0-3D0/32D0/PI*2
	+ (RMTOP2/V2/SINB2-MB2/V2/COSB2)
	+ LOG(MA2/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(ALPHA14D0PI)
	+ G2 = SQRT(ALPHA24D0PI)
	+ G3 = SQRT(ALPHA34D0PI)
	+ 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*2G1*2HD*2TPD
	+ IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI*2
	+ * HD*2(G12/3D0+G22)*TPD
	+
	+ IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI*2G1*2HU*2TP
	+ IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI*2
	+ * HU*2(-G12/3D0+G22)*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/(16D0PI2)2HU*4(TQ2-TGLU2)
	+ ENDIF
	+
	+ IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
	+ DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TQ2-TU2)
	+ ENDIF
	+
	+ IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
	+ DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TQ2-TU2)
	+ ENDIF
	+
	+ IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
	+ DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TU2-TGLU2)
	+ ENDIF
	+
	+ IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
	+ DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TU2-TQ2)
	+ ENDIF
	+
	+ IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
	+ DLAMBDAP2 = -4D0/(16D0PI2)2HU*4(TU2-TQ2)
	+ ENDIF
	+ ENDIF
	+ DLAMBDA3 = 0D0
	+ DLAMBDA4 = 0D0
	+ IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI*2G1*2HD*2TPD
	+ IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI*2HD*2
	+ (G22-G12/3D0)TPD
	+ IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
	+ 1D0/16D0/PI2G1*2HU*2TP
	+ IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
	+ * 3D0/64D0/PI*2HU*2(G22+G12/3D0)*TP
	+ IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI*2G2*2HU*2TP
	+ IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI*2G2*2
	+ HD2TPD
	+ LAMBDA1 = ((G12 + G22)/4D0)*
	+ * (1D0-3D0HD2(TPD + TDPD)/8D0/PI**2)
	+ +(3D0HD4D0/16D0/PI2) TPD(1D0
	+ + (3D0HD2/2D0 + HU2/2D0
	+ - 8D0G3*2) (TPD + 2D0TDPD)/16D0/PI*2)
	+ +(3D0HD4D0/8D0/PI2) TDPD(1D0 + (3D0HD2/2D0 + HU*2/2D0
	+ - 8D0G3*2) TDPD/16D0/PI**2) + DLAMBDA1
	+ LAMBDA2 = ((G12 + G22)/4D0)(1D0-3D0HU*2
	+ (TP + TDP)/8D0/PI*2)
	+ +(3D0HU4D0/16D0/PI2) TP(1D0
	+ + (3D0HU2/2D0 + HD2/2D0
	+ - 8D0G3*2) (TP + 2D0TDP)/16D0/PI*2)
	+ +(3D0HU4D0/8D0/PI2) TDP(1D0 + (3D0HU2/2D0 + HD*2/2D0
	+ - 8D0G3*2) TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
	+ LAMBDA3 = ((G22 - G12)/4D0)(1D0-3D0
	+ (HU2)(TP + TDP)/16D0/PI*2 -3D0
	+ (HD2)(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) = 2D0V2(LAMBDA1COSB2+2D0LAMBDA6*
	+ COSBSINB + LAMBDA5SINB2) + MA2SINB**2
	+
	+ M2(2,2) = 2D0V2(LAMBDA5COSB2+2D0LAMBDA7*
	+ COSBSINB + LAMBDA2SINB2) + MA2COSB**2
	+ M2(1,2) = 2D0V2(LAMBDA6COSB2+(LAMBDA3+LAMBDA4)
	+ COSBSINB + LAMBDA7SINB2) - MA2SINB*COSB
	+
	+ M2(2,1) = M2(1,2)
	+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	+CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
	+CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	+
	+ MSSUSY=DSQRT(.5D0(MQ2+MUR2)+MTOP*2)
	+
	+ IF(MCHI.GT.MSSUSY) GOTO 100
	+ IF(MCHI.LT.MTOP) MCHI=MTOP
	+
	+ TCHAR=LOG(MSSUSY2/MCHI2)
	+
	+ DELTAL12=(9D0/64D0/PI*2G24+5D0/192D0/PI2G14)TCHAR
	+ DELTAL3P4=(3D0/64D0/PI*2G24+7D0/192D0/PI2G1*4
	+ +4D0/32D0/PI2G1*2G2*2)TCHAR
	+
	+ DELTAM112=2D0DELTAL12V*2COSB**2
	+ DELTAM222=2D0DELTAL12V*2SINB**2
	+ DELTAM122=2D0DELTAL3P4V*2SINB*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 = 2D0M2P(1,2)/SQRT(TRM2P2-4D0DETM2P)
	+ COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P*2-4D0DETM2P)
	+ 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*2Y*2LOG(X2/Y2) + X*2Z*2LOG(Z2/X2)
	+ * + Y*2Z*2LOG(Y2/Z2))/((X2-Y2)(Y2-Z2)(X2-Z2))
	+
	+ 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-MW2/MZ2
	+ V = 174.1D0
	+
	+ ALPHA3 = 0.12D0/(1D0+23/12D0/PI0.12D0LOG(MTOP2/MZ2))
	+ G2 = DSQRT(0.0336D04D0PI)
	+ G1 = DSQRT(0.0101D04D0PI)
	+
	+ IF(MQ.GT.MUR) MST = MQ
	+ IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
	+
	+ MSUSYT = DSQRT(MST2 + MTOP2)
	+
	+ IF(MQ.GT.MD) MSB = MQ
	+ IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
	+
	+ MB = PYMRUN(5,MSB**2)
	+ MSUSYB = DSQRT(MSB2 + MB2)
	+ TT = LOG(MSUSYT2/MTOP2)
	+ TB = LOG(MSUSYB2/MTOP2)
	+
	+ RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
	+ HT = RMTOP/(V*SINB)
	+ HTST = RMTOP/V
	+ HB = MB/V/COSB
	+ G32 = ALPHA34D0PI
	+ BT2 = -(8D0G32 - 9D0HT2/2D0 - HB2/2D0)/(4D0PI)*2
	+ BB2 = -(8D0G32 - 9D0HB2/2D0 - HT2/2D0)/(4D0PI)*2
	+ AL2 = 3D0/8D0/PI*2HT**2
	+C BT2ST = -(8.G32 - 9.HTST*2/2.)/(4.PI)**2
	+C ALST = 3./8./PI*2HTST**2
	+ AL1 = 3D0/8D0/PI*2HB**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/PI2HTST*2
	+ * LOG(MTOP2/MA2))
	+ H1I = VI* COSBA
	+ H2I = VI*SINBA
	+ H1T = H1I(1D0+3D0/8D0/PI2HB*2LOG(MA2/MSUSYT2))**.25D0
	+ H2T = H2I(1D0+3D0/8D0/PI2HT*2LOG(MA2/MSUSYT2))**.25D0
	+ H1B = H1I(1D0+3D0/8D0/PI2HB*2LOG(MA2/MSUSYB2))**.25D0
	+ H2B = H2I(1D0+3D0/8D0/PI2HT*2LOG(MA2/MSUSYB2))**.25D0
	+ ELSE
	+ VI = V
	+ H1I = VI*COSB
	+ H2I = VI*SINB
	+ H1T=H1I(1D0+3D0/8D0/PI2HB*2LOG(MTOP2/MSUSYT2))**.25D0
	+ H2T=H2I(1D0+3D0/8D0/PI2HT*2LOG(MTOP2/MSUSYT2))**.25D0
	+ H1B=H1I(1D0+3D0/8D0/PI2HB*2LOG(MTOP2/MSUSYB2))**.25D0
	+ H2B=H2I(1D0+3D0/8D0/PI2HT*2LOG(MTOP2/MSUSYB2))**.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+2D0BT2TT- AL2TT - 4D0DELTAMT)
	+ MTOP2 = DSQRT(MTOP4)
	+ MBOT4 = MB*4(1D0+2D0BB2TB - AL1*TB)
	+ * /(1D0+DELTAMB)**4
	+ MBOT2 = DSQRT(MBOT4)
	+
	+ STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
	+ * +1D0/8D0(G22+G12)(H1T2-H2T2)
	+ * +SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	+ * MQ2 - MUR2)*20.25D0 + MTOP2(AT-XMU/TANBST)*2)
	+ STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
	+ * +1D0/8D0(G22+G12)(H1T2-H2T2)
	+ * - SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	+ * MQ2 - MUR2)*20.25D0
	+ * + MTOP2(AT-XMU/TANBST)*2)
	+ IF(STOP22.LT.0.) GOTO 120
	+ SBOT12 = (MQ2 + MD2)*.5D0
	+ * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	+ * + SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	+ * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**2)
	+ SBOT22 = (MQ2 + MD2)*.5D0
	+ * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	+ * - SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	+ * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**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 = -2ALPHA3/3D0/PIXMGL(AB-XMUTANB)*T1
	+ * + HT*2/(4D0PI)*2(AT-XMU/TANB)XMUTANB*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 = -2D0ALPHA3/3D0/PI(AT-XMU/TANB)XMGLT3
	+
	+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+2D0BT2TT- AL2TT - 4D0DELTAMT)
	+ MTOP2 = DSQRT(MTOP4)
	+ MBOT4 = MB*4(1D0+2D0BB2TB - AL1*TB)
	+ * /(1D0+DELTAMB)**4
	+ MBOT2 = DSQRT(MBOT4)
	+
	+ STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
	+ * +1D0/8D0(G22+G12)(H1T2-H2T2)
	+ * +SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	+ * MQ2 - MUR2)*20.25D0 + MTOP2(AT-XMU/TANBST)*2)
	+ STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
	+ * +1D0/8D0(G22+G12)(H1T2-H2T2)
	+ * - SQRT(((G2*2-5D0G1*2/3D0)/4D0(H1T2-H2T2) +
	+ * MQ2 - MUR2)*20.25D0
	+ * + MTOP2(AT-XMU/TANBST)*2)
	+
	+ IF(STOP22.LT.0.) GOTO 120
	+ SBOT12 = (MQ2 + MD2)*.5D0
	+ * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	+ * + SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	+ * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**2)
	+ SBOT22 = (MQ2 + MD2)*.5D0
	+ * - 1D0/8D0(G22+G12)(H1B2-H2B2)
	+ * - SQRT(((G12/3D0-G22)/4D0(H1B2-H2B*2) +
	+ * MQ2 - MD2)*20.25D0 + MBOT2(AB-XMUTANBSB)**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/3D0STW)*
	+ * LOG(STOP1/STOP2)
	+ * +(.5D0-2D0/3D0STW)LOG(STOP1*STOP2/(MQ2+MTOP2))
	+ * + 2D0/3D0STWLOG(STOP1*STOP2/(MUR2+MTOP2))
	+
	+ F1B=(MQ2-MD2)/(SBOT12-SBOT22)(-.5D0+2D0/3D0STW)*
	+ * LOG(SBOT1/SBOT2)
	+ * +(-.5D0+1D0/3D0STW)LOG(SBOT1*SBOT2/(MQ2+MBOT2))
	+ * - 1D0/3D0STWLOG(SBOT1*SBOT2/(MD2+MBOT2))
	+
	+ F2T=DSQRT(MTOP2)(AT-XMU/TANBST)/(STOP12-STOP22)
	+ * (-.5D0*LOG(STOP12/STOP22)
	+ * +(4D0/3D0STW-.5D0)(MQ2-MUR2)/(STOP12-STOP22)*
	+ * G(STOP12,STOP22))
	+
	+ F2B=DSQRT(MBOT2)(AB-XMUTANBSB)/(SBOT12-SBOT22)*
	+ * (.5D0*LOG(SBOT12/SBOT22)
	+ * +(-2D0/3D0STW+.5D0)(MQ2-MD2)/(SBOT12-SBOT22)*
	+ * G(SBOT12,SBOT22))
	+
	+ VH3B(1,1) = MBOT4/(COSBB*2)(LOG(SBOT1*2SBOT2**2/
	+ * (MQ2+MBOT2)/(MD2+MBOT2))
	+ * + 2D0(AB(AB-XMUTANBSB)/(SBOT12-SBOT22))
	+ * LOG(SBOT12/SBOT22)) +
	+ * MBOT4/(COSBB*2)(AB(AB-XMUTANBSB)/
	+ * (SBOT12-SBOT22))*2G(SBOT12,SBOT22)
	+
	+ VH3T(1,1) =
	+ * MTOP4/(SINBT*2)(XMU(-AT+XMU/TANBST)/(STOP1*2
	+ * -STOP22))2*G(STOP12,STOP22)
	+
	+ VH3B(1,1)=VH3B(1,1)+
	+ * MZ*2(2MBOT2F1B-DSQRT(MBOT2)ABF2B)
	+
	+ VH3T(1,1) = VH3T(1,1) +
	+ * MZ*2(DSQRT(MTOP2)XMU/TANBSTF2T)
	+
	+ VH3T(2,2) = MTOP4/(SINBT*2)(LOG(STOP1*2STOP2**2/
	+ * (MQ2+MTOP2)/(MUR2+MTOP2))
	+ * + 2D0(AT(AT-XMU/TANBST)/(STOP12-STOP22))*
	+ * LOG(STOP12/STOP22)) +
	+ * MTOP4/(SINBT*2)(AT*(AT-XMU/TANBST)/
	+ * (STOP12-STOP22))*2G(STOP12,STOP22)
	+
	+ VH3B(2,2) =
	+ * MBOT4/(COSBB*2)(XMU(-AB+XMUTANBSB)/(SBOT1**2
	+ * -SBOT22))2*G(SBOT12,SBOT22)
	+
	+ VH3T(2,2)=VH3T(2,2)+
	+ * MZ*2(-2MTOP2F1T+DSQRT(MTOP2)ATF2T)
	+ VH3B(2,2) = VH3B(2,2) -MZ*2DSQRT(MBOT2)XMUTANBSB*F2B
	+ VH3T(1,2) = -
	+ * MTOP4/(SINBT*2)XMU*(AT-XMU/TANBST)/
	+ * (STOP12-STOP22)(LOG(STOP12/STOP22) + AT
	+ * (AT - XMU/TANBST)/(STOP12-STOP22)*G(STOP12,STOP22))
	+
	+ VH3B(1,2) =
	+ * - MBOT4/(COSBB*2)XMU(AB-XMUTANBSB)/
	+ * (SBOT12-SBOT22)(LOG(SBOT12/SBOT22) + AB
	+ * (AB - XMUTANBSB)/(SBOT12-SBOT22)G(SBOT12,SBOT22))
	+
	+
	+ VH3T(1,2)=VH3T(1,2) +
	+ MZ2(MTOP2/TANBSTF1T-DSQRT(MTOP2)(AT/TANBST+XMU)/2D0*F2T)
	+
	+ VH3B(1,2)=VH3B(1,2) +
	+ MZ2(-MBOT2TANBSBF1B+DSQRT(MBOT2)(ABTANBSB+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 + MB2)/MB2)
	+C TD = LOG((MD2+MB2)/MB2)
	+
	+ DO 110 I = 1,2
	+ DO 100 J = 1,2
	+ VH(I,J) =
	+ * 6D0/(8D0PI2(H1T2+H2T2))
	+ * VH3T(I,J)0.5D0(1D0-AL(I,J)TT/2D0) +
	+ * 6D0/(8D0PI2(H1B2+H2B2))
	+ * 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(XXXM(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/(XMPXMGR))2XMI/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-XMF2/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)=2D0C1/8D0/XMI3SQRT(XL)((XMI2-XMB2-XMA2)
	+ & (ABS(CA)2+ABS(CB)2)-4D0DBLE(CADCONJG(CB))XMJXMFP)
	+ 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)+TANWZMIXC(IX,1)(2D0*EI+1)
	+ CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
	+ CAR=-2D0EITANW*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)+TANWZMIXC(IX,1)(2D0*EI-1)
	+ CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
	+ CAR=-2D0EITANW*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/XMI3SQRT(XL)((XMI2-XMB2-XMA2)*
	+ & (ABS(CA)2+ABS(CB)2)-4D0DBLE(CADCONJG(CB))XMJXMF)
	+ 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-EIXW)*(-SIN(ALFA+BETA))+
	+ & XMF*2/XMWCOSA/SBETA
	+ GHRR=XMZ/CW(EIXW)*(-SIN(ALFA+BETA))+
	+ & XMF*2/XMWCOSA/SBETA
	+ ELSE
	+ GHLL=XMZ/CW(0.5D0-EIXW)*(-SIN(ALFA+BETA))+
	+ & XMF*2/XMW(-SINA)/CBETA
	+ GHRR=XMZ/CW(EIXW)*(-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(-XMUSINA+
	+ & AT*COSA)
	+ ELSE
	+ GHLR=XMF/2D0/XMW/CBETA(XMUCOSA-
	+ & 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-EIXW)*COS(ALFA+BETA)+
	+ & XMF*2/XMWSINA/SBETA
	+ GHRR=XMZ/CW(EIXW)*COS(ALFA+BETA)+
	+ & XMF*2/XMWSINA/SBETA
	+ ELSE
	+ GHLL=XMZ/CW(0.5D0-EIXW)*COS(ALFA+BETA)+
	+ & XMF*2/XMWCOSA/CBETA
	+ GHRR=XMZ/CW(EIXW)*COS(ALFA+BETA)+
	+ & XMF*2/XMWCOSA/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(XMUCOSA+
	+ & AT*SINA)
	+ ELSE
	+ GHLR=XMF/2D0/XMW/CBETA(XMUSINA+
	+ & 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,XMSF12,XMB2)
	+ LKNT=LKNT+1
	+ IF(IG.EQ.23) THEN
	+ XLAM(LKNT)=C1/4D0/XMI3XL1.5D0/XMB2AL**2
	+ ELSE
	+ XLAM(LKNT)=C1/4D0/XMI3SQRT(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/SR2SFMIX(IFL,1)SFMIX(IFL-1,1)
	+ ELSE
	+ AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL-1,1)
	+ ENDIF
	+ ELSE
	+ IF(ILR.EQ.1) THEN
	+ AL=1D0/SR2SFMIX(IFL,1)SFMIX(IFL+1,1)
	+ ELSE
	+ AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL+1,1)
	+ ENDIF
	+ ENDIF
	+ XL=PYLAMF(XMI2,XMSF12,XMB2)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=C1/4D0/XMI3XL1.5D0/XMB2AL**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/SR2SFMIX(IFL,1)SFMIX(IFL-1,3)
	+ ELSE
	+ AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL-1,3)
	+ ENDIF
	+ ELSE
	+ IF(ILR.EQ.1) THEN
	+ AL=1D0/SR2SFMIX(IFL,1)SFMIX(IFL+1,3)
	+ ELSE
	+ AL=1D0/SR2SFMIX(IFL,3)SFMIX(IFL+1,3)
	+ ENDIF
	+ ENDIF
	+ XL=PYLAMF(XMI2,XMSF22,XMB2)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=C1/4D0/XMI3XL1.5D0/XMB2AL**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,XMSF12,XMB2)
	+ LKNT=LKNT+1
	+C.......Need to complexify
	+ AL=CH1(XMW22D0CBETASBETA-XMFP*2TANB-XMF**2/TANB)+
	+ & CH22D0XMFXMFP/(2D0CBETA*SBETA)+
	+ & CH3XMFP(-XMU+ABTANB)+CH4XMF*(-XMU+AT/TANB)
	+ XLAM(LKNT)=C1/8D0/XMI3SQRT(XL)/XMW2AL**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,XMSF12,XMB2)
	+ LKNT=LKNT+1
	+C.......Need to complexify
	+ AL=CH1(XMW22D0CBETASBETA-XMFP*2TANB-XMF**2/TANB)+
	+ & CH22D0XMFXMFP/(2D0CBETA*SBETA)+
	+ & CH3XMFP(-XMU+ABTANB)+CH4XMF*(-XMU+AT/TANB)
	+ XLAM(LKNT)=C1/8D0/XMI3SQRT(XL)/XMW2AL**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/3D0AS/2D0/XMI3SQRT(XL)((XMI2-XMB2-XMA2)
	+ & (XCA2+XCB2)+4D0XCAXCBXMJXMF)
	+ 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/(16PI2)G3 = G2/(4PI) G/(4PI) = C1 G/(4PI)
	+C...MM = C12 G2/(16PI2)
	+C...G = 1/(8PI)P/MI*2 MM = C13/(32PI2)LAM/(2MI*3)
	+ LKNT=LKNT+1
	+ XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
	+ XLAM(LKNT)=C13/64D0/PI2/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/(XMPXMGR))2AXMI/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/8D0AS/4D0/XMI3SQRT(XL)((XMI2+XMB2-XMA2)
	+ & (CA2+CB2)-4D0CACBXMIXMF)
	+ 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	+ GRIJ=ZMIXC(IX,1)(EITANW)*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)=C1AS/XMI3/(16D0PI)*
	+ & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	+ GRIJ=ZMIXC(IX,1)(EITANW)*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)=C1AS/XMI3/(16D0PI)*
	+ & 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.5D0C1AS/XMI3/(16D0PI)
	+ & 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(-SINBAN(J,3)+COSB*AN(J,4))
	+ ZN(2)=-2D0W2/3D0SINW(TANWAN(J,2)-AN(J,1))
	+ ZN(3)=-2W2/3D0SINWAN(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(COSBAN(J,3)+SINB*AN(J,4))
	+ ZN(2)=W2/3D0SINW(TANW*AN(J,2)-AN(J,1))
	+ ZN(3)=W2/3D0SINWAN(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=SINDCOSD2D0
	+ 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=XMGXM2XMR
	+ 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(FFSIND2-HHCOSD2))W
	+ G(1)=((HL2+FL2)(XMQA-2D0XMS2(1)-2D0XMXMG*SIN2D)
	+ & +4D0HFLXMXMR)XLN1
	+ & +((HL2+FL2)((XMQA-XMS2(1))XMS2(1)-XM24
	+ & +2D0XMXMG(XM2+XMR2-XMS2(1))SIN2D)
	+ & -4D0HFLXMRXM(XMG2+XM2-XMS2(1))
	+ & +8D0HFLXMQ4SIN2D)B1
	+ G(2)=((HR2+FR2)(XMQA-2D0XMS2(2)+2D0XMXMG*SIN2D)
	+ & +4D0HFRXMRXM)XLN2
	+ & +((HR2+FR2)((XMQA-XMS2(2))XMS2(2)-XM24
	+ & +2D0XMGXMSIN2D(XMS2(2)-XM2-XMR2))
	+ & +4D0HFRXMXMR(XMS2(2)-XMG2-XM2)
	+ & -8D0HFRXMQ4SIN2D)B2
	+ G(3)=(2D0HFLSIN2D(XMS2(1)(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
	+ & +XMG2XMR2+XM2XM2)-2D0XMRXMG(HL2SIND2+FL2COSD2)SBAR
	+ & -2D0XMGXMHFL(SBAR+XMR2-XMG2)
	+ & +XMRXM(HL2+FL2)SIN2D(SBAR+XMG2-XMR2)
	+ & -4D0XMQ4(HL2-FL2)COS2D)/(GRS+2D0XMS2(1))*XLN1
	+ G(4)=4D0COS2DXMXMG/(XMS2(1)-XMS2(2))
	+ & (((HLFR+HRFL)(XM2+XMR2)+2D0XMXMR(HH+FF))*(XLN1-XLN2)
	+ & +(HLFR+HRFL)(XMS2(2)XLN2-XMS2(1)*XLN1))
	+ G(5)=(2D0(HHCOSD2-FF*SIND2)
	+ & ((XMS2(2)(XMS2(2)+GRS)+XM2XM2+XMG2XMR2)*XLN2
	+ & +(XMS2(1)(XMS2(1)+GRS)+XM2XM2+XMG2XMR2)XLN1)
	+ & +XM((HH-FF)SIN2DXMG-(HRFL-HLFR)XMR)
	+ & ((GRS+XMS2(1)2D0)XLN1-(GRS+XMS2(2)2D0)*XLN2)
	+ & +((HRFL-HLFR)XMR(SIN2DXMG(SBAR-4D0*XM2)
	+ & +COS2DXM(SBAR+XMG2-XMR2))
	+ & +2D0(FFCOSD2-HHSIND2)XM2*(SBAR-XMG2-XMR2))
	+ & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
	+ G(6)=(-2D0HFRSIN2D(XMS2(2)(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
	+ & +XMG2XMR2+XM2XM2)-2D0XMRXMG(HR2SIND2+FR2COSD2)SBAR
	+ & -2D0XMGXMHFR(SBAR+XMR2-XMG2)
	+ & -XMRXM(HR2+FR2)SIN2D(SBAR+XMG2-XMR2)
	+ & -4D0XMQ4(HR2-FR2)COS2D)/(GRS+2D0XMS2(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)=FAKT1UMIX(JJ,2)SINC-UMIX(JJ,1)*COSC
	+ EEE(JJ)=FAKT2VMIX(JJ,2)COSC
	+ DDD(JJ)=FAKT1UMIX(JJ,2)COSC+UMIX(JJ,1)*SINC
	+ FFF(JJ)=FAKT2VMIX(JJ,2)SINC
	+ XX1(JJ)=FAKT2VMIX(JJ,2)SINA-VMIX(JJ,1)*COSA
	+ AAA(JJ)=FAKT1UMIX(JJ,2)COSA
	+ XX2(JJ)=FAKT2VMIX(JJ,2)COSA+VMIX(JJ,1)*SINA
	+ BBB(JJ)=FAKT1UMIX(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=COSA2-SINA2
	+ SIN2A=SINACOSA2D0
	+ COS2C=COSC2-SINC2
	+ SIN2C=SINCCOSC2D0
	+
	+ 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=XMGXMTXMB*XMR
	+ XMQ3=XMG2XMR2+XMT2XMB2
	+ 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)=-COSASINCCCC(I)AAA(I)-SINACOSCEEE(I)XX1(I)
	+ A(1,2)=XMGXMB(COSACOSCCCC(I)AAA(I)+SINASINCEEE(I)XX1(I))
	+ A(1,3)=-XMGXMR(COSACOSCCCC(I)XX1(I)+SINASINCEEE(I)AAA(I))
	+ A(1,4)=XMBXMR(COSASINCCCC(I)XX1(I)+SINACOSCEEE(I)AAA(I))
	+ A(1,5)=XMGXMT(COSACOSCEEE(I)XX1(I)+SINASINCCCC(I)AAA(I))
	+ A(1,6)=-XMTXMB(COSASINCEEE(I)XX1(I)+SINACOSCCCC(I)AAA(I))
	+ A(1,7)=XMTXMR(COSASINCEEE(I)AAA(I)+SINACOSCCCC(I)XX1(I))
	+ A(1,8)=-XMQ4(COSACOSCEEE(I)AAA(I)+SINASINCCCC(I)*XX1(I))
	+
	+ A(2,1)=-COSACOSCDDD(I)AAA(I)-SINASINCFFF(I)XX1(I)
	+ A(2,2)=-XMGXMB(COSASINCDDD(I)AAA(I)+SINACOSCFFF(I)XX1(I))
	+ A(2,3)=XMGXMR(COSASINCDDD(I)XX1(I)+SINACOSCFFF(I)AAA(I))
	+ A(2,4)=XMBXMR(COSACOSCDDD(I)XX1(I)+SINASINCFFF(I)AAA(I))
	+ A(2,5)=XMGXMT(COSASINCFFF(I)XX1(I)+SINACOSCDDD(I)AAA(I))
	+ A(2,6)=XMTXMB(COSACOSCFFF(I)XX1(I)+SINASINCDDD(I)AAA(I))
	+ A(2,7)=-XMTXMR(COSACOSCFFF(I)AAA(I)+SINASINCDDD(I)XX1(I))
	+ A(2,8)=-XMQ4(COSASINCFFF(I)AAA(I)+SINACOSCDDD(I)*XX1(I))
	+
	+ A(3,1)=-COSACOSCEEE(I)XX2(I)-SINASINCCCC(I)BBB(I)
	+ A(3,2)=XMGXMB(COSASINCEEE(I)XX2(I)+SINACOSCCCC(I)BBB(I))
	+ A(3,3)=XMGXMR(COSASINCEEE(I)BBB(I)+SINACOSCCCC(I)XX2(I))
	+ A(3,4)=-XMBXMR(COSACOSCEEE(I)BBB(I)+SINASINCCCC(I)XX2(I))
	+ A(3,5)=-XMGXMT(COSASINCCCC(I)BBB(I)+SINACOSCEEE(I)XX2(I))
	+ A(3,6)=XMTXMB(COSACOSCCCC(I)BBB(I)+SINASINCEEE(I)XX2(I))
	+ A(3,7)=XMTXMR(COSACOSCCCC(I)XX2(I)+SINASINCEEE(I)BBB(I))
	+ A(3,8)=-XMQ4(COSASINCCCC(I)XX2(I)+SINACOSCEEE(I)*BBB(I))
	+
	+ A(4,1)=-COSASINCFFF(I)XX2(I)-SINACOSCDDD(I)BBB(I)
	+ A(4,2)=-XMGXMB(COSACOSCFFF(I)XX2(I)+SINASINCDDD(I)BBB(I))
	+ A(4,3)=-XMGXMR(COSACOSCFFF(I)BBB(I)+SINASINCDDD(I)XX2(I))
	+ A(4,4)=-XMBXMR(COSASINCFFF(I)BBB(I)+SINACOSCDDD(I)XX2(I))
	+ A(4,5)=-XMGXMT(COSACOSCDDD(I)BBB(I)+SINASINCFFF(I)XX2(I))
	+ A(4,6)=-XMTXMB(COSASINCDDD(I)BBB(I)+SINACOSCFFF(I)XX2(I))
	+ A(4,7)=-XMTXMR(COSASINCDDD(I)XX2(I)+SINACOSCFFF(I)BBB(I))
	+ A(4,8)=-XMQ4(COSACOSCDDD(I)XX2(I)+SINASINCFFF(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)-XMGXMTSIN2A)
	+ & +2D0XX1(I)AAA(I)XMRXMB)*ANT1
	+ & +(ULR(1)/2D0(XMST(1)(XMQ2-XMST(1))-XMGTBR
	+ & -2D0XMGXMTSIN2A(XMST(1)-XMB2-XMR2))
	+ & +2D0XX1(I)AAA(I)XMRXMB*(XMST(1)-XMG2-XMT2)
	+ & +4D0SIN2AXX1(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)+XMGXMT*SIN2A)
	+ & -2D0XX2(I)BBB(I)XMRXMB)*ANT2
	+ & +(ULR(2)/2D0(XMST(3)(XMQ2-XMST(3))-XMGTBR
	+ & +2D0XMGXMTSIN2A(XMST(3)-XMB2-XMR2))
	+ & -2D0XX2(I)BBB(I)XMRXMB*(XMST(3)-XMG2-XMT2)
	+ & +4D0SIN2AXX2(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)-XMGXMB*SIN2C)
	+ & +2D0CCC(I)EEE(I)XMRXMT)*ANB1
	+ & +(VLR(1)/2D0(XMSB(1)(XMQ2-XMSB(1))-XMGBTR
	+ & -2D0XMGXMBSIN2C(XMSB(1)-XMT2-XMR2))
	+ & +2D0CCC(I)EEE(I)XMRXMT*(XMSB(1)-XMG2-XMB2)
	+ & +4D0SIN2CCCC(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)+XMGXMB*SIN2C)
	+ & -2D0DDD(I)FFF(I)XMRXMT)*ANB2
	+ & +(VLR(2)/2D0(XMSB(2)(XMQ2-XMSB(2))-XMGBTR
	+ & +2D0XMGXMBSIN2C(XMSB(2)-XMT2-XMR2))
	+ & -2D0DDD(I)FFF(I)XMRXMT*(XMSB(2)-XMG2-XMB2)
	+ & +4D0SIN2CDDD(I)FFF(I)XMQ4)
	+ & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
	+ SUMME(LIN)=SUMME(LIN)+2D0XMGXMT*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))XMBXMR(ANT2-ANT1))
	+ SUMME(LIN)=SUMME(LIN)+2D0XMGXMB*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))XMTXMR(ANB2-ANB1))
	+ DO 110 J=1,4
	+ SUMME(LIN)=SUMME(LIN)-2D0A(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)+2D0A(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)-2D0A(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/(XMPXMGR))2AXMI/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)=XFACABS(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 +
	+ $ .5D0ABS(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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	+ & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	+ GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	+ CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	+ CXC(2)=-GLIJ
	+ CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	+ CXC(4)=DCONJG(GLIJ)
	+ CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	+ CXC(6)=GRIJ
	+ CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	+ & 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/(16D0PI)*
	+ & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	+ & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	+ GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	+ CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	+ CXC(2)=-GLIJ
	+ CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	+ CXC(4)=DCONJG(GLIJ)
	+ CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	+ CXC(6)=GRIJ
	+ CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	+ & 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/(16D0PI)*
	+ & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	+ & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	+ GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	+ CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	+ CXC(2)=-GLIJ
	+ CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	+ CXC(4)=DCONJG(GLIJ)
	+ CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	+ CXC(6)=GRIJ
	+ CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	+ & 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/(16D0PI)*
	+ & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))
	+ & DCONJG(T3IZMIXC(IJ,2)-TANW(T3I-EI)*ZMIXC(IJ,1))
	+ GRIJ=ZMIXC(IX,1)DCONJG(ZMIXC(IJ,1))(EITANW)*2
	+ CXC(1)=DCMPLX((T3I-EIXW)/XW1)OLPP
	+ CXC(2)=-GLIJ
	+ CXC(3)=-DCMPLX((T3I-EIXW)/XW1)ORPP
	+ CXC(4)=DCONJG(GLIJ)
	+ CXC(5)=-DCMPLX((EIXW)/XW1)OLPP
	+ CXC(6)=GRIJ
	+ CXC(7)=DCMPLX((EIXW)/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/(16D0PI)*
	+ & 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(QIJEH(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/(16D0PI)*
	+ & 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/(16D0PI)*
	+ & 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)=3D0C12/XMI3/(16D0PI)*
	+ & 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=T3TZMIXC(IX,2)+TANWZMIXC(IX,1)(2D0EI-T3T)
	+ CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
	+ CAR=-2D0EITANW*ZMIXC(IX,1)
	+ CBR=CAL
	+ ELSE
	+ CBL=T3TZMIXC(IX,2)+TANWZMIXC(IX,1)(2D0EI-T3T)
	+ CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
	+ CAR=-2D0EITANW*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=CALSFMIX(J,1)+CARSFMIX(J,2)
	+ CB=CBLSFMIX(J,1)+CBRSFMIX(J,2)
	+ XLAM(LKNT)=0.5D0FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)*
	+ & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	+ 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=CALSFMIX(J,3)+CARSFMIX(J,4)
	+ CB=CBLSFMIX(J,3)+CBRSFMIX(J,4)
	+ XL=PYLAMF(XMI2,XMA2,XMB2)
	+ XLAM(LKNT)=0.5D0FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)*
	+ & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	+ 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	+ GRIJ=ZMIXC(IX,1)(EITANW)*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)=4D0C1AS/XMI3/(16D0PI)
	+ & 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.5D0C1AS/XMI3/(16D0PI)
	+ & 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=(T3IZMIXC(IX,2)-TANW(T3I-EI)ZMIXC(IX,1))OLPP
	+ GRIJ=ZMIXC(IX,1)(EITANW)*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.5D0C1AS/XMI3/(16D0PI)
	+ & 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/(XMPXMGR))2AXMI/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-XWEI)/XW/XW1)ORPP
	+ CXC(2)=DCMPLX(0D0,0D0)
	+ CXC(3)=DCMPLX((T3I-XWEI)/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/(16D0PI)*
	+ & 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-XWEI)/XW/XW1)ORPP
	+ CXC(3)=DCMPLX((T3I-XWEI)/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/(16D0PI)*
	+ & 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/(16D0PI)*
	+ & 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-XWEI)/XW/XW1)ORPP
	+ CXC(2)=DCMPLX(0D0,0D0)
	+ CXC(3)=DCMPLX((T3I-XWEI)/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)=3D0C12/XMI3/(16D0PI)*
	+ & 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)=3D0C12/XMI3/(16D0PI)*
	+ & 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-XWEI)/XW/XW1)ORPP
	+ CXC(2)=DCMPLX(0D0,0D0)
	+ CXC(3)=DCMPLX((T3I-XWEI)/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)=3D0C12/XMI3/(16D0PI)*
	+ & 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/(32M3)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/(16D0PI)*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/(16D0PI)*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)=3D0C12/XMI3/(16D0PI)*
	+ & 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=CALSFMIX(ISF,1)+CARSFMIX(ISF,2)
	+ CB=CBLSFMIX(ISF,1)+CBRSFMIX(ISF,2)
	+ XLAM(LKNT)=FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)
	+ & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	+ 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=CALSFMIX(ISF,3)+CARSFMIX(ISF,4)
	+ CB=CBLSFMIX(ISF,3)+CBRSFMIX(ISF,4)
	+ XL=PYLAMF(XMI2,XMA2,XMB2)
	+ XLAM(LKNT)=FCOLC1/8D0/XMI3SQRT(XL)( (XMI2+XMB2-XMA2)
	+ & (ABS(CA)2+ABS(CB)2)+4D0DBLE(CADCONJG(CB))XMFXMI)
	+ 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)=4D0C1AS/XMI3/(16D0PI)
	+ & 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)(-(X2+XY+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-2D0C)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/XSQRT( ( (X-XM12-XM32)2-4D0XM12XM32)
	+ &( (X-XM22-S)*2 -4D0XM22*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-XMV2)2+(XMVXMG)*2
	+ SIJ=2D0XXC(2)XXC(4)*S13
	+ IF(XMV.LE.1000D0) THEN
	+ OL2=ABS(QLLS)2+ABS(QRRS)2+ABS(QLRS)2+ABS(QRLS)2
	+ OLR=-2D0DBLE(QLRSDCONJG(QLLS)+QRLS*DCONJG(QRRS))
	+ WW=(OL22D0TINT(S23MAX,S23MIN,XM22,S)
	+ & +OLRSIJ(S23MAX-S23MIN))/WPROP2
	+ IF(XXC(5).LE.10000D0) THEN
	+ WFL1=4D0(DBLE(QLLSDCONJG(QLLU))*
	+ & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
	+ & .5D0DBLE(QLLSDCONJG(QLRT))SIJTPROP(S23MAX,S23MIN,XMSD2)+
	+ & DBLE(QLRSDCONJG(QLRT))TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
	+ & .5D0DBLE(QLRSDCONJG(QLLU))SIJTPROP(S23MAX,S23MIN,XMSD1))
	+ & (S13-XMV*2)/WPROP2
	+ ELSE
	+ WFL1=0D0
	+ ENDIF
	+
	+ IF(XXC(6).LE.10000D0) THEN
	+ WFL2=4D0(DBLE(QRRSDCONJG(QRRU))*
	+ & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
	+ & .5D0DBLE(QRRSDCONJG(QRLT))SIJTPROP(S23MAX,S23MIN,XMSU2)+
	+ & DBLE(QRLSDCONJG(QRLT))TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
	+ & .5D0DBLE(QRLSDCONJG(QRRU))SIJTPROP(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=2D0ABS(QLLU)2TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
	+ & +2D0ABS(QLRT)2TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
	+ & - 2D0DBLE(QLRTDCONJG(QLLU))*
	+ & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
	+ ELSE
	+ WF1=0D0
	+ ENDIF
	+ IF(XXC(6).LE.10000D0) THEN
	+ WF2=2D0ABS(QRRU)2TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
	+ & +2D0ABS(QRLT)2TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
	+ & - 2D0DBLE(QRLTDCONJG(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((XM12-XM22)/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+3D0XMV2(XMI2+XMJ2-XMV2))-
	+ &12D0GLRXM1XM2XMV2)
	+
	+ 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)+
	+ &4D0GLRXM1*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.5D0DCONJG(QIJDH(IH)-RIJ*EH(IH))
	+ F12K=0.5D0(QIJDH(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+EIXW)*SIN(ALFA+BETA)+
	+ & XMF*2/XMWSINA/CBETA
	+ GHRR=XMZ/CW(EIXW)*SIN(ALFA+BETA)+
	+ & XMF*2/XMWSINA/CBETA
	+ IF(IFL.EQ.5) THEN
	+ GHLR=-XMF/2D0/XMW/CBETA(XMUZCOSA-
	+ & ATRIB*SINA)
	+ ELSEIF(IFL.EQ.15) THEN
	+ GHLR=-XMF/2D0/XMW/CBETA(XMUZCOSA-
	+ & ATRIL*SINA)
	+ ELSE
	+ GHLR=0D0
	+ ENDIF
	+ ELSE
	+ GHLL=XMZ/CW(0.5D0-EIXW)*SIN(ALFA+BETA)-
	+ & XMF*2/XMWCOSA/SBETA
	+ GHRR=XMZ/CW(EIXW)*SIN(ALFA+BETA)-
	+ & XMF*2/XMWCOSA/SBETA
	+ IF(IFL.EQ.6) THEN
	+ GHLR=XMF/2D0/XMW/SBETA(XMUZSINA-
	+ & ATRIT*COSA)
	+ ELSE
	+ GHLR=0D0
	+ ENDIF
	+ ENDIF
	+
	+ ELSEIF(IH.EQ.2) THEN
	+ IF(IDU.EQ.1) THEN
	+ GHLL=XMZ/CW(0.5D0+EIXW)*COS(ALFA+BETA)-
	+ & XMF*2/XMWCOSA/CBETA
	+ GHRR=-XMZ/CW(EIXW)*COS(ALFA+BETA)-
	+ & XMF*2/XMWCOSA/CBETA
	+ IF(IFL.EQ.5) THEN
	+ GHLR=-XMF/2D0/XMW/CBETA(XMUZSINA+
	+ & ATRIB*COSA)
	+ ELSEIF(IFL.EQ.15) THEN
	+ GHLR=-XMF/2D0/XMW/CBETA(XMUZSINA+
	+ & ATRIL*COSA)
	+ ELSE
	+ GHLR=0D0
	+ ENDIF
	+ ELSE
	+ GHLL=-XMZ/CW(0.5D0-EIXW)*COS(ALFA+BETA)-
	+ & XMF*2/XMWSINA/SBETA
	+ GHRR=-XMZ/CW(EIXW)*COS(ALFA+BETA)-
	+ & XMF*2/XMWSINA/SBETA
	+ IF(IFL.EQ.6) THEN
	+ GHLR=-XMF/2D0/XMW/SBETA(XMUZCOSA+
	+ & 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(ATRIBTANB-XMUZ)
	+ ELSEIF(IFL.EQ.15) THEN
	+ GHLR=XMF/2D0/XMW(ATRILTANB-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)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GHLLAL+GHRRAR
	+ & +2D0GHLRALR)**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)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GHLLAL+GHRRAR
	+ & +2D0GHLRALR)**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)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GHLLAL+GHRRAR)**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=CBETADCONJG(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(2D0BETA)-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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GLSFMIX(6,1)SFMIX(5,1)+GRSFMIX(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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GLSFMIX(6,3)SFMIX(5,1)+GRSFMIX(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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GLSFMIX(6,1)SFMIX(5,3)+GRSFMIX(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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3*
	+ & (GLSFMIX(6,3)SFMIX(5,3)+GRSFMIX(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/SR2SIN(2D0BETA)
	+ 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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL*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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL*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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL2SFMIX(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,XM12,XM22)
	+ LKNT=LKNT+1
	+ XLAM(LKNT)=CFSQRT(XL)/4D0C1/XMI3GL2SFMIX(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)-
	+ &4D0GLRXM3*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-C2S8) .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-C2S8) .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-4D0Y*Z
	+ IF(PYLAMF.LT.0D0) PYLAMF=0D0
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYTBDY
	+C...Generates 3-body decays of gauginos.
	+
	+ SUBROUTINE PYTBDY(IDIN)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ 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=(T3IZMIXC(IZID1,2)-TANW(T3I-EI)ZMIXC(IZID1,1))
	+ & DCONJG(T3IZMIXC(IZID2,2)-TANW(T3I-EI)*ZMIXC(IZID2,1))
	+ GRIJ=ZMIXC(IZID1,1)DCONJG(ZMIXC(IZID2,1))(EITANW)*2
	+ XM1M2=SMZ(IZID1)*SMZ(IZID2)
	+ QLLS=DCMPLX((T3I-EIXW)/XW1)OLPP
	+ QLLU=-GLIJ
	+ QLRS=-DCMPLX((T3I-EIXW)/XW1)ORPP
	+ QLRT=DCONJG(GLIJ)
	+ QRLS=-DCMPLX((EIXW)/XW1)OLPP
	+ QRLT=GRIJ
	+ QRRS=DCMPLX((EIXW)/XW1)ORPP
	+ QRRU=-DCONJG(GRIJ)
	+ ELSEIF(IZID1IWID2.NE.0.OR.IZID2IWID1.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-XWEI)/XW/XW1)ORPP
	+ QRRS=-DCMPLX(EI/XW1)*OLPP
	+ QLRS=DCMPLX((T3I-XWEI)/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)/(2D0S12)
	+ S23DF1=(S12-XM(2)2-XM(1)2)**2
	+ & -(2D0XM(1)XM(2))**2
	+ S23DF2=(S12-XM(3)2-XM(5)2)**2
	+ & -(2D0XM(3)XM(5))**2
	+ S23DF1=S23DF1*EPS
	+ S23DF2=S23DF2*EPS
	+ S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0S12)
	+ 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 + GMMZ2
	+ 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+
	+ & 2D0DBLE(QLRDCONJG(QLL)+QRLDCONJG(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
	+ &-(2D0XM(1)XM(2))**2
	+ S23DF2=(X1-XM(3)2-XM(5)2)**2
	+ &-(2D0XM(3)XM(5))**2
	+ S23DF1=S23DF1*EPS
	+ S23DF2=S23DF2*EPS
	+ S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X1)
	+ F1=-2D0*S23DEL/EPS
	+ S23DF1=(X2-XM(2)2-XM(1)2)**2
	+ &-(2D0XM(1)XM(2))**2
	+ S23DF2=(X2-XM(3)2-XM(5)2)**2
	+ &-(2D0XM(3)XM(5))**2
	+ S23DF1=S23DF1*EPS
	+ S23DF2=S23DF2*EPS
	+ S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X2)
	+ 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=RX1+CX3
	+ F1=F2
	+ S23DF1=(X2-XM(2)2-XM(1)2)**2
	+ & -(2D0XM(1)XM(2))**2
	+ S23DF2=(X2-XM(3)2-XM(5)2)**2
	+ & -(2D0XM(3)XM(5))**2
	+ S23DF1=S23DF1*EPS
	+ S23DF2=S23DF2*EPS
	+ S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X2)
	+ F2=-2D0*S23DEL/EPS
	+ ELSE
	+ X3=X2
	+ X2=X1
	+ X1=RX2+CX0
	+ F2=F1
	+ S23DF1=(X1-XM(2)2-XM(1)2)**2
	+ & -(2D0XM(1)XM(2))**2
	+ S23DF2=(X1-XM(3)2-XM(5)2)**2
	+ & -(2D0XM(3)XM(5))**2
	+ S23DF1=S23DF1*EPS
	+ S23DF2=S23DF2*EPS
	+ S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0X1)
	+ 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)/(2D0S12)
	+ S23DF1=(S12-XM(2)2-XM(1)2)**2
	+ &-(2D0XM(1)XM(2))**2
	+ S23DF2=(S12-XM(3)2-XM(5)2)**2
	+ &-(2D0XM(3)XM(5))**2
	+ S23DF1=S23DF1*EPS
	+ S23DF2=S23DF2*EPS
	+ S23DEL=SQRT(MAX(0D0,S23DF1S23DF2))/(2D0S12)
	+ 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 + GMMZ2
	+ 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-EIXW)/XW1)OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
	+c QLR=-DCMPLX((T3I-EIXW)/XW1)ORPP*PROPZ+DCONJG(GLIJ)
	+c &/DCMPLX(TH-XML2)
	+c QRL=-DCMPLX((EIXW)/XW1)OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
	+c QRR=DCMPLX((EIXW)/XW1)ORPP*PROPZ
	+c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
	+ WT=-((ABS(QLL)2+ABS(QRR)2)*WU2+
	+ &(ABS(QRL)2+ABS(QLR)2)*WT2+
	+ &2D0DBLE(QLRDCONJG(QLL)+QRLDCONJG(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(D1D1-XM(1)*2)
	+ P2=SQRT(D2D2-XM(2)*2)
	+ P3=SQRT(D3D3-XM(3)*2)
	+ CTHE1=2D0*PYR(0)-1D0
	+ ANG1=2D0PYR(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)=P1STHE1CPHI1
	+ P(N+1,2)=P1STHE1SPHI1
	+ P(N+1,3)=P1*CTHE1
	+ P(N+1,4)=D1
	+
	+C...GET CPHI3
	+ ANG3=2D0PYR(0)PARU(1)
	+ CPHI3=COS(ANG3)
	+ SPHI3=SIN(ANG3)
	+ CTHE3=(P22-P12-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)=-P3STHE3CPHI3CTHE1CPHI1
	+ &+P3STHE3SPHI3*SPHI1
	+ &+P3CTHE3STHE1*CPHI1
	+ P(N+3,2)=-P3STHE3CPHI3CTHE1SPHI1
	+ &-P3STHE3SPHI3*CPHI1
	+ &+P3CTHE3STHE1*SPHI1
	+ P(N+3,3)=P3STHE3CPHI3*STHE1
	+ &+P3CTHE3CTHE1
	+ 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-2D0PARU(102))/(2D0PARU(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)/(2D0SINWCOSW)
	+ 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 = RMZ2DSQRT(SW2CW2)
	+ SQRDEL = DSQRT( (A-B)*2 + 4C**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= SWW12/(SWW12 + 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.D0XMNKK*2/SHAT)
	+ PI=DACOS(-1.D0)
	+c++lnk
	+c Q2=RUED(0)*2+(TPUP-RUED(0)**4)/SP
	+ Q2=RUED(1)*2+(TPUP-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.ALPHAS2/(SPTPUP)*2
	+ XMUED=FAC1(XMNKK4(6.TP4+18.TP*3UP+
	+ & 24.TP2UP*2+18.TPUP3+6.UP**4)
	+ & +XMNKK*2(6.TP4UP+12.TP3UP**2+
	+ & 12.TP2UP*3+6TPUP*4)
	+ & +2.TP6+6TP*5UP+13TP4UP**2+
	+ & 15.TP3UP*3+13TP*2UP**4+
	+ & 6.TPUP*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.ALPHAS2/(SPTPUP)*2
	+ XMUED=FAC1(12.SPUP5+5.SP*2UP*4+22.SP*3UP**3+
	+ & 5.SP4UP*2+12.SP*5UP)
	+ XMUED=COMFAC2.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.ALPHAS2/(TPUP)**2
	+ XMUED=FAC1*
	+ & (XMNKK*2(8TP3+4./3.TP*2UP+4./3.TPUP**2
	+ & +8.UP3)+8.TP*4+56./3.TP*3UP+
	+ & 20.TP2UP*2+56./3.
	+ & TPUP3+8.UP**4)
	+ SIGH(NCHN)=COMFAC2.XMUED
	+ ISIG(NCHN,3)=1
	+ IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
	+ ELSE
	+ FAC1=2./9.ALPHAS2/TP*2
	+ XMUED=FAC1(-XMNKK2SP+SP*2+0.25TP**2)
	+ SIGH(NCHN)=COMFAC2.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.ALPHAS2/(SPTPUP)*2
	+ XMUED=FAC1(-XMNKK4(8.TPUP*3+8.TP*2UP*2+8.TP*3UP
	+ + +4.UP4+4TP**4)
	+ + -XMNKK*2(0.5TPUP*4+4.TP*2UP*3+15./2.TP**3
	+ + UP2+ 4.TP*4UP)+TPUP5-0.25TP*2UP**4+
	+ + 2.TP3UP*3-0.25TP*4UP2+TP5*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.ALPHAS21./(SPTP)*2
	+ XMUED=FAC1(XMNKK2SP(4.TP*2-SPTP-SP**2)+
	+ & 4.TP4+3.SPTP3+11./12.TP*2SP**2-
	+ & 2./3.SP3TP+SP**4)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=COMFAC2.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.ALPHAS2/TP*2
	+ XMUED=FAC1(-XMNKK2SP+SP*2+0.25TP**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.ALPHAS2/TP*2
	+ XMUED=FAC1(4.XMNKK*2SP+4.SP2+8.SPTP+5TP**2)
	+ SIGH(NCHN)=COMFAC2.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.ALPHAS2/(TPUP)**2
	+ XMUED=FAC1(-8.XMNKK*2(TP3+TP2UP+TPUP2+UP3)
	+ & +8.TP4+4.TP*2UP*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.ALPHAS2/TP*2
	+ XMUED=FAC1(4.XMNKK*2SP+4.SP2+8.SPTP+5TP**2)
	+ SIGH(NCHN)=COMFAC2.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.ALPHAS21./(SP)**2
	+ XMUED=FAC1(2.XMNKK*2SP+SP*2+2.SPTP+2.TP**2)
	+ NCHN=NCHN+1
	+ ISIG(NCHN,1)=I
	+ ISIG(NCHN,2)=-I
	+ ISIG(NCHN,3)=1
	+ SIGH(NCHN)=COMFAC2.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-2D0XMGAMK*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-2D0XMGAMK*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(xx2+yy2) 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*2RINVNDIM/XMD(NDIM+2)
	+ XND=(NDIM-1.)/2.
	+ GAMMN=PYGAMM(XND)
	+ FAC=FAC/GAMMN
	+ XXA=DSQRT(XX2+YY2)
	+ GRADEN=4./PI2 * (YY2/(1.-YY2)*2)(1.+DCOS(PI*YY))
	+
	+ PYGRAW=DJAC*
	+ + FACXX(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(xx2+yy2) 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)XMNKK3/X4
	+ + ((1.-X2)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(AA + BB) .
	+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(YR2-YI2+XR,2.0D0YRYI+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(AA + BB) .
	+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(YR2-YI2+XR,2.0D0YRYI+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 = BRS2 + BIS2
	+ CR = (ARSBRS + AISBIS)/S
	+ CI = (AISBRS - ARSBIS)/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(A2+B2) 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(AA + BB) .
	+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-(UUT)/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-(UUT)/H)A(I-(UUT)/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/60/,WIDWSV/60D0/,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)*2XW/PARU(1)
	+ AS=PYALPS(SH)
	+ RADC=1D0+AS/PARU(1)
	+
	+ IF(KFLA.EQ.23) THEN
	+C...Z0:
	+ XWC=1D0/(16D0XWXW1)
	+ FAC=(AEMXWC/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-4D0EFXWV
	+ FCOF=3D0*RADC
	+ IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOFPYHFTH(SH,SHRM1,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-4D0EFXWV
	+ FCOF=1D0
	+ ENDIF
	+ BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
	+ WDTP(I)=FACFCOF(VF*2(1D0+2D0RM1)+AF2(1D0-4D0RM1))
	+ & BE34
	+ WDTP(0)=WDTP(0)+WDTP(I)
	+ 130 CONTINUE
	+
	+
	+ ELSEIF(KFLA.EQ.24) THEN
	+C...W+/-:
	+ FAC=(AEM/(24D0XW))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=3D0RADCVCKM((I-1)/4+1,MOD(I-1,4)+1)
	+ ELSEIF(I.LE.20) THEN
	+C...W+/- -> l+/- + nu
	+ FCOF=1D0
	+ ENDIF
	+ WDTP(I)=FACFCOF(2D0-RM1-RM2-(RM1-RM2)*2)
	+ & SQRT(MAX(0D0,(1D0-RM1-RM2)*2-4D0RM1*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+2D0RM1)SQRT(1D0-4D0RM1)*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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT-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=3RVLAMP(I,J,K)2SFMIX(KFSM,2ICNT-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=3RVLAMP(I,J,K)2SFMIX(KFSM,2ICNT-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=3RVLAMP(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)*2SFMIX(KFSM,2ICNT-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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT)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)*2SFMIX(KFSM,2ICNT-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,2ICNT)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=2RVLAMB(I,J,K)2SFMIX(KFSM,2ICNT)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=2RVLAMB(I,J,K)2SFMIX(KFSM,2ICNT)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 = 2SQRT(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=2D0SQRT(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=GWZPMIX(NCHI,3)/(2D0COSB*WMASS)
	+ C1U=GWZPMIX(NCHI,4)/(2D0SINB*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(CMSC1*SFMIX(I,1) + SFMIX(I,2)
	+ & (C2-C3SINW**2))
	+ AB(1,I,2)=ISM(CMSC1*SFMIX(I,3) + SFMIX(I,4)
	+ & (C2-C3SINW**2))
	+ AB(2,I,1)= CMSC1SFMIX(I,2) - SFMIX(I,1)(C2+C3(5D-1-SINW
	+ & **2))
	+ AB(2,I,2)=CMSC1SFMIX(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(CMSC1*SFMIX(J,1) - SFMIX(J,2)
	+ & ED(C2-C3SINW*2))
	+ AB(1,J,2)=ISM(CMSC1*SFMIX(J,3) - SFMIX(J,4)
	+ & ED(C2-C3SINW*2))
	+ AB(2,J,1)=CMSC1SFMIX(J,2) + SFMIX(J,1)
	+ & (EDC2-C3(1D0/2D0+EDSINW**2))
	+ AB(2,J,2)=CMSC1SFMIX(J,4) + SFMIX(J,3)
	+ & (EDC2-C3(1D0/2D0+EDSINW**2))
	+C...Inermediate sup
	+ J=J+1
	+ CMS=RMQ(J)
	+ AB(1,J,1)=ISM(CMSC1U*SFMIX(J,1) - SFMIX(J,2)
	+ & EU(C2-C3SINW*2))
	+ AB(1,J,2)=ISM(CMSC1U*SFMIX(J,3) - SFMIX(J,4)
	+ & EU(C2-C3SINW*2))
	+ AB(2,J,1)=CMSC1USFMIX(J,2) + SFMIX(J,1)
	+ & (EUC2+C3(1D0/2D0-EUSINW**2))
	+ AB(2,J,2)=CMSC1USFMIX(J,4) + SFMIX(J,3)
	+ & (EUC2+C3(1D0/2D0-EUSINW**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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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 = 4PARU(103)PARU(1)/PARU(102)
	+ C1U = UMIX(NCHI,2)/(SQRT(2D0)COSBWMASS)
	+ C1V = VMIX(NCHI,2)/(SQRT(2D0)SINBWMASS)
	+ 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)C1USFMIX(I,2) +
	+ & SFMIX(I,1)*C2
	+ AB(2,I,2) = -PMAS(PYCOMP(I),1)C1USFMIX(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)C1VSFMIX(J,1)
	+ AB(1,J,2) = -RMQ(J+1)C1VSFMIX(J,3)
	+ AB(2,J,1) = -ISM(RMQ(J)C1USFMIX(J,2) - SFMIX(J,1)C2)
	+ AB(2,J,2) = -ISM(RMQ(J)C1USFMIX(J,4) - SFMIX(J,3)C2)
	+C...Intermediate sup
	+ J=J+1
	+ AB(1,J,1) = -RMQ(J-1)C1USFMIX(J,1)
	+ AB(1,J,2) = -RMQ(J-1)C1USFMIX(J,3)
	+ AB(2,J,1) = -ISM(RMQ(J)C1VSFMIX(J,2) - SFMIX(J,1)C3)
	+ AB(2,J,2) = -ISM(RMQ(J)C1VSFMIX(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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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
	+ & /((2PARU(1)RMS(0))*332)
	+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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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
	+ & + RVLJIKRVLIJK XRESIJ
	+ XLAM(LKNT)=XLAM(LKNT)RVLAMC/((2PARU(1)RMS(0))332)
	+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
	+ & + RVLIJKRVLJKI XRESIJ
	+ & + RVLIJKRVLKIJ XRESIK
	+ & + RVLJKIRVLKIJ XRESJK
	+ XLAM(LKNT)=XLAM(LKNT)RVLAMC/((2.PARU(1)RMS(0))332)
	+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 = 4D0PARU(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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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/((2PARU(1)RMS(0))332)
	+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./(4SM(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./(4SM(1))(SM(1)-(PMAS(KC(3),1))2)2
	+ ELSE IF (MODE.EQ.3) THEN
	+ P2CM=1./(4SM(1))(SM(1)-(PMAS(KC(2),1))2)2
	+ ELSE
	+ P2CM=SM(1)/4.
	+ ENDIF
	+C...Calculate Width
	+ PYRVSB=RM2SQRT(MAX(0D0,P2CM))/(8PARU(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),2J+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),2J+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),2J+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 + PREFPYRVI3(1,3,2)
	+ & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
	+ & SFMIX(INTRES(IDR2,1),2IKR2+INTRES(IDR2,3)-1)
	+ ENDIF
	+
	+ IDR = IKR1+4
	+ IDR2 = IKR2
	+ IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
	+ XLAM = XLAM + PREFPYRVI3(1,2,3)
	+ & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
	+ & SFMIX(INTRES(IDR2,1),2IKR2+INTRES(IDR2,3)-1)
	+ ENDIF
	+
	+ IDR = IKR1+4
	+ IDR2 = IKR2+2
	+ IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
	+ XLAM = XLAM + PREFPYRVI3(2,1,3)
	+ & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
	+ & SFMIX(INTRES(IDR2,1),2IKR2+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 = 4D0E2E3
	+ PYRVG1 = DELTAYRVRX(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,E22-RM(2)2))
	+ SR2 = SQRT(MAX(0D0,E32-RM(3)2))
	+ DELTAY = 4D0SR1SR2
	+ 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 = DELTAYRVR(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 = 4D0E2E3
	+ PYRVG2 = DELTAYRVSX(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,E22-RM(2)2))
	+ SR2 = SQRT(MAX(0D0,E32-RM(3)2))
	+ DELTAY = 4D0SR1SR2
	+ PYRVG2 = DELTAYRVS(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 = 4D0E2E3
	+ 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,E22-RM(2)2))
	+ SR2 = SQRT(MAX(0D0,E32-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 = RVSB(1)B(2)XY
	+ 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)(XY-(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-RM2)2+RM*2RW**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)
	+ & +W1W2M1*M2)
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY1ENT
	+C...Stores one parton/particle in commonblock PYJETS.
	+
	+ SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Standard checks.
	+ MSTU(28)=0
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IPA=MAX(1,IABS(IP))
	+ IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
	+ &'(PY1ENT:) writing outside PYJETS memory')
	+ KC=PYCOMP(KF)
	+ IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
	+
	+C...Find mass. Reset K, P and V vectors.
	+ PM=0D0
	+ IF(MSTU(10).EQ.1) PM=P(IPA,5)
	+ IF(MSTU(10).GE.2) PM=PYMASS(KF)
	+ DO 100 J=1,5
	+ K(IPA,J)=0
	+ P(IPA,J)=0D0
	+ V(IPA,J)=0D0
	+ 100 CONTINUE
	+
	+C...Store parton/particle in K and P vectors.
	+ K(IPA,1)=1
	+ IF(IP.LT.0) K(IPA,1)=2
	+ K(IPA,2)=KF
	+ P(IPA,5)=PM
	+ P(IPA,4)=MAX(PE,PM)
	+ PA=SQRT(P(IPA,4)2-P(IPA,5)2)
	+ P(IPA,1)=PASIN(THE)COS(PHI)
	+ P(IPA,2)=PASIN(THE)SIN(PHI)
	+ P(IPA,3)=PA*COS(THE)
	+
	+C...Set N. Optionally fragment/decay.
	+ N=IPA
	+ IF(IP.EQ.0) CALL PYEXEC
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY2ENT
	+C...Stores two partons/particles in their CM frame,
	+C...with the first along the +z axis.
	+
	+ SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Standard checks.
	+ MSTU(28)=0
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IPA=MAX(1,IABS(IP))
	+ IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
	+ &'(PY2ENT:) writing outside PYJETS memory')
	+ KC1=PYCOMP(KF1)
	+ KC2=PYCOMP(KF2)
	+ IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
	+ &'(PY2ENT:) unknown flavour code')
	+
	+C...Find masses. Reset K, P and V vectors.
	+ PM1=0D0
	+ IF(MSTU(10).EQ.1) PM1=P(IPA,5)
	+ IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
	+ PM2=0D0
	+ IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
	+ IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
	+ DO 110 I=IPA,IPA+1
	+ DO 100 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+C...Check flavours.
	+ KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
	+ KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
	+ IF(MSTU(19).EQ.1) THEN
	+ MSTU(19)=0
	+ ELSE
	+ IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
	+ & '(PY2ENT:) unphysical flavour combination')
	+ ENDIF
	+ K(IPA,2)=KF1
	+ K(IPA+1,2)=KF2
	+
	+C...Store partons/particles in K vectors for normal case.
	+ IF(IP.GE.0) THEN
	+ K(IPA,1)=1
	+ IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
	+ K(IPA+1,1)=1
	+
	+C...Store partons in K vectors for parton shower evolution.
	+ ELSE
	+ K(IPA,1)=3
	+ K(IPA+1,1)=3
	+ K(IPA,4)=MSTU(5)*(IPA+1)
	+ K(IPA,5)=K(IPA,4)
	+ K(IPA+1,4)=MSTU(5)*IPA
	+ K(IPA+1,5)=K(IPA+1,4)
	+ ENDIF
	+
	+C...Check kinematics and store partons/particles in P vectors.
	+ IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
	+ &'(PY2ENT:) energy smaller than sum of masses')
	+ PA=SQRT(MAX(0D0,(PECM2-PM12-PM22)2-(2D0PM1PM2)**2))/
	+ &(2D0*PECM)
	+ P(IPA,3)=PA
	+ P(IPA,4)=SQRT(PM12+PA2)
	+ P(IPA,5)=PM1
	+ P(IPA+1,3)=-PA
	+ P(IPA+1,4)=SQRT(PM22+PA2)
	+ P(IPA+1,5)=PM2
	+
	+C...Set N. Optionally fragment/decay.
	+ N=IPA+1
	+ IF(IP.EQ.0) CALL PYEXEC
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY3ENT
	+C...Stores three partons or particles in their CM frame,
	+C...with the first along the +z axis and the third in the (x,z)
	+C...plane with x > 0.
	+
	+ SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Standard checks.
	+ MSTU(28)=0
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IPA=MAX(1,IABS(IP))
	+ IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
	+ &'(PY3ENT:) writing outside PYJETS memory')
	+ KC1=PYCOMP(KF1)
	+ KC2=PYCOMP(KF2)
	+ KC3=PYCOMP(KF3)
	+ IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
	+ &'(PY3ENT:) unknown flavour code')
	+
	+C...Find masses. Reset K, P and V vectors.
	+ PM1=0D0
	+ IF(MSTU(10).EQ.1) PM1=P(IPA,5)
	+ IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
	+ PM2=0D0
	+ IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
	+ IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
	+ PM3=0D0
	+ IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
	+ IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
	+ DO 110 I=IPA,IPA+2
	+ DO 100 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+C...Check flavours.
	+ KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
	+ KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
	+ KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
	+ IF(MSTU(19).EQ.1) THEN
	+ MSTU(19)=0
	+ ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
	+ ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
	+ & KQ1+KQ3.EQ.4)) THEN
	+ ELSE
	+ CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
	+ ENDIF
	+ K(IPA,2)=KF1
	+ K(IPA+1,2)=KF2
	+ K(IPA+2,2)=KF3
	+
	+C...Store partons/particles in K vectors for normal case.
	+ IF(IP.GE.0) THEN
	+ K(IPA,1)=1
	+ IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
	+ K(IPA+1,1)=1
	+ IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
	+ K(IPA+2,1)=1
	+
	+C...Store partons in K vectors for parton shower evolution.
	+ ELSE
	+ K(IPA,1)=3
	+ K(IPA+1,1)=3
	+ K(IPA+2,1)=3
	+ KCS=4
	+ IF(KQ1.EQ.-1) KCS=5
	+ K(IPA,KCS)=MSTU(5)*(IPA+1)
	+ K(IPA,9-KCS)=MSTU(5)*(IPA+2)
	+ K(IPA+1,KCS)=MSTU(5)*(IPA+2)
	+ K(IPA+1,9-KCS)=MSTU(5)*IPA
	+ K(IPA+2,KCS)=MSTU(5)*IPA
	+ K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
	+ ENDIF
	+
	+C...Check kinematics.
	+ MKERR=0
	+ IF(0.5D0X1PECM.LE.PM1.OR.0.5D0(2D0-X1-X3)PECM.LE.PM2.OR.
	+ &0.5D0X3PECM.LE.PM3) MKERR=1
	+ PA1=SQRT(MAX(1D-10,(0.5D0X1PECM)2-PM12))
	+ PA2=SQRT(MAX(1D-10,(0.5D0(2D0-X1-X3)PECM)2-PM22))
	+ PA3=SQRT(MAX(1D-10,(0.5D0X3PECM)2-PM32))
	+ CTHE2=(PA32-PA12-PA2*2)/(2D0PA1*PA2)
	+ CTHE3=(PA22-PA12-PA3*2)/(2D0PA1*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(PA12+PM12)
	+ P(IPA,5)=PM1
	+ P(IPA+2,1)=PA3SQRT(1D0-CTHE3*2)
	+ P(IPA+2,3)=PA3*CTHE3
	+ P(IPA+2,4)=SQRT(PA32+PM32)
	+ P(IPA+2,5)=PM3
	+ P(IPA+1,1)=-P(IPA+2,1)
	+ P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
	+ P(IPA+1,4)=SQRT(P(IPA+1,1)2+P(IPA+1,3)2+PM2**2)
	+ P(IPA+1,5)=PM2
	+
	+C...Set N. Optionally fragment/decay.
	+ N=IPA+2
	+ IF(IP.EQ.0) CALL PYEXEC
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY4ENT
	+C...Stores four partons or particles in their CM frame, with
	+C...the first along the +z axis, the last in the xz plane with x > 0
	+C...and the second having y < 0 and y > 0 with equal probability.
	+
	+ SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Standard checks.
	+ MSTU(28)=0
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IPA=MAX(1,IABS(IP))
	+ IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
	+ &'(PY4ENT:) writing outside PYJETS momory')
	+ KC1=PYCOMP(KF1)
	+ KC2=PYCOMP(KF2)
	+ KC3=PYCOMP(KF3)
	+ KC4=PYCOMP(KF4)
	+ IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
	+ &'(PY4ENT:) unknown flavour code')
	+
	+C...Find masses. Reset K, P and V vectors.
	+ PM1=0D0
	+ IF(MSTU(10).EQ.1) PM1=P(IPA,5)
	+ IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
	+ PM2=0D0
	+ IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
	+ IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
	+ PM3=0D0
	+ IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
	+ IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
	+ PM4=0D0
	+ IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
	+ IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
	+ DO 110 I=IPA,IPA+3
	+ DO 100 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+C...Check flavours.
	+ KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
	+ KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
	+ KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
	+ KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
	+ IF(MSTU(19).EQ.1) THEN
	+ MSTU(19)=0
	+ ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
	+ ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
	+ & KQ1+KQ4.EQ.4)) THEN
	+ ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
	+ & THEN
	+ ELSE
	+ CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
	+ ENDIF
	+ K(IPA,2)=KF1
	+ K(IPA+1,2)=KF2
	+ K(IPA+2,2)=KF3
	+ K(IPA+3,2)=KF4
	+
	+C...Store partons/particles in K vectors for normal case.
	+ IF(IP.GE.0) THEN
	+ K(IPA,1)=1
	+ IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
	+ K(IPA+1,1)=1
	+ IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
	+ & K(IPA+1,1)=2
	+ K(IPA+2,1)=1
	+ IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
	+ K(IPA+3,1)=1
	+
	+C...Store partons for parton shower evolution from q-g-g-qbar or
	+C...g-g-g-g event.
	+ ELSEIF(KQ1+KQ2.NE.0) THEN
	+ K(IPA,1)=3
	+ K(IPA+1,1)=3
	+ K(IPA+2,1)=3
	+ K(IPA+3,1)=3
	+ KCS=4
	+ IF(KQ1.EQ.-1) KCS=5
	+ K(IPA,KCS)=MSTU(5)*(IPA+1)
	+ K(IPA,9-KCS)=MSTU(5)*(IPA+3)
	+ K(IPA+1,KCS)=MSTU(5)*(IPA+2)
	+ K(IPA+1,9-KCS)=MSTU(5)*IPA
	+ K(IPA+2,KCS)=MSTU(5)*(IPA+3)
	+ K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
	+ K(IPA+3,KCS)=MSTU(5)*IPA
	+ K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
	+
	+C...Store partons for parton shower evolution from q-qbar-q-qbar event.
	+ ELSE
	+ K(IPA,1)=3
	+ K(IPA+1,1)=3
	+ K(IPA+2,1)=3
	+ K(IPA+3,1)=3
	+ K(IPA,4)=MSTU(5)*(IPA+1)
	+ K(IPA,5)=K(IPA,4)
	+ K(IPA+1,4)=MSTU(5)*IPA
	+ K(IPA+1,5)=K(IPA+1,4)
	+ K(IPA+2,4)=MSTU(5)*(IPA+3)
	+ K(IPA+2,5)=K(IPA+2,4)
	+ K(IPA+3,4)=MSTU(5)*(IPA+2)
	+ K(IPA+3,5)=K(IPA+3,4)
	+ ENDIF
	+
	+C...Check kinematics.
	+ MKERR=0
	+ IF(0.5D0X1PECM.LE.PM1.OR.0.5D0X2PECM.LE.PM2.OR.
	+ &0.5D0(2D0-X1-X2-X4)PECM.LE.PM3.OR.0.5D0X4PECM.LE.PM4)
	+ &MKERR=1
	+ PA1=SQRT(MAX(1D-10,(0.5D0X1PECM)2-PM12))
	+ PA2=SQRT(MAX(1D-10,(0.5D0X2PECM)2-PM22))
	+ PA4=SQRT(MAX(1D-10,(0.5D0X4PECM)2-PM42))
	+ X24=X1+X2+X4-1D0-X12-X14+(PM32-PM12-PM22-PM42)/PECM**2
	+ CTHE4=(X1X4-2D0X14)PECM2/(4D0PA1*PA4)
	+ IF(ABS(CTHE4).GE.1.002D0) MKERR=1
	+ CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
	+ STHE4=SQRT(1D0-CTHE4**2)
	+ CTHE2=(X1X2-2D0X12)PECM2/(4D0PA1*PA2)
	+ IF(ABS(CTHE2).GE.1.002D0) MKERR=1
	+ CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
	+ STHE2=SQRT(1D0-CTHE2**2)
	+ CPHI2=((X2X4-2D0X24)PECM2-4D0PA2CTHE2PA4*CTHE4)/
	+ &MAX(1D-8PECM2,4D0PA2STHE2PA4*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(PA12+PM12)
	+ P(IPA,5)=PM1
	+ P(IPA+3,1)=PA4*STHE4
	+ P(IPA+3,3)=PA4*CTHE4
	+ P(IPA+3,4)=SQRT(PA42+PM42)
	+ P(IPA+3,5)=PM4
	+ P(IPA+1,1)=PA2STHE2CPHI2
	+ P(IPA+1,2)=PA2STHE2SQRT(1D0-CPHI2*2)(-1D0)**INT(PYR(0)+0.5D0)
	+ P(IPA+1,3)=PA2*CTHE2
	+ P(IPA+1,4)=SQRT(PA22+PM22)
	+ 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+PM32)
	+ P(IPA+2,5)=PM3
	+
	+C...Set N. Optionally fragment/decay.
	+ N=IPA+3
	+ IF(IP.EQ.0) CALL PYEXEC
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY2FRM
	+C...An interface from a two-fermion generator to include
	+C...parton showers and hadronization.
	+
	+ SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYJETS/,/PYDAT1/
	+C...Local arrays.
	+ DIMENSION IJOIN(2),INTAU(2)
	+
	+C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(2)
	+ ENDIF
	+
	+C...Loop through entries and pick up all final fermions/antifermions.
	+ I1=0
	+ I2=0
	+ DO 100 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	+ KFA=IABS(K(I,2))
	+ IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
	+ IF(K(I,2).GT.0) THEN
	+ IF(I1.EQ.0) THEN
	+ I1=I
	+ ELSE
	+ CALL PYERRM(16,'(PY2FRM:) more than one fermion')
	+ ENDIF
	+ ELSE
	+ IF(I2.EQ.0) THEN
	+ I2=I
	+ ELSE
	+ CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 100 CONTINUE
	+
	+C...Check that event is arranged according to conventions.
	+ IF(I1.EQ.0.OR.I2.EQ.0) THEN
	+ CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
	+ ENDIF
	+ IF(I2.LT.I1) THEN
	+ CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
	+ ENDIF
	+
	+C...Check whether fermion pair is quarks or leptons.
	+ IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
	+ IQL12=1
	+ ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
	+ IQL12=2
	+ ELSE
	+ CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
	+ ENDIF
	+
	+C...Decide whether to allow or not photon radiation in showers.
	+ MSTJ(41)=2
	+ IF(IRAD.EQ.0) MSTJ(41)=1
	+
	+C...Do colour joining and parton showers.
	+ IP1=I1
	+ IP2=I2
	+ IF(IQL12.EQ.1) THEN
	+ IJOIN(1)=IP1
	+ IJOIN(2)=IP2
	+ CALL PYJOIN(2,IJOIN)
	+ ENDIF
	+ IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
	+ PM12S=(P(IP1,4)+P(IP2,4))2-(P(IP1,1)+P(IP2,1))2-
	+ & (P(IP1,2)+P(IP2,2))2-(P(IP1,3)+P(IP2,3))2
	+ CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
	+ ENDIF
	+
	+C...Do fragmentation and decays. Possibly except tau decay.
	+ IF(ITAU.EQ.0) THEN
	+ NTAU=0
	+ DO 110 I=1,N
	+ IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
	+ NTAU=NTAU+1
	+ INTAU(NTAU)=I
	+ K(I,1)=11
	+ ENDIF
	+ 110 CONTINUE
	+ ENDIF
	+ CALL PYEXEC
	+ IF(ITAU.EQ.0) THEN
	+ DO 120 I=1,NTAU
	+ K(INTAU(I),1)=1
	+ 120 CONTINUE
	+ ENDIF
	+
	+C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(1)
	+ ENDIF
	+
	+ END
	+
	+C*********************************************************************
	+
	+C...PY4FRM
	+C...An interface from a four-fermion generator to include
	+C...parton showers and hadronization.
	+
	+ SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
	+C...Local arrays.
	+ DIMENSION IJOIN(2),INTAU(4)
	+
	+C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(2)
	+ ENDIF
	+
	+C...Loop through entries and pick up all final fermions/antifermions.
	+ I1=0
	+ I2=0
	+ I3=0
	+ I4=0
	+ DO 100 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	+ KFA=IABS(K(I,2))
	+ IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
	+ IF(K(I,2).GT.0) THEN
	+ IF(I1.EQ.0) THEN
	+ I1=I
	+ ELSEIF(I3.EQ.0) THEN
	+ I3=I
	+ ELSE
	+ CALL PYERRM(16,'(PY4FRM:) more than two fermions')
	+ ENDIF
	+ ELSE
	+ IF(I2.EQ.0) THEN
	+ I2=I
	+ ELSEIF(I4.EQ.0) THEN
	+ I4=I
	+ ELSE
	+ CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 100 CONTINUE
	+
	+C...Check that event is arranged according to conventions.
	+ IF(I3.EQ.0.OR.I4.EQ.0) THEN
	+ CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
	+ ENDIF
	+ IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
	+ CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
	+ ENDIF
	+
	+C...Check which fermion pairs are quarks and which leptons.
	+ IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
	+ IQL12=1
	+ ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
	+ IQL12=2
	+ ELSE
	+ CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
	+ ENDIF
	+ IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
	+ IQL34=1
	+ ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
	+ IQL34=2
	+ ELSE
	+ CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
	+ ENDIF
	+
	+C...Decide whether to allow or not photon radiation in showers.
	+ MSTJ(41)=2
	+ IF(IRAD.EQ.0) MSTJ(41)=1
	+
	+C...Decide on dipole pairing.
	+ IP1=I1
	+ IP2=I2
	+ IP3=I3
	+ IP4=I4
	+ IF(IQL12.EQ.IQL34) THEN
	+ R1SQ=A1SQ
	+ R2SQ=A2SQ
	+ DELTA=ATOTSQ-A1SQ-A2SQ
	+ IF(ISTRAT.EQ.1) THEN
	+ IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
	+ IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
	+ ELSEIF(ISTRAT.EQ.2) THEN
	+ IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
	+ IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
	+ ENDIF
	+ IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
	+ IP2=I4
	+ IP4=I2
	+ ENDIF
	+ ENDIF
	+
	+C...If colour reconnection then bookkeep W+W- or Z0Z0
	+C...and copy q qbar q qbar consecutively.
	+ IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
	+ K(N+1,1)=11
	+ K(N+1,3)=IP1
	+ K(N+1,4)=N+3
	+ K(N+1,5)=N+4
	+ K(N+2,1)=11
	+ K(N+2,3)=IP3
	+ K(N+2,4)=N+5
	+ K(N+2,5)=N+6
	+ IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
	+ K(N+1,2)=23
	+ K(N+2,2)=23
	+ MINT(1)=22
	+ ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
	+ K(N+1,2)=24
	+ K(N+2,2)=-24
	+ MINT(1)=25
	+ ELSE
	+ K(N+1,2)=-24
	+ K(N+2,2)=24
	+ MINT(1)=25
	+ ENDIF
	+ DO 110 J=1,5
	+ K(N+3,J)=K(IP1,J)
	+ K(N+4,J)=K(IP2,J)
	+ K(N+5,J)=K(IP3,J)
	+ K(N+6,J)=K(IP4,J)
	+ P(N+1,J)=P(IP1,J)+P(IP2,J)
	+ P(N+2,J)=P(IP3,J)+P(IP4,J)
	+ P(N+3,J)=P(IP1,J)
	+ P(N+4,J)=P(IP2,J)
	+ P(N+5,J)=P(IP3,J)
	+ P(N+6,J)=P(IP4,J)
	+ V(N+1,J)=V(IP1,J)
	+ V(N+2,J)=V(IP3,J)
	+ V(N+3,J)=V(IP1,J)
	+ V(N+4,J)=V(IP2,J)
	+ V(N+5,J)=V(IP3,J)
	+ V(N+6,J)=V(IP4,J)
	+ 110 CONTINUE
	+ P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	+ & P(N+1,3)**2))
	+ P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)2-P(N+2,1)2-P(N+2,2)**2-
	+ & P(N+2,3)**2))
	+ K(N+3,3)=N+1
	+ K(N+4,3)=N+1
	+ K(N+5,3)=N+2
	+ K(N+6,3)=N+2
	+C...Remove original q qbar q qbar and update counters.
	+ K(IP1,1)=K(IP1,1)+10
	+ K(IP2,1)=K(IP2,1)+10
	+ K(IP3,1)=K(IP3,1)+10
	+ K(IP4,1)=K(IP4,1)+10
	+ IW1=N+1
	+ IW2=N+2
	+ NSD1=N+2
	+ IP1=N+3
	+ IP2=N+4
	+ IP3=N+5
	+ IP4=N+6
	+ N=N+6
	+ ENDIF
	+
	+C...Do colour joinings and parton showers.
	+ IF(IQL12.EQ.1) THEN
	+ IJOIN(1)=IP1
	+ IJOIN(2)=IP2
	+ CALL PYJOIN(2,IJOIN)
	+ ENDIF
	+ IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
	+ PM12S=(P(IP1,4)+P(IP2,4))2-(P(IP1,1)+P(IP2,1))2-
	+ & (P(IP1,2)+P(IP2,2))2-(P(IP1,3)+P(IP2,3))2
	+ CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
	+ ENDIF
	+ NAFT1=N
	+ IF(IQL34.EQ.1) THEN
	+ IJOIN(1)=IP3
	+ IJOIN(2)=IP4
	+ CALL PYJOIN(2,IJOIN)
	+ ENDIF
	+ IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
	+ PM34S=(P(IP3,4)+P(IP4,4))2-(P(IP3,1)+P(IP4,1))2-
	+ & (P(IP3,2)+P(IP4,2))2-(P(IP3,3)+P(IP4,3))2
	+ CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
	+ ENDIF
	+
	+C...Optionally do colour reconnection.
	+ MINT(32)=0
	+ MSTI(32)=0
	+ IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
	+ CALL PYRECO(IW1,IW2,NSD1,NAFT1)
	+ MSTI(32)=MINT(32)
	+ ENDIF
	+
	+C...Do fragmentation and decays. Possibly except tau decay.
	+ IF(ITAU.EQ.0) THEN
	+ NTAU=0
	+ DO 120 I=1,N
	+ IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
	+ NTAU=NTAU+1
	+ INTAU(NTAU)=I
	+ K(I,1)=11
	+ ENDIF
	+ 120 CONTINUE
	+ ENDIF
	+ CALL PYEXEC
	+ IF(ITAU.EQ.0) THEN
	+ DO 130 I=1,NTAU
	+ K(INTAU(I),1)=1
	+ 130 CONTINUE
	+ ENDIF
	+
	+C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(1)
	+ ENDIF
	+
	+ END
	+
	+C*********************************************************************
	+
	+C...PY6FRM
	+C...An interface from a six-fermion generator to include
	+C...parton showers and hadronization.
	+
	+ SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYJETS/,/PYDAT1/
	+C...Local arrays.
	+ DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
	+
	+C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(2)
	+ ENDIF
	+
	+C...Loop through entries and pick up all final fermions/antifermions.
	+ I1=0
	+ I2=0
	+ I3=0
	+ I4=0
	+ I5=0
	+ I6=0
	+ DO 100 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	+ KFA=IABS(K(I,2))
	+ IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
	+ IF(K(I,2).GT.0) THEN
	+ IF(I1.EQ.0) THEN
	+ I1=I
	+ ELSEIF(I3.EQ.0) THEN
	+ I3=I
	+ ELSEIF(I5.EQ.0) THEN
	+ I5=I
	+ ELSE
	+ CALL PYERRM(16,'(PY6FRM:) more than three fermions')
	+ ENDIF
	+ ELSE
	+ IF(I2.EQ.0) THEN
	+ I2=I
	+ ELSEIF(I4.EQ.0) THEN
	+ I4=I
	+ ELSEIF(I6.EQ.0) THEN
	+ I6=I
	+ ELSE
	+ CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 100 CONTINUE
	+
	+C...Check that event is arranged according to conventions.
	+ IF(I5.EQ.0.OR.I6.EQ.0) THEN
	+ CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
	+ ENDIF
	+ IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
	+ CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
	+ ENDIF
	+
	+C...Check which fermion pairs are quarks and which leptons.
	+ IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
	+ IQL12=1
	+ ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
	+ IQL12=2
	+ ELSE
	+ CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
	+ ENDIF
	+ IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
	+ IQL34=1
	+ ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
	+ IQL34=2
	+ ELSE
	+ CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
	+ ENDIF
	+ IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
	+ IQL56=1
	+ ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
	+ IQL56=2
	+ ELSE
	+ CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
	+ ENDIF
	+
	+C...Decide whether to allow or not photon radiation in showers.
	+ MSTJ(41)=2
	+ IF(IRAD.EQ.0) MSTJ(41)=1
	+
	+C...Allow dipole pairings only among leptons and quarks separately.
	+ P12D=P12
	+ P13D=0D0
	+ IF(IQL34.EQ.IQL56) P13D=P13
	+ P21D=0D0
	+ IF(IQL12.EQ.IQL34) P21D=P21
	+ P23D=0D0
	+ IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
	+ P31D=0D0
	+ IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
	+ P32D=0D0
	+ IF(IQL12.EQ.IQL56) P32D=P32
	+
	+C...Decide whether t+tbar.
	+ ITOP=0
	+ IF(PYR(0).LT.PTOP) THEN
	+ ITOP=1
	+
	+C...If t+tbar: reconstruct t's.
	+ IT=N+1
	+ ITB=N+2
	+ DO 110 J=1,5
	+ K(IT,J)=0
	+ K(ITB,J)=0
	+ P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
	+ P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
	+ V(IT,J)=0D0
	+ V(ITB,J)=0D0
	+ 110 CONTINUE
	+ K(IT,1)=1
	+ K(ITB,1)=1
	+ K(IT,2)=6
	+ K(ITB,2)=-6
	+ P(IT,5)=SQRT(MAX(0D0,P(IT,4)2-P(IT,1)2-P(IT,2)**2-
	+ & P(IT,3)**2))
	+ P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)2-P(ITB,1)2-P(ITB,2)**2-
	+ & P(ITB,3)**2))
	+ N=N+2
	+
	+C...If t+tbar: colour join t's and let them shower.
	+ IJOIN(1)=IT
	+ IJOIN(2)=ITB
	+ CALL PYJOIN(2,IJOIN)
	+ PMTTS=(P(IT,4)+P(ITB,4))2-(P(IT,1)+P(ITB,1))2-
	+ & (P(IT,2)+P(ITB,2))2-(P(IT,3)+P(ITB,3))2
	+ CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
	+
	+C...If t+tbar: pick up the t's after shower.
	+ ITNEW=IT
	+ ITBNEW=ITB
	+ DO 120 I=ITB+1,N
	+ IF(K(I,2).EQ.6) ITNEW=I
	+ IF(K(I,2).EQ.-6) ITBNEW=I
	+ 120 CONTINUE
	+
	+C...If t+tbar: loop over two top systems.
	+ DO 200 IT1=1,2
	+ IF(IT1.EQ.1) THEN
	+ ITO=IT
	+ ITN=ITNEW
	+ IBO=I1
	+ IW1=I3
	+ IW2=I4
	+ ELSE
	+ ITO=ITB
	+ ITN=ITBNEW
	+ IBO=I2
	+ IW1=I5
	+ IW2=I6
	+ ENDIF
	+ IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
	+ & '(PY6FRM:) not b in t decay')
	+
	+C...If t+tbar: find boost from original to new top frame.
	+ DO 130 J=1,3
	+ BETAO(J)=P(ITO,J)/P(ITO,4)
	+ BETAN(J)=P(ITN,J)/P(ITN,4)
	+ 130 CONTINUE
	+
	+C...If t+tbar: boost copy of b by t shower and connect it in colour.
	+ N=N+1
	+ IB=N
	+ K(IB,1)=3
	+ K(IB,2)=K(IBO,2)
	+ K(IB,3)=ITN
	+ DO 140 J=1,5
	+ P(IB,J)=P(IBO,J)
	+ V(IB,J)=0D0
	+ 140 CONTINUE
	+ CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
	+ CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
	+ K(IB,4)=MSTU(5)*ITN
	+ K(IB,5)=MSTU(5)*ITN
	+ K(ITN,4)=K(ITN,4)+IB
	+ K(ITN,5)=K(ITN,5)+IB
	+ K(ITN,1)=K(ITN,1)+10
	+ K(IBO,1)=K(IBO,1)+10
	+
	+C...If t+tbar: construct W recoiling against b.
	+ N=N+1
	+ IW=N
	+ DO 150 J=1,5
	+ K(IW,J)=0
	+ V(IW,J)=0D0
	+ 150 CONTINUE
	+ K(IW,1)=1
	+ KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
	+ IF(IABS(KCHW).EQ.3) THEN
	+ K(IW,2)=ISIGN(24,KCHW)
	+ ELSE
	+ CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
	+ ENDIF
	+ K(IW,3)=IW1
	+
	+C...If t+tbar: construct W momentum, including boost by t shower.
	+ DO 160 J=1,4
	+ P(IW,J)=P(IW1,J)+P(IW2,J)
	+ 160 CONTINUE
	+ P(IW,5)=SQRT(MAX(0D0,P(IW,4)2-P(IW,1)2-P(IW,2)**2-
	+ & P(IW,3)**2))
	+ CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
	+ CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
	+
	+C...If t+tbar: boost b and W to top rest frame.
	+ DO 170 J=1,3
	+ BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
	+ 170 CONTINUE
	+ CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+ CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+
	+C...If t+tbar: let b shower and pick up modified W.
	+ PMTS=(P(IB,4)+P(IW,4))2-(P(IB,1)+P(IW,1))2-
	+ & (P(IB,2)+P(IW,2))2-(P(IB,3)+P(IW,3))2
	+ CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
	+ DO 180 I=IW,N
	+ IF(IABS(K(I,2)).EQ.24) IWM=I
	+ 180 CONTINUE
	+
	+C...If t+tbar: take copy of W decay products.
	+ DO 190 J=1,5
	+ K(N+1,J)=K(IW1,J)
	+ P(N+1,J)=P(IW1,J)
	+ V(N+1,J)=V(IW1,J)
	+ K(N+2,J)=K(IW2,J)
	+ P(N+2,J)=P(IW2,J)
	+ V(N+2,J)=V(IW2,J)
	+ 190 CONTINUE
	+ K(IW1,1)=K(IW1,1)+10
	+ K(IW2,1)=K(IW2,1)+10
	+ K(IWM,1)=K(IWM,1)+10
	+ K(IWM,4)=N+1
	+ K(IWM,5)=N+2
	+ K(N+1,3)=IWM
	+ K(N+2,3)=IWM
	+ IF(IT1.EQ.1) THEN
	+ I3=N+1
	+ I4=N+2
	+ ELSE
	+ I5=N+1
	+ I6=N+2
	+ ENDIF
	+ N=N+2
	+
	+C...If t+tbar: boost W decay products, first by effects of t shower,
	+C...then by those of b shower. b and its shower simple boost back.
	+ CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
	+ CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
	+ CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+ CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
	+ & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
	+ CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
	+ & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
	+ CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ 200 CONTINUE
	+ ENDIF
	+
	+C...Decide on dipole pairing.
	+ IP1=I1
	+ IP3=I3
	+ IP5=I5
	+ PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
	+ IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
	+ IP2=I2
	+ IP4=I4
	+ IP6=I6
	+ ELSEIF(PRN.LT.P12D+P13D) THEN
	+ IP2=I2
	+ IP4=I6
	+ IP6=I4
	+ ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
	+ IP2=I4
	+ IP4=I2
	+ IP6=I6
	+ ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
	+ IP2=I4
	+ IP4=I6
	+ IP6=I2
	+ ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
	+ IP2=I6
	+ IP4=I2
	+ IP6=I4
	+ ELSE
	+ IP2=I6
	+ IP4=I4
	+ IP6=I2
	+ ENDIF
	+
	+C...Do colour joinings and parton showers
	+C...(except ones already made for t+tbar).
	+ IF(ITOP.EQ.0) THEN
	+ IF(IQL12.EQ.1) THEN
	+ IJOIN(1)=IP1
	+ IJOIN(2)=IP2
	+ CALL PYJOIN(2,IJOIN)
	+ ENDIF
	+ IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
	+ PM12S=(P(IP1,4)+P(IP2,4))2-(P(IP1,1)+P(IP2,1))2-
	+ & (P(IP1,2)+P(IP2,2))2-(P(IP1,3)+P(IP2,3))2
	+ CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
	+ ENDIF
	+ ENDIF
	+ IF(IQL34.EQ.1) THEN
	+ IJOIN(1)=IP3
	+ IJOIN(2)=IP4
	+ CALL PYJOIN(2,IJOIN)
	+ ENDIF
	+ IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
	+ PM34S=(P(IP3,4)+P(IP4,4))2-(P(IP3,1)+P(IP4,1))2-
	+ & (P(IP3,2)+P(IP4,2))2-(P(IP3,3)+P(IP4,3))2
	+ CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
	+ ENDIF
	+ IF(IQL56.EQ.1) THEN
	+ IJOIN(1)=IP5
	+ IJOIN(2)=IP6
	+ CALL PYJOIN(2,IJOIN)
	+ ENDIF
	+ IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
	+ PM56S=(P(IP5,4)+P(IP6,4))2-(P(IP5,1)+P(IP6,1))2-
	+ & (P(IP5,2)+P(IP6,2))2-(P(IP5,3)+P(IP6,3))2
	+ CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
	+ ENDIF
	+
	+C...Do fragmentation and decays. Possibly except tau decay.
	+ IF(ITAU.EQ.0) THEN
	+ NTAU=0
	+ DO 210 I=1,N
	+ IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
	+ NTAU=NTAU+1
	+ INTAU(NTAU)=I
	+ K(I,1)=11
	+ ENDIF
	+ 210 CONTINUE
	+ ENDIF
	+ CALL PYEXEC
	+ IF(ITAU.EQ.0) THEN
	+ DO 220 I=1,NTAU
	+ K(INTAU(I),1)=1
	+ 220 CONTINUE
	+ ENDIF
	+
	+C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(1)
	+ ENDIF
	+
	+ END
	+
	+C*********************************************************************
	+
	+C...PY4JET
	+C...An interface from a four-parton generator to include
	+C...parton showers and hadronization.
	+
	+ SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYJETS/,/PYDAT1/
	+C...Local arrays.
	+ DIMENSION IJOIN(2),PTOT(4),BETA(3)
	+
	+C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(2)
	+ ENDIF
	+
	+C...Loop through entries and pick up all final partons.
	+ I1=0
	+ I2=0
	+ I3=0
	+ I4=0
	+ DO 100 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	+ KFA=IABS(K(I,2))
	+ IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
	+ IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
	+ IF(I1.EQ.0) THEN
	+ I1=I
	+ ELSEIF(I3.EQ.0) THEN
	+ I3=I
	+ ELSE
	+ CALL PYERRM(16,'(PY4JET:) more than two quarks')
	+ ENDIF
	+ ELSEIF(K(I,2).LT.0) THEN
	+ IF(I2.EQ.0) THEN
	+ I2=I
	+ ELSEIF(I4.EQ.0) THEN
	+ I4=I
	+ ELSE
	+ CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
	+ ENDIF
	+ ELSE
	+ IF(I3.EQ.0) THEN
	+ I3=I
	+ ELSEIF(I4.EQ.0) THEN
	+ I4=I
	+ ELSE
	+ CALL PYERRM(16,'(PY4JET:) more than two gluons')
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ 100 CONTINUE
	+
	+C...Check that event is arranged according to conventions.
	+ IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
	+ CALL PYERRM(16,'(PY4JET:) event contains too few partons')
	+ ENDIF
	+ IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
	+ CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
	+ ENDIF
	+
	+C...Check whether second pair are quarks or gluons.
	+ IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
	+ IQG34=1
	+ ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
	+ IQG34=2
	+ ELSE
	+ CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
	+ ENDIF
	+
	+C...Boost partons to their cm frame.
	+ DO 110 J=1,4
	+ PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
	+ 110 CONTINUE
	+ ECM=SQRT(MAX(0D0,PTOT(4)2-PTOT(1)2-PTOT(2)2-PTOT(3)2))
	+ DO 120 J=1,3
	+ BETA(J)=PTOT(J)/PTOT(4)
	+ 120 CONTINUE
	+ CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+ CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+ CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+ CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
	+ NSAV=N
	+
	+C...Decide and set up shower history for q qbar q' qbar' events.
	+ IF(IQG34.EQ.1) THEN
	+ W1=PY4JTW(0,I1,I3,I4)
	+ W2=PY4JTW(0,I2,I3,I4)
	+ IF(W1.GT.PYR(0)*(W1+W2)) THEN
	+ CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
	+ ELSE
	+ CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
	+ ENDIF
	+
	+C...Decide and set up shower history for q qbar g g events.
	+ ELSE
	+ W1=PY4JTW(I1,I3,I2,I4)
	+ W2=PY4JTW(I1,I4,I2,I3)
	+ W3=PY4JTW(0,I3,I1,I4)
	+ W4=PY4JTW(0,I4,I1,I3)
	+ W5=PY4JTW(0,I3,I2,I4)
	+ W6=PY4JTW(0,I4,I2,I3)
	+ W7=PY4JTW(0,I1,I3,I4)
	+ W8=PY4JTW(0,I2,I3,I4)
	+ WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
	+ IF(W1.GT.WR) THEN
	+ CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
	+ ELSEIF(W1+W2.GT.WR) THEN
	+ CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
	+ ELSEIF(W1+W2+W3.GT.WR) THEN
	+ CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
	+ ELSEIF(W1+W2+W3+W4.GT.WR) THEN
	+ CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
	+ ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
	+ CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
	+ ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
	+ CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
	+ ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
	+ CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
	+ ELSE
	+ CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
	+ ENDIF
	+ ENDIF
	+
	+C...Boost back original partons and mark them as deleted.
	+ CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
	+ K(I1,1)=K(I1,1)+10
	+ K(I2,1)=K(I2,1)+10
	+ K(I3,1)=K(I3,1)+10
	+ K(I4,1)=K(I4,1)+10
	+
	+C...Rotate shower initiating partons to be along z axis.
	+ PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
	+ CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
	+ THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
	+ CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
	+
	+C...Set up copy of shower initiating partons as on mass shell.
	+ DO 140 I=N+1,N+2
	+ DO 130 J=1,5
	+ K(I,J)=0
	+ P(I,J)=0D0
	+ V(I,J)=V(I1,J)
	+ 130 CONTINUE
	+ K(I,1)=1
	+ K(I,2)=K(I-6,2)
	+ 140 CONTINUE
	+ IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
	+ K(N+1,3)=I1
	+ P(N+1,5)=P(I1,5)
	+ K(N+2,3)=I2
	+ P(N+2,5)=P(I2,5)
	+ ELSE
	+ K(N+1,3)=I2
	+ P(N+1,5)=P(I2,5)
	+ K(N+2,3)=I1
	+ P(N+2,5)=P(I1,5)
	+ ENDIF
	+ PABS=SQRT(MAX(0D0,(ECM2-P(N+1,5)2-P(N+2,5)2)2-
	+ &(2D0P(N+1,5)P(N+2,5))*2))/(2D0ECM)
	+ P(N+1,3)=PABS
	+ P(N+1,4)=SQRT(PABS2+P(N+1,5)2)
	+ P(N+2,3)=-PABS
	+ P(N+2,4)=SQRT(PABS2+P(N+2,5)2)
	+ N=N+2
	+
	+C...Decide whether to allow or not photon radiation in showers.
	+C...Connect up colours.
	+ MSTJ(41)=2
	+ IF(IRAD.EQ.0) MSTJ(41)=1
	+ IJOIN(1)=N-1
	+ IJOIN(2)=N
	+ CALL PYJOIN(2,IJOIN)
	+
	+C...Decide on maximum virtuality and do parton shower.
	+ IF(PMAX.LT.PARJ(82)) THEN
	+ PQMAX=QMAX
	+ ELSE
	+ PQMAX=PMAX
	+ ENDIF
	+ CALL PYSHOW(NSAV+1,-100,PQMAX)
	+
	+C...Rotate and boost back system.
	+ CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
	+
	+C...Do fragmentation and decays.
	+ CALL PYEXEC
	+
	+C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
	+ IF(ICOM.EQ.0) THEN
	+ MSTU(28)=0
	+ CALL PYHEPC(1)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY4JTW
	+C...Auxiliary to PY4JET, to evaluate weight of configuration.
	+
	+ FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ SAVE /PYJETS/
	+
	+C...First case: when both original partons radiate.
	+C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
	+ IF(IA1.NE.0) THEN
	+ DO 100 J=1,4
	+ P(N+1,J)=P(IA1,J)+P(IA2,J)
	+ P(N+2,J)=P(IA3,J)+P(IA4,J)
	+ 100 CONTINUE
	+ P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	+ & P(N+1,3)**2))
	+ P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)2-P(N+2,1)2-P(N+2,2)**2-
	+ & P(N+2,3)**2))
	+ Z1=P(IA1,4)/P(N+1,4)
	+ WT1=(4D0/3D0)((1D0+Z12)/(1D0-Z1))/(P(N+1,5)2-P(IA1,5)*2)
	+ Z2=P(IA3,4)/P(N+2,4)
	+ WT2=(4D0/3D0)((1D0+Z22)/(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+Z12)/(1D0-Z1))/(P(N+1,5)*2-
	+ & P(IA3,5)**2)
	+ ELSE
	+ Z1=P(IA2,4)/P(N+1,4)
	+ WT1=(4D0/3D0)((1D0+Z12)/(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+Z22)/(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(Z22+(1D0-Z2)*2)
	+ ENDIF
	+ ENDIF
	+
	+C...Total weight.
	+ PY4JTW=WT1*WT2
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PY4JTS
	+C...Auxiliary to PY4JET, to set up chosen configuration.
	+
	+ SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ SAVE /PYJETS/
	+
	+C...Reset info.
	+ DO 110 I=N+1,N+6
	+ DO 100 J=1,5
	+ K(I,J)=0
	+ V(I,J)=V(IA2,J)
	+ 100 CONTINUE
	+ K(I,1)=16
	+ 110 CONTINUE
	+
	+C...First case: when both original partons radiate.
	+C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
	+ IF(IA1.NE.0) THEN
	+
	+C...Set up flavour and history pointers for new partons.
	+ K(N+1,2)=K(IA1,2)
	+ K(N+2,2)=K(IA3,2)
	+ K(N+3,2)=K(IA1,2)
	+ K(N+4,2)=K(IA2,2)
	+ K(N+5,2)=K(IA3,2)
	+ K(N+6,2)=K(IA4,2)
	+ K(N+1,3)=IA1
	+ K(N+1,4)=N+3
	+ K(N+1,5)=N+4
	+ K(N+2,3)=IA3
	+ K(N+2,4)=N+5
	+ K(N+2,5)=N+6
	+ K(N+3,3)=N+1
	+ K(N+4,3)=N+1
	+ K(N+5,3)=N+2
	+ K(N+6,3)=N+2
	+
	+C...Set up momenta for new partons.
	+ DO 120 J=1,5
	+ P(N+1,J)=P(IA1,J)+P(IA2,J)
	+ P(N+2,J)=P(IA3,J)+P(IA4,J)
	+ P(N+3,J)=P(IA1,J)
	+ P(N+4,J)=P(IA2,J)
	+ P(N+5,J)=P(IA3,J)
	+ P(N+6,J)=P(IA4,J)
	+ 120 CONTINUE
	+ P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	+ & P(N+1,3)**2))
	+ P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)2-P(N+2,1)2-P(N+2,2)**2-
	+ & P(N+2,3)**2))
	+ QMAX=MIN(P(N+1,5),P(N+2,5))
	+
	+C...Second case: q radiates twice.
	+C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
	+C...IA5=N+2 does not radiate.
	+ ELSEIF(K(IA2,2).EQ.21) THEN
	+
	+C...Set up flavour and history pointers for new partons.
	+ K(N+1,2)=K(IA3,2)
	+ K(N+2,2)=K(IA5,2)
	+ K(N+3,2)=K(IA3,2)
	+ K(N+4,2)=K(IA2,2)
	+ K(N+5,2)=K(IA3,2)
	+ K(N+6,2)=K(IA4,2)
	+ K(N+1,3)=IA3
	+ K(N+1,4)=N+3
	+ K(N+1,5)=N+4
	+ K(N+2,3)=IA5
	+ K(N+3,3)=N+1
	+ K(N+3,4)=N+5
	+ K(N+3,5)=N+6
	+ K(N+4,3)=N+1
	+ K(N+5,3)=N+3
	+ K(N+6,3)=N+3
	+
	+C...Set up momenta for new partons.
	+ DO 130 J=1,5
	+ P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
	+ P(N+2,J)=P(IA5,J)
	+ P(N+3,J)=P(IA3,J)+P(IA4,J)
	+ P(N+4,J)=P(IA2,J)
	+ P(N+5,J)=P(IA3,J)
	+ P(N+6,J)=P(IA4,J)
	+ 130 CONTINUE
	+ P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	+ & P(N+1,3)**2))
	+ P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)2-P(N+3,1)2-P(N+3,2)**2-
	+ & P(N+3,3)**2))
	+ QMAX=P(N+3,5)
	+
	+C...Third case: q radiates g, g branches.
	+C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
	+C...IA5=N+2 does not radiate.
	+ ELSE
	+
	+C...Set up flavour and history pointers for new partons.
	+ K(N+1,2)=K(IA2,2)
	+ K(N+2,2)=K(IA5,2)
	+ K(N+3,2)=K(IA2,2)
	+ K(N+4,2)=21
	+ K(N+5,2)=K(IA3,2)
	+ K(N+6,2)=K(IA4,2)
	+ K(N+1,3)=IA2
	+ K(N+1,4)=N+3
	+ K(N+1,5)=N+4
	+ K(N+2,3)=IA5
	+ K(N+3,3)=N+1
	+ K(N+4,3)=N+1
	+ K(N+4,4)=N+5
	+ K(N+4,5)=N+6
	+ K(N+5,3)=N+4
	+ K(N+6,3)=N+4
	+
	+C...Set up momenta for new partons.
	+ DO 140 J=1,5
	+ P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
	+ P(N+2,J)=P(IA5,J)
	+ P(N+3,J)=P(IA2,J)
	+ P(N+4,J)=P(IA3,J)+P(IA4,J)
	+ P(N+5,J)=P(IA3,J)
	+ P(N+6,J)=P(IA4,J)
	+ 140 CONTINUE
	+ P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)2-P(N+1,1)2-P(N+1,2)**2-
	+ & P(N+1,3)**2))
	+ P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)2-P(N+4,1)2-P(N+4,2)**2-
	+ & P(N+4,3)**2))
	+ QMAX=P(N+4,5)
	+
	+ ENDIF
	+ N=N+6
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYJOIN
	+C...Connects a sequence of partons with colour flow indices,
	+C...as required for subsequent shower evolution (or other operations).
	+
	+ SUBROUTINE PYJOIN(NJOIN,IJOIN)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local array.
	+ DIMENSION IJOIN(*)
	+
	+C...Check that partons are of right types to be connected.
	+ IF(NJOIN.LT.2) GOTO 120
	+ KQSUM=0
	+ DO 100 IJN=1,NJOIN
	+ I=IJOIN(IJN)
	+ IF(I.LE.0.OR.I.GT.N) GOTO 120
	+ IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0) GOTO 120
	+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
	+ IF(KQ.EQ.0) GOTO 120
	+ IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
	+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
	+ IF(IJN.EQ.1) KQS=KQ
	+ 100 CONTINUE
	+ IF(KQSUM.NE.0) GOTO 120
	+
	+C...Connect the partons sequentially (closing for gluon loop).
	+ KCS=(9-KQS)/2
	+ IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
	+ DO 110 IJN=1,NJOIN
	+ I=IJOIN(IJN)
	+ K(I,1)=3
	+ IF(IJN.NE.1) IP=IJOIN(IJN-1)
	+ IF(IJN.EQ.1) IP=IJOIN(NJOIN)
	+ IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
	+ IF(IJN.EQ.NJOIN) IN=IJOIN(1)
	+ K(I,KCS)=MSTU(5)*IN
	+ K(I,9-KCS)=MSTU(5)*IP
	+ IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
	+ IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
	+ 110 CONTINUE
	+
	+C...Error exit: no action taken.
	+ RETURN
	+ 120 CALL PYERRM(12,
	+ &'(PYJOIN:) given entries can not be joined by one string')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYGIVE
	+C...Sets values of commonblock variables.
	+
	+ SUBROUTINE PYGIVE(CHIN)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYDAT4/CHAF(500,2)
	+ CHARACTER CHAF*16
	+ COMMON/PYDATR/MRPY(6),RRPY(100)
	+ COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
	+ COMMON/PYINT6/PROC(0:500)
	+ CHARACTER PROC*28
	+ COMMON/PYINT7/SIGT(0:6,0:6,0:5)
	+ COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
	+ &XPDIR(-6:6)
	+ COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
	+ COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
	+ COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
	+ COMMON/PYPUED/IUED(0:99),RUED(0:99)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
	+ &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
	+ &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
	+C...Local arrays and character variables.
	+ CHARACTER CHIN(),CHFIX104,CHBIT104,CHOLD8,CHNEW8,CHOLD2*28,
	+ &CHNEW228,CHNAM6,CHVAR(56)6,CHALP(2)26,CHIND8,CHINI10,
	+ &CHINR16,CHDIG10
	+ 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,70, 1,2,1,4000,1,5,20,
	+ &2,2,1,4000,1,5,20, 2,2,1,4000,1,5,20, 1,1,1,200,4*0,
	+ &2,1,1,200,40, 1,1,1,200,40, 2,1,1,200,4*0,
	+ &1,2,1,500,1,4,20, 2,2,1,500,1,4,20, 2,1,1,2000,4*0,
	+ &2,2,1,4,1,4,20, 1,2,1,500,1,3,20, 1,2,1,8000,1,2,2*0,
	+ &2,1,1,8000,40, 1,2,1,8000,1,5,20, 3,2,1,500,1,2,2*0,
	+ &1,1,1,6,40, 2,1,1,100,40,
	+ &1,70, 1,1,1,500,40, 1,2,1,2,-40,40,20, 2,1,1,200,40,
	+ &1,1,1,200,40, 2,1,1,200,40, 1,1,1,200,40, 2,1,1,200,40,
	+ &1,1,1,400,40, 2,1,1,400,40, 1,1,1,500,4*0,
	+ &1,2,1,500,1,2,20, 2,2,1,500,1,20,20, 1,3,1,40,1,4,1,2,
	+ &2,2,1,2,-40,40,20, 1,2,1,1000,1,3,20, 2,1,1,1000,4*0,
	+ &1,1,1,500,40, 2,2,1,500,1,5,20, 1,2,0,500,1,3,2*0,
	+ &2,2,0,500,1,3,20, 4,1,0,500,40, 2,3,0,6,0,6,0,5,
	+ &2,1,-6,6,40, 2,1,-6,6,40, 2,1,-6,6,4*0,
	+ &2,1,-6,6,40, 2,1,-6,6,40, 1,1,0,99,40, 2,1,0,99,40,
	+ &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,40, 2,1,0,99,40, 1,1,0,99,40, 2,1,0,99,40/
	+ 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(),CHTMP104,CHFIX104,CHMODE10,CHCODE8,
	+ &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(MYTUNE)
	+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 ---- LHC tune variations on Pro-Q2O
	+C 136 Q12-F1 : Variation with wide fragmentation function (Mar 2012)
	+C 137 Q12-F2 : Variation with narrow fragmentation function (Mar 2012)
	+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 345 AMBT2B-CT6L : 2nd ATLAS MB tune, vers 'B', w CTEQ6L1 (Jul 2011)
	+C 346 AUET2B-CT6L : UE tune accompanying AMBT2B (Jul 2011)
	+C 347 AUET2B-CT66 : AUET2 with CTEQ 6.6 NLO PDFs (Nov 2011)
	+C 348 AUET2B-CT10 : AUET2 with CTEQ 10 NLO PDFs (Nov 2011)
	+C 349 AUET2B-NN21 : AUET2 with NNPDF 2.1 NLO PDFs (Nov 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 370 P12 : Retune of Perugia 2011 w CTEQ6L1 (Oct 2012)
	+C 371 P12-radHi : Variation with alphaS(pT/2)
	+C 372 P12-radLo : Variation with alphaS(2pT)
	+C 373 P12-mpiHi : Variation with more semi-hard MPI -> more UE
	+C 374 P12-loCR : Variation using lower CR strength -> more Nch
	+C 375 P12-noCR : Variation without any color reconnections
	+C 376 P12-FL : Variation with more longitudinal fragmentation
	+C 377 P12-FT : Variation with more transverse fragmentation
	+C 378 P12-M8LO : Variation using MSTW 2008 LO PDFs
	+C 379 P12-LO : Variation using MRST LO PDFs
	+
	+C ======= The Uppsala models ===========================================
	+C 1201 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
	+C 1202 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
	+C 1401 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
	+C 1402 GAL 1 : GAL 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...SAVE statements
	+ SAVE /PYDAT1/,/PYPARS/
	+
	+C...Internal parameters
	+ PARAMETER(MXTUNS=500)
	+ CHARACTER*8 CHDOC
	+ PARAMETER (CHDOC='Oct 2012')
	+ 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=130,139)/
	+ & 'Q12','Q12-radHi','Q12-radLo','Q12-mpiHi','Q12-noCR',
	+ & 'Q12-M','Q12-F1','Q12-F2','Q12-LE','Q12-TeV'/
	+ 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 'AMBT2B-CT6L1','AUET2B-CT6L1','AUET2B-CT66','AUET2B-CT10',
	+ 4 'AUET2B-NN21'/
	+ 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=370,379)/
	+ & 'P12','P12-radHi','P12-radLo','P12-mpiHi','P12-loCR',
	+ & 'P12-noCR','P12-FL','P12-FT','P12-M8LO','P12-LO**'/
	+ 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 (MYTUNE.LE.MXTUNS.AND.MYTUNE.GE.0) THEN
	+ CHNAME=CHNAMS(MYTUNE)
	+ IF (MYTUNE.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
	+ ITUNE = MYTUNE
	+
	+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
	+
	+ 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 P. Skands & D. Wicke, hep-ph/0703081'
	+ 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, AMBT2B, AUET2B + NLO PDF vars
	+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.349) 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...pT-ordered shower default for everything
	+ MSTJ(41) = 12
	+
	+C...FSR inside resonance decays, base value (modified by individual tunes)
	+ PARJ(81) = 0.29
	+
	+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 IF (ITUNE.LE.344) THEN
	+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
	+ ELSE
	+C... A*T2 tunes, from ATL-PHYS-PUB-2011-008
	+ PARJ( 1) = 0.073
	+ PARJ( 2) = 0.202
	+ PARJ( 3) = 0.950
	+ PARJ( 4) = 0.033
	+ PARJ(11) = 0.309
	+ PARJ(12) = 0.402
	+ PARJ(13) = 0.544
	+ PARJ(25) = 0.628
	+ PARJ(26) = 0.129
	+C...# Switch on Bowler:
	+ MSTJ(11) = 5
	+C... # Fragmentation
	+ PARJ(21) = 0.30
	+ PARJ(41) = 0.368
	+ PARJ(42) = 1.004
	+ PARJ(47) = 0.873
	+ PARJ(81) = 0.256
	+ PARJ(82) = 0.830
	+ ENDIF
	+
	+C...Default scales and alphaS choices
	+ IF (ITUNE.GE.345) THEN
	+ MSTP(3) = 1
	+ PARU(112) = 0.192
	+ PARP(1) = 0.192
	+ PARP(61) = 0.192
	+ 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
	+ ELSEIF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
	+C...AMBT2B, AUET2B use CTEQ6L1
	+ MSTP(52) = 2
	+ MSTP(51) = 10042
	+ ELSEIF (ITUNE.EQ.347) THEN
	+C...AUET2B-CT66 uses CTEQ66 NLO PDFs
	+ MSTP(52) = 2
	+ MSTP(51) = 10550
	+ ELSEIF (ITUNE.EQ.348) THEN
	+C...AUET2B-CT10 uses CTEQ10 NLO PDFs
	+ MSTP(52) = 2
	+ MSTP(51) = 10800
	+ ELSEIF (ITUNE.EQ.349) THEN
	+C...AUET2B-NN21 uses NNPDF 2.1 NLO PDF
	+ MSTP(52) = 2
	+ MSTP(51) = 192800
	+ 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
	+ ELSEIF (ITUNE.EQ.345) THEN
	+C...AMBT2B
	+ PARP(77) = 0.357D0
	+ PARP(78) = 0.235D0
	+ ELSEIF (ITUNE.EQ.346) THEN
	+C...AUET2B
	+ PARP(77) = 0.491D0
	+ PARP(78) = 0.311D0
	+ ELSEIF (ITUNE.EQ.347) THEN
	+C...AUET2B-CT66
	+ PARP(77) = 0.505D0
	+ PARP(78) = 0.385D0
	+ ELSEIF (ITUNE.EQ.348) THEN
	+C...AUET2B-CT10
	+ PARP(77) = 0.125D0
	+ PARP(78) = 0.309D0
	+ ELSEIF (ITUNE.EQ.349) THEN
	+C...AUET2B-NN21
	+ PARP(77) = 0.498D0
	+ PARP(78) = 0.354D0
	+ 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
	+ ELSEIF (ITUNE.EQ.345) THEN
	+ PARP(82) = 2.34
	+ PARP(83) = 0.356
	+ PARP(84) = 0.605
	+ PARP(90) = 0.246
	+ ELSEIF (ITUNE.EQ.346) THEN
	+ PARP(82) = 2.26
	+ PARP(83) = 0.356
	+ PARP(84) = 0.443
	+ PARP(90) = 0.249
	+ ELSEIF (ITUNE.EQ.347) THEN
	+ PARP(82) = 1.87
	+ PARP(83) = 0.356
	+ PARP(84) = 0.561
	+ PARP(90) = 0.189
	+ ELSEIF (ITUNE.EQ.348) THEN
	+ PARP(82) = 1.89
	+ PARP(83) = 0.356
	+ PARP(84) = 0.415
	+ PARP(90) = 0.182
	+ ELSEIF (ITUNE.EQ.349) THEN
	+ PARP(82) = 1.86
	+ PARP(83) = 0.356
	+ PARP(84) = 0.588
	+ PARP(90) = 0.177
	+ ENDIF
	+
	+C...Primordial kT
	+ PARP(91) = 2.0D0
	+ PARP(93) = 5D0
	+ IF (ITUNE.GE.340) THEN
	+ PARP(93) = 10D0
	+ ENDIF
	+ IF (ITUNE.GE.345) THEN
	+ PARP(91) = 2.0
	+ ENDIF
	+
	+C...ISR
	+ IF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
	+ MSTP(64) = 2
	+ PARP(62) = 1.13
	+ PARP(64) = 0.68
	+ PARP(67) = 1.0
	+ ELSE IF (ITUNE.EQ.347) THEN
	+ MSTP(64) = 2
	+ PARP(62) = 0.946
	+ PARP(64) = 1.032
	+ PARP(67) = 1.0
	+ ELSE IF (ITUNE.EQ.348) THEN
	+ MSTP(64) = 2
	+ PARP(62) = 0.312
	+ PARP(64) = 0.939
	+ PARP(67) = 1.0
	+ ELSE IF (ITUNE.EQ.349) THEN
	+ MSTP(64) = 2
	+ PARP(62) = 1.246
	+ PARP(64) = 0.771
	+ PARP(67) = 1.0
	+ ELSE IF (ITUNE.GE.340) THEN
	+ PARP(62) = 1.025
	+ ENDIF
	+
	+C...FSR off ISR (LambdaQCD) for A*ET2B tunes
	+ IF (ITUNE.GE.345) THEN
	+ MSTP(72) = 2
	+ PARP(72) = 0.527
	+ IF (ITUNE.EQ.348) THEN
	+ PARP(72) = 0.537
	+ ENDIF
	+ 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'
	+ ELSEIF (ITUNE.EQ.345.OR.ITUNE.EQ.346) THEN
	+ CH60='A*T2B tunes by ATLAS, ATL-PHYS-PUB-2011-009'
	+ ELSEIF (ITUNE.GE.347) THEN
	+ CH60='A*T2B-NLO tunes by ATLAS, ATL-PHYS-PUB-2011-014'
	+ WRITE(M11,5030) CH60
	+ CH60='Warning: NLO PDFs are NOT recommended!'
	+ ENDIF
	+ WRITE(M11,5030) CH60
	+ CH60='Physics Model: '//
	+ & 'T. Sjostrand & P. Skands, hep-ph/0408302'
	+ WRITE(M11,5030) CH60
	+ CH60='CR by P. Skands & D. Wicke, hep-ph/0703081'
	+ 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(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) THEN
	+ WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
	+ 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,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)
	+ IF (MSTP(70).EQ.0) THEN
	+ WRITE(M11,5050) 62, PARP(62), CHPARP(62)
	+ ENDIF
	+ WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
	+ WRITE(M11,5050) 71, PARP(71), CHPARP(71)
	+ WRITE(M11,5050) 72, PARP(72), CHPARP(72)
	+ 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.379)) 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 and 370-379 (Perugia 2011 and 2012)
	+ ITUNSV = ITUNE
	+ IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
	+ IF (ITUNE.GE.370.AND.ITUNE.LE.379) 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 and 2012 tunes
	+C...(written as modifications on top of Perugia 2010)
	+C================
	+ IF ( (ITUNSV.GE.350.AND.ITUNSV.LE.359)
	+ & .OR.(ITUNSV.GE.370.AND.ITUNSV.LE.379) ) 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... Perugia 2012 Variations
	+C================
	+ IF (ITUNE.GE.370) THEN
	+C... CTEQ6L1 Baseline
	+ MSTP(52) = 2
	+ MSTP(51) = 10042
	+ PARP(82) = 2.65D0
	+C... Needs slower cutoff scaling than CTEQ5L
	+ PARP(90) = 0.24D0
	+C... Slightly lower CR strength than Perugia 2011
	+ PARP(78) = 0.035D0
	+C... Adjusted fragmentation parameters wrt 2011
	+ PARJ(1) = 0.085D0
	+ PARJ(2) = 0.2
	+ PARJ(3) = 0.92
	+ PARJ(25) = 0.70
	+ PARJ(26) = 0.135
	+ PARJ(41) = 0.45
	+ PARJ(42) = 1.0
	+ PARJ(45) = 0.86
	+ ENDIF
	+C... Variations
	+ IF (ITUNE.EQ.371) 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) = 2.725D0
	+C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
	+C... (since more radiation otherwise generates faster mult growth)
	+ PARP(90) = 0.25
	+ ELSEIF (ITUNE.EQ.372) 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.6D0
	+C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
	+C... (since less radiation otherwise generates slower mult growth)
	+ PARP(90) = 0.23
	+ ELSEIF (ITUNE.EQ.373) THEN
	+C... mpiHi: high Lambda scale for MPI
	+ PARP(1) = 0.26D0
	+ PARU(112) = 0.26D0
	+ PARP(82) = 3.0D0
	+ PARP(90) = 0.24D0
	+ ELSEIF (ITUNE.EQ.374) THEN
	+C... LOCR : uses global CR model. Less extreme alternative to noCR.
	+ MSTP(95) = 6
	+ PARP(78) = 0.25D0
	+ PARP(82) = 2.7D0
	+ PARP(83) = 1.50D0
	+ PARP(90) = 0.24
	+ ELSEIF (ITUNE.EQ.375) THEN
	+C... NOCR : with higher pT0
	+ MSTP(95) = 0
	+ PARP(82) = 2.80D0
	+ ELSEIF (ITUNE.EQ.376) THEN
	+C... hadF1 (harder frag function, smaller n.p. pT)
	+ PARJ(21) = 0.30
	+ PARJ(41) = 0.36
	+ PARJ(42) = 1.0
	+ PARJ(45) = 0.75
	+ ELSEIF (ITUNE.EQ.377) THEN
	+C... hadF2 (softer frag function, larger n.p. pT)
	+ PARJ(21) = 0.36
	+ PARJ(41) = 0.45
	+ PARJ(42) = 0.75
	+ PARJ(45) = 0.9
	+ ELSEIF (ITUNE.EQ.378) THEN
	+C... MSTW08LO
	+ MSTP(52) = 2
	+ MSTP(51) = 21000
	+ PARP(82) = 2.9D0
	+C...Uses a large LambdaQCD MSbar value (close to CMW one)
	+C...(Nominally, MSTW 2008 alphaS(mZ) = 0.139)
	+ PARP(1) = 0.26D0
	+ PARU(112) = 0.26D0
	+C...Tentative (fast) energy scaling
	+ PARP(90) = 0.29
	+ ELSEIF (ITUNE.EQ.379) THEN
	+C... MSTW LO**
	+ MSTP(52) = 2
	+ MSTP(51) = 20651
	+ PARP(62) = 1.5D0
	+C... Use a smaller LambdaQCD MSbar than with CTEQ
	+ PARP(1) = 0.14D0
	+ PARU(112) = 0.14D0
	+C... Compensate for higher <pT> with less CR
	+ PARP(78) = 0.034
	+ PARP(82) = 3.25D0
	+C...Tentative scaling
	+ PARP(90) = 0.25
	+ 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 P. Skands & D. Wicke, hep-ph/0703081'
	+ 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 P. Skands & D. Wicke, hep-ph/0703081'
	+ 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 P. Skands & D. Wicke, hep-ph/0703081'
	+ 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 P. Skands & D. Wicke, hep-ph/0703081'
	+ 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) THEN
	+ WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
	+ 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
	+ CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
	+ WRITE(M11,5030) CH60
	+ ENDIF
	+C...GAL Recommended settings from Uppsala web page
	+ MSTP(95) = 13
	+ PARP(78) = 0.10
	+ 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)
	+ WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
	+ WRITE(M11,5050) 78, PARP(78), CHPARP(78)
	+ 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
	+ MSTP(95) = 11
	+ PARP(78) = 0.50
	+ 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)
	+ WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
	+ WRITE(M11,5050) 78, PARP(78), CHPARP(78)
	+ 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(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT4/MWID(500),WIDS(500,5)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
	+C...Local array.
	+ DIMENSION PS(2,6),IJOIN(100)
	+
	+C...Initialize and reset.
	+ MSTU(24)=0
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ MSTU(29)=0
	+ MSTU(31)=MSTU(31)+1
	+ MSTU(1)=0
	+ MSTU(2)=0
	+ MSTU(3)=0
	+ IF(MSTU(17).LE.0) MSTU(90)=0
	+ MCONS=1
	+
	+C...Sum up momentum, energy and charge for starting entries.
	+ NSAV=N
	+ DO 110 I=1,2
	+ DO 100 J=1,6
	+ PS(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+ DO 130 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
	+ DO 120 J=1,4
	+ PS(1,J)=PS(1,J)+P(I,J)
	+ 120 CONTINUE
	+ PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
	+ 130 CONTINUE
	+ PARU(21)=PS(1,4)
	+
	+C...Start by all decays of coloured resonances involved in shower.
	+ NORIG=N
	+ DO 140 I=1,NORIG
	+ IF(K(I,1).EQ.3) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
	+ ENDIF
	+ 140 CONTINUE
	+
	+C...Prepare system for subsequent fragmentation/decay.
	+ CALL PYPREP(0)
	+ IF(MINT(51).NE.0) RETURN
	+
	+C...Loop through jet fragmentation and particle decays.
	+ MBE=0
	+ 150 MBE=MBE+1
	+ IP=0
	+ 160 IP=IP+1
	+ KC=0
	+ IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
	+ IF(KC.EQ.0) THEN
	+
	+C...Deal with any remaining undecayed resonance
	+C...(normally the task of PYEVNT, so seldom used).
	+ ELSEIF(MWID(KC).NE.0) THEN
	+ IBEG=IP
	+ IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
	+ IBEG=IP+1
	+ 170 IBEG=IBEG-1
	+ IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
	+ IF(K(IBEG,1).NE.2) IBEG=IBEG+1
	+ IEND=IP-1
	+ 180 IEND=IEND+1
	+ IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
	+ IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
	+ NJOIN=0
	+ DO 190 I=IBEG,IEND
	+ IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
	+ NJOIN=NJOIN+1
	+ IJOIN(NJOIN)=I
	+ ENDIF
	+ 190 CONTINUE
	+ ENDIF
	+ CALL PYRESD(IP)
	+ CALL PYPREP(IBEG)
	+ IF(MINT(51).NE.0) RETURN
	+
	+C...Particle decay if unstable and allowed. Save long-lived particle
	+C...decays until second pass after Bose-Einstein effects.
	+ ELSEIF(KCHG(KC,2).EQ.0) THEN
	+ IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
	+ & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
	+ & CALL PYDECY(IP)
	+
	+C...Decay products may develop a shower.
	+ IF(MSTJ(92).GT.0) THEN
	+ IP1=MSTJ(92)
	+ QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
	+ & 1))2-(P(IP1,2)+P(IP1+1,2))2-(P(IP1,3)+P(IP1+1,3))**2))
	+ MINT(33)=0
	+ CALL PYSHOW(IP1,IP1+1,QMAX)
	+ CALL PYPREP(IP1)
	+ IF(MINT(51).NE.0) RETURN
	+ MSTJ(92)=0
	+ ELSEIF(MSTJ(92).LT.0) THEN
	+ IP1=-MSTJ(92)
	+ MINT(33)=0
	+ CALL PYSHOW(IP1,-3,P(IP,5))
	+ CALL PYPREP(IP1)
	+ IF(MINT(51).NE.0) RETURN
	+ MSTJ(92)=0
	+ ENDIF
	+
	+C...Jet fragmentation: string or independent fragmentation.
	+ ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
	+ MFRAG=MSTJ(1)
	+ IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
	+ IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
	+ IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
	+ & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
	+ IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
	+ ENDIF
	+ ENDIF
	+ IF(MFRAG.EQ.1) CALL PYSTRF(IP)
	+ IF(MFRAG.EQ.2) CALL PYINDF(IP)
	+ IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
	+ IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
	+ ENDIF
	+
	+C...Loop back if enough space left in PYJETS and no error abort.
	+ IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
	+ ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
	+ GOTO 160
	+ ELSEIF(IP.LT.N) THEN
	+ CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
	+ ENDIF
	+
	+C...Include simple Bose-Einstein effect parametrization if desired.
	+ IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
	+ CALL PYBOEI(NSAV)
	+ GOTO 150
	+ ENDIF
	+
	+C...Check that momentum, energy and charge were conserved.
	+ DO 210 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
	+ DO 200 J=1,4
	+ PS(2,J)=PS(2,J)+P(I,J)
	+ 200 CONTINUE
	+ PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
	+ 210 CONTINUE
	+ PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
	+ &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
	+ IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
	+ &'(PYEXEC:) four-momentum was not conserved')
	+ IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
	+ &'(PYEXEC:) charge was not conserved')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYPREP
	+C...Rearranges partons along strings.
	+C...Special considerations for systems with junctions, with
	+C...possibility of junction-antijunction annihilation.
	+C...Allows small systems to collapse into one or two particles.
	+C...Checks flavours and colour singlet invariant masses.
	+
	+ SUBROUTINE PYPREP(IP)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+C...The common block of colour tags.
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
	+ &/PYPARS/
	+ DATA NERRPR/0/
	+ SAVE NERRPR
	+C...Local arrays.
	+ DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
	+ &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
	+ &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
	+ &IJCP(0:6),TJUOLD(5)
	+ CHARACTER CHTMP*6
	+
	+C...Function to give four-product.
	+ FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	+
	+C...Rearrange parton shower product listing along strings: begin loop.
	+ MSTU(24)=0
	+ NOLD=N
	+ I1=N
	+ NJUNC=0
	+ NPIECE=0
	+ NJJSTR=0
	+ MSTU32=MSTU(32)+1
	+ DO 100 I=MAX(1,IP),N
	+C...First store junction positions.
	+ IF(K(I,1).EQ.42) THEN
	+ NJUNC=NJUNC+1
	+ IJUNC(NJUNC,0)=I
	+ IJUNC(NJUNC,4)=0
	+ ENDIF
	+ 100 CONTINUE
	+
	+ DO 250 MQGST=1,3
	+ DO 240 I=MAX(1,IP),N
	+C...Special treatment for junctions
	+ IF (K(I,1).LE.0) GOTO 240
	+ IF(K(I,1).EQ.42) THEN
	+C...MQGST=2: Look for junction-junction strings (not detected in the
	+C...main search below).
	+ IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
	+ IF (NJJSTR.EQ.0) THEN
	+ NJJSTR = (3*NJUNC-NPIECE)/2
	+ ENDIF
	+C...Check how many already identified strings end on this junction
	+ ILC=0
	+ DO 110 J=1,NPIECE
	+ IF (IPIECE(J,4).EQ.I) ILC=ILC+1
	+ 110 CONTINUE
	+C...If less than 3, remaining must be to another junction
	+ IF (ILC.LT.3) THEN
	+ IF (ILC.NE.2) THEN
	+C...Multiple j-j connections not handled yet.
	+ CALL PYERRM(2,
	+ & '(PYPREP:) Too many junction-junction strings.')
	+ MINT(51)=1
	+ RETURN
	+ ENDIF
	+C...The colour information in the junction is unreadable for the
	+C...colour space search further down in this routine, so we must
	+C...start on the colour mother of this junction and then "artificially"
	+C...prevent the colour mother from connecting here again.
	+ ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
	+ KCS=4
	+ IF (MOD(ITJUNC,2).EQ.0) KCS=5
	+C...Switch colour if the junction-junction leg is presumably a
	+C...junction mother leg rather than a junction daughter leg.
	+ IF (ITJUNC.GE.3) KCS=9-KCS
	+ IF (MINT(33).EQ.0) THEN
	+C...Find the unconnected leg and reorder junction daughter pointers so
	+C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
	+C...piece.
	+ IA=MOD(K(I,4),MSTU(5))
	+ IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
	+ ITMP=MOD(K(I,5),MSTU(5))
	+ IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
	+ ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
	+ K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
	+ ELSE
	+ K(I,5)=K(I,5)+(IA-ITMP)
	+ ENDIF
	+ K(I,4)=K(I,4)+(ITMP-IA)
	+ IA=ITMP
	+ ENDIF
	+ IF (ITJUNC.LE.2) THEN
	+C...Beam baryon junction
	+ K(IA,KCS) = K(IA,KCS) + 2MSTU(5)*2
	+ K(I,KCS) = K(I,KCS) + 1MSTU(5)*2
	+C...Else 1 -> 2 decay junction
	+ ELSE
	+ K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
	+ K(I,KCS) = K(I,KCS) + 2MSTU(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.2MSTU(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)+2MSTU(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)+2MSTU(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 - JDIJS)
	+ 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=4D0FOUR(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=8D0FOUR(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+ISGNTJJ(1,IX)P(IJCP(2)-1,IX)
	+ T1P2=T1P2+ISGNTJJ(1,IX)P(IJCP(3)-1,IX)
	+ T2P3=T2P3+ISGNTJJ(2,IX)P(IJCP(4)+1,IX)
	+ T2P4=T2P4+ISGNTJJ(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+ISGNTJJ(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+ISGNTJJ(1,IX)P(IJCP(3)+1,IX)
	+ T2G2=T2G2+ISGNTJJ(2,IX)P(IJCP(4)-1,IX)
	+ ENDIF
	+ 580 CONTINUE
	+ DELMJJ=16D0T1P1T1P2T2P3T2P4
	+ IF (JJGLUE.EQ.0) THEN
	+ DELMJJ=DELMJJ(T1T2+SQRT(T1T2*2-1))
	+ ELSE
	+ DELMJJ=DELMJJ4D0T1G1*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+IFCISW+3)+1,IJCP(IST+IFCISW+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=2INT(PYR(0)+3D0PARJ(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=2INT(PYR(0)+3D0PARJ(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((PECM2-(P(N+2,5)+P(N+3,5))2)(PECM*2-
	+ &(P(N+2,5)-P(N+3,5))*2))/(2D0PECM)
	+ 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/(2D0MAX(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,(PECM2-PR1-PR2)2-4D0PR1PR2))
	+ PREVCF=PARJ(42)
	+ IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
	+ PREV=1D0/(1D0+EXP(MIN(50D0,PREVCFALAMBDPARJ(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(PA2+P(N+2,5)2)
	+ P(N+3,4)=SQRT(PA2+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-alphae3)*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)=ALPHAP(I1,J)+BETAP(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(PCLPG2+(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-DELTAALPHA)P(I1,4).LT.P(I1,5).OR.
	+ & (1D0-DELTABETA)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-DELTAALPHA)P(I1,J)
	+ P(I2,J)=(1D0-DELTABETA)P(I2,J)
	+ 1070 CONTINUE
	+ P(I1,5)=(1D0-DELTAALPHA)P(I1,5)
	+ P(I2,5)=(1D0-DELTABETA)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=2D0HCR+PECM2-P(N+2,5)2-2D0P(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(HBSQRT(MAX(0D0,((HB+HC)*2-4D0(HB+HD)P(N+2,5)*2)/
	+ & (HA*2-(PECMP(IR,5))**2)))-(HB+HC))/(HB+HD)
	+ HK1=(0.5D0(P(N+2,5)2-PECM2)+HDHK2)/HB
	+ DO 1110 J=1,4
	+ P(N+2,J)=(1D0+HK1)DPC(J)-HK2P(IR,J)
	+ P(IR,J)=(1D0+HK2)P(IR,J)-HK1DPC(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.9D0PARJ(32)+DPS(5))*2) CALL PYERRM(3,
	+ & '(PYPREP:) too small mass in jet system')
	+ NP=0
	+ KFN=0
	+ KQS=0
	+ NJU=0
	+ DO 1170 J=1,5
	+ DPS(J)=0D0
	+ 1170 CONTINUE
	+ ENDIF
	+ 1180 CONTINUE
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYSTRF
	+C...Handles the fragmentation of an arbitrary colour singlet
	+C...jet system according to the Lund string fragmentation model.
	+
	+ SUBROUTINE PYSTRF(IP)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local arrays. All MOPS variables ends with MO
	+ DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
	+ &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
	+ &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
	+ &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
	+ &PBST(3,5),TJUOLD(5)
	+
	+C...Function: four-product of two vectors.
	+ FOUR(I,J)=P(I,4)P(J,4)-P(I,1)P(J,1)-P(I,2)P(J,2)-P(I,3)P(J,3)
	+ DFOUR(I,J)=DP(I,4)DP(J,4)-DP(I,1)DP(J,1)-DP(I,2)*DP(J,2)-
	+ &DP(I,3)*DP(J,3)
	+
	+C...Reset counters.
	+ MSTJ(91)=0
	+ NSAV=N
	+ MSTU90=MSTU(90)
	+ NP=0
	+ KQSUM=0
	+ DO 100 J=1,5
	+ DPS(J)=0D0
	+ 100 CONTINUE
	+ MJU(1)=0
	+ MJU(2)=0
	+ NTRYFN=0
	+ IJUORI(1)=0
	+ IJUORI(2)=0
	+
	+C...Identify parton system.
	+ I=IP-1
	+ 110 I=I+1
	+ IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
	+ CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0) GOTO 110
	+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
	+ IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
	+ IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
	+ CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+
	+C...Take copy of partons to be considered. Check flavour sum.
	+ NP=NP+1
	+ DO 120 J=1,5
	+ K(N+NP,J)=K(I,J)
	+ P(N+NP,J)=P(I,J)
	+ IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
	+ 120 CONTINUE
	+ DPS(4)=DPS(4)+SQRT(P(I,1)2+P(I,2)2+P(I,3)2+P(I,5)2)
	+ K(N+NP,3)=I
	+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
	+ IF(K(I,1).EQ.41) THEN
	+ IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
	+ MJU(1)=N+NP
	+ IJUORI(1)=I
	+ ELSE
	+ MJU(2)=N+NP
	+ IJUORI(2)=I
	+ ENDIF
	+ ENDIF
	+ IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
	+ IF(MOD(KQSUM,3).NE.0) THEN
	+ CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
	+
	+C...Boost copied system to CM frame (for better numerical precision).
	+ IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
	+ MBST=0
	+ MSTU(33)=1
	+ CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
	+ & -DPS(3)/DPS(4))
	+ ELSE
	+ MBST=1
	+ HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
	+ DO 130 I=N+1,N+NP
	+ HHPMT=P(I,1)2+P(I,2)2+P(I,5)**2
	+ IF(P(I,3).GT.0D0) THEN
	+ HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
	+ P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
	+ P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
	+ ELSE
	+ HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
	+ P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
	+ P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
	+ ENDIF
	+ 130 CONTINUE
	+ ENDIF
	+
	+C...Search for very nearby partons that may be recombined.
	+ NTRYR=0
	+ NTRYWR=0
	+ PARU12=PARU(12)
	+ PARU13=PARU(13)
	+ MJU(3)=MJU(1)
	+ MJU(4)=MJU(2)
	+ NR=NP
	+ NRMIN=2
	+ IF(MJU(1).GT.0) NRMIN=NRMIN+2
	+ IF(MJU(2).GT.0) NRMIN=NRMIN+2
	+ 140 IF(NR.GT.NRMIN) THEN
	+ PDRMIN=2D0*PARU12
	+ DO 150 I=N+1,N+NR
	+ IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
	+ I1=I+1
	+ IF(I.EQ.N+NR) I1=N+1
	+ IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
	+ IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
	+ & GOTO 150
	+ IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
	+ & GOTO 150
	+ PAP=SQRT((P(I,1)2+P(I,2)2+P(I,3)*2)(P(I1,1)**2+
	+ & P(I1,2)2+P(I1,3)2))
	+ PVP=P(I,1)P(I1,1)+P(I,2)P(I1,2)+P(I,3)*P(I1,3)
	+ PDR=4D0(PAP-PVP)2/MAX(1D-6,PARU132PAP+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).EQ.2) MSTU(90)=0
	+ 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
	+ MSTU(90)=MSTU90
	+ 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)+2D0PBST(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)-DHK2DP(2,J)
	+ P(IN1+1,J)=(1D0+DHK2)DP(2,J)-DHK1DP(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).EQ.2) MSTU(90)=0
	+ 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+2D0DHCX1DHCX2*DHC12)
	+ DHCY1=DFOUR(4,1)/DHC12
	+ DHCY2=DFOUR(4,2)/DHC12
	+ DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	+ DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	+ DO 420 J=1,4
	+ DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	+ P(IN(6),J)=DP(3,J)
	+ P(IN(6)+1,J)=DHCYY(DP(4,J)-DHCY2DP(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.ZP(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+4NS.OR.IN(2).GT.N+NR+4NS.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+2D0DHCX1DHCX2*DHC12)
	+ DHCY1=DFOUR(4,1)/DHC12
	+ DHCY2=DFOUR(4,2)/DHC12
	+ DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	+ DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	+ DO 500 J=1,4
	+ DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	+ P(IN(3),J)=DP(3,J)
	+ P(IN(3)+1,J)=DHCYY(DP(4,J)-DHCY2DP(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(PXP2+PYP2-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,DHS22-4D0DHS1*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-2JQ)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
	+ IF(MSTU(90+MSTU(90)).EQ.I+1) MSTU(90)=MSTU(90)-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=2INT(PYR(0)+3D0PARJ(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.5D0FOUR(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)-DHK2DP(2,J)
	+ P(IN1+1,J)=(1D0+DHK2)DP(2,J)-DHK1DP(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).EQ.2) MSTU(90)=0
	+ 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(3JT+1)=N+NR+1+4(JT/2)*(NS-1)
	+ IN(3JT+2)=IN(3JT+1)+1
	+ IN(3JT+3)=N+NR+4NS+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.1D0P(N+NR+1,5)*2)
	+ 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
	+ ZR=PR3/(ZP(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+2D0DHCX1DHCX2*DHC12)
	+ DHCY1=DFOUR(4,1)/DHC12
	+ DHCY2=DFOUR(4,2)/DHC12
	+ DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	+ DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	+ DO 820 J=1,4
	+ DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	+ P(IN3,J)=DP(3,J)
	+ P(IN3+1,J)=DHCYY(DP(4,J)-DHCY2DP(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.5D0PARJ(36)PMQ(3)
	+ WREM2=FOUR(N+NRS,N+NRS)
	+ IF(WREM2.LT.0.10D0) GOTO 710
	+ IF(WREM2.LT.MAX(WMIN(1D0+(2D0PYR(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-4D0PR(1)*PR(2)))
	+ Z=(WREM2+PR(JT)-PR(JR)+PW12(2D0Z-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=GBMOXTMO3/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.ZP(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(JSIN(JR).GT.JSIN(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(JSIN(1).GT.JSIN(3JR+1).OR.JSIN(2).GT.JSIN(3JR+2).OR.
	+ &IN(1).GT.IN(2)) GOTO 710
	+ IF(IN(1).NE.IN(3JT+1).OR.IN(2).NE.IN(3JT+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+2D0DHCX1DHCX2*DHC12)
	+ DHCY1=DFOUR(4,1)/DHC12
	+ DHCY2=DFOUR(4,2)/DHC12
	+ DHCYX=DHCXX(DHCX1DHCY2+DHCX2DHCY1)DHC12
	+ DHCYY=1D0/SQRT(1D0+2D0DHCY1DHCY2DHC12-DHCYX*2)
	+ DO 980 J=1,4
	+ DP(3,J)=DHCXX(DP(3,J)-DHCX2DP(1,J)-DHCX1*DP(2,J))
	+ P(IN(3),J)=DP(3,J)
	+ P(IN(3)+1,J)=DHCYY(DP(4,J)-DHCY2DP(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(3JT+3),IN(3))+PY(3)*
	+ & FOUR(IN(3*JT+3)+1,IN(3)))
	+ PYP=-(PX(3)FOUR(IN(3JT+3),IN(3)+1)+PY(3)*
	+ & FOUR(IN(3*JT+3)+1,IN(3)+1))
	+ IF(ABS(PXP2+PYP2-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(3JT+3),J)+PY(JT)P(IN(3JT+3)+1,J)+
	+ & PX(3)P(IN(3),J)+PY(3)P(IN(3)+1,J)
	+ DO 990 IN1=IN(3JT+1),IN(1)-4JS,4*JS
	+ P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
	+ 990 CONTINUE
	+ DO 1000 IN2=IN(3JT+2),IN(2)-4JS,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)-JSP(IN2+2,JT)DHC
	+ IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JSP(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,DHS22-4D0DHS1*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(JSIN(JR).GT.JSIN(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-2JQ)*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(3JQ+1),IN(3JQ+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)+(2JQ-3)JS*
	+ & PX(3))*2+(PY(3-JQ)+(2JQ-3)JSPY(3))**2
	+ ENDIF
	+
	+C...Solve kinematics for final two hadrons, if possible.
	+ WREM2=2D0DHR1DHR2*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-4D0WREM2*PR(JT)))
	+ PREVCF=PARJ(42)
	+ IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
	+ PREV=1D0/(1D0+EXP(MIN(50D0,PREVCFFBPARJ(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-
	+ &4D0WREM2PR(JT))),DBLE(JS))
	+ DO 1090 J=1,4
	+ P(I-1,J)=(PX(JT)+PX(3))P(IN(3JQ+3),J)+(PY(JT)+PY(3))*
	+ & P(IN(3JQ+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-10P(I-1,4)2.OR.DM2F2.GT.1D-10P(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)*2A(J,J).LT.A(I,J)*2A(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(2D0AIKAIJ/(3D0*AJK))
	+ PEJ=SQRT(2D0AJKAIJ/(3D0*AIK))
	+ PEK=SQRT(2D0AIKAJK/(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=PEJMINPEKMIN+0.5D0PAJMIN*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.25D0PAIMAX**2
	+ PAJMAX=(PEIMAXSQRT(MAX(0D0,AIJ2-PMJ2HI))-
	+ & 0.5D0PAIMAXAIJ)/HI
	+ PAKMAX=(PEIMAXSQRT(MAX(0D0,AIK2-PMK2HI))-
	+ & 0.5D0PAIMAXAIK)/HI
	+ PEJMAX=SQRT(PAJMAX**2+PMJ2)
	+ PEKMAX=SQRT(PAKMAX**2+PMK2)
	+ FMAX=PEJMAXPEKMAX+0.5D0PAJMAX*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.25D0PAI**2
	+ PAJ=(PEISQRT(MAX(0D0,AIJ2-PMJ2HI))-0.5D0PAIAIJ)/HI
	+ PEJ=SQRT(PAJ**2+PMJ2)
	+ PAK=(PEISQRT(MAX(0D0,AIK2-PMK2HI))-0.5D0PAIAIK)/HI
	+ PEK=SQRT(PAK**2+PMK2)
	+ FNOW=PEJPEK+0.5D0PAJ*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+VXCM2+VYCM2+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=(PCM5SPCM(4,4)-PCM45PCM(5,4))/(PCM4SPCM5S-PCM45*2)
	+ C5=(PCM4SPCM(5,4)-PCM45PCM(4,4))/(PCM4SPCM5S-PCM45*2)
	+ VXJU=C4PCM(4,1)+C5PCM(5,1)
	+ VYJU=C4PCM(4,2)+C5PCM(5,2)
	+ VZJU=C4PCM(4,3)+C5PCM(5,3)
	+ GAMJU=SQRT(1D0+VXJU2+VYJU2+VZJU**2)
	+
	+C...Add two boosts, giving final result.
	+ FCM=(VXJUVXCM+VYJUVYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
	+ VJU(1)=VXJU+FCM*VXCM
	+ VJU(2)=VYJU+FCM*VYCM
	+ VJU(3)=VZJU+FCM*VZCM
	+ VJU(4)=SQRT(1D0+VJU(1)2+VJU(2)2+VJU(3)**2)
	+ VJU(5)=1D0
	+
	+C...In case of error in reconstruction: revert to CM frame of system.
	+ CTH12=(PCM(1,1)PCM(2,1)+PCM(1,2)PCM(2,2)+PCM(1,3)*PCM(2,3))/
	+ &(PCM(1,5)*PCM(2,5))
	+ CTH13=(PCM(1,1)PCM(3,1)+PCM(1,2)PCM(3,2)+PCM(1,3)*PCM(3,3))/
	+ &(PCM(1,5)*PCM(3,5))
	+ CTH23=(PCM(2,1)PCM(3,1)+PCM(2,2)PCM(3,2)+PCM(2,3)*PCM(3,3))/
	+ &(PCM(2,5)*PCM(3,5))
	+ ERRCCM=(CTH12+0.5D0)2+(CTH13+0.5D0)2+(CTH23+0.5D0)**2
	+ ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
	+ DO 170 I=1,3
	+ FAC1=PJU(I,1)VJU(1)+PJU(I,2)VJU(2)+PJU(I,3)*VJU(3)
	+ FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
	+ PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
	+ PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
	+ PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
	+ PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
	+ PCM(I,5)=SQRT(PCM(I,1)2+PCM(I,2)2+PCM(I,3)**2)
	+ 170 CONTINUE
	+ CTH12=(PCM(1,1)PCM(2,1)+PCM(1,2)PCM(2,2)+PCM(1,3)*PCM(2,3))/
	+ &(PCM(1,5)*PCM(2,5))
	+ CTH13=(PCM(1,1)PCM(3,1)+PCM(1,2)PCM(3,2)+PCM(1,3)*PCM(3,3))/
	+ &(PCM(1,5)*PCM(3,5))
	+ CTH23=(PCM(2,1)PCM(3,1)+PCM(2,2)PCM(3,2)+PCM(2,3)*PCM(3,3))/
	+ &(PCM(2,5)*PCM(3,5))
	+ ERRCJU=(CTH12+0.5D0)2+(CTH13+0.5D0)2+(CTH23+0.5D0)**2
	+ ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
	+ IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
	+ VJU(1)=VXCM
	+ VJU(2)=VYCM
	+ VJU(3)=VZCM
	+ VJU(4)=GAMCM
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYINDF
	+C...Handles the fragmentation of a jet system (or a single
	+C...jet) according to independent fragmentation models.
	+
	+ SUBROUTINE PYINDF(IP)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local arrays.
	+ DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
	+ &KFLO(2),PXO(2),PYO(2),WO(2)
	+
	+C.. MOPS error message
	+ IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
	+ &' are not treated as expected in independent fragmentation')
	+
	+C...Reset counters. Identify parton system and take copy. Check flavour.
	+ NSAV=N
	+ MSTU90=MSTU(90)
	+ NJET=0
	+ KQSUM=0
	+ DO 100 J=1,5
	+ DPS(J)=0D0
	+ 100 CONTINUE
	+ I=IP-1
	+ 110 I=I+1
	+ IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
	+ CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0) GOTO 110
	+ KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
	+ IF(KQ.EQ.0) GOTO 110
	+ NJET=NJET+1
	+ IF(KQ.NE.2) KQSUM=KQSUM+KQ
	+ DO 120 J=1,5
	+ K(NSAV+NJET,J)=K(I,J)
	+ P(NSAV+NJET,J)=P(I,J)
	+ DPS(J)=DPS(J)+P(I,J)
	+ 120 CONTINUE
	+ K(NSAV+NJET,3)=I
	+ IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
	+ &K(I+1,1).EQ.2)) GOTO 110
	+ IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
	+ CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+
	+C...Boost copied system to CM frame. Find CM energy and sum flavours.
	+ IF(NJET.NE.1) THEN
	+ MSTU(33)=1
	+ CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
	+ & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
	+ ENDIF
	+ PECM=0D0
	+ DO 130 J=1,3
	+ NFI(J)=0
	+ 130 CONTINUE
	+ DO 140 I=NSAV+1,NSAV+NJET
	+ PECM=PECM+P(I,4)
	+ KFA=IABS(K(I,2))
	+ IF(KFA.LE.3) THEN
	+ NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
	+ ELSEIF(KFA.GT.1000) THEN
	+ KFLA=MOD(KFA/1000,10)
	+ KFLB=MOD(KFA/100,10)
	+ IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
	+ IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
	+ ENDIF
	+ 140 CONTINUE
	+
	+C...Loop over attempts made. Reset counters.
	+ NTRY=0
	+ 150 NTRY=NTRY+1
	+ IF(NTRY.GT.200) THEN
	+ CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ N=NSAV+NJET
	+ MSTU(90)=MSTU90
	+ DO 160 J=1,3
	+ NFL(J)=NFI(J)
	+ IFET(J)=0
	+ KFLF(J)=0
	+ 160 CONTINUE
	+
	+C...Loop over jets to be fragmented.
	+ DO 230 IP1=NSAV+1,NSAV+NJET
	+ MSTJ(91)=0
	+ NSAV1=N
	+ MSTU91=MSTU(90)
	+
	+C...Initial flavour and momentum values. Jet along +z axis.
	+ KFLH=IABS(K(IP1,2))
	+ IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
	+ KFLO(2)=0
	+ WF=P(IP1,4)+SQRT(P(IP1,1)2+P(IP1,2)2+P(IP1,3)**2)
	+
	+C...Initial values for quark or diquark jet.
	+ 170 IF(IABS(K(IP1,2)).NE.21) THEN
	+ NSTR=1
	+ KFLO(1)=K(IP1,2)
	+ CALL PYPTDI(0,PXO(1),PYO(1))
	+ WO(1)=WF
	+
	+C...Initial values for gluon treated like random quark jet.
	+ ELSEIF(MSTJ(2).LE.2) THEN
	+ NSTR=1
	+ IF(MSTJ(2).EQ.2) MSTJ(91)=1
	+ KFLO(1)=INT(1D0+(2D0+PARJ(2))PYR(0))(-1)**INT(PYR(0)+0.5D0)
	+ CALL PYPTDI(0,PXO(1),PYO(1))
	+ WO(1)=WF
	+
	+C...Initial values for gluon treated like quark-antiquark jet pair,
	+C...sharing energy according to Altarelli-Parisi splitting function.
	+ ELSE
	+ NSTR=2
	+ IF(MSTJ(2).EQ.4) MSTJ(91)=1
	+ KFLO(1)=INT(1D0+(2D0+PARJ(2))PYR(0))(-1)**INT(PYR(0)+0.5D0)
	+ KFLO(2)=-KFLO(1)
	+ CALL PYPTDI(0,PXO(1),PYO(1))
	+ PXO(2)=-PXO(1)
	+ PYO(2)=-PYO(1)
	+ WO(1)=WFPYR(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(ZW-PR/MAX(1D-4,Z*W))
	+ P(I,4)=0.5D0(ZW+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+3D0PARJ(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.8D0P(I,5)+0.2D0))
	+ 420 CONTINUE
	+ DO 440 I=NSAV+NJET+1,N
	+ IR1=K(I,3)
	+ IR2=N+IR1-NSAV
	+ PLS=(P(I,1)P(IR1,1)+P(I,2)P(IR1,2)+P(I,3)*P(IR1,3))/
	+ & (P(IR1,1)2+P(IR1,2)2+P(IR1,3)**2)
	+ DO 430 J=1,3
	+ P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)PSS)-1D0)
	+ & PLS*P(IR1,J)
	+ 430 CONTINUE
	+ P(I,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)2+P(I,5)2)
	+ 440 CONTINUE
	+ ENDIF
	+
	+C...Scale momenta for energy conservation.
	+ IF(MOD(MSTJ(3),5).NE.0) THEN
	+ PMS=0D0
	+ PES=0D0
	+ PQS=0D0
	+ DO 450 I=NSAV+NJET+1,N
	+ PMS=PMS+P(I,5)
	+ PES=PES+P(I,4)
	+ PQS=PQS+P(I,5)**2/P(I,4)
	+ 450 CONTINUE
	+ IF(PMS.GE.PECM) GOTO 150
	+ NECO=0
	+ 460 NECO=NECO+1
	+ PFAC=(PECM-PQS)/(PES-PQS)
	+ PES=0D0
	+ PQS=0D0
	+ DO 480 I=NSAV+NJET+1,N
	+ DO 470 J=1,3
	+ P(I,J)=PFAC*P(I,J)
	+ 470 CONTINUE
	+ P(I,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)2+P(I,5)2)
	+ PES=PES+P(I,4)
	+ PQS=PQS+P(I,5)**2/P(I,4)
	+ 480 CONTINUE
	+ IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
	+ ENDIF
	+
	+C...Origin of produced particles and parton daughter pointers.
	+ 490 DO 500 I=NSAV+NJET+1,N
	+ IF(MSTU(16).NE.2) K(I,3)=NSAV+1
	+ IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
	+ 500 CONTINUE
	+ DO 510 I=NSAV+1,NSAV+NJET
	+ I1=K(I,3)
	+ K(I1,1)=K(I1,1)+10
	+ IF(MSTU(16).NE.2) THEN
	+ K(I1,4)=NSAV+1
	+ K(I1,5)=NSAV+1
	+ ELSE
	+ K(I1,4)=K(I1,4)-NJET+1
	+ K(I1,5)=K(I1,5)-NJET+1
	+ IF(K(I1,5).LT.K(I1,4)) THEN
	+ K(I1,4)=0
	+ K(I1,5)=0
	+ ENDIF
	+ ENDIF
	+ 510 CONTINUE
	+
	+C...Document independent fragmentation system. Remove copy of jets.
	+ NSAV=NSAV+1
	+ K(NSAV,1)=11
	+ K(NSAV,2)=93
	+ K(NSAV,3)=IP
	+ K(NSAV,4)=NSAV+1
	+ K(NSAV,5)=N-NJET+1
	+ DO 520 J=1,4
	+ P(NSAV,J)=DPS(J)
	+ V(NSAV,J)=V(IP,J)
	+ 520 CONTINUE
	+ P(NSAV,5)=SQRT(MAX(0D0,DPS(4)2-DPS(1)2-DPS(2)2-DPS(3)2))
	+ V(NSAV,5)=0D0
	+ DO 540 I=NSAV+NJET,N
	+ DO 530 J=1,5
	+ K(I-NJET+1,J)=K(I,J)
	+ P(I-NJET+1,J)=P(I,J)
	+ V(I-NJET+1,J)=V(I,J)
	+ 530 CONTINUE
	+ 540 CONTINUE
	+ N=N-NJET+1
	+ DO 550 IZ=MSTU90+1,MSTU(90)
	+ MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
	+ 550 CONTINUE
	+
	+C...Boost back particle system. Set production vertices.
	+ IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
	+ &DPS(2)/DPS(4),DPS(3)/DPS(4))
	+ DO 570 I=NSAV+1,N
	+ DO 560 J=1,4
	+ V(I,J)=V(IP,J)
	+ 560 CONTINUE
	+ 570 CONTINUE
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYDECY
	+C...Handles the decay of unstable particles.
	+
	+ SUBROUTINE PYDECY(IP)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
	+C...Local arrays.
	+ DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
	+ &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
	+ CHARACTER CIDC*4
	+ DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
	+ logical :: first, second
	+ integer :: idx
	+
	+C...Functions: momentum in two-particle decays and four-product.
	+ PAWT(A,B,C)=SQRT((A2-(B+C)2)(A2-(B-C)2))/(2D0A)
	+ 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) == K(ITAU,2)) THEN
	+C...If tau -> tau + gamma then add gamma energy and loop.
	+!!! BCN: Catching invalid access to K(0,2)
	+ idx = K(IMTAU,4)
	+ IF(idx > 0) THEN
	+ first = K(idx,2) == 22
	+ ELSE
	+ first = .false.
	+ END IF
	+ idx = K(IMTAU,5)
	+ IF(idx > 0) THEN
	+ second = K(idx,2) == 22
	+ ELSE
	+ second = .false.
	+ END IF
	+ IF(first) THEN
	+ DO 130 J=1,4
	+ PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
	+ 130 CONTINUE
	+ ELSEIF(second) 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 .AND.
	+ & IABS(K(IMTAU,2)).LT.1000000) 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)
	+C DO 200 II=NSAV+1,NSAV+NDECAY
	+C K(II,1)=1
	+C K(II,3)=IP
	+C K(II,4)=0
	+C K(II,5)=0
	+C 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... call pylist (2)
	+
	+C... If Parent is Higgs (IORIG=25,35,36), another tau is boosted and rotate.
	+C... Only Higgs to tau pair decay
	+C... Fix Akiya Miyamoto for transversely polarized taus.
	+C IF(KFORIG.EQ.25.OR.KFORIG.EQ.35.OR.KFORIG.EQ.36) THEN
	+C ITFOUND=0
	+C IF (.NOT.(K(IORIG,4).EQ.0.OR.K(IORIG,5).EQ.0)) THEN
	+C DO 60210 J=K(IORIG,4), K(IORIG,5)
	+C IF( ABS(K(J,2)).EQ.15 ) THEN
	+C ITFOUND=ITFOUND+1
	+C IF( ITFOUND.GT.3 ) THEN
	+C PRINT *,'%%Fatal error in PYDCAY after PYTAUD,'
	+C PRINT *,'call: Higgs has >2 tau daughters.'
	+C STOP
	+C ENDIF
	+C CALL PYROBO(J,J,THETAU,PHITAU,0D0,0D0,0D0)
	+C CALL PYROBO(J,J,0D0,0D0,DBETAU(1),
	+C & DBETAU(2),DBETAU(3))
	+C ENDIF
	+C60210 CONTINUE
	+C ENDIF
	+C ... In the case of single tau decay, copy momentum before PYTAUD
	+C ELSE
	+ DO 211 J=1,4
	+ P(ITAU,J)=PTAU(J)
	+ 211 CONTINUE
	+C ENDIF
	+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.5D0XBBMIXV(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(100MOD(KFA/10,100)+3)
	+ ELSEIF(KPA.EQ.81) THEN
	+ KFP=KFS(1000MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
	+ ELSEIF(KP.EQ.82) THEN
	+ CALL PYDCYK(-KFSINT(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(-2D0CNDELOG(MAX(1D-10,PYR(0))))*
	+ & SIN(PARU(2)*PYR(0))
	+ ND=0.5D0+0.5D0NP+0.25D0NQ+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
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ IF(NQ.EQ.4) THEN
	+ IF(PYR(0).LT.PARJ(66)) JT=4
	+ ENDIF
	+ 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=4D0PMAS(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.5D0PMES/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(PA2+P(N+IL,5)2)
	+ PV(IL+1,4)=SQRT(PA2+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(GABEP/(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
	+ & +2D0FOUR(N+1,N+2)FOUR(N+1,N+3)*FOUR(N+2,N+3)
	+ IF(MAX(WTWTCOR(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.5D0PMES)(FOUR122+FOUR132)+
	+ & PMES(FOUR12FOUR13+FOUR122+FOUR132)
	+ IF(WT.LT.PYR(0)0.25D0PMST(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=(FOUR10FOUR12-PMS1FOUR02)**2
	+ IF(KFAS.EQ.22) HNUM=PMS1(2D0FOUR10FOUR12FOUR02-
	+ & PMS1FOUR022-PMS0FOUR12*2-PMS2FOUR10*2+PMS1PMS0*PMS2)
	+ HNUM=MAX(1D-6PMS12PMS0*PMS2,HNUM)
	+ HDEN=(FOUR10*2-PMS1PMS0)(FOUR122-PMS1PMS2)
	+ 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=2D0FOUR(IP,N+1)/P(IP,5)*2
	+ HX2=2D0FOUR(IP,N+2)/P(IP,5)*2
	+ HX3=2D0FOUR(IP,N+3)/P(IP,5)*2
	+ WT=((1D0-HX1)/(HX2HX3))2+((1D0-HX2)/(HX1HX3))**2+
	+ & ((1D0-HX3)/(HX1HX2))*2
	+ IF(WT.LT.2D0*PYR(0)) GOTO 390
	+ IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)P(IP,5)2.LT.4D0PARJ(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=2D0FOUR(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-2D0HX1).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-2D0HD(P(N+1,4)2+P(N+2,4)2)+HD*2
	+ HF=HDHC-HB*2
	+ HG=HDHC-HAHB
	+ HH=(SQRT(HG*2+HEHF)-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(GABEP/(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)+2KFL1B+(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)+2KFL2B+(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
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ IF(MSTU(121).NE.-1) THEN
	+ IF((1D0+PARJ(1))*PYR(0).GT.1D0)THEN
	+ MBARY=1
	+ CALL PYNMES(0)
	+ ENDIF
	+ ELSE
	+ 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=SQWTPARF(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=33+3MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
	+ ENDIF
	+ ELSE
	+ IF(MSTU(121).EQ.0)THEN
	+ IPOS=35+5MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
	+ ELSE
	+ IPOS=35+54+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=900MAX(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=(100KFLA+10KFLB+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=(100KFLA+10KFLB+KFLS)KFS(-1)**KFLA
	+ ELSE
	+ RMIX=PYR(0)
	+ IMIX=2KFLA+10KMUL
	+ 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=SU6OCT4SU6S/(3*SU6S+1)
	+ IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)4/(3SU6S+1)
	+ ELSE
	+ IF(KBARY.EQ.6) SU6OCT=SU6OCT(3+SU6S)/(3SU6S+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(3SU6S/(3SU6S+KFLDS**2)+PYR(0))
	+ ENDIF
	+ KF=ISIGN(1000KFLD+100KFLE+10*KFLF+KFLS,KFL1)
	+ IF(KSIG.EQ.0) KF=ISIGN(1000KFLD+100KFLF+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+80KTAB1+25KTS+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+80KTAB1+25KTS+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(2KTAB1-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=1000KFL3A+100KFL3B+1
	+ IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A(KFL3A-2)+2KFL3B) KFL3=
	+ & KFL3+2
	+ KFL3=ISIGN(KFL3,KFL1(13-2KTAB1))
	+ 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+80KTAB1+25KTABS)+PARF(144+80KTAB1+
	+ & 25KTABS)+PARF(145+80KTAB1+25*KTABS))
	+ KF=110+2*KTABS+1
	+ IF(RFL.GT.PARF(143+80KTAB1+25KTABS)) KF=220+2*KTABS+1
	+ IF(RFL.GT.PARF(143+80KTAB1+25KTABS)+PARF(144+80*KTAB1+
	+ & 25KTABS)) KF=330+2KTABS+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=(100KFLA+10KFLB+2KTABS+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=(100KFLA+10KFLB+2KTABS+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(1000KFLD+100KFLF+10*KFLE+2,KFL1)
	+ IF(KTABS.GE.1) KF=ISIGN(1000KFLD+100KFLE+10KFLF+2KTABS,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)=3D0PARJ(18)/(2D0PARJ(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)4PARF(146)/(3*PARF(146)+1)
	+ 100 CONTINUE
	+ SU6(8)=SU6(2)4/(3PARF(146)+1)
	+ SU6(6)=SU6(6)(3+PARF(146))/(3PARF(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=(2D0SU6(1)+PARJ(2)SU6(8))
	+ DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
	+ DMB(IUS0)=DMB(ISU0)
	+ DMB(ISS1)=(2D0SU6(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)=(2D0SU6(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)=PAR2MPARJ(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)6D0QBB(ISS1)
	+ QBM(IUU1)=6D0*QBB(IUU1)
	+ QBM(ISU1)=3D0*QBB(ISU1)
	+ QBM(IUS1)=PARJ(2)3D0QBB(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)=6D0PARJ(2)EXP(-PARJ(10)PMSS1)DMB(7+ISU0)
	+ DMB(7+IUU1)=6D0EXP(-PARJ(10)PMUD1)
	+ DMB(7+ISU1)=3D0EXP(-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)=WQWSQBM(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=2KFQOLD+10KMUL
	+ 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=100KFLA+10KFLB+KFJ
	+ PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
	+ PARF(IPOS+IMES)=QWTSWTEXP(-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+5KMUL+ID)=QWTSWTDWTEXP(-PARF(193)*PMM)
	+ IF(KMUL.EQ.0.AND.ID.GT.3) THEN
	+ WTFAIL=WTFAIL+QWTSWTDWT*(1D0-PARJ(21+ID))
	+ PARF(IPOS+5*KMUL+ID)=
	+ & PARF(IPOS+5KMUL+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+FREDFBBPARF(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+4D0FA*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(ZMAX0.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=FCLOG(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 zc.
	+ 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(-4D0FCZ(1D0-Z)2.LT.PYR(0)((1D0-Z)*2-FCZ)**2)
	+ & GOTO 110
	+ ELSE
	+ IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
	+ IF(FC.LT.0D0) Z=Z**(-1D0/FC)
	+ ENDIF
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYSHOW
	+C...Generates timelike parton showers from given partons.
	+
	+ SUBROUTINE PYSHOW(IP1,IP2,QMAX)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
	+C...Local arrays.
	+ DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
	+ &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
	+ &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
	+ &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
	+ &IREF(1000)
	+
	+C...Check that QMAX not too low.
	+ IF(MSTJ(41).LE.0) THEN
	+ RETURN
	+ ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
	+ IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
	+ ELSE
	+ IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
	+ & RETURN
	+ ENDIF
	+
	+C...Store positions of shower initiating partons.
	+ MPSPD=0
	+ IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
	+ NPA=1
	+ IPA(1)=IP1
	+ ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
	+ & MSTU(32))) THEN
	+ NPA=2
	+ IPA(1)=IP1
	+ IPA(2)=IP2
	+ ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
	+ & .AND.IP2.GE.-80) THEN
	+ NPA=IABS(IP2)
	+ DO 100 I=1,NPA
	+ IPA(I)=IP1+I-1
	+ 100 CONTINUE
	+ ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
	+ &IP2.EQ.-100) THEN
	+ MPSPD=1
	+ NPA=2
	+ IPA(1)=IP1+6
	+ IPA(2)=IP1+7
	+ ELSE
	+ CALL PYERRM(12,
	+ & '(PYSHOW:) failed to reconstruct showering system')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+
	+C...Send off to PYPTFS for pT-ordered evolution if requested,
	+C...if at least 2 partons, and without predefined shower branchings.
	+ IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
	+ &MPSPD.EQ.0) THEN
	+ NPART=NPA
	+ DO 110 II=1,NPART
	+ IPART(II)=IPA(II)
	+ PTPART(II)=0.5D0*QMAX
	+ 110 CONTINUE
	+ CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
	+ RETURN
	+ ENDIF
	+
	+C...Initialization of cutoff masses etc.
	+ DO 120 IFL=0,40
	+ ISCOL(IFL)=0
	+ ISCHG(IFL)=0
	+ KSH(IFL)=0
	+ 120 CONTINUE
	+ ISCOL(21)=1
	+ KSH(21)=1
	+ PMTH(1,21)=PYMASS(21)
	+ PMTH(2,21)=SQRT(PMTH(1,21)*2+0.25D0PARJ(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.25D0PARJ(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.25D0PMQTH1**2)
	+ PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
	+ PMTH(4,IFL)=SQRT(PMTH(1,IFL)*2+0.25D0PARJ(82)**2)+PMTH(2,21)
	+ PMTH(5,IFL)=SQRT(PMTH(1,IFL)*2+0.25D0PARJ(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.25D0PARJ(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.5D0PARJ(82),1.1D0PARJ(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.25D0PMQTH1**2)
	+ PMTH(3,IR)=PMTH(2,IR)+PMQTH2
	+ PMTH(4,IR)=SQRT(PMTH(1,IR)*2+0.25D0PARJ(82)**2)+PMTH(2,21)
	+ PMTH(5,IR)=SQRT(PMTH(1,IR)*2+0.25D0PARJ(83)**2)+PMTH(2,22)
	+ ELSEIF(ISCOL(IR).EQ.1) THEN
	+ PMTH(2,IR)=SQRT(PMTH(1,IR)*2+0.25D0PARJ(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.25D0PARJ(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-4D0EIPARU(102)
	+ EF=KCHG(KFLA(1),1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFPARU(102)
	+ XWC=1D0/(16D0PARU(102)(1D0-PARU(102)))
	+ SH=PS(5)**2
	+ SQMZ=PMAS(23,1)**2
	+ SQWZ=PS(5)*PMAS(23,2)
	+ SBWZ=1D0/((SH-SQMZ)2+SQWZ2)
	+ VECT=EI*2EF*2+2D0EIVIEFVFXWCSH(SH-SQMZ)*SBWZ+
	+ & (VI2+AI2)VF2XWC*2SH*2SBWZ
	+ AXIV=(VI2+AI2)AF2XWC*2SH*2SBWZ
	+ 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-(2D0PMTH(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-(2D0PMTMPE/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=6D0LOG((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=6D0MSTJ(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)*22D0*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.4D0PMTH(2,IFF)2) B0=(33D0-2D0IFF)/6D0
	+ 430 CONTINUE
	+C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
	+ PMSC=MAX(0.5D0PARJ(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=PMSCEXP(MAX(-50D0,LOG(PYR(0))PARU(2)/(PARU(111)*FBR)))
	+ ELSEIF(MSTJ(44).EQ.1) THEN
	+ PMSQCD=4D0ALAMS(0.25D0PMSC/ALAMS)(PYR(0)*(B0/FBR))
	+ ELSE
	+ PMSQCD=PMSCEXP(MAX(-50D0,ALFMB0*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.5D0PARJ(83),PMS-PMTH(1,IR)*2)
	+ IF(FBRE.LT.1D-3) THEN
	+ PMSQED=0D0
	+ ELSE
	+ PMSQED=PMSEEXP(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-
	+ & 4D0PMSGD1PMSGD2))
	+ 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.2D0PYR(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.
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ IF(M3JC.EQ.0) THEN
	+ IF(1D0+Z*2.LT.2D0PYR(0)) GOTO 410
	+ ENDIF
	+ 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(Z2+(1D0-Z)2.LT.PYR(0)) GOTO 410
	+ KFLB=1+INT(MSTJ(45)*PYR(0))
	+ PMQ=4D0PMTH(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=4D0PMTH(2,21)*2/V(IEP(1),5)
	+ IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0PMQ)SQRT(1D0-PMQ)
	+ & .LT.PYR(0)(1D0+0.5D0PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
	+ ELSE
	+ IF((1D0+0.5D0PMQ)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-2D0ZC)PYR(0)
	+ K(IEP(1),5)=21
	+ ELSE
	+ Z=ZC+(1D0-2D0ZC)PYR(0)
	+ KFLB=1+INT(MSTJ(45)*PYR(0))
	+ PMQ=4D0PMTH(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+PMQTH32)/V(IEP(1),5)
	+ PMQ2=(PMTH(1,IRGD2)2+PMQTH32)/V(IEP(1),5)
	+ ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED*2)((1D0-PMQ1-PMQ2)**2-
	+ & 4D0PMQ1PMQ2)))
	+ 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.5D0PS(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(X12+X22)
	+ 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,PEDME2-PS1ME+PM2ME2))
	+ 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-PM2ME2)2-
	+ & 4D0PS1MEPM2ME**2))
	+ PEDME=PEM(0.5D0(V(IM,5)-PMLME+PS1ME-PM2ME*2)+PMLMEZMME)/
	+ & V(IM,5)
	+ ECMME=PEDME+SQRT(MAX(0D0,PEDME2-PS1ME+PM2ME2))
	+ 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,PEDME2-PS1ME+PM2ME2))
	+ M3JCC=66
	+ ENDIF
	+C...Construct ME variables.
	+ R1ME=PM1ME/ECMME
	+ R2ME=PM2ME/ECMME
	+ X1=(1D0+PS1ME/ECMME2-R2ME2)(Z+(1D0-Z)PM1ME**2/PS1ME)
	+ X2=1D0+R2ME2-PS1ME/ECMME2
	+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=WMEMAX(1D-10,1D0+R1ME2-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+R2ME2-R1ME2-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=4D0X3((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)-4D0PMDAO**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)*2THE2ID.LT.1D0) GOTO 410
	+ ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
	+ THE2ID=Z(1D0-Z)(0.5D0P(IM,4))*2/V(IEP(1),5)
	+ IF(PARJ(85)*2THE2ID.LT.1D0) GOTO 410
	+ ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
	+ THE2ID=Z(1D0-Z)(0.5D0P(IM,4))*2/V(IEP(1),5)
	+ IF(PARJ(86)*2THE2ID.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.5D0P(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-
	+ & 4D0V(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+PMQTH32)/V(I1,5)
	+ PMQ2=(PMTH(1,IRGD2)2+PMQTH32)/V(I1,5)
	+ ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED*2)((1D0-PMQ1-PMQ2)**2-
	+ & 4D0PMQ1PMQ2)))
	+ 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-
	+ & 4D0PMQ1PMQ2)))
	+ 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-4D0V(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=PMLSZM(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)-
	+ & ZMV(N+2,5))-0.25D0PMLS)/PZM**2
	+ ELSE
	+ PTS=PMLS(ZM(1D0-ZM)PEM2/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=2D0ZAU/(1D0+ZAU*2)
	+ ELSE
	+ HAZIP=(ZAU/(1D0-ZAU(1D0-ZAU)))*2
	+ ENDIF
	+ IF(K(N+1,2).NE.21) THEN
	+ HAZIP=HAZIP(-2D0ZM(1D0-ZM))/(1D0-2D0ZM*(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)/(ZSZGM))
	+ 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))+
	+ & PZMSQRT(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))+
	+ & PEMSQRT(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)+
	+ & 2D0PEMP(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)=(PEMP(N+1,4)-PZMP(N+1,3))/P(IM,5)
	+ V(N+2,2)=(PEMP(N+2,4)-PZMP(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(BEXP(IM,1)+BEYP(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)+GABEPBEX)2+(P(IM,2)+GABEPBEY)**2)
	+ THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
	+ IF(PTIMB.GT.1D-4) THEN
	+ PHI=PYANGL(P(IM,1)+GABEPBEX,P(IM,2)+GABEPBEY)
	+ 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=BEXDP(1)+BEYDP(2)+BEZ*DP(3)
	+ DGABP=GA(GADBP/(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(2D0CAD*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-HAZICCAD)/(1D0+HAZIC*2-2D0HAZIC*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-HAZIICAD)/(1D0+HAZII*2-2D0HAZII*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
	+C...JRR: due to ifort/gfortran differences: PYR in new if-clause.
	+ IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21)) THEN
	+ IF(PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
	+ ENDIF
	+ 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(BEXP(IPA(1),1)+BEYP(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)
	+ & +GABEPBEX)2+(P(IPA(1),2)+GABEPBEY)**2))
	+ PHI=PYANGL(P(IPA(1),1)+GABEPBEX,P(IPA(1),2)+GABEPBEY)
	+ MSTU(33)=1
	+ CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
	+ ELSE
	+ CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
	+ & PS(3)/PS(4))
	+ MSTU(33)=1
	+ CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
	+ ENDIF
	+
	+C...Decay vertex of shower.
	+ DO 630 I=NS+1,N
	+ DO 620 J=1,5
	+ V(I,J)=V(IP1,J)
	+ 620 CONTINUE
	+ 630 CONTINUE
	+
	+C...Delete trivial shower, else connect initiators.
	+ IF(N.LE.NS+NPA+IIM) THEN
	+ N=NS
	+ ELSE
	+ DO 640 IP=1,NPA
	+ K(IPA(IP),1)=14
	+ K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
	+ K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
	+ K(NS+IIM+IP,3)=IPA(IP)
	+ IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
	+ IF(K(NS+IIM+IP,1).NE.1) THEN
	+ K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
	+ K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
	+ ENDIF
	+ 640 CONTINUE
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYPTFS
	+C...Generates pT-ordered timelike final-state parton showers.
	+
	+C...MODE defines how to find radiators and recoilers.
	+C... = 0 : based on colour flow between undecayed partons.
	+C... = 1 : for IPART <= NPARTD only consider primary partons,
	+C... whether decayed or not; else as above.
	+C... = 2 : based on common history, whether decayed or not.
	+C... = 3 : use (or create) MCT color information to shower partons
	+
	+ SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Parameter statement for maximum size of showers.
	+ PARAMETER (MAXNUR=1000)
	+C...Commonblocks.
	+ COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
	+ &/PYINT1/
	+C...Local arrays.
	+ DIMENSION IPOS(2MAXNUR),IREC(2MAXNUR),IFLG(2*MAXNUR),
	+ &ISCOL(2MAXNUR),ISCHG(2MAXNUR),PTSCA(2MAXNUR),IMESAV(2MAXNUR),
	+ &PT2SAV(2MAXNUR),ZSAV(2MAXNUR),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.1D0ALAM3)*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-4D0EIPARU(102)
	+ EF=KCHG(KFLA1,1)/3D0
	+ AF=SIGN(1D0,EF+0.1D0)
	+ VF=AF-4D0EFPARU(102)
	+ XWC=1D0/(16D0PARU(102)(1D0-PARU(102)))
	+ SH=PSUM(5)**2
	+ SQMZ=PMAS(23,1)**2
	+ SQWZ=PSUM(5)*PMAS(23,2)
	+ SBWZ=1D0/((SH-SQMZ)2+SQWZ2)
	+ VECT=EI*2EF*2+2D0EIVIEFVFXWCSH(SH-SQMZ)*SBWZ+
	+ & (VI2+AI2)VF2XWC*2SH*2SBWZ
	+ AXIV=(VI2+AI2)AF2XWC*2SH*2SBWZ
	+ 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.25D0SHTCOR,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.5D00.5D0NFLAV
	+
	+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=WTPSGLCOLFACLOG(1D0/ZMNCUT-1D0)/B0
	+ EVCOEF=EVEMGL
	+ IF(MOCT.EQ.1) THEN
	+ EVEMQQ=WTPSQQ(1D0-2D0ZMNCUT)/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-2D0ZMNCUT)
	+ 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.PM2SHT/(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.WTPSGLPYR(0)) GOTO 350
	+
	+C...Weighting of g->gg branching.
	+ ELSEIF(IFLAG.EQ.1) THEN
	+ IF(1D0+Z*3.LT.WTPSGLPYR(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-4D0PMQ*2/PM2))
	+ WTME=ROOTQQ(Z2+(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=AEM2PICHG2WTPSGA*LOG(1D0/ZMNCUT-1D0)
	+
	+C...Pick pT2 (in overestimated z range).
	+ 370 PT2=PT2PYR(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.PM2SHT/(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.WTPSGAPYR(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-4D0PMQ*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=-ASYPOL2D0Z(1D0-Z)/(1D0-2D0Z*(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.5D0SQRT(MAX(0D0,(SHT-PM2-PM2R)2-4D0PM2*PM2R)/SHT)
	+ PT2COR=PM2(PEM2Z(1D0-Z)-0.25D0PM2)/PZM**2
	+ PTCOR=SQRT(MAX(0D0,PT2COR))
	+ PZN=(PEM*2Z-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(PTCOR2+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(PTCOR2+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(2D0CAD*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=WMEMAX(1D-10,1D0+R1ME2-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+R2ME2-R1ME2-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(X12+X22)
	+ WPS=2D0(CHG12(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+R1ME2-R2ME2-X1)/MAX(1D-10,2D0-X1-X2)
	+ WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
	+ & MAX(1D-10,1D0+R2ME2-R1ME2-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...(X12+X22)/((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.2D0R1.OR.X1.GE.1D0+R12-R2*2) RETURN
	+ IF(X2.LE.2D0R2.OR.X2.GE.1D0+R22-R1*2) RETURN
	+ IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
	+ IF((2D0-2D0X1-2D0X2+X1X2+2D0R1*2+2D0R22)2.GE.
	+ &(X1*2-4D0R1*2)(X2*2-4D0R2**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=PS2D0((X1+X2-1D0+ANUM-R12-R22)/
	+ & ((1D0+R12-R22-X1)(1D0+R22-R1*2-X2))-
	+ & R12/(1D0+R22-R12-X2)2-
	+ & R22/(1D0+R12-R22-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-R12-R14+6R1R2-R22+2R1*2R22-R24)/2.D0
	+ RFO1=-1.D0(3+6R12+R14-6R1R2+6R13R2-2R2*2
	+ & -6R12R2*2+6R1R23+R24-3X1+6R1R2*X1
	+ & +2R22X1+X1*2-2R1*2X1*2+3R1*2(2-X1-X2)
	+ & +6R1R2(2-X1-X2)-R22(2-X1-X2)-2X1(2-X1-X2)
	+ & -5R12X1(2-X1-X2)+R22X1(2-X1-X2)+X12(2-X1-X2)
	+ & -3(2-X1-X2)2-3R1*2(2-X1-X2)2+R22(2-X1-X2)*2
	+ & +2X1(2-X1-X2)2+(2-X1-X2)3-X2)/
	+ & (-1+R12-R22+X2)**2
	+ RFO1=RFO1-2(-3+R12-6R1R2+6R1*3R2+3R22-4R1*2R2**2
	+ & +6R1R2*3+2X1+3R12X1+R2*2X1-X12-R12X1*2
	+ & -R2*2X1*2+4(2-X1-X2)+2R12(2-X1-X2)+3R1R2*(2-X1
	+ & -X2)-R2*2(2-X1-X2)-3X1(2-X1-X2)-2R12X1*(2-X1-X2)
	+ & +X1*2(2-X1-X2)-(2-X1-X2)2-R12(2-X1-X2)2+R1R2*(2
	+ & -X1-X2)*2+X1(2-X1-X2)**2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ RFO1=RFO1-1.D0(-1+2R12+R14+6R1R2+6R13R2-2R2*2
	+ & -6R12R2*2+6R1R23+R24-X1-2R1*2X1-6R1R2*X1
	+ & +8R22X1+X1*2-2R2*2X12-R12(2-X1-X2)+R22(2
	+ & -X1-X2)-R1*2X1(2-X1-X2)+R22X1(2-X1-X2)+X12
	+ & (2-X1-X2)+X2)/(-1-R12+R22+X1)**2
	+ RFO1=RFO1/2.D0
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(2-R12-R14-6R1R2-R22+2R1*2R22-R24)/2.D0
	+ RFO2=-1(3+6R12+R14+6R1R2-6R13R2-2R2*2
	+ & -6R12R2*2-6R1R23+R24-3X1-6R1R2X1+2R2*2X1
	+ & +X1*2-2R1*2X1*2+3R1*2(2-X1-X2)-6R1R2*(2-X1-X2)
	+ & -R2*2(2-X1-X2)-2X1(2-X1-X2)-5R12X1*(2-X1-X2)
	+ & +R2*2X1(2-X1-X2)+X12(2-X1-X2)-3(2-X1-X2)*2
	+ & -3R12(2-X1-X2)2+R22(2-X1-X2)2+2X1(2-X1-X2)*2
	+ & +(2-X1-X2)3-X2)/(-1+R12-R22+X2)2
	+ RFO2=RFO2-2(-3+R12+6R1R2-6R1*3R2+3R22-4R1*2R2**2
	+ & -6R1R2*3+2X1+3R12X1+R2*2X1-X12-R12X1*2
	+ & -R2*2X1*2+4(2-X1-X2)+2R12(2-X1-X2)-3R1R2*(2-X1
	+ & -X2)-R2*2(2-X1-X2)-3X1(2-X1-X2)-2R12X1*(2-X1-X2)
	+ & +X1*2(2-X1-X2)-(2-X1-X2)2-R12(2-X1-X2)2-R1R2*(2
	+ & -X1-X2)*2+X1(2-X1-X2)**2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ RFO2=RFO2-1(-1+2R12+R14-6R1R2-6R13R2-2R2*2
	+ & -6R12R2*2-6R1R23+R24-X1-2R1*2X1+6R1R2*X1
	+ & +8R22X1+X1*2-2R2*2X12-R12(2-X1-X2)+R22(2-X1
	+ & -X2)-R1*2X1(2-X1-X2)+R22X1(2-X1-X2)+X12(2-X1-X2)
	+ & +X2)/(-1-R12+R22+X1)**2
	+ RFO2=RFO2/2.D0
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(2D0-R12-R14-R22+2D0R1*2R22-R24)/2D0
	+ RFO4=(1-R1*4+6R1*2R22-R24+X1+3R12X1-9R22X1
	+ & -3X12-R12X1*2+3R2*2X12+X13-X2-R1*2X2
	+ & +R2*2X2-R1*2X1X2+R22X1X2+X12X2)/
	+ & (-1-R12+R22+X1)**2
	+ RFO4=RFO4
	+ & -2(1+R12+R22-4R1*2R22+R12X1+2R2*2X1-X1**2
	+ & -R2*2X1*2+2R1*2X2+R2*2X2-3X1X2+X1*2X2-X2**2
	+ & -R1*2X2*2+X1X2**2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ RFO4=RFO4+(1-R1*4+6R1*2R22-R24-X1+R1*2X1-R2*2X1+X2
	+ & -9R12X2+3R22X2+R1*2X1X2-R22X1X2-3X2**2
	+ & +3R12X22-R22X22+X1X22+X23)/
	+ & (-1+R12-R22+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-2D0R12+R14+R2*2-6D0R1R2*2
	+ & +R1*2R2*2-2D0R2**4)
	+ RFO1=2(-1+R1-2R1*2+2R13-R14+R15-R22+R1R2*2
	+ & -5R12R22+R13R22-2R1R24+2X1-2R1X1
	+ & +2R12X1-2R13X1+2R22X1+5R1R2*2X1
	+ & +R1*2R2*2X1+2R24X1-X1*2+R1X12-R22X12+3X2
	+ & +4R12X2+R1*4X2+2R22X2+2R12R2*2X2-4X1X2
	+ & -2R12X1X2-R22X1X2+X12X2-2X2*2
	+ & -2R12X2*2+X1X22)/(1-R12+R2**2-X2)/(-2+X1+X2)
	+ RFO1=RFO1+(2R22+6R1R22-6R1*2R2*2+6R1*3R2**2
	+ & +2R24+6R1R24-R22X1+R1*2R2*2X1-R2*4X1+X2
	+ & -R1*4X2-3R22X2-6R1R2*2X2+9R12R2*2X2
	+ & -2R24X2-X1X2+R12X1X2-X22-3R1*2X2**2
	+ & +2R22X2*2+X1X22)/(-1+R12-R22+X2)2
	+ RFO1=RFO1+(-4-8R12-4R1*4+4R2*2-4R1*2R2*2+8R2**4
	+ & +9X1+10R1*2X1+R1*4X1-3R22X1+6R1R2*2X1
	+ & +R1*2R2*2X1-2R24X1-6X12-2R1*2X12+X13
	+ & +7X2+8R1*2X2+R1*4X2-7R22X2+6R1R2*2X2
	+ & +R1*2R2*2X2-2R24X2-9X1X2-3R12X1*X2
	+ & +2R22X1X2+2X1*2X2-3X22-R12X2**2
	+ & +2R22X2*2+X1X22)/(-2+X1+X2)2
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0-2D0R12+R14+R2*2+6D0R1R2*2
	+ & +R1*2R2*2-2D0R2**4)
	+ RFO2=2(1+R1+2R1*2+2R13+R14+R15+R22+R1R2*2
	+ & +5R12R22+R13R22-2R1R24-2X1-2R1X1
	+ & -2R12X1-2R13X1-2R22X1+5R1R2*2X1
	+ & -R1*2R2*2X1-2R24X1+X1*2+R1X12+R22X12-3X2
	+ & -4R12X2-R1*4X2-2R22X2-2R12R2*2X2+4X1X2
	+ & +2R12X1X2+R22X1X2-X12X2+2X22+2R1*2X2**2
	+ & -X1X22)/(-1+R12-R2*2+X2)/(-2+X1+X2)
	+ RFO2=RFO2+(2R22-6R1R22-6R1*2R2*2-6R1*3R2**2
	+ & +2R24-6R1R24-R22X1+R1*2R2*2X1-R2*4X1+X2
	+ & -R1*4X2-3R22X2+6R1R2*2X2+9R12R2*2X2
	+ & -2R24X2-X1X2+R12X1X2-X22-3R1*2X2**2
	+ & +2R22X2*2+X1X22)/(-1+R12-R22+X2)2
	+ RFO2=RFO2+(-4-8R12-4R1*4+4R2*2-4R1*2R2*2+8R2*4+9X1
	+ & +10R12X1+R1*4X1-3R22X1-6R1R2*2X1
	+ & +R1*2R2*2X1-2R24X1-6X12-2R1*2X12+X13
	+ & +7X2+8R1*2X2+R1*4X2-7R22X2-6R1R2*2X2
	+ & +R1*2R2*2X2-2R24X2-9X1X2-3R12X1*X2
	+ & +2R22X1X2+2X1*2X2-3X22-R12X2*2+2R2*2X2**2
	+ & +X1X22)/(-2+X1+X2)*2
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1.D0-2.D0R12+R14+R22+R12R22-2.D0R2**4)
	+ RFO4=2(1+2R12+R14+R2*2+5R1*2R2*2-2X1-2R12X1
	+ & -2R22X1-R1*2R2*2X1-2R24X1+X12+R22X1*2
	+ & -3X2-4R1*2X2-R1*4X2-2R22X2-2R12R2*2X2
	+ & +4X1X2+2R12X1X2+R22X1X2-X12X2+2X2*2
	+ & +2R12X2*2-X1X22)/(-1+R12-R2**2+X2)/(-2+X1+X2)
	+ RFO4=RFO4+(2R22-6R1*2R2*2+2R24-R22X1+R12R2*2X1
	+ & -R2*4X1+X2-R1*4X2-3R22X2+9R12R2*2X2
	+ & -2R24X2-X1X2+R12X1X2-X22-3R1*2X2**2
	+ & +2R22X2*2+X1X22)/(-1+R12-R22+X2)2
	+ RFO4=RFO4+(-4-8R12-4R1*4+4R2*2-4R1*2R2*2+8R2*4+9X1
	+ & +10R12X1+R1*4X1-3R22X1+R1*2R2*2X1-2R24X1
	+ & -6X12-2R1*2X12+X13+7X2+8R1*2X2+R1*4X2
	+ & -7R22X2+R1*2R2*2X2-2R24X2-9X1X2-3R12X1*X2
	+ & +2R22X1X2+2X1*2X2-3X22-R12X2*2+2R2*2X2**2
	+ & +X1X22)/(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-R12-R22-2D0R1*R2)
	+ RFO1=-(-1+R1*4-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	+ & +R24+X1-R12X1+2R1R2X1+3R22X1+X2+R1*2X2
	+ & -R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	+ & -2(R12+R14-2R1*3R2+R2*2-6R1*2R2*2-2R1R2*3
	+ & +R24-R12X1+R1R2X1+2R2*2X1+2R12X2+R1R2X2
	+ & -R2*2X2-X1X2)/(-1-R12+R22+X1)/(-1+R12-R2*2+X2)
	+ & -(-1+R1*4-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	+ & +R24+X1-R12X1+R22X1+X2+3R12X2+2R1R2*X2
	+ & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0-R12-R22+2D0R1*R2)
	+ RFO2=-(-1+R1*4+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	+ & +R24+X1-R12X1-2R1R2X1+3R22X1+X2+R1*2X2
	+ & -R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	+ & -(-1+R1*4+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	+ & +R24+X1-R12X1+R22X1+X2+3R12X2-2R1R2*X2
	+ & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	+ & +2(-R12-R14-2R1*3R2-R2*2+6R1*2R2**2
	+ & -2R1R23-R24+R1*2X1+R1R2X1-2R22X1
	+ & -2R12X2+R1R2X2+R2*2X2+X1*X2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1D0-R12-R2*2)
	+ RFO4=-(-1+R1*4-6R1*2R22+R24+X1-R1*2X1+3R22X1+X2
	+ & +R1*2X2-R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	+ & -2(R12+R14+R22-6R1*2R22+R24-R1*2X1
	+ & +2R22X1+2R12X2-R2*2X2-X1*X2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ & -(-1+R1*4-6R1*2R22+R24+X1-R1*2X1+R2*2X1
	+ & +X2+3R12X2-R2*2X2-X1X2)/(-1+R12-R22+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+R12-R22+2D0R1)
	+ RFO1=(4-4R12+4R2*2-3X1-2R1X1+R1*2X1-R2*2X1-5*X2
	+ & -2R1X2+R1*2X2-R2*2X2+X1X2+X22)/(-2+X1+X2)*2
	+ & +2(3-R1-5R12-R13+3R22+R1R2*2-2X1-R1*X1
	+ & +R1*2X1-4X2+2R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (1-R12+R22-X2)/(-2+X1+X2)
	+ & +(2-2R1-6R1*2-2R1*3+2R2*2-2R1R22-X1+R12X1
	+ & -R2*2X1-3X2+2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (-1+R12-R22+X2)**2
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0+R12-R22-2D0R1)
	+ RFO2=(4-4R12+4R2*2-3X1+2R1X1+R1*2X1-R2*2X1-5*X2
	+ & +2R1X2+R1*2X2-R2*2X2+X1X2+X22)/(-2+X1+X2)*2
	+ & +2(3+R1-5R12+R13+3R22-R1R2*2-2X1+R1*X1
	+ & +R1*2X1-4X2+2R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (1-R12+R22-X2)/(-2+X1+X2)
	+ & +(2+2R1-6R1*2+2R1*3+2R2*2+2R1R22-X1+R12X1
	+ & -R2*2X1-3X2-2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (-1+R12-R22+X2)**2
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1D0+R12-R2*2)
	+ RFO4=(4-4R12+4R2*2-3X1+R1*2X1-R2*2X1-5X2+R12X2
	+ & -R2*2X2+X1X2+X22)/(-2+X1+X2)*2
	+ & +2(3-5R1*2+3R2*2-2X1+R1*2X1-4X2+2R1*2X2
	+ & -R2*2X2+X1X2+X22)/(1-R12+R2*2-X2)/(-2+X1+X2)
	+ & +(2-6R12+2R22-X1+R12X1-R22X1-3X2+3R1*2X2
	+ & -R2*2X2+X1X2+X22)/(-1+R12-R22+X2)*2
	+ ISSET4=1
	+ ENDIF
	+
	+C...V -> ~q ~qbar (~q = squark).
	+ ELSEIF(ICLASS.EQ.6) THEN
	+ RLO1=PS(1D0-2D0R12+R14-2D0R22-2D0R1*2R22+R24)
	+ RFO1=2D03D0+(1+R12+R22-X1)(4R12-X1*2)/
	+ & (-1-R12+R22+X1)**2
	+ & -2D0(-1-3R12-R22+X1+X1*2/2+X2-X1X2/2)/
	+ & (-1-R12+R22+X1)
	+ & +(1+R12+R22-X2)(4R22-X22)
	+ & /(-1+R12-R22+X2)**2
	+ & -2D0(-1-R12-3R2*2+X1+X2-X1X2/2+X2**2/2)/
	+ & (-1+R12-R22+X2)
	+ & -(-4R12-4R1*4-4R2*2-8R1*2R2*2-4R2*4+2X1
	+ & +6R12X1+6R22X1-2X12+2X2+6R12X2+6R22X2
	+ & -4X1X2-2R12X1X2-2R2*2X1X2+X12X2-2X2*2
	+ & +X1X22)/(-1-R12+R22+X1)/(-1+R12-R2*2+X2)
	+ ISSET1=1
	+
	+C...~q -> ~q V.
	+ ELSEIF(ICLASS.EQ.7) THEN
	+ RLO1=PS(1D0-2D0R12+R14-2D0R22-2D0R1*2R22+R24)
	+ RFO1=16R22+8(4R22+2R2*2X1+X2+R1*2X2+R2*2X2-X1*X2
	+ & -2X22)/(3(-1+R12-R22+X2))+8(1+R12+R22-X2)
	+ & (4R22-X22)/(3(-1+R12-R22+X2)*2)+8(X1+X2)*
	+ & (-1-2R12-R14-2R2*2+2R1*2R22-R24+2*X1
	+ & +2R12X1+2R22X1-X1*2+2X2+2R12X2+2R22X2
	+ & -2X1X2-X2*2)/(3(-2+X1+X2)*2)+8(-1-R12+R22-X1)*
	+ & (2R22X1+X2+R1*2X2+R2*2X2-X1X2-X2*2)/
	+ & (3(-1+R12-R22+X2)(-2+X1+X2))+8(1+2R12+R14
	+ & +2R22-2R1*2R22+R24-2X1-2R1*2X1-4R22X1
	+ & +X1*2-3X2-3R12X2-3R22X2+3X1X2+2X2*2)/
	+ & (3*(-2+X1+X2))
	+ RFO1=3D0*RFO1/8D0
	+ ISSET1=1
	+
	+C...S -> ~q ~qbar.
	+ ELSEIF(ICLASS.EQ.8) THEN
	+ RLO1=PS
	+ RFO1=(-1-2R12-R14-2R2*2+2R1*2R22-R24+2*X1
	+ & +2R12X1+2R22X1-X12-R22X12+2X2+2R12X2
	+ & +2R22X2-3X1X2-R1*2X1X2-R22X1X2+X12X2-X2**2
	+ & -R1*2X2*2+X1X2**2)/
	+ & (1+R12-R22-X1)2/(-1+R12-R22+X2)2
	+ RFO1=2D0*RFO1
	+ ISSET1=1
	+
	+C...~q -> ~q S.
	+ ELSEIF(ICLASS.EQ.9) THEN
	+ RLO1=PS
	+ RFO1=(-1-R12-R22+X2)/(-1+R12-R22+X2)**2
	+ & +(1+R12-R22+X1)/(-1+R12-R22+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+R12-R22+2D0R1)
	+ RFO1=(2R1+X1)(-1-R12-R22+X1)/(-1-R12+R22+X1)**2
	+ & +2(-1-R12-2R13-R22-2R1R2*2+3X1/2+R1*X1
	+ & -R1*2X1/2-R2*2X1/2+X2+R1X2+R12X2-X1*X2/2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ & +(2-2R1-6R1*2-2R1*3+2R2*2-2R1R22-X1+R12X1
	+ & -R2*2X1-3X2+2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (-1+R12-R22+X2)**2
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0-2D0R1+R12-R22)
	+ RFO2=(2R1-X1)(1+R12+R22-X1)/(-1-R12+R22+X1)**2
	+ & +2(-1-R12+2R13-R22+2R1R2*2+3X1/2-R1*X1
	+ & -R1*2X1/2-R2*2X1/2+X2-R1X2+R12X2-X1*X2/2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ & +(2+2R1-6R1*2+2R1*3+2R2*2+2R1R22-X1+R12X1
	+ & -R2*2X1-3X2-2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (-1+R12-R22+X2)**2
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1+R12-R2*2)
	+ RFO4=X1(-1-R12-R22+X1)/(-1-R12+R22+X1)*2
	+ & +2D0(-1-R12-R22+3X1/2-R1*2X1/2-R2*2X1/2
	+ & +X2+R1*2X2-X1*X2/2)/
	+ & (-1-R12+R22+X1)/(-1+R12-R22+X2)
	+ & +(2-6R12+2R22-X1+R12X1-R22X1-3X2+3R1*2X2
	+ & -R2*2X2+X1X2+X22)/(-1+R12-R22+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+2R1R2+R22-X1-X2)(X1+X2)/(-2+X1+X2)**2
	+ & -(-1+R1*4-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	+ & +R24+X1-R12X1+R22X1+X2+3R12X2+2R1R2*X2
	+ & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	+ & +(-1-2R12-R14-2R1R2-2R1*3R2+2R1R23+R24
	+ & +X1+R1*2X1-2R1R2X1-3R2*2X1+2R12X2-2R22X2
	+ & +X1X2+X22)/(-1+R12-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-2R1R2+R22-X1-X2)(X1+X2)/
	+ & (-2+X1+X2)**2
	+ & -(-1+R1*4+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	+ & +R24+X1-R12X1+R22X1+X2+3R12X2-2R1R2*X2
	+ & -R2*2X2-X1X2)/(-1+R12-R22+X2)*2
	+ & +(-1-2R12-R14+2R1R2+2R1*3R2-2R1R23+R24
	+ & +X1+R1*2X1+2R1R2X1-3R2*2X1+2R12X2-2R22X2
	+ & +X1X2+X22)/(-1+R12-R2*2+X2)/(-2+X1+X2)
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1D0-R12-R2*2)
	+ RFO4=(1+R12+R22-X1-X2)(X1+X2)/(-2+X1+X2)*2
	+ & -(-1+R1*4-6R1*2R22+R24+X1-R1*2X1+R2*2X1+X2
	+ & +3R12X2-R2*2X2-X1*X2)/
	+ & (-1+R12-R22+X2)**2
	+ & -(-1-2R12-R14+R24+X1+R12X1-3R22X1
	+ & +2R12X2-2R22X2+X1X2+X2*2)/
	+ & (2-X1-X2)/(-1+R12-R22+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-R12+R22+2D0R2)
	+ RFO1=(2R2+X2)(-1-R12-R22+X2)/(-1+R12-R22+X2)**2
	+ & +(4+4R12-4R2*2-5X1-R1*2X1-2R2X1+R2*2X1+X1**2
	+ & -3X2-R12X2-2R2X2+R2*2X2+X1*X2)/
	+ & (-2+X1+X2)*2-2(-1-R12+R2+R12R2-R22-R2*3+X1
	+ & +R2X1+R22X1+2X2+R12X2-X1X2/2-X2*2/2)/
	+ & (2-X1-X2)/(-1+R12-R22+X2)
	+ ISSET1=1
	+ END IF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0-R12+R22-2D0R2)
	+ RFO2=(2R2-X2)(1+R12+R22-X2)/(-1+R12-R22+X2)**2
	+ & +(4+4R12-4R2*2-5X1-R1*2X1+2R2X1+R2*2X1+X1**2
	+ & -3X2-R12X2+2R2X2+R2*2X2+X1*X2)/
	+ & (-2+X1+X2)*2-2(-1-R12-R2-R12R2-R22+R2*3+X1
	+ & -R2X1+R22X1+2X2+R12X2-X1X2/2-X2*2/2)/
	+ & (2-X1-X2)/(-1+R12-R22+X2)
	+ ISSET2=1
	+ END IF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1D0-R12+R2*2)
	+ RFO4=X2(-1-R12-R22+X2)/(-1+R12-R22+X2)*2
	+ & +(4+4R12-4R2*2-5X1-R1*2X1+R2*2X1+X1**2
	+ & -3X2-R12X2+R2*2X2+X1*X2)/
	+ & (-2+X1+X2)*2-2(-1-R12-R22+X1+R2*2X1+2*X2
	+ & +R1*2X2-X1X2/2-X2*2/2)/
	+ & (2-X1-X2)/(-1+R12-R22+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+R12-R22+2D0R1)
	+ RFO1=4(2R1+X1)(-1-R12-R22+X1)/(3(-1-R12+R22+X1)**2)
	+ & -(-1-R1*2-2R13-R22-2R1R2*2+3X1/2+R1X1-R12X1/2
	+ & -R2*2X1/2+X2+R1X2+R12X2-X1X2/2)/(3(-1-R12+R22
	+ & +X1)(-1+R12-R22+X2))-3(-1+R1-R12-R13-R2**2
	+ & +R1R22+2X1+R2*2X1-X1*2/2+X2+R1X2+R1*2X2-X1*X2/2)/
	+ & ((-1-R12+R22+X1)(2-X1-X2))+3(4-4R12+4R2*2-3X1
	+ & -2R1X1+R1*2X1-R2*2X1-5X2-2R1X2+R12X2-R2*2X2
	+ & +X1X2+X22)/(-2+X1+X2)2+3(3-R1-5R12-R13+3R2**2
	+ & +R1R22-2X1-R1X1+R12X1-4X2+2R1*2X2-R2*2X2
	+ & +X1X2+X22)/((1-R12+R22-X2)(-2+X1+X2))+4(2-2R1
	+ & -6R12-2R1*3+2R2*2-2R1R22-X1+R12X1-R2*2X1
	+ & -3X2+2R1X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (3(-1+R12-R22+X2)*2)
	+ RFO1=3D0*RFO1/4D0
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0+R12-R22-2D0R1)
	+ RFO2=4(2R1-X1)(1+R12+R22-X1)/(3(-1-R12+R22+X1)**2)
	+ & -3(-1-R1-R12+R13-R22-R1R2*2+2X1+R2*2X1-X1**2/2
	+ & +X2-R1X2+R12X2-X1X2/2)/((-1-R12+R22+X1)(2-X1-X2))
	+ & +(2+2R12-4R1*3+2R2*2-4R1R22-3X1+2R1X1
	+ & +R1*2X1+R2*2X1-2X2+2R1X2-2R1*2X2+X1*X2)/
	+ & (6(-1-R12+R22+X1)(-1+R12-R22+X2))+3(4-4R1**2
	+ & +4R22-3X1+2R1X1+R1*2X1-R2*2X1-5X2+2R1*X2
	+ & +R1*2X2-R2*2X2+X1X2+X22)/(-2+X1+X2)2+3(3+R1
	+ & -5R12+R13+3R2*2-R1R2*2-2X1+R1X1+R12X1-4*X2
	+ & +2R12X2-R2*2X2+X1X2+X2*2)/
	+ & ((1-R12+R22-X2)(-2+X1+X2))+4(2+2R1-6R1*2+2R1**3
	+ & +2R22+2R1R22-X1+R12X1-R2*2X1-3X2-2R1*X2
	+ & +3R12X2-R2*2X2+X1X2+X2*2)/
	+ & (3(-1+R12-R22+X2)*2)
	+ RFO2=3D0*RFO2/4D0
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1D0+R12-R2*2)
	+ RFO4=8X1(-1-R12-R22+X1)/(3(-1-R12+R22+X1)2)-6(-1
	+ & -R12-R22+2X1+R22X1-X12/2+X2+R12X2-X1X2/2)/
	+ & ((-1-R12+R22+X1)(2-X1-X2))+(2+2R1*2+2R2*2-3X1
	+ & +R1*2X1+R2*2X1-2X2-2R1*2X2+X1X2)/(3(-1-R1**2
	+ & +R2*2+X1)(-1+R12-R22+X2))+6(4-4R1*2+4R2*2-3X1
	+ & +R1*2X1-R2*2X1-5X2+R12X2-R2*2X2+X1X2+X2*2)/
	+ & (-2+X1+X2)*2+6(3-5R12+3R2*2-2X1+R1*2X1-4*X2
	+ & +2R12X2-R2*2X2+X1X2+X2*2)/
	+ & ((1-R12+R22-X2)(-2+X1+X2))+8(2-6R12+2R2**2-X1
	+ & +R1*2X1-R2*2X1-3X2+3R1*2X2-R2*2X2+X1X2+X2*2)/
	+ & (3(-1+R12-R22+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-R12-R22-2D0R1*R2)
	+ RFO1=64(1+R12+2R1R2+R22-X1-X2)(X1+X2)/(9(-2+X1+X2)*2)
	+ & -16(-1+R14-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	+ & +R24+X1-R12X1+2R1R2X1+3R22X1+X2+R1*2X2
	+ & -R2*2X2-X1X2)/(-1-R12+R22+X1)2-16(R12+R14
	+ & -2R13R2+R2*2-6R1*2R2*2-2R1R23+R2*4
	+ & -R1*2X1+R1R2X1+2R22X1+2R12X2+R1R2X2-R2*2X2
	+ & -X1X2)/((-1-R12+R22+X1)(-1+R12-R22+X2))
	+ & -64(-1+R14-2R1R2-2R1*3R2-6R12R2*2-2R1R2*3
	+ & +R24+X1-R12X1+R22X1+X2+3R12X2+2R1R2*X2
	+ & -R2*2X2-X1X2)/(9(-1+R12-R22+X2)**2)
	+ & +8(-1+R14-2R1R2+2R1*3R2-2R22-2R1R23-R2*4
	+ & -2R12X1+2R22X1+X1*2+X2-3R1*2X2-2R1R2*X2
	+ & +R2*2X2+X1X2)/((-1-R12+R22+X1)(-2+X1+X2))
	+ RFO1=RFO1
	+ & +8(-1-2R12-R14-2R1R2-2R13R2+2R1R23+R24
	+ & +X1+R1*2X1-2R1R2X1-3R2*2X1+2R12X2-2R22X2
	+ & +X1X2+X22)/(9(2-X1-X2)(-1+R12-R2*2+X2))
	+ RFO1=9D0*RFO1/64D0
	+ ISSET1=1
	+ ENDIF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1-R12-R22+2D0R1*R2)
	+ RFO2=64(1+R12-2R1R2+R22-X1-X2)(X1+X2)/(9(-2+X1+X2)*2)
	+ & -16(-1+R14+2R1R2+2R1*3R2-6R12R2*2+2R1R2*3
	+ & +R24+X1-R12X1-2R1R2X1+3R22X1+X2+R1*2X2
	+ & -R2*2X2-X1X2)/(-1-R12+R22+X1)2-64(-1+R1**4
	+ & +2R1R2+2R13R2-6R12R2*2+2R1R23+R2*4+X1
	+ & -R1*2X1+R2*2X1+X2+3R12X2-2R1R2X2-R22X2
	+ & -X1X2)/(9(-1+R12-R22+X2)*2)+16(-R12-R14
	+ & -2R13R2-R2*2+6R1*2R2*2-2R1R23-R24+R12X1
	+ & +R1R2X1-2R22X1-2R12X2+R1R2X2+R2*2X2+X1*X2)/
	+ & ((-1-R12+R22+X1)(-1+R12-R2*2+X2))
	+ RFO2=RFO2
	+ & +8(-1+R14+2R1R2-2R1*3R2-2R22+2R1R23-R2*4
	+ & -2R12X1+2R22X1+X1*2+X2-3R1*2X2+2R1R2*X2
	+ & +R2*2X2+X1X2)/((-1-R12+R22+X1)(-2+X1+X2))
	+ & +8(-1-2R12-R14+2R1R2+2R13R2-2R1R2**3
	+ & +R24+X1+R12X1+2R1R2X1-3R22X1+2R12X2
	+ & -2R22X2+X1X2+X22)/(9(2-X1-X2)(-1+R12-R2*2+X2))
	+ RFO2=9D0*RFO2/64D0
	+ ISSET2=1
	+ ENDIF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1-R12-R2*2)
	+ RFO4=128(1+R12+R22-X1-X2)(X1+X2)/(9(-2+X1+X2)2)-32(-1
	+ & +R1*4-6R1*2R22+R24+X1-R1*2X1+3R22X1+X2
	+ & +R1*2X2-R2*2X2-X1X2)/(-1-R12+R22+X1)*2
	+ & -32(R12+R14+R22-6R1*2R22+R24-R1*2X1
	+ & +2R22X1+2R12X2-R2*2X2-X1*X2)/
	+ & ((-1-R12+R22+X1)(-1+R12-R22+X2))-128(-1+R1**4
	+ & -6R12R22+R24+X1-R1*2X1+R2*2X1+X2+3R12X2
	+ & -R2*2X2-X1X2)/(9(-1+R12-R22+X2)**2)
	+ & +16(-1+R14-2R22-R24-2R12X1+2R22X1+X1**2
	+ & +X2-3R12X2+R2*2X2+X1*X2)/
	+ & ((-1-R12+R22+X1)*(-2+X1+ X2))
	+ RFO4=RFO4+16(-1-2R12-R14+R24+X1+R12X1-3R2*2X1
	+ & +2R12X2-2R22X2+X1X2+X2*2)/
	+ & (9(1-R12+R22-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-R12+R22+2D0R2)
	+ RFO1=32(2R2+X2)(-1-R12-R22+X2)/(9(-1+R12-R22+X2)**2)
	+ & +8(-1-R12-2R1*2R2-R2*2-2R2*3+X1+R2X1+R2*2X1
	+ & +3X2/2-R12X2/2+R2X2-R22X2/2-X1*X2/2)/
	+ & ((-1-R12+R22+X1)(-1+R12-R22+X2))+8(2+2R12-2R2
	+ & -2R12R2-6R22-2R2*3-3X1-R1*2X1+2R2X1
	+ & +3R22X1+X12-X2-R12X2+R22X2+X1*X2)/
	+ & (-1-R12+R22+X1)*2+32(4+4R12-4R2*2-5X1
	+ & -R1*2X1-2R2X1+R2*2X1+X1*2-3X2-R1*2X2-2R2X2
	+ & +R2*2X2+X1X2)/(9(-2+X1+X2)**2)
	+ RFO1=RFO1+8(3+3R12-R2+R12R2-5R22-R23-4X1-R12X1
	+ & +2R22X1+X1*2-2X2-R2X2+R22X2+X1*X2)/
	+ & ((-1-R12+R22+X1)(2-X1-X2))+8(-1-R12+R2+R12*R2
	+ & -R22-R23+X1+R2X1+R22X1+2X2+R12X2-X1*X2/2
	+ & -X2*2/2)/(9(2-X1-X2)(-1+R12-R2*2+X2))
	+ RFO1=9D0*RFO1/32D0
	+ ISSET1=1
	+ END IF
	+ IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
	+ RLO2=PS(1D0-R12+R22-2D0R2)
	+ RFO2=32(2R2-X2)(1+R12+R22-X2)/(9(-1+R12-R22+X2)**2)
	+ & +8(-1-R12+2R1*2R2-R2*2+2R2*3+X1-R2X1+R2*2X1
	+ & +3X2/2-R12X2/2-R2X2-R22X2/2-X1*X2/2)/
	+ & ((-1-R12+R22+X1)(-1+R12-R22+X2))+8(2+2R12+2R2
	+ & +2R12R2-6R22+2R2*3-3X1-R1*2X1-2R2X1
	+ & +3R22X1+X12-X2-R12X2+R22X2+X1*X2)/
	+ & (-1-R12+R22+X1)*2+8(3+3R12+R2-R12R2-5R2*2
	+ & +R2*3-4X1-R1*2X1+2R22X1+X1*2-2X2+R2X2+R22X2
	+ & +X1X2)/((-1-R12+R22+X1)(2-X1-X2))
	+ RFO2=RFO2+32(4+4R1*2-4R2*2-5X1-R1*2X1+2R2X1+R2*2X1
	+ & +X1*2-3X2-R1*2X2+2R2X2+R2*2X2+X1*X2)/
	+ & (9(-2+X1+X2)2)+8(-1-R12-R2-R12R2-R22+R2*3+X1
	+ & -R2X1+R22X1+2X2+R12X2-X1X2/2-X2*2/2)/
	+ & (9(2-X1-X2)(-1+R12-R22+X2))
	+ RFO2=9D0*RFO2/32D0
	+ ISSET2=1
	+ END IF
	+ IF(ICOMBI.EQ.4) THEN
	+ RLO4=PS(1D0-R12+R2*2)
	+ RFO4=64X2(-1-R12-R22+X2)/(9(-1+R12-R22+X2)*2)
	+ & +16(-1-R12-R22+X1+R22X1+3X2/2-R12X2/2
	+ & -R2*2X2/2-X1*X2/2)/
	+ & ((-1-R12+R22+X1)(-1+R12-R22+X2))+16(3+3R1*2
	+ & -5R22-4X1-R1*2X1+2R22X1+X1*2-2X2+R2*2X2
	+ & +X1X2)/((-1-R12+R22+X1)(2-X1-X2))
	+ & +64(4+4R1*2-4R2*2-5X1-R1*2X1+R2*2X1+X1*2-3X2
	+ & -R1*2X2+R2*2X2+X1X2)/(9(-2+X1+X2)**2)
	+ RFO4=RFO4+16(2+2R1*2-6R2*2-3X1-R1*2X1+3R22X1+X1**2
	+ & -X2-R1*2X2+R2*2X2+X1X2)/(-1-R12+R22+X1)*2
	+ & +16(-1-R12-R22+X1+R22X1+2X2+R12X2-X1*X2/2
	+ & -X2*2/2)/(9(2-X1-X2)(-1+R12-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=PS2D0((X1+X2-1D0+ANUM-R12-R22)/
	+ & ((1D0+R12-R22-X1)(1D0+R22-R1*2-X2))-
	+ & R12/(1D0+R22-R12-X2)2-
	+ & R22/(1D0+R12-R22-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=ALPCORRLO1+(1D0-ALPCOR)RLO2
	+ RFO=ALPCORRFO1+(1D0-ALPCOR)RFO2
	+ ELSEIF(ISSET4.EQ.1) THEN
	+ RLO=RLO4
	+ RFO=RFO4
	+ ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
	+ RLO=0.5D0*(RLO1+RLO2)
	+ RFO=0.5D0*(RFO1+RFO2)
	+ ELSEIF(ISSET1.EQ.1) THEN
	+ RLO=RLO1
	+ RFO=RFO1
	+ ELSE
	+ CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
	+ RLO=1D0
	+ RFO=0D0
	+ ENDIF
	+
	+C...Output.
	+ PYMAEL=RFO/RLO
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYBOEI
	+C...Modifies an event so as to approximately take into account
	+C...Bose-Einstein effects according to a simple phenomenological
	+C...parametrization.
	+
	+ SUBROUTINE PYBOEI(NSAV)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
	+C...Local arrays and data.
	+ DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
	+ &BEIW(100),BEI3W(100)
	+ DATA KFBE/211,-211,111,321,-321,130,310,221,331/
	+C...Statement function: squared invariant mass.
	+ SDIP(I,J)=((P(I,4)+P(J,4))2-(P(I,3)+P(J,3))2-
	+ &(P(I,2)+P(J,2))2-(P(I,1)+P(J,1))2)
	+
	+C...Boost event to overall CM frame. Calculate CM energy.
	+ IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
	+ DO 100 J=1,4
	+ DPS(J)=0D0
	+ 100 CONTINUE
	+ DO 120 I=1,N
	+ KFA=IABS(K(I,2))
	+ IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
	+ & .AND.K(I,3).GT.0) THEN
	+ KFMA=IABS(K(K(I,3),2))
	+ IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
	+ ENDIF
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
	+ DO 110 J=1,4
	+ DPS(J)=DPS(J)+P(I,J)
	+ 110 CONTINUE
	+ 120 CONTINUE
	+ CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
	+ &-DPS(3)/DPS(4))
	+ PECM=0D0
	+ DO 130 I=1,N
	+ IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
	+ 130 CONTINUE
	+
	+C...Check if we have separated strings
	+
	+C...Reserve copy of particles by species at end of record.
	+ IWP=0
	+ IWN=0
	+ NBE(0)=N+MSTU(3)
	+ NMAX=NBE(0)
	+ SMMIN=PECM
	+ DO 190 IBE=1,MIN(10,MSTJ(52)+1)
	+ NBE(IBE)=NBE(IBE-1)
	+ DO 180 I=NSAV+1,N
	+ IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
	+ DO 140 IIBE=1,IBE-1
	+ IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
	+ 140 CONTINUE
	+ ELSE
	+ IF(K(I,2).NE.KFBE(IBE)) GOTO 180
	+ ENDIF
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
	+ IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
	+ CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
	+ RETURN
	+ ENDIF
	+ NBE(IBE)=NBE(IBE)+1
	+ NMAX=NBE(IBE)
	+ K(NBE(IBE),1)=I
	+ K(NBE(IBE),2)=0
	+ K(NBE(IBE),3)=0
	+ K(NBE(IBE),4)=0
	+ K(NBE(IBE),5)=0
	+ P(NBE(IBE),1)=0.0D0
	+ P(NBE(IBE),2)=0.0D0
	+ P(NBE(IBE),3)=0.0D0
	+ P(NBE(IBE),4)=0.0D0
	+ P(NBE(IBE),5)=0.0D0
	+ SMMIN=MIN(SMMIN,P(I,5))
	+C...Check if particles comes from different W's or Z's
	+ IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
	+ IM=I
	+ 150 IF(K(IM,3).GT.0) THEN
	+ IM=K(IM,3)
	+ IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
	+ K(NBE(IBE),5)=IM
	+ IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
	+ IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
	+ IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
	+ IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
	+ ENDIF
	+ ENDIF
	+C...Check if particles comes from different strings.
	+ IF(PARJ(94).GT.0.0D0) THEN
	+ IM=I
	+ 160 IF(K(IM,3).GT.0) THEN
	+ IM=K(IM,3)
	+ IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
	+ K(NBE(IBE),5)=IM
	+ ENDIF
	+ ENDIF
	+ DO 170 J=1,3
	+ P(NBE(IBE),J)=0D0
	+ V(NBE(IBE),J)=0D0
	+ 170 CONTINUE
	+ P(NBE(IBE),5)=-1.0D0
	+ 180 CONTINUE
	+ 190 CONTINUE
	+ IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
	+
	+C...Calculate separation between W+ and W- or between two Z0's.
	+C...No separation if there has been re-connections.
	+ SIGW=PARJ(93)
	+ IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
	+ IF(K(IWP,2).EQ.23) THEN
	+ DMW=PMAS(23,1)
	+ DGW=PMAS(23,2)
	+ ELSE
	+ DMW=PMAS(24,1)
	+ DGW=PMAS(24,2)
	+ ENDIF
	+ DMP=P(IWP,5)
	+ DMN=P(IWN,5)
	+ TAUPD=DMP/SQRT((DMP2-DMW2)*2+(DGW(DMP2)/DMW)2)
	+ TAUND=DMN/SQRT((DMN2-DMW2)*2+(DGW(DMN2)/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.1D0MIN(PMHQ,PARJ(93)3.0D0)
	+ QDELW=0.1D0*MIN(PMHQ,SIGW)
	+ QDEL3W=0.1D0MIN(PMHQ,SIGW3.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.5D0QDEL3/(3.0D0PARJ(93)))
	+ BEEXW=EXP(0.5D0*QDELW/SIGW)
	+ BEEX3W=EXP(0.5D0QDEL3W/(3.0D0SIGW))
	+ 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(QBIN2+QDEL2/12D0)/SQRT(QBIN2+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(QBIN2+QDEL32/12D0)/SQRT(QBIN2+PMHQ*2)
	+ IF(MSTJ(51).EQ.1) THEN
	+ BEEX3=BEEX3*BERT3
	+ BEI3(IBIN)=BEI3(IBIN)*BEEX3
	+ ELSE
	+ BEI3(IBIN)=BEI3(IBIN)EXP(-(QBIN/(3.0D0PARJ(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(QBIN2+QDELW2/12D0)/SQRT(QBIN2+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(QBIN2+QDEL3W*2/12D0)/
	+ & SQRT(QBIN2+PMHQ2)
	+ IF(MSTJ(51).EQ.1) THEN
	+ BEEX3W=BEEX3W*BERT3W
	+ BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
	+ ELSE
	+ BEI3W(IBIN)=BEI3W(IBIN)EXP(-(QBIN/(3.0D0SIGW))**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=(RBIN3-IBIN3)/(3IBIN(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+3D0PARJ(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=(RBIN33-IBIN33)/(3IBIN3(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+3D0PARJ(92)QMOV3))*(2D0/3D0)
	+ RSCALE=1.0D0
	+ IF(MSTJ(54).EQ.2)
	+ & RSCALE=1.0D0-EXP(-(QOLD/(2D0PARJ(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=(RBINW3-IBINW3)/(3IBINW(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+3D0PARJ(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=(RBIN3W3-IBIN3W3)/(3IBIN3W(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+3D0PARJ(92)QMOV3W))*(2D0/3D0)
	+ IF(MSTJ(54).EQ.2)
	+ & RSCALE=1.0D0-EXP(-(QOLD/(2D0SIGW))*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(S12SM3,S13MIN(SM1,SM3),
	+ & S23MIN(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 (WMAXWI.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=S12MIN(MIN(S23,S24),MIN(S13,S14))S34
	+ W=MIN(W,S13MIN(MIN(S23,S34),S12)S24)
	+ W=MIN(W,S14MIN(MIN(S24,S34),S12)S23)
	+ W=MIN(W,MIN(S23,S24)S13S14)
	+ 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,ENEW2-P2-(P(I3,5)+P(I4,5))2)
	+ Q2OLDP=MAX(0.0D0,EOLD2-P2-(P(I3,5)+P(I4,5))2)
	+ CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
	+ DO 370 J=1,3
	+ V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
	+ V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
	+ 370 CONTINUE
	+ ENDIF
	+ 380 CONTINUE
	+ 390 CONTINUE
	+ 400 CONTINUE
	+
	+C...Shift momenta and recalculate energies.
	+ ESUMP=0.0D0
	+ ESUM=0.0D0
	+ PROD=0.0D0
	+ DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
	+ I=K(IM,1)
	+ ESUMP=ESUMP+P(I,4)
	+ DO 410 J=1,3
	+ P(I,J)=P(I,J)+P(IM,J)
	+ 410 CONTINUE
	+ P(I,4)=SQRT(P(I,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	+ ESUM=ESUM+P(I,4)
	+ DO 420 J=1,3
	+ PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
	+ 420 CONTINUE
	+ 430 CONTINUE
	+
	+ PARJ(96)=0.0D0
	+ IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
	+ 440 ALPHA=(ESUMP-ESUM)/PROD
	+ PARJ(96)=PARJ(96)+ALPHA
	+ PROD=0.0D0
	+ ESUM=0.0D0
	+ DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
	+ I=K(IM,1)
	+ DO 450 J=1,3
	+ P(I,J)=P(I,J)+ALPHA*V(IM,J)
	+ 450 CONTINUE
	+ P(I,4)=SQRT(P(I,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	+ ESUM=ESUM+P(I,4)
	+ DO 460 J=1,3
	+ PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
	+ 460 CONTINUE
	+ 470 CONTINUE
	+ IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
	+ & GOTO 440
	+ ENDIF
	+
	+C...Rescale all momenta for energy conservation.
	+ PES=0D0
	+ PQS=0D0
	+ DO 480 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
	+ PES=PES+P(I,4)
	+ PQS=PQS+P(I,5)**2/P(I,4)
	+ 480 CONTINUE
	+ PARJ(95)=PES-PECM
	+ FAC=(PECM-PQS)/(PES-PQS)
	+ DO 500 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
	+ DO 490 J=1,3
	+ P(I,J)=FAC*P(I,J)
	+ 490 CONTINUE
	+ P(I,4)=SQRT(P(I,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	+ 500 CONTINUE
	+
	+C...Boost back to correct reference frame.
	+ 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
	+ DO 520 I=1,N
	+ IF(K(I,1).LT.0) K(I,1)=-K(I,1)
	+ 520 CONTINUE
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYBESQ
	+C...Calculates the momentum shift in a system of two particles assuming
	+C...the relative momentum squared should be shifted to Q2NEW. NI is the
	+C...last position occupied in /PYJETS/.
	+
	+ SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYJETS/,/PYDAT1/
	+C...Local arrays and data.
	+ DIMENSION DP(5)
	+ SAVE HC1
	+
	+ IF(MSTJ(55).EQ.0) THEN
	+ DQ2=Q2NEW-Q2OLD
	+ DP2=(P(I1,1)-P(I2,1))2+(P(I1,2)-P(I2,2))2+
	+ & (P(I1,3)-P(I2,3))**2
	+ DP12=P(I1,1)2+P(I1,2)2+P(I1,3)**2
	+ & -P(I2,1)2-P(I2,2)2-P(I2,3)**2
	+ SE=P(I1,4)+P(I2,4)
	+ DE=P(I1,4)-P(I2,4)
	+ DQ2SE=DQ2+SE**2
	+ DA=SEDEDP12-DP2*DQ2SE
	+ DB=DP2DQ2SE-DP12*2
	+ HA=(DA+SQRT(MAX(DA*2+DQ2(DQ2+SE2-DE2)DB,0D0)))/(2D0DB)
	+ 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.5D0SQRT(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(PZ2+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(PZ2+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.5D0PMAS(KC,2)TAN((2D0PYR(0)-1D0)
	+ & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
	+ ELSE
	+ PM0=PYMASS
	+ PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))2-PM02)/
	+ & (PM0*PMAS(KC,2)))
	+ PMUPP=ATAN(((PM0+PMAS(KC,3))2-PM02)/(PM0*PMAS(KC,2)))
	+ PYMASS=SQRT(MAX(0D0,PM0*2+PM0PMAS(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)*2PARF(90+KFA)2/PARU(117)2))/
	+ & LOG(MAX(4D0,Q2/PARU(117)2)))(12D0/(33D0-2D0*MSTU(118)))
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYNAME
	+C...Gives the particle/parton name as a character string.
	+
	+ SUBROUTINE PYNAME(KF,CHAU)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT4/CHAF(500,2)
	+ CHARACTER CHAF*16
	+ SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
	+C...Local character variable.
	+ CHARACTER CHAU*16
	+
	+C...Read out code with distinction particle/antiparticle.
	+ CHAU=' '
	+ KC=PYCOMP(KF)
	+ IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
	+
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYCHGE
	+C...Gives three times the charge for a particle/parton.
	+
	+ FUNCTION PYCHGE(KF)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYDAT2/
	+
	+C...Read out charge and change sign for antiparticle.
	+ PYCHGE=0
	+ KC=PYCOMP(KF)
	+ IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYCOMP
	+C...Compress the standard KF codes for use in mass and decay arrays;
	+C...also checks whether a given code actually is defined.
	+
	+ FUNCTION PYCOMP(KF)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYDAT1/,/PYDAT2/
	+C...Local arrays and saved data.
	+ DIMENSION KFORD(100:500),KCORD(101:500)
	+ SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
	+
	+C...Whenever necessary reorder codes for faster search.
	+ IF(MSTU(20).EQ.0) THEN
	+ NFORD=100
	+ KFORD(100)=0
	+ DO 120 I=101,500
	+ KFA=KCHG(I,4)
	+ IF(KFA.LE.100) GOTO 120
	+ NFORD=NFORD+1
	+ DO 100 I1=NFORD-1,0,-1
	+ IF(KFA.GE.KFORD(I1)) GOTO 110
	+ KFORD(I1+1)=KFORD(I1)
	+ KCORD(I1+1)=KCORD(I1)
	+ 100 CONTINUE
	+ 110 KFORD(I1+1)=KFA
	+ KCORD(I1+1)=I
	+ 120 CONTINUE
	+ MSTU(20)=1
	+ KFLAST=0
	+ KCLAST=0
	+ ENDIF
	+
	+C...Fast action if same code as in latest call.
	+ IF(KF.EQ.KFLAST) THEN
	+ PYCOMP=KCLAST
	+ RETURN
	+ ENDIF
	+
	+C...Starting values. Remove internal diquark flags.
	+ PYCOMP=0
	+ KFA=IABS(KF)
	+ IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
	+ & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
	+
	+C...Simple cases: direct translation.
	+ IF(KFA.GT.KFORD(NFORD)) THEN
	+ ELSEIF(KFA.LE.100) THEN
	+ PYCOMP=KFA
	+
	+C...Else binary search.
	+ ELSE
	+ IMIN=100
	+ IMAX=NFORD+1
	+ 130 IAVG=(IMIN+IMAX)/2
	+ IF(KFORD(IAVG).GT.KFA) THEN
	+ IMAX=IAVG
	+ IF(IMAX.GT.IMIN+1) GOTO 130
	+ ELSEIF(KFORD(IAVG).LT.KFA) THEN
	+ IMIN=IAVG
	+ IF(IMAX.GT.IMIN+1) GOTO 130
	+ ELSE
	+ PYCOMP=KCORD(IAVG)
	+ ENDIF
	+ ENDIF
	+
	+C...Check if antiparticle allowed.
	+ IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
	+ IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
	+ ENDIF
	+
	+C...Save codes for possible future fast action.
	+ KFLAST=KF
	+ KCLAST=PYCOMP
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYERRM
	+C...Informs user of errors in program execution.
	+
	+ SUBROUTINE PYERRM(MERR,CHMESS)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYJETS/,/PYDAT1/
	+C...Local character variable.
	+ CHARACTER CHMESS()
	+
	+C...Write first few warnings, then be silent.
	+ IF(MERR.LE.10) THEN
	+ MSTU(27)=MSTU(27)+1
	+ MSTU(28)=MERR
	+ IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
	+ & MERR,MSTU(31),CHMESS
	+
	+C...Write first few errors, then be silent or stop program.
	+ ELSEIF(MERR.LE.20) THEN
	+ IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
	+ MSTU(30)=MSTU(30)+1
	+ MSTU(24)=MERR-10
	+ IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
	+ & MERR-10,MSTU(31),CHMESS
	+ IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
	+ WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
	+ WRITE(MSTU(11),5200)
	+ IF(MERR.NE.17) CALL PYLIST(2)
	+ CALL PYSTOP(3)
	+ ENDIF
	+
	+C...Stop program in case of irreparable error.
	+ ELSE
	+ WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
	+ CALL PYSTOP(3)
	+ ENDIF
	+
	+C...Formats for output.
	+ 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
	+ &' PYEXEC calls:'/5X,A)
	+ 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
	+ &' PYEXEC calls:'/5X,A)
	+ 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
	+ &'event!')
	+ 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
	+ &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYALEM
	+C...Calculates the running alpha_electromagnetic.
	+
	+ FUNCTION PYALEM(Q2)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYDAT1/
	+
	+C...Calculate real part of photon vacuum polarization.
	+C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
	+C...For hadrons use parametrization of H. Burkhardt et al.
	+C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
	+ AEMPI=PARU(101)/(3D0*PARU(1))
	+ IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
	+ RPIGG=0D0
	+ ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
	+ RPIGG=0D0
	+ ELSEIF(MSTU(101).EQ.2) THEN
	+ RPIGG=1D0-PARU(101)/PARU(103)
	+ ELSEIF(Q2.LT.0.09D0) THEN
	+ RPIGG=AEMPI(13.4916D0+LOG(Q2))+0.00835D0LOG(1D0+Q2)
	+ ELSEIF(Q2.LT.9D0) THEN
	+ RPIGG=AEMPI(16.3200D0+2D0LOG(Q2))+
	+ & 0.00238D0LOG(1D0+3.927D0Q2)
	+ ELSEIF(Q2.LT.1D4) THEN
	+ RPIGG=AEMPI(13.4955D0+3D0LOG(Q2))+0.00165D0+
	+ & 0.00299D0*LOG(1D0+Q2)
	+ ELSE
	+ RPIGG=AEMPI(13.4955D0+3D0LOG(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,(2D0107D0/2025D0),(2D0963D0/14375D0),
	+c &(2D0*321D0/3703D0),0D0/
	+c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
	+c &(-2D0963D0/13225D0),(-2D0321D0/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(-6D0PARU(1)/
	+ & ((33D0-2D0MSTU(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=ALAM2Q2RAT(2D0/(33D0-2D0NF))
	+ IF(MSTU(111).EQ.2) ALAM2=ALAM2LOG(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=ALAM2Q2RAT(-2D0/(33D0-2D0NF))
	+ IF(MSTU(111).EQ.2) ALAM2=ALAM2LOG(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)/(B0ALGQ)(1D0-B1*LOG(ALGQ)/
	+ & (B0*2ALGQ)))
	+ 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(X2+Y2)
	+ 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(IJ,179)K,179)
	+ I=J
	+ J=K
	+ K=M
	+ L=MOD(53*L+1,169)
	+ IF(MOD(L*M,64).GE.32) S=S+T
	+ T=0.5D0*T
	+ 100 CONTINUE
	+ RRPY(II)=S
	+ 110 CONTINUE
	+ TWOM24=1D0
	+ DO 120 I24=1,24
	+ TWOM24=0.5D0*TWOM24
	+ 120 CONTINUE
	+ RRPY98=362436D0*TWOM24
	+ RRPY99=7654321D0*TWOM24
	+ RRPY00=16777213D0*TWOM24
	+ MRPY2=1
	+ MRPY3=0
	+ MRPY4=97
	+ MRPY5=33
	+ ENDIF
	+
	+C...Generate next random number.
	+ 130 RUNI=RRPY(MRPY4)-RRPY(MRPY5)
	+ IF(RUNI.LT.0D0) RUNI=RUNI+1D0
	+ RRPY(MRPY4)=RUNI
	+ MRPY4=MRPY4-1
	+ IF(MRPY4.EQ.0) MRPY4=97
	+ MRPY5=MRPY5-1
	+ IF(MRPY5.EQ.0) MRPY5=97
	+ RRPY98=RRPY98-RRPY99
	+ IF(RRPY98.LT.0D0) RRPY98=RRPY98+RRPY00
	+ RUNI=RUNI-RRPY98
	+ IF(RUNI.LT.0D0) RUNI=RUNI+1D0
	+ IF(RUNI.LE.0D0.OR.RUNI.GE.1D0) GOTO 130
	+
	+C...Update counters. Random number to output.
	+ MRPY3=MRPY3+1
	+ IF(MRPY3.EQ.1000000000) THEN
	+ MRPY2=MRPY2+1
	+ MRPY3=0
	+ ENDIF
	+ PYR=RUNI
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYRGET
	+C...Dumps the state of the random number generator on a file
	+C...for subsequent startup from this state onwards.
	+
	+ SUBROUTINE PYRGET(LFN,MOVE)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDATR/MRPY(6),RRPY(100)
	+ SAVE /PYDATR/
	+C...Local character variable.
	+ CHARACTER CHERR*8
	+
	+C...Backspace required number of records (or as many as there are).
	+ IF(MOVE.LT.0) THEN
	+ NBCK=MIN(MRPY(6),-MOVE)
	+ DO 100 IBCK=1,NBCK
	+ BACKSPACE(LFN,ERR=110,IOSTAT=IERR)
	+ 100 CONTINUE
	+ MRPY(6)=MRPY(6)-NBCK
	+ ENDIF
	+
	+C...Unformatted write on unit LFN.
	+ WRITE(LFN,ERR=110,IOSTAT=IERR) (MRPY(I1),I1=1,5),
	+ &(RRPY(I2),I2=1,100)
	+ MRPY(6)=MRPY(6)+1
	+ RETURN
	+
	+C...Write error.
	+ 110 WRITE(CHERR,'(I8)') IERR
	+ CALL PYERRM(18,'(PYRGET:) error when accessing file, IOSTAT ='//
	+ &CHERR)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYRSET
	+C...Reads a state of the random number generator from a file
	+C...for subsequent generation from this state onwards.
	+
	+ SUBROUTINE PYRSET(LFN,MOVE)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDATR/MRPY(6),RRPY(100)
	+ SAVE /PYDATR/
	+C...Local character variable.
	+ CHARACTER CHERR*8
	+
	+C...Backspace required number of records (or as many as there are).
	+ IF(MOVE.LT.0) THEN
	+ NBCK=MIN(MRPY(6),-MOVE)
	+ DO 100 IBCK=1,NBCK
	+ BACKSPACE(LFN,ERR=120,IOSTAT=IERR)
	+ 100 CONTINUE
	+ MRPY(6)=MRPY(6)-NBCK
	+ ENDIF
	+
	+C...Unformatted read from unit LFN.
	+ NFOR=1+MAX(0,MOVE)
	+ DO 110 IFOR=1,NFOR
	+ READ(LFN,ERR=120,IOSTAT=IERR) (MRPY(I1),I1=1,5),
	+ & (RRPY(I2),I2=1,100)
	+ 110 CONTINUE
	+ MRPY(6)=MRPY(6)+NFOR
	+ RETURN
	+
	+C...Write error.
	+ 120 WRITE(CHERR,'(I8)') IERR
	+ CALL PYERRM(18,'(PYRSET:) error when accessing file, IOSTAT ='//
	+ &CHERR)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYROBO
	+C...Performs rotations and boosts.
	+
	+ SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ SAVE /PYJETS/,/PYDAT1/
	+C...Local arrays.
	+ DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
	+
	+C...Find and check range of rotation/boost.
	+ IMIN=IMI
	+ IF(IMIN.LE.0) IMIN=1
	+ IF(MSTU(1).GT.0) IMIN=MSTU(1)
	+ IMAX=IMA
	+ IF(IMAX.LE.0) IMAX=N
	+ IF(MSTU(2).GT.0) IMAX=MSTU(2)
	+ IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
	+ CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
	+ RETURN
	+ ENDIF
	+
	+C...Optional resetting of V (when not set before.)
	+ IF(MSTU(33).NE.0) THEN
	+ DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
	+ DO 100 J=1,5
	+ V(I,J)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+ MSTU(33)=0
	+ ENDIF
	+
	+C...Rotate, typically from z axis to direction (theta,phi).
	+ IF(THE2+PHI2.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(BEX2+BEY2+BEZ**2.GT.1D-20) THEN
	+ DBX=BEX
	+ DBY=BEY
	+ DBZ=BEZ
	+ DB=SQRT(DBX2+DBY2+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=DBXDP(1)+DBYDP(2)+DBZ*DP(3)
	+ DGABP=DGA(DGADBP/(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=DBXDV(1)+DBYDV(2)+DBZ*DV(3)
	+ DGABV=DGA(DGADBV/(1D0+DGA)+DV(4))
	+ V(I,1)=DV(1)+DGABV*DBX
	+ V(I,2)=DV(2)+DGABV*DBY
	+ V(I,3)=DV(3)+DGABV*DBZ
	+ V(I,4)=DGA*(DV(4)+DBV)
	+ 160 CONTINUE
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYEDIT
	+C...Performs global manipulations on the event record, in particular
	+C...to exclude unstable or undetectable partons/particles.
	+
	+ SUBROUTINE PYEDIT(MEDIT)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
	+C...Local arrays.
	+ DIMENSION NS(2),PTS(2),PLS(2)
	+
	+C...Remove unwanted partons/particles.
	+ IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
	+ IMAX=N
	+ IF(MSTU(2).GT.0) IMAX=MSTU(2)
	+ I1=MAX(1,MSTU(1))-1
	+ DO 110 I=MAX(1,MSTU(1)),IMAX
	+ IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
	+ IF(MEDIT.EQ.1) THEN
	+ IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
	+ ELSEIF(MEDIT.EQ.2) THEN
	+ IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 110
	+ ELSEIF(MEDIT.EQ.3) THEN
	+ IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0) GOTO 110
	+ IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
	+ ELSEIF(MEDIT.EQ.5) THEN
	+ IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0) GOTO 110
	+ IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
	+ & KCHG(KC,2).EQ.0) GOTO 110
	+ ENDIF
	+
	+C...Pack remaining partons/particles. Origin no longer known.
	+ I1=I1+1
	+ DO 100 J=1,5
	+ K(I1,J)=K(I,J)
	+ P(I1,J)=P(I,J)
	+ V(I1,J)=V(I,J)
	+ 100 CONTINUE
	+ K(I1,3)=0
	+ 110 CONTINUE
	+ IF(I1.LT.N) MSTU(3)=0
	+ IF(I1.LT.N) MSTU(70)=0
	+ N=I1
	+
	+C...Selective removal of class of entries. New position of retained.
	+ ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
	+ I1=0
	+ DO 120 I=1,N
	+ K(I,3)=MOD(K(I,3),MSTU(5))
	+ IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
	+ IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
	+ IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
	+ & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
	+ IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
	+ & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
	+ IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
	+ I1=I1+1
	+ K(I,3)=K(I,3)+MSTU(5)*I1
	+ 120 CONTINUE
	+
	+C...Find new event history information and replace old.
	+ DO 140 I=1,N
	+ IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
	+ & K(I,3)/MSTU(5).EQ.0) GOTO 140
	+ ID=I
	+ 130 IM=MOD(K(ID,3),MSTU(5))
	+ IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
	+ IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
	+ & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
	+ ID=IM
	+ GOTO 130
	+ ENDIF
	+ ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
	+ IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
	+ & K(IM,2).EQ.94) THEN
	+ ID=IM
	+ GOTO 130
	+ ENDIF
	+ ENDIF
	+ K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
	+ IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
	+ IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
	+ & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
	+ IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
	+ & K(K(I,4),3)/MSTU(5)
	+ IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
	+ & K(K(I,5),3)/MSTU(5)
	+ ELSE
	+ KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
	+ IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
	+ & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
	+ KCD=MOD(K(I,4),MSTU(5))
	+ IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
	+ K(I,4)=MSTU(5)*2(K(I,4)/MSTU(5)*2)+MSTU(5)KCM+KCD
	+ KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
	+ IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
	+ KCD=MOD(K(I,5),MSTU(5))
	+ IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
	+ K(I,5)=MSTU(5)*2(K(I,5)/MSTU(5)*2)+MSTU(5)KCM+KCD
	+ ENDIF
	+ 140 CONTINUE
	+
	+C...Pack remaining entries.
	+ I1=0
	+ MSTU90=MSTU(90)
	+ MSTU(90)=0
	+ DO 170 I=1,N
	+ IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
	+ I1=I1+1
	+ DO 150 J=1,5
	+ K(I1,J)=K(I,J)
	+ P(I1,J)=P(I,J)
	+ V(I1,J)=V(I,J)
	+ 150 CONTINUE
	+C...Also update LHA1 colour tags
	+ MCT(I1,1)=MCT(I,1)
	+ MCT(I1,2)=MCT(I,2)
	+ K(I1,3)=MOD(K(I1,3),MSTU(5))
	+ DO 160 IZ=1,MSTU90
	+ IF(I.EQ.MSTU(90+IZ)) THEN
	+ MSTU(90)=MSTU(90)+1
	+ MSTU(90+MSTU(90))=I1
	+ PARU(90+MSTU(90))=PARU(90+IZ)
	+ ENDIF
	+ 160 CONTINUE
	+ 170 CONTINUE
	+ IF(I1.LT.N) MSTU(3)=0
	+ IF(I1.LT.N) MSTU(70)=0
	+ N=I1
	+
	+C...Fill in some missing daughter pointers (lost in colour flow).
	+ ELSEIF(MEDIT.EQ.16) THEN
	+ DO 220 I=1,N
	+ IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
	+ IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
	+C...Find daughters who point to mother.
	+ DO 180 I1=I+1,N
	+ IF(K(I1,3).NE.I) THEN
	+ ELSEIF(K(I,4).EQ.0) THEN
	+ K(I,4)=I1
	+ ELSE
	+ K(I,5)=I1
	+ ENDIF
	+ 180 CONTINUE
	+ IF(K(I,5).EQ.0) K(I,5)=K(I,4)
	+ IF(K(I,4).NE.0) GOTO 220
	+C...Find daughters who point to documentation version of mother.
	+ IM=K(I,3)
	+ IF(IM.LE.0.OR.IM.GE.I) GOTO 220
	+ IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
	+ IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
	+ DO 190 I1=I+1,N
	+ IF(K(I1,3).NE.IM) THEN
	+ ELSEIF(K(I,4).EQ.0) THEN
	+ K(I,4)=I1
	+ ELSE
	+ K(I,5)=I1
	+ ENDIF
	+ 190 CONTINUE
	+ IF(K(I,5).EQ.0) K(I,5)=K(I,4)
	+ IF(K(I,4).NE.0) GOTO 220
	+C...Find daughters who point to documentation daughters who,
	+C...in their turn, point to documentation mother.
	+ ID1=IM
	+ ID2=IM
	+ DO 200 I1=IM+1,I-1
	+ IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
	+ ID2=I1
	+ IF(ID1.EQ.IM) ID1=I1
	+ ENDIF
	+ 200 CONTINUE
	+ DO 210 I1=I+1,N
	+ IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
	+ ELSEIF(K(I,4).EQ.0) THEN
	+ K(I,4)=I1
	+ ELSE
	+ K(I,5)=I1
	+ ENDIF
	+ 210 CONTINUE
	+ IF(K(I,5).EQ.0) K(I,5)=K(I,4)
	+ 220 CONTINUE
	+
	+C...Save top entries at bottom of PYJETS commonblock.
	+ ELSEIF(MEDIT.EQ.21) THEN
	+ IF(2*N.GE.MSTU(4)) THEN
	+ CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
	+ RETURN
	+ ENDIF
	+ DO 240 I=1,N
	+ DO 230 J=1,5
	+ K(MSTU(4)-I,J)=K(I,J)
	+ P(MSTU(4)-I,J)=P(I,J)
	+ V(MSTU(4)-I,J)=V(I,J)
	+ 230 CONTINUE
	+ 240 CONTINUE
	+ MSTU(32)=N
	+
	+C...Restore bottom entries of commonblock PYJETS to top.
	+ ELSEIF(MEDIT.EQ.22) THEN
	+ DO 260 I=1,MSTU(32)
	+ DO 250 J=1,5
	+ K(I,J)=K(MSTU(4)-I,J)
	+ P(I,J)=P(MSTU(4)-I,J)
	+ V(I,J)=V(MSTU(4)-I,J)
	+ 250 CONTINUE
	+ 260 CONTINUE
	+ N=MSTU(32)
	+
	+C...Mark primary entries at top of commonblock PYJETS as untreated.
	+ ELSEIF(MEDIT.EQ.23) THEN
	+ I1=0
	+ DO 270 I=1,N
	+ KH=K(I,3)
	+ IF(KH.GE.1) THEN
	+ IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
	+ ENDIF
	+ IF(KH.NE.0) GOTO 280
	+ I1=I1+1
	+ IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
	+ IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
	+ 270 CONTINUE
	+ 280 N=I1
	+
	+C...Place largest axis along z axis and second largest in xy plane.
	+ ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
	+ CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
	+ & P(MSTU(61),2)),0D0,0D0,0D0)
	+ CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
	+ & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
	+ CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
	+ & P(MSTU(61)+1,2)),0D0,0D0,0D0)
	+ IF(MEDIT.EQ.31) RETURN
	+
	+C...Rotate to put slim jet along +z axis.
	+ DO 290 IS=1,2
	+ NS(IS)=0
	+ PTS(IS)=0D0
	+ PLS(IS)=0D0
	+ 290 CONTINUE
	+ DO 300 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
	+ IF(MSTU(41).GE.2) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 300
	+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
	+ & .EQ.0) GOTO 300
	+ ENDIF
	+ IS=2D0-SIGN(0.5D0,P(I,3))
	+ NS(IS)=NS(IS)+1
	+ PTS(IS)=PTS(IS)+SQRT(P(I,1)2+P(I,2)2)
	+ 300 CONTINUE
	+ IF(NS(1)PTS(2)2.LT.NS(2)PTS(1)**2)
	+ & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
	+
	+C...Rotate to put second largest jet into -z,+x quadrant.
	+ DO 310 I=1,N
	+ IF(P(I,3).GE.0D0) GOTO 310
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
	+ IF(MSTU(41).GE.2) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 310
	+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
	+ & .EQ.0) GOTO 310
	+ ENDIF
	+ IS=2D0-SIGN(0.5D0,P(I,1))
	+ PLS(IS)=PLS(IS)-P(I,3)
	+ 310 CONTINUE
	+ IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
	+ & 0D0,0D0,0D0)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYLIST
	+C...Gives program heading, or lists an event, or particle
	+C...data, or current parameter values.
	+
	+ SUBROUTINE PYLIST(MLIST)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+
	+C...HEPEVT commonblock.
	+ PARAMETER (NMXHEP=4000)
	+ COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ DOUBLE PRECISION PHEP,VHEP
	+ SAVE /HEPEVT/
	+
	+C...User process event common block.
	+ INTEGER MAXNUP
	+ PARAMETER (MAXNUP=500)
	+ INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	+ DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	+ COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	+ &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	+ &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	+ SAVE /HEPEUP/
	+
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ COMMON/PYCTAG/NCT,MCT(4000,2)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
	+C...Local arrays, character variables and data.
	+ CHARACTER CHAP16,CHAC16,CHAN16,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=1000KFLA+100KFLB+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=10000KFLR+100KFLB+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=10000KFLR+110KFLB+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=1000KFLA+100KFLC+10*KFLB+KFLS
	+ IF(KFLSP.GE.2) KF=1000KFLA+100KFLB+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(2IREFER)36, LINE*79,
	+ &VERS1, SUBV3, DATE2, YEAR4, HOUR2, MINU2, 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
	+
	+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 CHINL120,CHKF9,CHVAR(22)9,CHLIN72,
	+ &CHBLK(20)72,CHOLD16,CHTMP16,CHNEW16,CHCOM*24
	+ DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
	+ &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
	+ &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
	+ &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
	+ &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
	+
	+C...Write header if not yet done.
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+
	+C...Write information on file for editing.
	+ IF(MUPDA.EQ.1) THEN
	+ DO 110 KC=1,500
	+ WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
	+ & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
	+ & MWID(KC),MDCY(KC,1)
	+ DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
	+ WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
	+ & (KFDP(IDC,J),J=1,5)
	+ 100 CONTINUE
	+ 110 CONTINUE
	+
	+C...Read complete set of information from edited file or
	+C...read partial set of new or updated information from edited file.
	+ ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
	+
	+C...Reset counters.
	+ KCC=100
	+ NDC=0
	+ CHKF=' '
	+ IF(MUPDA.EQ.2) THEN
	+ DO 120 I=1,MSTU(6)
	+ KCHG(I,4)=0
	+ 120 CONTINUE
	+ ELSE
	+ DO 130 KC=1,MSTU(6)
	+ IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
	+ NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
	+ 130 CONTINUE
	+ ENDIF
	+
	+C...Begin of loop: read new line; unknown whether particle or
	+C...decay data.
	+ 140 READ(LFN,5200,END=190) CHINL
	+
	+C...Identify particle code and whether already defined (for MUPDA=3).
	+ IF(CHINL(2:10).NE.' ') THEN
	+ CHKF=CHINL(2:10)
	+ READ(CHKF,5300) KF
	+ IF(MUPDA.EQ.2) THEN
	+ IF(KF.LE.100) THEN
	+ KC=KF
	+ ELSE
	+ KCC=KCC+1
	+ KC=KCC
	+ ENDIF
	+ ELSE
	+ KCREP=0
	+ IF(KF.LE.100) THEN
	+ KCREP=KF
	+ ELSE
	+ DO 150 KCR=101,KCC
	+ IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
	+ 150 CONTINUE
	+ ENDIF
	+C...Remove duplicate old decay data.
	+ IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
	+ IDCREP=MDCY(KCREP,2)
	+ NDCREP=MDCY(KCREP,3)
	+ DO 160 I=1,KCC
	+ IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
	+ 160 CONTINUE
	+ DO 180 I=IDCREP,NDC-NDCREP
	+ MDME(I,1)=MDME(I+NDCREP,1)
	+ MDME(I,2)=MDME(I+NDCREP,2)
	+ BRAT(I)=BRAT(I+NDCREP)
	+ DO 170 J=1,5
	+ KFDP(I,J)=KFDP(I+NDCREP,J)
	+ 170 CONTINUE
	+ 180 CONTINUE
	+ NDC=NDC-NDCREP
	+ KC=KCREP
	+ ELSEIF(KCREP.NE.0) THEN
	+ KC=KCREP
	+ ELSE
	+ KCC=KCC+1
	+ KC=KCC
	+ ENDIF
	+ ENDIF
	+
	+C...Study line with particle data.
	+ IF(KC.GT.MSTU(6)) CALL PYERRM(27,
	+ & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
	+ READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
	+ & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
	+ & MWID(KC),MDCY(KC,1)
	+ MDCY(KC,2)=0
	+ MDCY(KC,3)=0
	+
	+C...Study line with decay data.
	+ ELSE
	+ NDC=NDC+1
	+ IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
	+ & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
	+ IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
	+ MDCY(KC,3)=MDCY(KC,3)+1
	+ READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
	+ & (KFDP(NDC,J),J=1,5)
	+ ENDIF
	+
	+C...End of loop; ensure that PYCOMP tables are updated.
	+ GOTO 140
	+ 190 CONTINUE
	+ MSTU(20)=0
	+
	+C...Perform possible tests that new information is consistent.
	+ DO 220 KC=1,MSTU(6)
	+ KF=KCHG(KC,4)
	+ IF(KF.EQ.0) GOTO 220
	+ WRITE(CHKF,5300) KF
	+ IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
	+ & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
	+ & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
	+ BRSUM=0D0
	+ DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
	+ IF(MDME(IDC,2).GT.80) GOTO 210
	+ KQ=KCHG(KC,1)
	+ PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
	+ MERR=0
	+ DO 200 J=1,5
	+ KP=KFDP(IDC,J)
	+ IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
	+ IF(KP.EQ.81) KQ=0
	+ ELSEIF(PYCOMP(KP).EQ.0) THEN
	+ MERR=3
	+ ELSE
	+ KQ=KQ-PYCHGE(KP)
	+ KPC=PYCOMP(KP)
	+ PMS=PMS-PMAS(KPC,1)
	+ IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
	+ & PMAS(KPC,3))
	+ ENDIF
	+ 200 CONTINUE
	+ IF(KQ.NE.0) MERR=MAX(2,MERR)
	+ IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
	+ & MERR=MAX(1,MERR)
	+ IF(MERR.EQ.3) CALL PYERRM(17,
	+ & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
	+ IF(MERR.EQ.2) CALL PYERRM(17,
	+ & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
	+ IF(MERR.EQ.1) CALL PYERRM(7,
	+ & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
	+ BRSUM=BRSUM+BRAT(IDC)
	+ 210 CONTINUE
	+ WRITE(CHTMP,5500) BRSUM
	+ IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
	+ & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
	+ & CHTMP(9:16)//' for KF ='//CHKF)
	+ 220 CONTINUE
	+
	+C...Write DATA statements for inclusion in program.
	+ ELSEIF(MUPDA.EQ.4) THEN
	+
	+C...Find out how many codes and decay channels are actually used.
	+ KCC=0
	+ NDC=0
	+ DO 230 I=1,MSTU(6)
	+ IF(KCHG(I,4).NE.0) THEN
	+ KCC=I
	+ NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
	+ ENDIF
	+ 230 CONTINUE
	+
	+C...Initialize writing of DATA statements for inclusion in program.
	+ DO 300 IVAR=1,22
	+ NDIM=MSTU(6)
	+ IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
	+ NLIN=1
	+ CHLIN=' '
	+ CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
	+ LLIN=35
	+ CHOLD='START'
	+
	+C...Loop through variables for conversion to characters.
	+ DO 280 IDIM=1,NDIM
	+ IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
	+ IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
	+ IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
	+ IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
	+ IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
	+ IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
	+ IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
	+ IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
	+ IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
	+ IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
	+ IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
	+ IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
	+ IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
	+ IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
	+ IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
	+ IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
	+ IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
	+ IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
	+ IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
	+ IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
	+ IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
	+ IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
	+
	+C...Replace variables beyond what is properly defined.
	+ IF(IVAR.LE.4) THEN
	+ IF(IDIM.GT.KCC) CHTMP=' 0'
	+ ELSEIF(IVAR.LE.8) THEN
	+ IF(IDIM.GT.KCC) CHTMP=' 0.0'
	+ ELSEIF(IVAR.LE.11) THEN
	+ IF(IDIM.GT.KCC) CHTMP=' 0'
	+ ELSEIF(IVAR.LE.13) THEN
	+ IF(IDIM.GT.NDC) CHTMP=' 0'
	+ ELSEIF(IVAR.LE.14) THEN
	+ IF(IDIM.GT.NDC) CHTMP=' 0.0'
	+ ELSEIF(IVAR.LE.19) THEN
	+ IF(IDIM.GT.NDC) CHTMP=' 0'
	+ ELSEIF(IVAR.LE.21) THEN
	+ IF(IDIM.GT.KCC) CHTMP=' '
	+ ELSE
	+ IF(IDIM.GT.KCC) CHTMP=' 0'
	+ ENDIF
	+
	+C...Length of variable, trailing decimal zeros, quotation marks.
	+ LLOW=1
	+ LHIG=1
	+ DO 240 LL=1,16
	+ IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
	+ IF(CHTMP(LL:LL).NE.' ') LHIG=LL
	+ 240 CONTINUE
	+ CHNEW=CHTMP(LLOW:LHIG)//' '
	+ LNEW=1+LHIG-LLOW
	+ IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
	+ LNEW=LNEW+1
	+ 250 LNEW=LNEW-1
	+ IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
	+ IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
	+ IF(LNEW.EQ.0) THEN
	+ CHNEW(1:3)='0D0'
	+ LNEW=3
	+ ELSE
	+ CHNEW(LNEW+1:LNEW+2)='D0'
	+ LNEW=LNEW+2
	+ ENDIF
	+ ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
	+ DO 260 LL=LNEW,1,-1
	+ IF(CHNEW(LL:LL).EQ.'''') THEN
	+ CHTMP=CHNEW
	+ CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
	+ LNEW=LNEW+1
	+ ENDIF
	+ 260 CONTINUE
	+ LNEW=MIN(14,LNEW)
	+ CHTMP=CHNEW
	+ CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
	+ LNEW=LNEW+2
	+ ENDIF
	+
	+C...Form composite character string, often including repetition counter.
	+ IF(CHNEW.NE.CHOLD) THEN
	+ NRPT=1
	+ CHOLD=CHNEW
	+ CHCOM=CHNEW
	+ LCOM=LNEW
	+ ELSE
	+ LRPT=LNEW+1
	+ IF(NRPT.GE.2) LRPT=LNEW+3
	+ IF(NRPT.GE.10) LRPT=LNEW+4
	+ IF(NRPT.GE.100) LRPT=LNEW+5
	+ IF(NRPT.GE.1000) LRPT=LNEW+6
	+ LLIN=LLIN-LRPT
	+ NRPT=NRPT+1
	+ WRITE(CHTMP,5400) NRPT
	+ LRPT=1
	+ IF(NRPT.GE.10) LRPT=2
	+ IF(NRPT.GE.100) LRPT=3
	+ IF(NRPT.GE.1000) LRPT=4
	+ CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
	+ LCOM=LRPT+1+LNEW
	+ ENDIF
	+
	+C...Add characters to end of line, to new line (after storing old line),
	+C...or to new block of lines (after writing old block).
	+ IF(LLIN+LCOM.LE.70) THEN
	+ CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
	+ LLIN=LLIN+LCOM+1
	+ ELSEIF(NLIN.LE.19) THEN
	+ CHLIN(LLIN+1:72)=' '
	+ CHBLK(NLIN)=CHLIN
	+ NLIN=NLIN+1
	+ CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
	+ LLIN=6+LCOM+1
	+ ELSE
	+ CHLIN(LLIN:72)='/'//' '
	+ CHBLK(NLIN)=CHLIN
	+ WRITE(CHTMP,5400) IDIM-NRPT
	+ CHBLK(1)(30:33)=CHTMP(13:16)
	+ DO 270 ILIN=1,NLIN
	+ WRITE(LFN,5700) CHBLK(ILIN)
	+ 270 CONTINUE
	+ NLIN=1
	+ CHLIN=' '
	+ CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
	+ & ',I= , )/'//CHCOM(1:LCOM)//','
	+ WRITE(CHTMP,5400) IDIM-NRPT+1
	+ CHLIN(25:28)=CHTMP(13:16)
	+ LLIN=35+LCOM+1
	+ ENDIF
	+ 280 CONTINUE
	+
	+C...Write final block of lines.
	+ CHLIN(LLIN:72)='/'//' '
	+ CHBLK(NLIN)=CHLIN
	+ WRITE(CHTMP,5400) NDIM
	+ CHBLK(1)(30:33)=CHTMP(13:16)
	+ DO 290 ILIN=1,NLIN
	+ WRITE(LFN,5700) CHBLK(ILIN)
	+ 290 CONTINUE
	+ 300 CONTINUE
	+ ENDIF
	+
	+C...Formats for reading and writing particle data.
	+ 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
	+ 5100 FORMAT(10X,2I5,F12.6,5I10)
	+ 5200 FORMAT(A120)
	+ 5300 FORMAT(I9)
	+ 5400 FORMAT(I16)
	+ 5500 FORMAT(F16.5)
	+ 5600 FORMAT(F16.6)
	+ 5700 FORMAT(A72)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYK
	+C...Provides various integer-valued event related data.
	+
	+ FUNCTION PYK(I,J)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Default value. For I=0 number of entries, number of stable entries
	+C...or 3 times total charge.
	+ PYK=0
	+ IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
	+ ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
	+ PYK=N
	+ ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
	+ DO 100 I1=1,N
	+ IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
	+ IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
	+ & PYCHGE(K(I1,2))
	+ 100 CONTINUE
	+ ELSEIF(I.EQ.0) THEN
	+
	+C...For I > 0 direct readout of K matrix or charge.
	+ ELSEIF(J.LE.5) THEN
	+ PYK=K(I,J)
	+ ELSEIF(J.EQ.6) THEN
	+ PYK=PYCHGE(K(I,2))
	+
	+C...Status (existing/fragmented/decayed), parton/hadron separation.
	+ ELSEIF(J.LE.8) THEN
	+ IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
	+ IF(J.EQ.8) PYK=PYK*K(I,2)
	+ ELSEIF(J.LE.12) THEN
	+ KFA=IABS(K(I,2))
	+ KC=PYCOMP(KFA)
	+ KQ=0
	+ IF(KC.NE.0) KQ=KCHG(KC,2)
	+ IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
	+ IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
	+ IF(J.EQ.11) PYK=KC
	+ IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
	+
	+C...Heaviest flavour in hadron/diquark.
	+ ELSEIF(J.EQ.13) THEN
	+ KFA=IABS(K(I,2))
	+ PYK=MOD(KFA/100,10)(-1)*MOD(KFA/100,10)
	+ IF(KFA.LT.10) PYK=KFA
	+ IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
	+ PYK=PYK*ISIGN(1,K(I,2))
	+
	+C...Particle history: generation, ancestor, rank.
	+ ELSEIF(J.LE.15) THEN
	+ I2=I
	+ I1=I
	+ 110 PYK=PYK+1
	+ I2=I1
	+ I1=K(I1,3)
	+ IF(I1.GT.0) THEN
	+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
	+ ENDIF
	+ IF(J.EQ.15) PYK=I2
	+ ELSEIF(J.EQ.16) THEN
	+ KFA=IABS(K(I,2))
	+ IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
	+ & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
	+ I1=I
	+ 120 I2=I1
	+ I1=K(I1,3)
	+ IF(I1.GT.0) THEN
	+ KFAM=IABS(K(I1,2))
	+ ILP=1
	+ IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
	+ IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
	+ & ILP=0
	+ IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
	+ IF(ILP.EQ.1) GOTO 120
	+ ENDIF
	+ IF(K(I1,1).EQ.12) THEN
	+ DO 130 I3=I1+1,I2
	+ IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
	+ & .AND.K(I3,2).NE.93) PYK=PYK+1
	+ 130 CONTINUE
	+ ELSE
	+ I3=I2
	+ 140 PYK=PYK+1
	+ I3=I3+1
	+ IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
	+ ENDIF
	+ ENDIF
	+
	+C...Particle coming from collapsing jet system or not.
	+ ELSEIF(J.EQ.17) THEN
	+ I1=I
	+ 150 PYK=PYK+1
	+ I3=I1
	+ I1=K(I1,3)
	+ I0=MAX(1,I1)
	+ KC=PYCOMP(K(I0,2))
	+ IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
	+ IF(PYK.EQ.1) PYK=-1
	+ IF(PYK.GT.1) PYK=0
	+ RETURN
	+ ENDIF
	+ IF(KCHG(KC,2).EQ.0) GOTO 150
	+ IF(K(I1,1).NE.12) PYK=0
	+ IF(K(I1,1).NE.12) RETURN
	+ I2=I1
	+ 160 I2=I2+1
	+ IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
	+ K3M=K(I3-1,3)
	+ IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
	+ K3P=K(I3+1,3)
	+ IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
	+
	+C...Number of decay products. Colour flow.
	+ ELSEIF(J.EQ.18) THEN
	+ IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
	+ IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
	+ ELSEIF(J.LE.22) THEN
	+ IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
	+ IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
	+ IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
	+ IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
	+ IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
	+ ELSE
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYP
	+C...Provides various real-valued event related data.
	+
	+ FUNCTION PYP(I,J)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local array.
	+ DIMENSION PSUM(4)
	+
	+C...Set default value. For I = 0 sum of momenta or charges,
	+C...or invariant mass of system.
	+ PYP=0D0
	+ IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
	+ ELSEIF(I.EQ.0.AND.J.LE.4) THEN
	+ DO 100 I1=1,N
	+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
	+ 100 CONTINUE
	+ ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
	+ DO 120 J1=1,4
	+ PSUM(J1)=0D0
	+ DO 110 I1=1,N
	+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
	+ & P(I1,J1)
	+ 110 CONTINUE
	+ 120 CONTINUE
	+ PYP=SQRT(MAX(0D0,PSUM(4)2-PSUM(1)2-PSUM(2)2-PSUM(3)2))
	+ ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
	+ DO 130 I1=1,N
	+ IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
	+ 130 CONTINUE
	+ ELSEIF(I.EQ.0) THEN
	+
	+C...Direct readout of P matrix.
	+ ELSEIF(J.LE.5) THEN
	+ PYP=P(I,J)
	+
	+C...Charge, total momentum, transverse momentum, transverse mass.
	+ ELSEIF(J.LE.12) THEN
	+ IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
	+ IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)2+P(I,2)2+P(I,3)**2
	+ IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)2+P(I,2)2
	+ IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)2+P(I,1)2+P(I,2)**2
	+ IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
	+
	+C...Theta and phi angle in radians or degrees.
	+ ELSEIF(J.LE.16) THEN
	+ IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)2+P(I,2)2))
	+ IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
	+ IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
	+
	+C...True rapidity, rapidity with pion mass, pseudorapidity.
	+ ELSEIF(J.LE.19) THEN
	+ PMR=0D0
	+ IF(J.EQ.17) PMR=P(I,5)
	+ IF(J.EQ.18) PMR=PYMASS(211)
	+ PR=MAX(1D-20,PMR2+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=2D0SQRT(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=2D0SQRT(P(I,1)2+P(I,2)*2)/PARU(21)
	+ IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
	+ IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
	+ IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
	+ ENDIF
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYSPHE
	+C...Performs sphericity tensor analysis to give sphericity,
	+C...aplanarity and the related event axes.
	+
	+ SUBROUTINE PYSPHE(SPH,APL)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local arrays.
	+ DIMENSION SM(3,3),SV(3,3)
	+
	+C...Calculate matrix to be diagonalized.
	+ NP=0
	+ DO 110 J1=1,3
	+ DO 100 J2=J1,3
	+ SM(J1,J2)=0D0
	+ 100 CONTINUE
	+ 110 CONTINUE
	+ PS=0D0
	+ DO 140 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
	+ IF(MSTU(41).GE.2) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 140
	+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	+ & GOTO 140
	+ ENDIF
	+ NP=NP+1
	+ PA=SQRT(P(I,1)2+P(I,2)2+P(I,3)**2)
	+ PWT=1D0
	+ IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
	+ & MAX(1D-10,PA)**(PARU(41)-2D0)
	+ DO 130 J1=1,3
	+ DO 120 J2=J1,3
	+ SM(J1,J2)=SM(J1,J2)+PWTP(I,J1)P(I,J2)
	+ 120 CONTINUE
	+ 130 CONTINUE
	+ PS=PS+PWTPA*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(2D0SP,SQRT(3D0(1D0-SP*2))-SP)
	+ P(N+3,4)=1D0/3D0+SQRT(-SQ)MIN(2D0SP,-SQRT(3D0(1D0-SP*2))-SP)
	+ P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
	+ IF(P(N+2,4).LT.1D-5) THEN
	+ CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
	+ SPH=-1D0
	+ APL=-1D0
	+ RETURN
	+ ENDIF
	+
	+C...Find first and last eigenvector by solving equation system.
	+ DO 240 I=1,3,2
	+ DO 180 J1=1,3
	+ SV(J1,J1)=SM(J1,J1)-P(N+I,4)
	+ DO 170 J2=J1+1,3
	+ SV(J1,J2)=SM(J1,J2)
	+ SV(J2,J1)=SM(J1,J2)
	+ 170 CONTINUE
	+ 180 CONTINUE
	+ SMAX=0D0
	+ DO 200 J1=1,3
	+ DO 190 J2=1,3
	+ IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
	+ JA=J1
	+ JB=J2
	+ SMAX=ABS(SV(J1,J2))
	+ 190 CONTINUE
	+ 200 CONTINUE
	+ SMAX=0D0
	+ DO 220 J3=JA+1,JA+2
	+ J1=J3-3*((J3-1)/3)
	+ RL=SV(J1,JB)/SV(JA,JB)
	+ DO 210 J2=1,3
	+ SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
	+ IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
	+ JC=J1
	+ SMAX=ABS(SV(J1,J2))
	+ 210 CONTINUE
	+ 220 CONTINUE
	+ JB1=JB+1-3*(JB/3)
	+ JB2=JB+2-3*((JB+1)/3)
	+ P(N+I,JB1)=-SV(JC,JB2)
	+ P(N+I,JB2)=SV(JC,JB1)
	+ P(N+I,JB)=-(SV(JA,JB1)P(N+I,JB1)+SV(JA,JB2)P(N+I,JB2))/
	+ & SV(JA,JB)
	+ PA=SQRT(P(N+I,1)2+P(N+I,2)2+P(N+I,3)**2)
	+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
	+ DO 230 J=1,3
	+ P(N+I,J)=SGN*P(N+I,J)/PA
	+ 230 CONTINUE
	+ 240 CONTINUE
	+
	+C...Middle axis orthogonal to other two. Fill other codes.
	+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
	+ P(N+2,1)=SGN(P(N+1,2)P(N+3,3)-P(N+1,3)*P(N+3,2))
	+ P(N+2,2)=SGN(P(N+1,3)P(N+3,1)-P(N+1,1)*P(N+3,3))
	+ P(N+2,3)=SGN(P(N+1,1)P(N+3,2)-P(N+1,2)*P(N+3,1))
	+ DO 260 I=1,3
	+ K(N+I,1)=31
	+ K(N+I,2)=95
	+ K(N+I,3)=I
	+ K(N+I,4)=0
	+ K(N+I,5)=0
	+ P(N+I,5)=0D0
	+ DO 250 J=1,5
	+ V(I,J)=0D0
	+ 250 CONTINUE
	+ 260 CONTINUE
	+
	+C...Calculate sphericity and aplanarity. Select storing option.
	+ SPH=1.5D0*(P(N+2,4)+P(N+3,4))
	+ APL=1.5D0*P(N+3,4)
	+ MSTU(61)=N+1
	+ MSTU(62)=NP
	+ IF(MSTU(43).LE.1) MSTU(3)=3
	+ IF(MSTU(43).GE.2) N=N+3
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYTHRU
	+C...Performs thrust analysis to give thrust, oblateness
	+C...and the related event axes.
	+
	+ SUBROUTINE PYTHRU(THR,OBL)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local arrays.
	+ DIMENSION TDI(3),TPR(3)
	+
	+C...Take copy of particles that are to be considered in thrust analysis.
	+ NP=0
	+ PS=0D0
	+ DO 100 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
	+ IF(MSTU(41).GE.2) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 100
	+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	+ & GOTO 100
	+ ENDIF
	+ IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
	+ CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
	+ THR=-2D0
	+ OBL=-2D0
	+ RETURN
	+ ENDIF
	+ NP=NP+1
	+ K(N+NP,1)=23
	+ P(N+NP,1)=P(I,1)
	+ P(N+NP,2)=P(I,2)
	+ P(N+NP,3)=P(I,3)
	+ P(N+NP,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)**2)
	+ P(N+NP,5)=1D0
	+ IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
	+ & P(N+NP,4)**(PARU(42)-1D0)
	+ PS=PS+P(N+NP,4)*P(N+NP,5)
	+ 100 CONTINUE
	+
	+C...Very low multiplicities (0 or 1) not considered.
	+ IF(NP.LE.1) THEN
	+ CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
	+ THR=-1D0
	+ OBL=-1D0
	+ RETURN
	+ ENDIF
	+
	+C...Loop over thrust and major. T axis along z direction in latter case.
	+ DO 320 ILD=1,2
	+ IF(ILD.EQ.2) THEN
	+ K(N+NP+1,1)=31
	+ PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
	+ MSTU(33)=1
	+ CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
	+ THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
	+ CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
	+ ENDIF
	+
	+C...Find and order particles with highest p (pT for major).
	+ DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
	+ P(ILF,4)=0D0
	+ 110 CONTINUE
	+ DO 160 I=N+1,N+NP
	+ IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)2+P(I,2)2)
	+ DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
	+ IF(P(I,4).LE.P(ILF,4)) GOTO 140
	+ DO 120 J=1,5
	+ P(ILF+1,J)=P(ILF,J)
	+ 120 CONTINUE
	+ 130 CONTINUE
	+ ILF=N+NP+3
	+ 140 DO 150 J=1,5
	+ P(ILF+1,J)=P(I,J)
	+ 150 CONTINUE
	+ 160 CONTINUE
	+
	+C...Find and order initial axes with highest thrust (major).
	+ DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
	+ P(ILG,4)=0D0
	+ 170 CONTINUE
	+ NC=2**(MIN(MSTU(44),NP)-1)
	+ DO 250 ILC=1,NC
	+ DO 180 J=1,3
	+ TDI(J)=0D0
	+ 180 CONTINUE
	+ DO 200 ILF=1,MIN(MSTU(44),NP)
	+ SGN=P(N+NP+ILF+3,5)
	+ IF(2*ILF((ILC+2(ILF-1)-1)/2ILF).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)=SGNTPR(J)/(PSTHP)
	+ 310 CONTINUE
	+ P(N+NP+ILD,4)=THP
	+ P(N+NP+ILD,5)=0D0
	+ ENDIF
	+ IAGR=IAGR+1
	+ IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
	+ 320 CONTINUE
	+
	+C...Find minor axis and value by orthogonality.
	+ SGN=(-1D0)**INT(PYR(0)+0.5D0)
	+ P(N+NP+3,1)=-SGN*P(N+NP+2,2)
	+ P(N+NP+3,2)=SGN*P(N+NP+2,1)
	+ P(N+NP+3,3)=0D0
	+ THP=0D0
	+ DO 330 I=N+1,N+NP
	+ THP=THP+P(I,5)ABS(P(N+NP+3,1)P(I,1)+P(N+NP+3,2)*P(I,2))
	+ 330 CONTINUE
	+ P(N+NP+3,4)=THP/PS
	+ P(N+NP+3,5)=0D0
	+
	+C...Fill axis information. Rotate back to original coordinate system.
	+ DO 350 ILD=1,3
	+ K(N+ILD,1)=31
	+ K(N+ILD,2)=96
	+ K(N+ILD,3)=ILD
	+ K(N+ILD,4)=0
	+ K(N+ILD,5)=0
	+ DO 340 J=1,5
	+ P(N+ILD,J)=P(N+NP+ILD,J)
	+ V(N+ILD,J)=0D0
	+ 340 CONTINUE
	+ 350 CONTINUE
	+ CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
	+
	+C...Calculate thrust and oblateness. Select storing option.
	+ THR=P(N+1,4)
	+ OBL=P(N+2,4)-P(N+3,4)
	+ MSTU(61)=N+1
	+ MSTU(62)=NP
	+ IF(MSTU(43).LE.1) MSTU(3)=3
	+ IF(MSTU(43).GE.2) N=N+3
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYCLUS
	+C...Subdivides the particle content of an event into jets/clusters.
	+
	+ SUBROUTINE PYCLUS(NJET)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local arrays and saved variables.
	+ DIMENSION PS(5)
	+ SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
	+
	+C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
	+ R2T(I1,I2)=(P(I1,5)P(I2,5)-P(I1,1)P(I2,1)-P(I1,2)*P(I2,2)-
	+ &P(I1,3)P(I2,3))2D0P(I1,5)P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
	+ R2M(I1,I2)=2D0P(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)=2D0MIN(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=2D0MAX(R2ACC,PS(5)*2)
	+ DO 400 ITRY1=N+1,N+NJET-1
	+ DO 390 ITRY2=ITRY1+1,N+NJET
	+ IF(MSTU(46).LE.2) THEN
	+ R2=R2T(ITRY1,ITRY2)
	+ ELSEIF(MSTU(46).LE.4) THEN
	+ R2=R2M(ITRY1,ITRY2)
	+ ELSE
	+ R2=R2D(ITRY1,ITRY2)
	+ ENDIF
	+ IF(R2.GE.R2MIN) GOTO 390
	+ IMIN1=ITRY1
	+ IMIN2=ITRY2
	+ R2MIN=R2
	+ 390 CONTINUE
	+ 400 CONTINUE
	+
	+C...If allowed, join two closest jets and start over.
	+ IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
	+ IREC=MIN(IMIN1,IMIN2)
	+ IDEL=MAX(IMIN1,IMIN2)
	+ DO 410 J=1,4
	+ P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
	+ 410 CONTINUE
	+ P(IREC,5)=SQRT(P(IREC,1)2+P(IREC,2)2+P(IREC,3)**2)
	+ DO 430 I=IDEL+1,N+NJET
	+ DO 420 J=1,5
	+ P(I-1,J)=P(I,J)
	+ 420 CONTINUE
	+ 430 CONTINUE
	+ IF(MSTU(46).GE.2) THEN
	+ DO 440 I=N+NP+1,N+2*NP
	+ IORI=N+K(I,4)
	+ IF(IORI.EQ.IDEL) K(I,4)=IREC-N
	+ IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
	+ 440 CONTINUE
	+ ENDIF
	+ NJET=NJET-1
	+ GOTO 300
	+
	+C...Divide up broad jet if empty cluster in list of final ones.
	+ ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
	+ DO 450 I=N+1,N+NJET
	+ K(I,5)=0
	+ 450 CONTINUE
	+ DO 460 I=N+NP+1,N+2*NP
	+ K(N+K(I,4),5)=K(N+K(I,4),5)+1
	+ 460 CONTINUE
	+ IEMP=0
	+ DO 470 I=N+1,N+NJET
	+ IF(K(I,5).EQ.0) IEMP=I
	+ 470 CONTINUE
	+ IF(IEMP.NE.0) THEN
	+ NLOOP=NLOOP+1
	+ ISPL=0
	+ R2MAX=0D0
	+ DO 480 I=N+NP+1,N+2*NP
	+ IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
	+ IJET=N+K(I,4)
	+ R2=R2T(I,IJET)
	+ IF(R2.LE.R2MAX) GOTO 480
	+ ISPL=I
	+ R2MAX=R2
	+ 480 CONTINUE
	+ IF(ISPL.NE.0) THEN
	+ IJET=N+K(ISPL,4)
	+ DO 490 J=1,4
	+ P(IEMP,J)=P(ISPL,J)
	+ P(IJET,J)=P(IJET,J)-P(ISPL,J)
	+ 490 CONTINUE
	+ P(IEMP,5)=P(ISPL,5)
	+ P(IJET,5)=SQRT(P(IJET,1)2+P(IJET,2)2+P(IJET,3)**2)
	+ IF(NLOOP.LE.2) GOTO 300
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+
	+C...If generalized thrust has not yet converged, continue iteration.
	+ IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
	+ &THEN
	+ TSAV=PSJT/PSS
	+ GOTO 310
	+ ENDIF
	+
	+C...Reorder jets according to energy.
	+ DO 510 I=N+1,N+NJET
	+ DO 500 J=1,5
	+ V(I,J)=P(I,J)
	+ 500 CONTINUE
	+ 510 CONTINUE
	+ DO 540 INEW=N+1,N+NJET
	+ PEMAX=0D0
	+ DO 520 ITRY=N+1,N+NJET
	+ IF(V(ITRY,4).LE.PEMAX) GOTO 520
	+ IMAX=ITRY
	+ PEMAX=V(ITRY,4)
	+ 520 CONTINUE
	+ K(INEW,1)=31
	+ K(INEW,2)=97
	+ K(INEW,3)=INEW-N
	+ K(INEW,4)=0
	+ DO 530 J=1,5
	+ P(INEW,J)=V(IMAX,J)
	+ 530 CONTINUE
	+ V(IMAX,4)=-1D0
	+ K(IMAX,5)=INEW
	+ 540 CONTINUE
	+
	+C...Clean up particle-jet assignments and jet information.
	+ DO 550 I=N+NP+1,N+2*NP
	+ IORI=K(N+K(I,4),5)
	+ K(I,4)=IORI-N
	+ IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
	+ K(IORI,4)=K(IORI,4)+1
	+ 550 CONTINUE
	+ IEMP=0
	+ PSJT=0D0
	+ DO 570 I=N+1,N+NJET
	+ K(I,5)=0
	+ PSJT=PSJT+P(I,5)
	+ P(I,5)=SQRT(MAX(P(I,4)2-P(I,5)2,0D0))
	+ DO 560 J=1,5
	+ V(I,J)=0D0
	+ 560 CONTINUE
	+ IF(K(I,4).EQ.0) IEMP=I
	+ 570 CONTINUE
	+
	+C...Select storing option. Output variables. Check for failure.
	+ MSTU(61)=N+1
	+ MSTU(62)=NP
	+ MSTU(63)=NPRE
	+ PARU(61)=PS(5)
	+ PARU(62)=PSJT/PSS
	+ PARU(63)=SQRT(R2MIN)
	+ IF(NJET.LE.1) PARU(63)=0D0
	+ IF(IEMP.NE.0) THEN
	+ CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
	+ NJET=-1
	+ RETURN
	+ ENDIF
	+ IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
	+ IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
	+ NSAV=NJET
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYCELL
	+C...Provides a simple way of jet finding in eta-phi-ET coordinates,
	+C...as used for calorimeters at hadron colliders.
	+
	+ SUBROUTINE PYCELL(NJET)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Loop over all particles. Find cell that was hit by given particle.
	+ PTLRAT=1D0/SINH(PARU(51))**2
	+ NP=0
	+ NC=N
	+ DO 110 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
	+ IF(P(I,1)2+P(I,2)2.LE.PTLRATP(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(PT2+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))(2IETA-1-MSTU(51))
	+ P(NC,2)=(PARU(1)/MSTU(52))(2IPHI-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(-2D0LOG(MAX(1D-10,PYR(0)))PEI)
	+ & COS(PARU(2)*PYR(0))
	+ IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
	+ P(IC,5)=PEF
	+ IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
	+ 130 CONTINUE
	+ ENDIF
	+
	+C...Remove cells below threshold.
	+ IF(PARU(58).GT.0D0) THEN
	+ NCC=NC
	+ NC=N
	+ DO 140 IC=N+1,NCC
	+ IF(P(IC,5).GT.PARU(58)) THEN
	+ NC=NC+1
	+ K(NC,3)=K(IC,3)
	+ K(NC,4)=K(IC,4)
	+ K(NC,5)=K(IC,5)
	+ P(NC,1)=P(IC,1)
	+ P(NC,2)=P(IC,2)
	+ P(NC,5)=P(IC,5)
	+ ENDIF
	+ 140 CONTINUE
	+ ENDIF
	+
	+C...Find initiator cell: the one with highest pT of not yet used ones.
	+ NJ=NC
	+ 150 ETMAX=0D0
	+ DO 160 IC=N+1,NC
	+ IF(K(IC,5).NE.2) GOTO 160
	+ IF(P(IC,5).LE.ETMAX) GOTO 160
	+ ICMAX=IC
	+ ETA=P(IC,1)
	+ PHI=P(IC,2)
	+ ETMAX=P(IC,5)
	+ 160 CONTINUE
	+ IF(ETMAX.LT.PARU(52)) GOTO 220
	+ IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
	+ CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
	+ NJET=-2
	+ RETURN
	+ ENDIF
	+ K(ICMAX,5)=1
	+ NJ=NJ+1
	+ K(NJ,4)=0
	+ K(NJ,5)=1
	+ P(NJ,1)=ETA
	+ P(NJ,2)=PHI
	+ P(NJ,3)=0D0
	+ P(NJ,4)=0D0
	+ P(NJ,5)=0D0
	+
	+C...Sum up unused cells within required distance of initiator.
	+ DO 170 IC=N+1,NC
	+ IF(K(IC,5).EQ.0) GOTO 170
	+ IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
	+ DPHIA=ABS(P(IC,2)-PHI)
	+ IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
	+ PHIC=P(IC,2)
	+ IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
	+ IF((P(IC,1)-ETA)2+(PHIC-PHI)2.GT.PARU(54)**2) GOTO 170
	+ K(IC,5)=-K(IC,5)
	+ K(NJ,4)=K(NJ,4)+K(IC,4)
	+ P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
	+ P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
	+ P(NJ,5)=P(NJ,5)+P(IC,5)
	+ 170 CONTINUE
	+
	+C...Reject cluster below minimum ET, else accept.
	+ IF(P(NJ,5).LT.PARU(53)) THEN
	+ NJ=NJ-1
	+ DO 180 IC=N+1,NC
	+ IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
	+ 180 CONTINUE
	+ ELSEIF(MSTU(54).LE.2) THEN
	+ P(NJ,3)=P(NJ,3)/P(NJ,5)
	+ P(NJ,4)=P(NJ,4)/P(NJ,5)
	+ IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
	+ & P(NJ,4))
	+ DO 190 IC=N+1,NC
	+ IF(K(IC,5).LT.0) K(IC,5)=0
	+ 190 CONTINUE
	+ ELSE
	+ DO 200 J=1,4
	+ P(NJ,J)=0D0
	+ 200 CONTINUE
	+ DO 210 IC=N+1,NC
	+ IF(K(IC,5).GE.0) GOTO 210
	+ P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
	+ P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
	+ P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
	+ P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
	+ K(IC,5)=0
	+ 210 CONTINUE
	+ ENDIF
	+ GOTO 150
	+
	+C...Arrange clusters in falling ET sequence.
	+ 220 DO 250 I=1,NJ-NC
	+ ETMAX=0D0
	+ DO 230 IJ=NC+1,NJ
	+ IF(K(IJ,5).EQ.0) GOTO 230
	+ IF(P(IJ,5).LT.ETMAX) GOTO 230
	+ IJMAX=IJ
	+ ETMAX=P(IJ,5)
	+ 230 CONTINUE
	+ K(IJMAX,5)=0
	+ K(N+I,1)=31
	+ K(N+I,2)=98
	+ K(N+I,3)=I
	+ K(N+I,4)=K(IJMAX,4)
	+ K(N+I,5)=0
	+ DO 240 J=1,5
	+ P(N+I,J)=P(IJMAX,J)
	+ V(N+I,J)=0D0
	+ 240 CONTINUE
	+ 250 CONTINUE
	+ NJET=NJ-NC
	+
	+C...Convert to massless or massive four-vectors.
	+ IF(MSTU(54).EQ.2) THEN
	+ DO 260 I=N+1,N+NJET
	+ ETA=P(I,3)
	+ P(I,1)=P(I,5)*COS(P(I,4))
	+ P(I,2)=P(I,5)*SIN(P(I,4))
	+ P(I,3)=P(I,5)*SINH(ETA)
	+ P(I,4)=P(I,5)*COSH(ETA)
	+ P(I,5)=0D0
	+ 260 CONTINUE
	+ ELSEIF(MSTU(54).GE.3) THEN
	+ DO 270 I=N+1,N+NJET
	+ P(I,5)=SQRT(MAX(0D0,P(I,4)2-P(I,1)2-P(I,2)2-P(I,3)2))
	+ 270 CONTINUE
	+ ENDIF
	+
	+C...Information about storage.
	+ MSTU(61)=N+1
	+ MSTU(62)=NP
	+ MSTU(63)=NC-N
	+ IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
	+ IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYJMAS
	+C...Determines, approximately, the two jet masses that minimize
	+C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
	+
	+ SUBROUTINE PYJMAS(PMH,PML)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+C...Local arrays.
	+ DIMENSION SM(3,3),SAX(3),PS(3,5)
	+
	+C...Reset.
	+ NP=0
	+ DO 120 J1=1,3
	+ DO 100 J2=J1,3
	+ SM(J1,J2)=0D0
	+ 100 CONTINUE
	+ DO 110 J2=1,4
	+ PS(J1,J2)=0D0
	+ 110 CONTINUE
	+ 120 CONTINUE
	+ PSS=0D0
	+ PIMASS=PMAS(PYCOMP(211),1)
	+
	+C...Take copy of particles that are to be considered in mass analysis.
	+ DO 170 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
	+ IF(MSTU(41).GE.2) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 170
	+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	+ & GOTO 170
	+ ENDIF
	+ IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
	+ CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
	+ PMH=-2D0
	+ PML=-2D0
	+ RETURN
	+ ENDIF
	+ NP=NP+1
	+ DO 130 J=1,5
	+ P(N+NP,J)=P(I,J)
	+ 130 CONTINUE
	+ IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
	+ IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
	+ P(N+NP,4)=SQRT(P(N+NP,5)2+P(I,1)2+P(I,2)2+P(I,3)2)
	+
	+C...Fill information in sphericity tensor and total momentum vector.
	+ DO 150 J1=1,3
	+ DO 140 J2=J1,3
	+ SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
	+ 140 CONTINUE
	+ 150 CONTINUE
	+ PSS=PSS+(P(I,1)2+P(I,2)2+P(I,3)**2)
	+ DO 160 J=1,4
	+ PS(3,J)=PS(3,J)+P(N+NP,J)
	+ 160 CONTINUE
	+ 170 CONTINUE
	+
	+C...Very low multiplicities (0 or 1) not considered.
	+ IF(NP.LE.1) THEN
	+ CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
	+ PMH=-1D0
	+ PML=-1D0
	+ RETURN
	+ ENDIF
	+ PARU(61)=SQRT(MAX(0D0,PS(3,4)2-PS(3,1)2-PS(3,2)**2-
	+ &PS(3,3)**2))
	+
	+C...Find largest eigenvalue to matrix (third degree equation).
	+ DO 190 J1=1,3
	+ DO 180 J2=J1,3
	+ SM(J1,J2)=SM(J1,J2)/PSS
	+ 180 CONTINUE
	+ 190 CONTINUE
	+ SQ=(SM(1,1)SM(2,2)+SM(1,1)SM(3,3)+SM(2,2)*SM(3,3)-
	+ &SM(1,2)2-SM(1,3)2-SM(2,3)**2)/3D0-1D0/9D0
	+ SR=-0.5D0(SQ+1D0/9D0+SM(1,1)SM(2,3)*2+SM(2,2)SM(1,3)**2+
	+ &SM(3,3)SM(1,2)2-SM(1,1)SM(2,2)*SM(3,3))+
	+ &SM(1,2)SM(1,3)SM(2,3)+1D0/27D0
	+ SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
	+ SMA=1D0/3D0+SQRT(-SQ)MAX(2D0SP,SQRT(3D0(1D0-SP*2))-SP)
	+
	+C...Find largest eigenvector by solving equation system.
	+ DO 210 J1=1,3
	+ SM(J1,J1)=SM(J1,J1)-SMA
	+ DO 200 J2=J1+1,3
	+ SM(J2,J1)=SM(J1,J2)
	+ 200 CONTINUE
	+ 210 CONTINUE
	+ SMAX=0D0
	+ DO 230 J1=1,3
	+ DO 220 J2=1,3
	+ IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
	+ JA=J1
	+ JB=J2
	+ SMAX=ABS(SM(J1,J2))
	+ 220 CONTINUE
	+ 230 CONTINUE
	+ SMAX=0D0
	+ DO 250 J3=JA+1,JA+2
	+ J1=J3-3*((J3-1)/3)
	+ RL=SM(J1,JB)/SM(JA,JB)
	+ DO 240 J2=1,3
	+ SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
	+ IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
	+ JC=J1
	+ SMAX=ABS(SM(J1,J2))
	+ 240 CONTINUE
	+ 250 CONTINUE
	+ JB1=JB+1-3*(JB/3)
	+ JB2=JB+2-3*((JB+1)/3)
	+ SAX(JB1)=-SM(JC,JB2)
	+ SAX(JB2)=SM(JC,JB1)
	+ SAX(JB)=-(SM(JA,JB1)SAX(JB1)+SM(JA,JB2)SAX(JB2))/SM(JA,JB)
	+
	+C...Divide particles into two initial clusters by hemisphere.
	+ DO 270 I=N+1,N+NP
	+ PSAX=P(I,1)SAX(1)+P(I,2)SAX(2)+P(I,3)*SAX(3)
	+ IS=1
	+ IF(PSAX.LT.0D0) IS=2
	+ K(I,3)=IS
	+ DO 260 J=1,4
	+ PS(IS,J)=PS(IS,J)+P(I,J)
	+ 260 CONTINUE
	+ 270 CONTINUE
	+ PMS=MAX(1D-10,PS(1,4)2-PS(1,1)2-PS(1,2)2-PS(1,3)2)+
	+ &MAX(1D-10,PS(2,4)2-PS(2,1)2-PS(2,2)2-PS(2,3)2)
	+
	+C...Reassign one particle at a time; find maximum decrease of m^2 sum.
	+ 280 PMD=0D0
	+ IM=0
	+ DO 290 J=1,4
	+ PS(3,J)=PS(1,J)-PS(2,J)
	+ 290 CONTINUE
	+ DO 300 I=N+1,N+NP
	+ PPS=P(I,4)PS(3,4)-P(I,1)PS(3,1)-P(I,2)PS(3,2)-P(I,3)PS(3,3)
	+ IF(K(I,3).EQ.1) PMDI=2D0(P(I,5)*2-PPS)
	+ IF(K(I,3).EQ.2) PMDI=2D0(P(I,5)*2+PPS)
	+ IF(PMDI.LT.PMD) THEN
	+ PMD=PMDI
	+ IM=I
	+ ENDIF
	+ 300 CONTINUE
	+
	+C...Loop back if significant reduction in sum of m^2.
	+ IF(PMD.LT.-PARU(48)*PMS) THEN
	+ PMS=PMS+PMD
	+ IS=K(IM,3)
	+ DO 310 J=1,4
	+ PS(IS,J)=PS(IS,J)-P(IM,J)
	+ PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
	+ 310 CONTINUE
	+ K(IM,3)=3-IS
	+ GOTO 280
	+ ENDIF
	+
	+C...Final masses and output.
	+ MSTU(61)=N+1
	+ MSTU(62)=NP
	+ PS(1,5)=SQRT(MAX(0D0,PS(1,4)2-PS(1,1)2-PS(1,2)2-PS(1,3)2))
	+ PS(2,5)=SQRT(MAX(0D0,PS(2,4)2-PS(2,1)2-PS(2,2)2-PS(2,3)2))
	+ PMH=MAX(PS(1,5),PS(2,5))
	+ PML=MIN(PS(1,5),PS(2,5))
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYFOWO
	+C...Calculates the first few Fox-Wolfram moments.
	+
	+ SUBROUTINE PYFOWO(H10,H20,H30,H40)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Copy momenta for particles and calculate H0.
	+ NP=0
	+ H0=0D0
	+ HD=0D0
	+ DO 110 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
	+ IF(MSTU(41).GE.2) THEN
	+ KC=PYCOMP(K(I,2))
	+ IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
	+ & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
	+ & K(I,2).EQ.KSUSY1+39) GOTO 110
	+ IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
	+ & GOTO 110
	+ ENDIF
	+ IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
	+ CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
	+ H10=-1D0
	+ H20=-1D0
	+ H30=-1D0
	+ H40=-1D0
	+ RETURN
	+ ENDIF
	+ NP=NP+1
	+ DO 100 J=1,3
	+ P(N+NP,J)=P(I,J)
	+ 100 CONTINUE
	+ P(N+NP,4)=SQRT(P(I,1)2+P(I,2)2+P(I,3)**2)
	+ H0=H0+P(N+NP,4)
	+ HD=HD+P(N+NP,4)**2
	+ 110 CONTINUE
	+ H0=H0**2
	+
	+C...Very low multiplicities (0 or 1) not considered.
	+ IF(NP.LE.1) THEN
	+ CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
	+ H10=-1D0
	+ H20=-1D0
	+ H30=-1D0
	+ H40=-1D0
	+ RETURN
	+ ENDIF
	+
	+C...Calculate H1 - H4.
	+ H10=0D0
	+ H20=0D0
	+ H30=0D0
	+ H40=0D0
	+ DO 130 I1=N+1,N+NP
	+ DO 120 I2=I1+1,N+NP
	+ CTHE=(P(I1,1)P(I2,1)+P(I1,2)P(I2,2)+P(I1,3)*P(I2,3))/
	+ & (P(I1,4)*P(I2,4))
	+ H10=H10+P(I1,4)P(I2,4)CTHE
	+ H20=H20+P(I1,4)P(I2,4)(1.5D0CTHE*2-0.5D0)
	+ H30=H30+P(I1,4)P(I2,4)(2.5D0CTHE3-1.5D0CTHE)
	+ H40=H40+P(I1,4)P(I2,4)(4.375D0CTHE4-3.75D0CTHE**2+
	+ & 0.375D0)
	+ 120 CONTINUE
	+ 130 CONTINUE
	+
	+C...Calculate H1/H0 - H4/H0. Output.
	+ MSTU(61)=N+1
	+ MSTU(62)=NP
	+ H10=(HD+2D0*H10)/H0
	+ H20=(HD+2D0*H20)/H0
	+ H30=(HD+2D0*H30)/H0
	+ H40=(HD+2D0*H40)/H0
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYTABU
	+C...Evaluates various properties of an event, with statistics
	+C...accumulated during the course of the run and
	+C...printed at the end.
	+
	+ SUBROUTINE PYTABU(MTABU)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Parameter statement to help give large particle numbers.
	+ PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
	+ &KEXCIT=4000000,KDIMEN=5000000)
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
	+C...Local arrays, character variables, saved variables and data.
	+ DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
	+ &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
	+ &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
	+ &KFDM(8),KFDC(200,0:8),NPDC(200)
	+ SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
	+ &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
	+ &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
	+ CHARACTER CHAU16,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/1200D0/,FM2FM/1200D0/,
	+ &NEVEE/0/,FE1EC/500D0/,FE2EC/500D0/,FE1EA/250D0/,FE2EA/250D0/,
	+ &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,FACNPRFS,FACNFIFS,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,PMR2+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))/(2D0PARU(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(2MOD(IYETA/2IB,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=FACNMUFM/DBLE(2*(IB-1))
	+ IF(IM.EQ.3) BNAVE=FACNMUFM/DBLE(4*(IB-1))
	+ DO 490 IP=1,4
	+ FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
	+ FMOMS(IP)=SQRT(MAX(0D0,FAC(FACFM2FM(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(FACFM2FM(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(PMR2+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)+FACP(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(FACFE2EC(J)-FEEC1**2)))
	+ FEEC2=FAC*FE1EC(51-J)
	+ FEES2=SQRT(MAX(0D0,FAC(FACFE2EC(51-J)-FEEC2**2)))
	+ FEECA=FAC*FE1EA(J)
	+ FEESA=SQRT(MAX(0D0,FAC(FACFE2EA(J)-FEECA**2)))
	+ WRITE(MSTU(11),5800) 3.6D0(J-1),3.6D0J,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(FACFE2EC(I)-P(I,1)**2)))
	+ P(I,2)=FAC*FE1EC(51-I)
	+ V(I,2)=SQRT(MAX(0D0,FAC(FACFE2EC(51-I)-P(I,2)**2)))
	+ P(I,3)=FAC*FE1EA(I)
	+ V(I,3)=SQRT(MAX(0D0,FAC(FACFE2EA(I)-P(I,3)**2)))
	+ P(I,4)=PARU(1)*(I-1)/50D0
	+ P(I,5)=PARU(1)*I/50D0
	+ V(I,4)=3.6D0*(I-1)
	+ V(I,5)=3.6D0*I
	+ 630 CONTINUE
	+ N=25
	+ DO 640 J=1,5
	+ K(N+1,J)=0
	+ P(N+1,J)=0D0
	+ V(N+1,J)=0D0
	+ 640 CONTINUE
	+ K(N+1,1)=32
	+ K(N+1,2)=99
	+ K(N+1,5)=NEVEE
	+ MSTU(3)=1
	+
	+C...Reset statistics on decay channels.
	+ ELSEIF(MTABU.EQ.50) THEN
	+ NEVDC=0
	+ NKFDC=0
	+ NREDC=0
	+
	+C...Identify and order flavour content of final state.
	+ ELSEIF(MTABU.EQ.51) THEN
	+ NEVDC=NEVDC+1
	+ NDS=0
	+ DO 670 I=1,N
	+ IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
	+ NDS=NDS+1
	+ IF(NDS.GT.8) THEN
	+ NREDC=NREDC+1
	+ RETURN
	+ ENDIF
	+ KFM=2*IABS(K(I,2))
	+ IF(K(I,2).LT.0) KFM=KFM-1
	+ DO 650 IDS=NDS-1,1,-1
	+ IIN=IDS+1
	+ IF(KFM.LT.KFDM(IDS)) GOTO 660
	+ KFDM(IDS+1)=KFDM(IDS)
	+ 650 CONTINUE
	+ IIN=1
	+ 660 KFDM(IIN)=KFM
	+ 670 CONTINUE
	+
	+C...Find whether old or new final state.
	+ DO 690 IDC=1,NKFDC
	+ IF(NDS.LT.KFDC(IDC,0)) THEN
	+ IKFDC=IDC
	+ GOTO 700
	+ ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
	+ DO 680 I=1,NDS
	+ IF(KFDM(I).LT.KFDC(IDC,I)) THEN
	+ IKFDC=IDC
	+ GOTO 700
	+ ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
	+ GOTO 690
	+ ENDIF
	+ 680 CONTINUE
	+ IKFDC=-IDC
	+ GOTO 700
	+ ENDIF
	+ 690 CONTINUE
	+ IKFDC=NKFDC+1
	+ 700 IF(IKFDC.LT.0) THEN
	+ IKFDC=-IKFDC
	+ ELSEIF(NKFDC.GE.200) THEN
	+ NREDC=NREDC+1
	+ RETURN
	+ ELSE
	+ DO 720 IDC=NKFDC,IKFDC,-1
	+ NPDC(IDC+1)=NPDC(IDC)
	+ DO 710 I=0,8
	+ KFDC(IDC+1,I)=KFDC(IDC,I)
	+ 710 CONTINUE
	+ 720 CONTINUE
	+ NKFDC=NKFDC+1
	+ KFDC(IKFDC,0)=NDS
	+ DO 730 I=1,NDS
	+ KFDC(IKFDC,I)=KFDM(I)
	+ 730 CONTINUE
	+ NPDC(IKFDC)=0
	+ ENDIF
	+ NPDC(IKFDC)=NPDC(IKFDC)+1
	+
	+C...Write statistics on decay channels.
	+ ELSEIF(MTABU.EQ.52) THEN
	+ FAC=1D0/MAX(1,NEVDC)
	+ WRITE(MSTU(11),5900) NEVDC
	+ DO 750 IDC=1,NKFDC
	+ DO 740 I=1,KFDC(IDC,0)
	+ KFM=KFDC(IDC,I)
	+ KF=(KFM+1)/2
	+ IF(2*KF.NE.KFM) KF=-KF
	+ CALL PYNAME(KF,CHAU)
	+ CHDC(I)=CHAU(1:12)
	+ IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
	+ 740 CONTINUE
	+ WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
	+ 750 CONTINUE
	+ IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
	+
	+C...Copy statistics on decay channels into /PYJETS/.
	+ ELSEIF(MTABU.EQ.53) THEN
	+ FAC=1D0/MAX(1,NEVDC)
	+ DO 780 IDC=1,NKFDC
	+ K(IDC,1)=32
	+ K(IDC,2)=99
	+ K(IDC,3)=0
	+ K(IDC,4)=0
	+ K(IDC,5)=KFDC(IDC,0)
	+ DO 760 J=1,5
	+ P(IDC,J)=0D0
	+ V(IDC,J)=0D0
	+ 760 CONTINUE
	+ DO 770 I=1,KFDC(IDC,0)
	+ KFM=KFDC(IDC,I)
	+ KF=(KFM+1)/2
	+ IF(2*KF.NE.KFM) KF=-KF
	+ IF(I.LE.5) P(IDC,I)=KF
	+ IF(I.GE.6) V(IDC,I-5)=KF
	+ 770 CONTINUE
	+ V(IDC,5)=FAC*NPDC(IDC)
	+ 780 CONTINUE
	+ N=NKFDC
	+ DO 790 J=1,5
	+ K(N+1,J)=0
	+ P(N+1,J)=0D0
	+ V(N+1,J)=0D0
	+ 790 CONTINUE
	+ K(N+1,1)=32
	+ K(N+1,2)=99
	+ K(N+1,5)=NEVDC
	+ V(N+1,5)=FAC*NREDC
	+ MSTU(3)=1
	+ ENDIF
	+
	+C...Format statements for output on unit MSTU(11) (default 6).
	+ 5000 FORMAT(///20X,'Event statistics - initial state'/
	+ &20X,'based on an analysis of ',I6,' events'//
	+ &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
	+ &'according to fragmenting system multiplicity'/
	+ &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
	+ &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
	+ 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
	+ 5200 FORMAT(///20X,'Event statistics - final state'/
	+ &20X,'based on an analysis of ',I7,' events'//
	+ &5X,'Mean primary multiplicity =',F10.4/
	+ &5X,'Mean final multiplicity =',F10.4/
	+ &5X,'Mean charged multiplicity =',F10.4//
	+ &5X,'Number of particles produced per event (directly and via ',
	+ &'decays/branchings)'/
	+ &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
	+ &8X,'Total'/35X,'prim seco prim seco'/)
	+ 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
	+ 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
	+ &20X,'based on an analysis of ',I6,' events'//
	+ &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
	+ &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
	+ 5500 FORMAT(10X)
	+ 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
	+ 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
	+ &20X,'based on an analysis of ',I6,' events'//
	+ &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
	+ &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
	+ 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
	+ 5900 FORMAT(///20X,'Decay channel analysis - final state'/
	+ &20X,'based on an analysis of ',I6,' events'//
	+ &2X,'Probability',10X,'Complete final state'/)
	+ 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
	+ 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
	+ &'or table overflow)')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYEEVT
	+C...Handles the generation of an e+e- annihilation jet event.
	+
	+ SUBROUTINE PYEEVT(KFL,ECM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Check input parameters.
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IF(KFL.LT.0.OR.KFL.GT.8) THEN
	+ CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
	+ IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
	+ IF(ECM.LT.ECMMIN) THEN
	+ CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+
	+C...Check consistency of MSTJ options set.
	+ IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
	+ CALL PYERRM(6,
	+ & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
	+ MSTJ(110)=1
	+ ENDIF
	+ IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
	+ CALL PYERRM(6,
	+ & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
	+ MSTJ(111)=0
	+ ENDIF
	+
	+C...Initialize alpha_strong and total cross-section.
	+ MSTU(111)=MSTJ(108)
	+ IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
	+ &MSTU(111)=1
	+ PARU(112)=PARJ(121)
	+ IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
	+ IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
	+ &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
	+ &XTOT)
	+ IF(MSTJ(116).GE.3) MSTJ(116)=1
	+ PARJ(171)=0D0
	+
	+C...Add initial e+e- to event record (documentation only).
	+ NTRY=0
	+ 100 NTRY=NTRY+1
	+ IF(NTRY.GT.100) THEN
	+ CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
	+ RETURN
	+ ENDIF
	+ MSTU(24)=0
	+ NC=0
	+ IF(MSTJ(115).GE.2) THEN
	+ NC=NC+2
	+ CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
	+ K(NC-1,1)=21
	+ CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
	+ K(NC,1)=21
	+ ENDIF
	+
	+C...Radiative photon (in initial state).
	+ MK=0
	+ ECMC=ECM
	+ IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
	+ &THEK,PHIK,ALPK)
	+ IF(MK.EQ.1) ECMC=SQRT(ECM(ECM-2D0PAK))
	+ 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,DBEKSIN(THEK),0D0,DBEKCOS(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-2D0MSTU(112))PARU(111)))))
	+ Q2R=PARJ(168)ECM*2
	+ ELSE
	+ PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
	+ & (2D0PARU(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.115D0MSTU(118))ALSPI**2
	+ IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0MSTU(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.519D0MSTU(118))ALSPI*2
	+ ENDIF
	+
	+C...Calculate Z0 width if default value not acceptable.
	+ IF(MSTJ(102).GE.3) THEN
	+ RVA=3D0(3D0+(4D0PARU(102)-1D0)*2)+6D0RQCD*(2D0+
	+ & (1D0-8D0PARU(102)/3D0)2+(4D0PARU(102)/3D0-1D0)**2)
	+ DO 100 KFLC=5,6
	+ VQ=1D0
	+ IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
	+ & (2D0PYMASS(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+3D0RQCD(0.5D0VQ(3D0-VQ*2)VF2+VQ3)
	+ 100 CONTINUE
	+ PARJ(124)=PARU(101)PARJ(123)RVA/(48D0PARU(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/(16D0PARU(102)(1D0-PARU(102)))
	+ SFW=ECM4/((ECM2-PARJ(123)2)2+(PARJ(123)PARJ(124))*2)
	+ SFI=SFW(1D0-(PARJ(123)/ECM)*2)
	+ VE=4D0*PARU(102)-1D0
	+ SF1I=SFF(VEPOLL+PARJ(132)-PARJ(131))
	+ SF1W=SFF*2((VE*2+1D0)POLL+2D0VE(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-(2D0PMQ/ECM)*2)
	+
	+C...Calculate R and sum of charges for QED or QFD case.
	+ RQQ=RQQ+3D0QF2POLL
	+ IF(MSTJ(102).LE.1) THEN
	+ RTOT=RTOT+3D00.5D0VQ(3D0-VQ2)QF*2POLL
	+ ELSE
	+ VF=SIGN(1D0,QF)-4D0QFPARU(102)
	+ RQV=RQV-6D0QFVF*SF1I
	+ RVA=RVA+3D0(VF2+1D0)SF1W
	+ RTOT=RTOT+3D0(0.5D0VQ(3D0-VQ2)(QF*2POLL-
	+ & 2D0QFVFHF1I+VF2HF1W)+VQ*3HF1W)
	+ ENDIF
	+ 110 CONTINUE
	+ RSUM=RQQ
	+ IF(MSTJ(102).GE.2) RSUM=RQQ+SFIRQV+SFWRVA
	+
	+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-(2D0PARJ(127)/ECM)*2)
	+ ALE=2D0*LOG(ECM/PYMASS(11))-1D0
	+ SIGV=ALE/3D0+2D0LOG(ECM2/(PYMASS(13)PYMASS(15)))/3D0-4D0/3D0+
	+ &1.526D0LOG(ECM*2/0.932D0)
	+
	+C...Soft and hard radiative cross-section in QED case.
	+ IF(MSTJ(102).LE.1) THEN
	+ SIGV=1.5D0ALE-0.5D0+PARU(1)2/3D0+2D0SIGV
	+ SIGS=ALE(2D0LOG(XKL)-LOG(1D0-XKL)-XKL)
	+ SIGH=ALE(2D0LOG(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.5D0SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
	+ PARJ(164)=(RQVSZW2(1D0-2D0SFW)+RVA(2D0SFI+SZW*2-
	+ & 4D0+3D0SZM-SZM2))/(SZWRSUM)
	+ SIGV=1.5D0ALE-0.5D0+PARU(1)2/3D0+((2D0RQQ+SFI*RQV)/
	+ & RSUM)SIGV+(SZWSFWRQV/RSUM)PARU(1)*20D0/9D0
	+ SIGS=ALE(2D0LOG(XKL)+PARJ(161)LOG(1D0-XKL)+PARJ(162)XKL+
	+ & PARJ(163)LOG(((XKL-SZM)2+SZW2)/(SZM2+SZW*2))+
	+ & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
	+ SIGH=ALE(2D0LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
	+ & (1D0-XKL))+PARJ(162)(XKU-XKL)+PARJ(163)
	+ & LOG(((XKU-SZM)2+SZW2)/((XKL-SZM)2+SZW2))+
	+ & 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)=2D0LOG(XX)+PARJ(161)LOG(1D0-XX)+PARJ(162)*XX+
	+ &PARJ(163)LOG((XX-SZM)2+SZW2)+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-(2D0PARJ(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.2D0PYR(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.5D0ECMXK
	+
	+C...Photon polar and azimuthal angle.
	+ PME=2D0(PYMASS(11)/ECM)*2
	+ 120 CTHM=PME(2D0/PME)*PYR(0)
	+ IF(1D0-(XK*2CTHM(1D0-0.5D0CTHM)+2D0(1D0-XK)PME/MAX(PME,
	+ &CTHM(1D0-0.5D0CTHM)))/(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+(XKCTHE)*2).GT.
	+ &PYR(0)) SGN=-1D0
	+ ALPK=ASIN(SGNSTHE(XK-SGN(2D0SQRT(1D0-XK)-2D0+XK)*CTHE)/
	+ &(2D0-XK(1D0-SGNCTHE)))
	+
	+ 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/(16D0PARU(102)(1D0-PARU(102)))
	+ SFW=ECMC4/((ECMC2-PARJ(123)2)2+(PARJ(123)PARJ(124))*2)
	+ SFI=SFW(1D0-(PARJ(123)/ECMC)*2)
	+ VE=4D0*PARU(102)-1D0
	+ HF1I=SFISFF(VE*POLL+PARJ(132)-PARJ(131))
	+ HF1W=SFWSFF2((VE*2+1D0)POLL+2D0VE(PARJ(132)-PARJ(131)))
	+ RFMAX=MAX(4D0/9D0POLL-4D0/3D0(1D0-8D0PARU(102)/3D0)HF1I+
	+ & ((1D0-8D0PARU(102)/3D0)2+1D0)HF1W,1D0/9D0POLL+2D0/3D0
	+ & (-1D0+4D0PARU(102)/3D0)HF1I+((-1D0+4D0PARU(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-(2D0PMQ/ECMC)*2))
	+
	+C...Calculate weight in QED or QFD case.
	+ IF(MSTJ(102).LE.1) THEN
	+ RF=QF**2
	+ RFV=0.5D0VQ(3D0-VQ*2)QF**2
	+ ELSE
	+ VF=SIGN(1D0,QF)-4D0QFPARU(102)
	+ RF=QF*2POLL-2D0QFVFHF1I+(VF2+1D0)HF1W
	+ RFV=0.5D0VQ(3D0-VQ*2)(QF*2POLL-2D0QFVFHF1I+VF2HF1W)+
	+ & VQ*3HF1W
	+ IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ*3HF1W/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.2D0PMQ+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-2D0MSTU(112))PARU(111)))))
	+ Q2R=PARJ(168)ECM*2
	+ ELSE
	+ PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0PARU(112)/ECM)*2))
	+ Q2=PARJ(169)ECM*2
	+ PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
	+ & (2D0PARU(112)/ECM)*2))
	+ Q2R=PARJ(168)ECM*2
	+ ENDIF
	+
	+C...alpha_strong for R and R itself.
	+ ALSPI=(3D0/4D0)CFPYALPS(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.115D0MSTU(118))ALSPI**2
	+ IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
	+ & (33D0-2D0MSTU(112))/12D0LOG(PARJ(168))ALSPI*2)
	+ ELSE
	+ RQCD=1D0+ALSPI-(3D0/32D0+0.519D0MSTU(118))(4D0ALSPI/3D0)*2
	+ ENDIF
	+
	+C...alpha_strong for jet rate. Initial value for y cut.
	+ ALSPI=(3D0/4D0)CFPYALPS(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)=(2D0ALSPI/3D0)((3D0-6D0CUT+2D0LOG(CUT))*
	+ & LOG(CUT/(1D0-2D0CUT))+(2.5D0+1.5D0CUT-6.571D0)*
	+ & (1D0-3D0CUT)+5.833D0(1D0-3D0CUT)2-3.894D0
	+ & (1D0-3D0CUT)3+1.342D0(1D0-3D0CUT)*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*2CT*2(2.419D0+0.5989D0CT+0.6782D0CT**2-
	+ & 0.2661D0CT3+0.01159D0CT**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)+(100D0CUT-IZ)(ZHUT(IZ+1)-ZHUT(IZ))
	+ ENDIF
	+ PARJ(153)=ALSPIPARJ(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-2D0MSTU(112))/12D0LOG(PARJ(169))ALSPIPARJ(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.330D0CT+0.8304D0CT**2
	+ IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)*2(3.035D0-2.091D0*CT+
	+ & 0.4059D0CT*2)
	+ XQQQQ=1.25D0(-0.1080D0+0.01486D0CT+0.009364D0CT*2)
	+ IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
	+ ELSE
	+ XQQGG=-0.09773D0+0.2959D0CT-0.2764D0CT*2+0.08832D0CT**3
	+ IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)*2(-0.04079D0+
	+ & 0.1340D0CT-0.1326D0CT*2+0.04365D0CT**3)
	+ XQQQQ=1.25D0(0.003661D0-0.004888D0CT-0.001081D0CT*2+
	+ & 0.002093D0CT*3)
	+ IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
	+ ENDIF
	+ PARJ(154)=ALSPI*2CT*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)CFPYALPS(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)CFPYALPS(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(4D0CUT)**(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-2D0CUT)*
	+ & LOG((1D0-2D0CUT)/CUT)+0.5D0(9D0CUT*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+X2/4D0+X3/9D0+X4/16D0+X5/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=(2D0PMQ/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+80D0CUT)
	+ 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-2D0MSTU(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(Y132+Y232+2D0Y12.LE.2D0PYR(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=(Y132+Y232+2D0Y12)/(Y13Y23)
	+ WT2=CF(-2D0(CUTL-Y12L)*2-3D0CUTL-1D0+3.289868D0+
	+ & 2D0(2D0CUTL-Y12L)*CUT/Y12)+
	+ & CN((CUTL-Y12L)2-(CUTL-Y13L)2-(CUTL-Y23L)*2-
	+ & 11D0CUTL/6D0+67D0/18D0+1.644934D0-(2D0CUTL-Y12L)*CUT/Y12+
	+ & (2D0CUTL-Y13L)CUT/Y13+(2D0CUTL-Y23L)CUT/Y23)+
	+ & TR(2D0CUTL/3D0-10D0/9D0)+
	+ & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
	+ & Y13L(4D0Y12*2+2D0Y12Y13+4D0Y12Y23+Y13Y23)/
	+ & (Y12+Y23)*2+Y23L(4D0Y122+2D0Y12Y23+4D0Y12*Y13+
	+ & Y13Y23)/(Y12+Y13)*2)/WT1+
	+ & CN(Y13LY13/(Y12+Y23)+Y23LY23/(Y12+Y13))/WT1+(CN-2D0CF)*
	+ & ((Y122+(Y12+Y13)2)(Y12LY23L-Y12LY12M-Y23L
	+ & Y23M+1.644934D0-Y12I-Y23I)/(Y13Y23)+(Y122+(Y12+Y23)2)
	+ & (Y12LY13L-Y12LY12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
	+ & (Y13Y23)+(Y132+Y232)/(Y13Y23*(Y13+Y23))-
	+ & 2D0Y12LY122/(Y13+Y23)2-4D0Y12LY12/(Y13+Y23))/WT1-
	+ & CN(Y13LY23L-Y13LY13M-Y23LY23M+1.644934D0-Y13I-Y23I)
	+ IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
	+ IF(1D0+WTOPT+ALS2PIWT2.LE.WTMAXPYR(0)) GOTO 110
	+ PARJ(156)=(WTOPT+ALS2PIWT2)/(1D0+WTOPT+ALS2PIWT2)
	+
	+ 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)ZY3+ZHUP(IZ,10)/(ZX-ZY2)+
	+ & 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)ZY3+ZHUP(IZ,10)/(ZX-ZY2)+
	+ & 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)ZY3+ZHUP(IZ,10)/(ZX-ZY2)+
	+ & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
	+ WT2=WTL+(WTU-WTL)(100D0CUT+1D0-IZ)
	+ ENDIF
	+ IF(1D0+WTOPT+2D0ALS2PIWT2.LE.0D0) MSTJ(121)=1
	+ IF(1D0+WTOPT+2D0ALS2PIWT2.LE.WTMAX*PYR(0)) GOTO 110
	+ PARJ(156)=(WTOPT+2D0ALS2PIWT2)/(1D0+WTOPT+2D0ALS2PIWT2)
	+ ENDIF
	+
	+C...Impose mass cuts (gives two jets). For fixed jet number new try.
	+ X1=1D0-Y23
	+ X2=1D0-Y13
	+ X3=1D0-Y12
	+ IF(4D0Y23Y13Y12/X3*2.LE.QME) NJET=2
	+ IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
	+ & 0.5D0QME2+(0.5D0QME+0.25D0QME2)((1D0-X2)/(1D0-X1)+
	+ & (1D0-X1)/(1D0-X2)).GT.(X12+X22)*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(4D0CUT2+PYR(0)((1D0-CUT)*2-4D0CUT**2))
	+ IF(LOG((X3-CUT)/CUT).LE.PYR(0)LOG((1D0-2D0CUT)/CUT)) GOTO 140
	+ YD=SIGN(2D0CUT((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*2PYR(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=(2D0PMQ/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.1125D0CFTR/CUT**2
	+ ID=1
	+
	+C...Sample the five kinematical variables (for qqgg preweighted in y34).
	+ 110 Y134=3D0CUT+(1D0-6D0CUT)*PYR(0)
	+ Y234=3D0CUT+(1D0-6D0CUT)*PYR(0)
	+ IF(IT.EQ.1) Y34=(1D0-5D0CUT)EXP(-CT*PYR(0))
	+ IF(IT.EQ.2) Y34=CUT+(1D0-6D0CUT)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-4D0SQRT(MAX(0D0,VT(1D0-VT)*
	+ &VB(1D0-VB)))CP-(1D0-2D0VT)(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)=(Y12Y342-Y13Y24Y34+Y14Y23Y34+3D0Y12Y23Y34+
	+ & 3D0Y12Y14Y34+4D0Y12*2Y34-Y13Y23Y24+2D0Y12Y23*Y24-
	+ & Y13Y14Y24-2D0Y12Y13Y24+2D0Y12*2Y24+Y14Y232+2D0Y12*
	+ & Y232+Y142Y23+4D0Y12Y14Y23+4D0Y122Y23+2D0Y12Y14**2+
	+ & 2D0Y12Y13Y14+4D0Y12*2Y14+2D0Y122Y13+2D0Y12*3)/
	+ & (2D0Y13Y134Y234Y24)+(Y24Y34+Y12Y34+Y13*Y24-
	+ & Y14Y23+Y12Y13)/(Y13Y1342)+2D0Y23*(1D0-Y13)/
	+ & (Y13Y134Y24)+Y34/(2D0Y13Y24)
	+ WTB(IC)=(Y12Y24Y34+Y12Y14Y34-Y13Y242+Y13Y14Y24+2D0Y12*
	+ & Y14Y24)/(Y13Y134Y23Y14)+Y12(1D0+Y34)Y124/(Y134Y234Y14*
	+ & Y24)-(2D0Y13Y24+Y14*2+Y13Y23+2D0Y12Y13)/(Y13Y134Y14)+
	+ & Y12Y123Y124/(2D0Y13Y14Y23Y24)
	+ WTC(IC)=-(5D0Y12Y34*2+2D0Y12Y24Y34+2D0Y12Y23*Y34+
	+ & 2D0Y12Y14Y34+2D0Y12Y13Y34+4D0Y122Y34-Y13Y24*2+
	+ & Y14Y23Y24+Y13Y23Y24+Y13Y14Y24-Y12Y14Y24-Y13*2Y24-
	+ & 3D0Y12Y13Y24-Y14Y232-Y142Y23+Y13Y14*Y23-
	+ & 3D0Y12Y14Y23-Y12Y13Y23)/(4D0Y134Y234Y34**2)+
	+ & (3D0Y12Y34*2-3D0Y13Y24Y34+3D0Y12Y24*Y34+
	+ & 3D0Y14Y23Y34-Y13Y24*2-Y12Y23Y34+6D0Y12Y14Y34+
	+ & 2D0Y12Y13Y34-2D0Y12*2Y34+Y14Y23Y24-3D0Y13Y23*Y24-
	+ & 2D0Y13Y14Y24+4D0Y12Y14Y24+2D0Y12Y13*Y24+
	+ & 3D0Y14Y23*2+2D0Y14*2Y23+2D0Y142Y12+
	+ & 2D0Y122Y14+6D0Y12Y14Y23-2D0Y12Y13*2-
	+ & 2D0Y122Y13)/(4D0Y13Y134Y234Y34)
	+ WTC(IC)=WTC(IC)+(2D0Y12Y34*2-2D0Y13Y24Y34+Y12Y24Y34+
	+ & 4D0Y13Y23Y34+4D0Y12Y14Y34+2D0Y12Y13Y34+2D0Y12*2Y34-
	+ & Y13Y242+3D0Y14Y23Y24+4D0Y13Y23Y24-2D0Y13Y14Y24+
	+ & 4D0Y12Y14Y24+2D0Y12Y13Y24+2D0Y14Y23*2+4D0Y13Y23*2+
	+ & 2D0Y13Y14Y23+2D0Y12Y14Y23+4D0Y12Y13Y23+2D0Y12Y14*2+
	+ & 4D0Y122Y13+4D0Y12Y13Y14+2D0Y12*2Y14)/
	+ & (4D0Y13Y134Y24Y34)-(Y12Y342-2D0Y14Y24Y34-
	+ & 2D0Y13Y24Y34-Y14Y23Y34+Y13Y23Y34+Y12Y14*Y34+
	+ & 2D0Y12Y13Y34-2D0Y14*2Y24-4D0Y13Y14*Y24-
	+ & 4D0Y132Y24-Y14*2Y23-Y13*2Y23+Y12Y13Y14-
	+ & Y12Y132)/(2D0Y13Y34Y134*2)+(Y12Y34**2-
	+ & 4D0Y14Y24Y34-2D0Y13Y24Y34-2D0Y14Y23*Y34-
	+ & 4D0Y13Y23Y34-4D0Y12Y14Y34-4D0Y12Y13*Y34-
	+ & 2D0Y13Y14Y24+2D0Y13*2Y24+2D0Y142Y23-
	+ & 2D0Y13Y14Y23-Y12Y14*2-6D0Y12Y13Y14-
	+ & Y12Y132)/(4D0Y34*2Y134**2)
	+ WTTOT=WTTOT+Y34CF(CFWTA(IC)+(CF-0.5D0CN)*WTB(IC)+
	+ & CN*WTC(IC))/8D0
	+ ELSE
	+ WTD(IC)=(Y13Y23Y34+Y12Y23Y34-Y12*2Y34+Y13Y23Y24+2D0Y12
	+ & Y23Y24-Y14Y23*2+Y12Y13Y24+Y12Y14Y23+Y12Y13Y14)/(Y132
	+ & Y123*2)-(Y12Y34*2-Y13Y24Y34+Y12Y24Y34-Y14Y23Y34-Y12
	+ & Y23Y34-Y13Y24*2+Y14Y23Y24-Y13Y23Y24-Y132Y24+Y14*
	+ & Y232)/(Y132Y123Y134)+(Y13Y14Y12+Y34Y14Y12-Y34*2Y12+
	+ & Y13Y14Y24+2D0Y34Y14Y24-Y23Y14*2+Y34Y13Y24+Y34Y23*Y14+
	+ & Y34Y13Y23)/(Y13*2Y134*2)-(Y34Y12*2-Y13Y24Y12+Y34Y24*
	+ & Y12-Y23Y14Y12-Y34Y14Y12-Y13Y242+Y23Y14Y24-Y13Y14*Y24-
	+ & Y13*2Y24+Y23Y142)/(Y132Y134*Y123)
	+ WTE(IC)=(Y12Y34(Y23-Y24+Y14+Y13)+Y13Y242-Y14Y23Y24+Y13
	+ & Y23Y24+Y13Y14Y24+Y132Y24-Y14Y23(Y14+Y23+Y13))/(Y13Y23
	+ & Y123Y134)-Y12(Y12Y34-Y23Y24-Y13Y24-Y14Y23-Y14Y13)/(Y13
	+ & Y23Y1232)-(Y14+Y13)(Y24+Y23)Y34/(Y13Y23Y134Y234)+
	+ & (Y12Y34(Y14-Y24+Y23+Y13)+Y13Y242-Y23Y14Y24+Y13Y14*Y24+
	+ & Y13Y23Y24+Y13*2Y24-Y23Y14(Y14+Y23+Y13))/(Y13Y14Y134*
	+ & Y123)-Y34(Y34Y12-Y14Y24-Y13Y24-Y23Y14-Y23Y13)/(Y13Y14
	+ & Y134*2)-(Y23+Y13)(Y24+Y14)Y12/(Y13Y14Y123Y124)
	+ WTTOT=WTTOT+CF(TRWTD(IC)+(CF-0.5D0CN)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))/(8D0WTTOT)
	+ 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.5D0Y34(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-Q12Y134
	+ X4=1D0-(1D0-Q12)Y134-Q12Y234
	+ X2=1D0-Y124
	+ X12=(1D0-Q12)Y13+Q12Y23
	+ X14=Y12-0.5D0*QME
	+ IF(Y134Y234/((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)=CFTR(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=(2D0PMQN/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-Q24Y134
	+ X4=1D0-(1D0-Q24)Y134-Q24Y123
	+ X2=1D0-(1D0-Q13)Y234-Q13Y124
	+ X12=(1D0-Q24)((1D0-Q13)Y14+Q13Y34)+Q24((1D0-Q13)*Y12+
	+ & Q13*Y23)
	+ X14=Y24-0.5D0*QME
	+ X34=(1D0-Q24)((1D0-Q13)Y23+Q13Y12)+Q24((1D0-Q13)*Y34+
	+ & Q13*Y14)
	+ IF(PMQ2+PMQN2+MIN(X12,X34)ECM*2.LE.
	+ & (PARJ(127)+PMQ+PMQN)**2) NJET=2
	+ IF(Y123Y134/((1D0-X1)(1D0-X4)).LE.PYR(0)) NJET=2
	+ ENDIF
	+ 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYXDIF
	+C...Gives the angular orientation of events.
	+
	+ SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Charge. Factors depending on polarization for QED case.
	+ QF=KCHG(KFL,1)/3D0
	+ POLL=1D0-PARJ(131)*PARJ(132)
	+ POLD=PARJ(132)-PARJ(131)
	+ IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
	+ HF1=POLL
	+ HF2=0D0
	+ HF3=PARJ(133)**2
	+ HF4=0D0
	+
	+C...Factors depending on flavour, energy and polarization for QFD case.
	+ ELSE
	+ SFF=1D0/(16D0PARU(102)(1D0-PARU(102)))
	+ SFW=ECM4/((ECM2-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-4D0QFPARU(102)
	+ HF1=QF*2POLL-2D0QFVFSFISFF(VEPOLL-AE*POLD)+
	+ & (VF2+AF2)SFWSFF*2((VE2+AE2)POLL-2D0VEAEPOLD)
	+ HF2=-2D0QFAFSFISFF(AEPOLL-VEPOLD)+2D0VFAFSFWSFF2
	+ & (2D0VEAEPOLL-(VE2+AE2)POLD)
	+ HF3=PARJ(133)*2(QF*2-2D0QFVFSFISFFVE+(VF2+AF2)*
	+ & SFWSFF2(VE2-AE2))
	+ HF4=-PARJ(133)*22D0QFVFSFW(PARJ(123)PARJ(124)/ECM2)
	+ & 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=(2D0PYMASS(KFL)/ECM)*2
	+ IF(NJET.EQ.2) THEN
	+ SIGU=4D0*SQRT(1D0-QME)
	+ SIGL=2D0QMESQRT(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=(X1X2-2D0X1-2D0X2+2D0+QME)/SQRT((X12-QME)(X2**2-QME))
	+ ST12=SQRT(1D0-CT12**2)
	+ IF(MSTJ(109).NE.1) THEN
	+ SIGU=2D0X12+X22(1D0+CT12*2)-QME(3D0+CT12**2-X1-X2)-
	+ & QMEX1/XQ+0.5D0QME((X22-QME)ST12*2-2D0X2)*XQ
	+ SIGL=(X2ST12)2-QME(3D0-CT12*2-2.5D0(X1+X2)+X1*X2+QME)+
	+ & 0.5D0QME(X1*2-X1-QME)/XQ+0.5D0QME((X22-QME)CT12**2-
	+ & X2)*XQ
	+ SIGT=0.5D0(X22-QME-0.5D0QME(X22-QME)/XQ)ST12**2
	+ SIGI=((1D0-0.5D0QMEXQ)(X22-QME)ST12*CT12+
	+ & QME(1D0-X1-X2+0.5D0X1X2+0.5D0QME)*ST12/CT12)/SQ2
	+ SIGA=X2*2ST12/SQ2
	+ SIGP=2D0(X12-X22CT12)
	+
	+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))(X32-0.5D0XT**2)+
	+ & PARJ(171)(X32-0.5D0XT*2-4D0(1D0-X1)(1D0-X2)*2/X1)
	+ SIGL=(1D0-PARJ(171))0.5D0XT**2+
	+ & PARJ(171)0.5D0(1D0-X1)*2XT**2
	+ SIGT=(1D0-PARJ(171))0.25D0XT**2+
	+ & PARJ(171)0.25D0XT*2(1D0-2D0*X1)
	+ SIGI=-(0.5D0/SQ2)((1D0-PARJ(171))XTX3CT13+
	+ & PARJ(171)XT((1D0-2D0X1)X3CT13-X1(X1-X2)))
	+ SIGA=(0.25D0/SQ2)XT(2D0(1D0-X1)-X1X3)
	+ 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=(2D0HF1A+HF3A+HF4A)ABS(SIGU)+2D0(HF1A+HF3A+HF4A)
	+ &ABS(SIGL)+2D0(HF1A+2D0HF3A+2D0HF4A)ABS(SIGT)+2D0SQ2
	+ &(HF1A+2D0HF3A+2D0HF4A)ABS(SIGI)+4D0SQ2HF2AABS(SIGA)+
	+ &2D0HF2AABS(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(C2PHIHF3-S2PHIHF4))*SIGU+
	+ &2D0(STHE2HF1-STHE*2(C2PHIHF3-S2PHIHF4))*SIGL+
	+ &2D0(STHE2C2CHIHF1+((1D0+CTHE2)C2CHIC2PHI-2D0CTHES2CHI
	+ &S2PHI)HF3-((1D0+CTHE2)C2CHIS2PHI+2D0CTHES2CHIC2PHI)HF4)
	+ &SIGT-2D0SQ2(2D0STHECTHECCHIHF1-2D0STHE(CTHECCHIC2PHI-
	+ &SCHIS2PHI)HF3+2D0STHE(CTHECCHIS2PHI+SCHIC2PHI)HF4)*SIGI+
	+ &4D0SQ2STHECCHIHF2SIGA+2D0CTHEHF2SIGP
	+ IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYONIA
	+C...Generates Upsilon and toponium decays into three gluons
	+C...or two gluons and a photon.
	+
	+ SUBROUTINE PYONIA(KFL,ECM)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	+ SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
	+
	+C...Printout. Check input parameters.
	+ IF(MSTU(12).NE.12345) CALL PYLIST(0)
	+ IF(KFL.LT.0.OR.KFL.GT.8) THEN
	+ CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+ IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
	+ CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
	+ IF(MSTU(21).GE.1) RETURN
	+ ENDIF
	+
	+C...Initial e+e- and onium state (optional).
	+ NC=0
	+ IF(MSTJ(115).GE.2) THEN
	+ NC=NC+2
	+ CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
	+ K(NC-1,1)=21
	+ CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
	+ K(NC,1)=21
	+ ENDIF
	+ KFLC=IABS(KFL)
	+ IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
	+ NC=NC+1
	+ KF=110*KFLC+3
	+ MSTU10=MSTU(10)
	+ MSTU(10)=1
	+ P(NC,5)=ECM
	+ CALL PY1ENT(NC,KF,ECM,0D0,0D0)
	+ K(NC,1)=21
	+ K(NC,3)=1
	+ MSTU(10)=MSTU10
	+ ENDIF
	+
	+C...Choose x1 and x2 according to matrix element.
	+ NTRY=0
	+ 100 X1=PYR(0)
	+ X2=PYR(0)
	+ X3=2D0-X1-X2
	+ IF(X3.GE.1D0.OR.((1D0-X1)/(X2X3))2+((1D0-X2)/(X1X3))**2+
	+ &((1D0-X3)/(X1X2))2.LE.2D0PYR(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.2D0QF2PARU(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=(X1X3-2D0X1-2D0X3+2D0)/(X1X3)
	+ ST13=SQRT(1D0-CT13**2)
	+ SIGL=0.5D0X32((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=(SIGLCT13/ST13+0.5D0X1X3(1D0-X2)*2ST13)/SQ2
	+ SIGMAX=(2D0HF1+HF3)ABS(SIGU)+2D0(HF1+HF3)ABS(SIGL)+2D0*(HF1+
	+ & 2D0HF3)ABS(SIGT)+2D0SQ2(HF1+2D0HF3)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*2C2PHIHF3)SIGU+2D0(STHE2HF1-
	+ & STHE*2C2PHIHF3)SIGL+2D0(STHE2C2CHIHF1+((1D0+CTHE2)
	+ & C2CHIC2PHI-2D0CTHES2CHIS2PHI)HF3)SIGT-
	+ & 2D0SQ2(2D0STHECTHECCHIHF1-2D0STHE
	+ & (CTHECCHIC2PHI-SCHIS2PHI)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*2ICHAR(TITFX(3IT-2:3IT-2))+
	+ & 256ICHAR(TITFX(3IT-1:3IT-1))+ICHAR(TITFX(3IT: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)=F1BIN(IS1+IX)+F2BIN(IS2+IX)
	+ 100 CONTINUE
	+ ELSEIF(OPER.EQ.'-') THEN
	+ DO 110 IX=6,8+NX
	+ BIN(IS3+IX)=F1BIN(IS1+IX)-F2BIN(IS2+IX)
	+ 110 CONTINUE
	+ ELSEIF(OPER.EQ.'*') THEN
	+ DO 120 IX=6,8+NX
	+ BIN(IS3+IX)=F1BIN(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 TITLE60, OUT100, 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(3IT-2:3IT)=CHAR(IEQ/2562)//CHAR(MOD(IEQ,2562)/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.LINDYAC(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.LINDYAC(1)10D0**IPOT) IPOT=IPOT-1
	+ IF(YMAX-YMIN.GT.LINDYAC(10)10D0**IPOT) IPOT=IPOT+1
	+ DELY=DYAC(1)
	+ DO 120 IDEL=1,9
	+ IF(YMAX-YMIN.GE.LINDYAC(IDEL)10D0**IPOT) DELY=DYAC(IDEL+1)
	+ 120 CONTINUE
	+ DY=DELY10D0*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),10IR)/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),10IR)/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+CTAX*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 TITLE60,FORMAT13
	+
	+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(3IT-2:3IT)=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-4D0RM3*RM4))
	+ RPTS=4D0VINT(71)*2/SHAT
	+ BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)*2-4D0RM3*RM4-RPTS))
	+ RM34=2D0RM3RM4
	+ RSQM=1D0+RM34
	+ RTHM=(4D0RM3RM4+RPTS)/(1D0-RM3-RM4+BE34L)
	+ THAT=-0.5D0SHATMAX(RTHM,1D0-RM3-RM4-BE34*CTH)
	+ UHAT=-0.5D0SHATMAX(RTHM,1D0-RM3-RM4+BE34*CTH)
	+ PT2=MAX(VINT(71)*2,0.25D0SHATBE342(1D0-CTH**2))
	+
	+C...Decisions by user to be put here.
	+
	+C...Stop program if this routine is ever called.
	+C...You should not copy these lines to your own routine.
	+ WRITE(MSTU(11),5000)
	+ CALL PYSTOP(6)
	+
	+C...Format for error printout.
	+ 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
	+ &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
	+ &1X,'Execution stopped!')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...PYEVWT
	+C...Dummy routine, which the user can replace in order to multiply the
	+C...standard PYTHIA differential cross-section by a process- and
	+C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
	+C...to generation of weighted events, with weight 1/WTXS, while for
	+C...MSTP(142)=2 it corresponds to a modification of the underlying
	+C...physics.
	+
	+ SUBROUTINE PYEVWT(WTXS)
	+
	+C...Double precision and integer declarations.
	+ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+ IMPLICIT INTEGER(I-N)
	+ INTEGER PYK,PYCHGE,PYCOMP
	+C...Commonblocks.
	+ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+ COMMON/PYINT1/MINT(400),VINT(400)
	+ COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
	+ SAVE /PYDAT1/,/PYINT1/,/PYINT2/
	+
	+C...Set default weight for WTXS.
	+ WTXS=1D0
	+
	+C...Read out subprocess number.
	+ ISUB=MINT(1)
	+ ISTSB=ISET(ISUB)
	+
	+C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
	+ TAU=VINT(21)
	+ YST=VINT(22)
	+ CTH=0D0
	+ IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
	+ TAUP=0D0
	+ IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
	+
	+C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
	+ X1=VINT(41)
	+ X2=VINT(42)
	+ XF=X1-X2
	+ SHAT=VINT(44)
	+ THAT=VINT(45)
	+ UHAT=VINT(46)
	+ PT2=VINT(48)
	+
	+C...Modifications by user to be put here.
	+
	+C...Stop program if this routine is ever called.
	+C...You should not copy these lines to your own routine.
	+ WRITE(MSTU(11),5000)
	+ CALL PYSTOP(4)
	+
	+C...Format for error printout.
	+ 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
	+ &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
	+ &1X,'Execution stopped!')
	+
	+ RETURN
	+ END
	+
	+C*********************************************************************
	+
	+C...UPINIT
	+C...Dummy routine, to be replaced by a user implementing external
	+C...processes. Is supposed to fill the HEPRUP commonblock with info
	+C...on incoming beams and allowed processes.
	+
	+C...New example: handles a standard Les Houches Events File.
	+
	+c$$$ SUBROUTINE UPINIT
	+c$$$
	+c$$$C...Double precision and integer declarations.
	+c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+c$$$ IMPLICIT INTEGER(I-N)
	+c$$$
	+c$$$C...PYTHIA commonblock: only used to provide read unit MSTP(161).
	+c$$$ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+c$$$ SAVE /PYPARS/
	+c$$$
	+c$$$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$$$
	+c$$$C...Lines to read in assumed never longer than 200 characters.
	+c$$$ PARAMETER (MAXLEN=200)
	+c$$$ CHARACTER*(MAXLEN) STRING
	+c$$$
	+c$$$C...Format for reading lines.
	+c$$$ CHARACTER*6 STRFMT
	+c$$$ STRFMT='(A000)'
	+c$$$ WRITE(STRFMT(3:5),'(I3)') MAXLEN
	+c$$$
	+c$$$C...Loop until finds line beginning with "<init>" or "<init ".
	+c$$$ 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
	+c$$$ IBEG=0
	+c$$$ 110 IBEG=IBEG+1
	+c$$$C...Allow indentation.
	+c$$$ IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
	+c$$$ IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
	+c$$$ &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
	+c$$$
	+c$$$C...Read first line of initialization info.
	+c$$$ READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
	+c$$$ &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	+c$$$
	+c$$$C...Read NPRUP subsequent lines with information on each process.
	+c$$$ DO 120 IPR=1,NPRUP
	+c$$$ READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
	+c$$$ & XMAXUP(IPR),LPRUP(IPR)
	+c$$$ 120 CONTINUE
	+c$$$ RETURN
	+c$$$
	+c$$$C...Error exit: give up if initalization does not work.
	+c$$$ 130 WRITE(,) ' Failed to read LHEF initialization information.'
	+c$$$ WRITE(,) ' Event generation will be stopped.'
	+c$$$ CALL PYSTOP(12)
	+c$$$
	+c$$$ RETURN
	+c$$$ 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.
	+
	+c$$$ SUBROUTINE UPEVNT
	+c$$$
	+c$$$C...Double precision and integer declarations.
	+c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+c$$$ IMPLICIT INTEGER(I-N)
	+c$$$
	+c$$$C...PYTHIA commonblock: only used to provide read unit MSTP(162).
	+c$$$ COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	+c$$$ SAVE /PYPARS/
	+c$$$
	+c$$$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$$$
	+c$$$C...Lines to read in assumed never longer than 200 characters.
	+c$$$ PARAMETER (MAXLEN=200)
	+c$$$ CHARACTER*(MAXLEN) STRING
	+c$$$
	+c$$$C...Format for reading lines.
	+c$$$ CHARACTER*6 STRFMT
	+c$$$ STRFMT='(A000)'
	+c$$$ WRITE(STRFMT(3:5),'(I3)') MAXLEN
	+c$$$
	+c$$$C...Loop until finds line beginning with "<event>" or "<event ".
	+c$$$ 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
	+c$$$ IBEG=0
	+c$$$ 110 IBEG=IBEG+1
	+c$$$C...Allow indentation.
	+c$$$ IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
	+c$$$ IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
	+c$$$ &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
	+c$$$
	+c$$$C...Read first line of event info.
	+c$$$ READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
	+c$$$ &AQEDUP,AQCDUP
	+c$$$
	+c$$$C...Read NUP subsequent lines with information on each particle.
	+c$$$ DO 120 I=1,NUP
	+c$$$ READ(MSTP(162),*,END=130,ERR=130) 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$$$ 120 CONTINUE
	+c$$$ RETURN
	+c$$$
	+c$$$C...Error exit, typically when no more events.
	+c$$$ 130 WRITE(,) ' Failed to read LHEF event information.'
	+c$$$ WRITE(,) ' Will assume end of file has been reached.'
	+c$$$ NUP=0
	+c$$$ MSTI(51)=1
	+c$$$
	+c$$$ RETURN
	+c$$$ 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.
	+
	+c$$$ SUBROUTINE UPVETO(IVETO)
	+c$$$
	+c$$$C...HEPEVT commonblock.
	+c$$$ PARAMETER (NMXHEP=4000)
	+c$$$ COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+c$$$ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+c$$$ DOUBLE PRECISION PHEP,VHEP
	+c$$$ SAVE /HEPEVT/
	+c$$$
	+c$$$C...Next few lines allow you to see what info PYVETO extracted from
	+c$$$C...the full event record for the first two events.
	+c$$$C...Delete if you don't want it.
	+c$$$ DATA NLIST/0/
	+c$$$ SAVE NLIST
	+c$$$ IF(NLIST.LE.2) THEN
	+c$$$ WRITE(,) ' Full event record at time of UPVETO call:'
	+c$$$ CALL PYLIST(1)
	+c$$$ WRITE(,) ' Part of event record made available to UPVETO:'
	+c$$$ CALL PYLIST(5)
	+c$$$ NLIST=NLIST+1
	+c$$$ ENDIF
	+c$$$
	+c$$$C...Make decision here.
	+c$$$ IVETO = 0
	+c$$$
	+c$$$ RETURN
	+c$$$ END
	+
	+C*********************************************************************
	+
	+c$$$C...PDFSET
	+c$$$C...Dummy routine, to be removed when PDFLIB is to be linked.
	+c$$$
	+c$$$ SUBROUTINE PDFSET(PARM,VALUE)
	+c$$$
	+c$$$C...Double precision and integer declarations.
	+c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+c$$$ IMPLICIT INTEGER(I-N)
	+c$$$ INTEGER PYK,PYCHGE,PYCOMP
	+c$$$C...Commonblocks.
	+c$$$ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+c$$$ SAVE /PYDAT1/
	+c$$$C...Local arrays and character variables.
	+c$$$ CHARACTER*20 PARM(20)
	+c$$$ DOUBLE PRECISION VALUE(20)
	+c$$$
	+c$$$C...Stop program if this routine is ever called.
	+c$$$ WRITE(MSTU(11),5000)
	+c$$$ CALL PYSTOP(5)
	+c$$$ PARM(20)=PARM(1)
	+c$$$ VALUE(20)=VALUE(1)
	+c$$$
	+c$$$C...Format for error printout.
	+c$$$ 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
	+c$$$ &1X,'Dummy routine PDFSET in PYTHIA file called instead.'/
	+c$$$ &1X,'Execution stopped!')
	+c$$$
	+c$$$ RETURN
	+c$$$ END
	+c$$$
	+c$$$C*********************************************************************
	+c$$$
	+c$$$C...STRUCTM
	+c$$$C...Dummy routine, to be removed when PDFLIB is to be linked.
	+c$$$
	+c$$$ SUBROUTINE STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU)
	+c$$$
	+c$$$C...Double precision and integer declarations.
	+c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+c$$$ IMPLICIT INTEGER(I-N)
	+c$$$ INTEGER PYK,PYCHGE,PYCOMP
	+c$$$C...Commonblocks.
	+c$$$ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+c$$$ SAVE /PYDAT1/
	+c$$$C...Local variables
	+c$$$ DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU
	+c$$$
	+c$$$C...Stop program if this routine is ever called.
	+c$$$ WRITE(MSTU(11),5000)
	+c$$$ CALL PYSTOP(5)
	+c$$$ UPV=XX+QQ
	+c$$$ DNV=XX+2D0*QQ
	+c$$$ USEA=XX+3D0*QQ
	+c$$$ DSEA=XX+4D0*QQ
	+c$$$ STR=XX+5D0*QQ
	+c$$$ CHM=XX+6D0*QQ
	+c$$$ BOT=XX+7D0*QQ
	+c$$$ TOP=XX+8D0*QQ
	+c$$$ GLU=XX+9D0*QQ
	+c$$$
	+c$$$C...Format for error printout.
	+c$$$ 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
	+c$$$ &1X,'Dummy routine STRUCTM in PYTHIA file called instead.'/
	+c$$$ &1X,'Execution stopped!')
	+c$$$
	+c$$$ RETURN
	+c$$$ END
	+c$$$
	+c$$$C*********************************************************************
	+c$$$
	+c$$$C...STRUCTP
	+c$$$C...Dummy routine, to be removed when PDFLIB is to be linked.
	+c$$$
	+c$$$ SUBROUTINE STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
	+c$$$ &BOT,TOP,GLU)
	+c$$$
	+c$$$C...Double precision and integer declarations.
	+c$$$ IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+c$$$ IMPLICIT INTEGER(I-N)
	+c$$$ INTEGER PYK,PYCHGE,PYCOMP
	+c$$$C...Commonblocks.
	+c$$$ COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+c$$$ SAVE /PYDAT1/
	+c$$$C...Local variables
	+c$$$ DOUBLE PRECISION XX,QQ2,P2,UPV,DNV,USEA,DSEA,STR,CHM,BOT,
	+c$$$ &TOP,GLU
	+c$$$
	+c$$$C...Stop program if this routine is ever called.
	+c$$$ WRITE(MSTU(11),5000)
	+c$$$ CALL PYSTOP(5)
	+c$$$ UPV=XX+QQ2
	+c$$$ DNV=XX+2D0*QQ2
	+c$$$ USEA=XX+3D0*QQ2
	+c$$$ DSEA=XX+4D0*QQ2
	+c$$$ STR=XX+5D0*QQ2
	+c$$$ CHM=XX+6D0*QQ2
	+c$$$ BOT=XX+7D0*QQ2
	+c$$$ TOP=XX+8D0*QQ2
	+c$$$ GLU=XX+9D0*QQ2
	+c$$$
	+c$$$C...Format for error printout.
	+c$$$ 5000 FORMAT(1X,'Error: you did not link PDFLIB correctly.'/
	+c$$$ &1X,'Dummy routine STRUCTP in PYTHIA file called instead.'/
	+c$$$ &1X,'Execution stopped!')
	+c$$$
	+c$$$ RETURN
	+c$$$ 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.
	+
	+CAM SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
	+CAM
	+CAMC...Double precision and integer declarations.
	+CAM IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	+CAM IMPLICIT INTEGER(I-N)
	+CAM INTEGER PYK,PYCHGE,PYCOMP
	+CAMC...Commonblocks.
	+CAM COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	+CAM COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	+CAM SAVE /PYJETS/,/PYDAT1/
	+CAM
	+CAMC...Stop program if this routine is ever called.
	+CAMC...You should not copy these lines to your own routine.
	+CAM NDECAY=ITAU+IORIG+KFORIG
	+CAM WRITE(MSTU(11),5000)
	+CAM CALL PYSTOP(10)
	+CAM
	+CAMC...Format for error printout.
	+CAM 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
	+CAM &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
	+CAM &1X,'Execution stopped!')
	+CAM
	+CAM RETURN
	+CAM 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
	Index: trunk/contrib/pythia6/Makefile.am
	===================================================================
	--- trunk/contrib/pythia6/Makefile.am (revision 0)
	+++ trunk/contrib/pythia6/Makefile.am (revision 8889)
	@@ -0,0 +1,83 @@
	+## Makefile.am -- Makefile for WHIZARD
	+##
	+## Process this file with automake to produce Makefile.in
	+##
	+########################################################################
	+#
	+# Copyright (C) 1999-2023 by
	+# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	+# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	+# Juergen Reuter <juergen.reuter@desy.de>
	+# with contributions from
	+# cf. main AUTHORS file
	+#
	+# WHIZARD is free software; you can redistribute it and/or modify it
	+# under the terms of the GNU General Public License as published by
	+# the Free Software Foundation; either version 2, or (at your option)
	+# any later version.
	+#
	+# WHIZARD is distributed in the hope that it will be useful, but
	+# WITHOUT ANY WARRANTY; without even the implied warranty of
	+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	+# GNU General Public License for more details.
	+#
	+# You should have received a copy of the GNU General Public License
	+# along with this program; if not, write to the Free Software
	+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	+#
	+########################################################################
	+
	+## The files in this directory end up in an auxiliary libtool library.
	+AM_FFLAGS =
	+AM_FCFLAGS =
	+
	+if PYTHIA6_AVAILABLE
	+
	+if FC_IS_NAG
	+AM_FFLAGS += -dcfuns -w
	+AM_FCFLAGS += -dcfuns -w
	+endif
	+
	+if PYTHIA6_IS_EH
	+AM_FFLAGS += -DPYTHIA6_EH
	+endif
	+
	+noinst_LTLIBRARIES = libpythia6_wo.la
	+
	+if LHAPDF5_AVAILABLE
	+libpythia6_wo_la_SOURCES = pythia.F
	+else
	+if LHAPDF6_AVAILABLE
	+libpythia6_wo_la_SOURCES = pythia.F
	+else
	+libpythia6_wo_la_SOURCES = pythia.F pythia_pdf.f
	+endif
	+endif
	+
	+else
	+
	+noinst_LTLIBRARIES = libpythia6_wo_dummy.la
	+libpythia6_wo_dummy_la_SOURCES = pythia6_dummy.f90
	+
	+endif
	+########################################################################
	+## Default Fortran compiler options
	+
	+## Profiling
	+if FC_USE_PROFILING
	+AM_FFLAGS += $(FCFLAGS_PROFILING)
	+AM_FCFLAGS += $(FCFLAGS_PROFILING)
	+endif
	+
	+## OpenMP
	+if FC_USE_OPENMP
	+AM_FFLAGS += $(FCFLAGS_OPENMP)
	+AM_FCFLAGS += $(FCFLAGS_OPENMP)
	+endif
	+
	+########################################################################
	+## Non-standard cleanup tasks
	+
	+## Remove backup files
	+maintainer-clean-local:
	+ -rm -f *~
	Index: trunk/contrib/pythia6/pythia_pdf.f
	===================================================================
	--- trunk/contrib/pythia6/pythia_pdf.f (revision 0)
	+++ trunk/contrib/pythia6/pythia_pdf.f (revision 8889)
	@@ -0,0 +1,107 @@
	+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
	Index: trunk/contrib/pythia6/pythia6_dummy.f90
	===================================================================
	--- trunk/contrib/pythia6/pythia6_dummy.f90 (revision 0)
	+++ trunk/contrib/pythia6/pythia6_dummy.f90 (revision 8889)
	@@ -0,0 +1,91 @@
	+subroutine pylist (i)
	+ integer, intent(in) :: i
	+end subroutine pylist
	+
	+subroutine pyinit (frame, beam, target, win)
	+ character(), intent(in) :: frame, beam, target
	+ double precision, intent(in) :: win
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pyinit
	+
	+subroutine pygive (chin)
	+ character chin()
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pygive
	+
	+subroutine pyevnt()
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pyevnt
	+
	+subroutine pyexec()
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pyexec
	+
	+function pyp(I,J)
	+ integer, intent(in) :: i,j
	+ double precision :: pyp
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end function pyp
	+
	+subroutine pystat (mstat)
	+ integer, intent(in) :: mstat
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pystat
	+
	+subroutine pystop ()
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pystop
	+
	+subroutine pyrobo (imi, ima, the, phi, bex, bey, bez)
	+ integer, intent(in) :: imi, ima
	+ double precision, intent(in) :: the, phi, bex, bey, bez
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pyrobo
	+
	+subroutine pyedit (medit)
	+ integer, intent(in) :: medit
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pyedit
	+
	+subroutine pyhepc (mconv)
	+ integer, intent(in) :: mconv
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine pyhepc
	+
	+function pyr (idummy)
	+ integer, intent(in) :: idummy
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: PYTHIA6 has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end function pyr
	Index: trunk/contrib/tauola/photos.f
	===================================================================
	--- trunk/contrib/tauola/photos.f (revision 0)
	+++ trunk/contrib/tauola/photos.f (revision 8889)
	@@ -0,0 +1,3367 @@
	+*///////////////////////////////////////////////////////////////////////
	+*//
	+*// !!!!!!! WARNING!!!!! This source may be agressive !!!!
	+*//
	+*// Due to short common block names it may owerwrite variables in other
	+*// parts of the code.
	+*//
	+*// One should add suffix c_Photos_ to names of all commons as soon as
	+*// possible!!
	+*///////////////////////////////////////////////////////////////////////
	+
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOtos CDE-s
	+C.
	+C. Purpose: Keep definitions for PHOTOS QED correction Monte Carlo.
	+C.
	+C. Input Parameters: None
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): Z. Was, B. van Eijk Created at: 29/11/89
	+C. Last Update: 10/08/93
	+C.
	+C. =========================================================
	+C. General Structure Information: =
	+C. =========================================================
	+C: ROUTINES:
	+C. 1) INITIALIZATION:
	+C. PHOCDE
	+C. PHOINI
	+C. PHOCIN
	+C. PHOINF
	+C. 2) GENERAL INTERFACE:
	+C. PHOTOS
	+C. PHOTOS_GET
	+C. PHOTOS_SET
	+C. PHOTOS_MAKE
	+C. PHOBOS
	+C. PHOIN
	+C. PHOTWO (specific interface
	+C. PHOOUT
	+C. PHOCHK
	+C. PHTYPE (specific interface
	+C. PHOMAK (specific interface
	+C. 3) QED PHOTON GENERATION:
	+C. PHINT
	+C. PHOBW
	+C. PHOPRE
	+C. PHOOMA
	+C. PHOENE
	+C. PHOCOR
	+C. PHOFAC
	+C. PHODO
	+C. 4) UTILITIES:
	+C. PHOTRI
	+C. PHOAN1
	+C. PHOAN2
	+C. PHOBO3
	+C. PHORO2
	+C. PHORO3
	+C. PHORIN
	+C. PHORAN
	+C. PHOCHA
	+C. PHOSPI
	+C. PHOERR
	+C. PHOREP
	+C. PHLUPA
	+C. PHCORK
	+C. IPHQRK
	+C. IPHEKL
	+C. COMMONS:
	+C. NAME USED IN SECT. # OF OCC. Comment
	+C. PHOQED 1) 2) 3 Flags whether emisson to be gen.
	+C. PHOLUN 1) 4) 6 Output device number
	+C. PHOCOP 1) 3) 4 photon coupling & min energy
	+C. PHPICO 1) 3) 4) 5 PI & 2*PI
	+C. PHSEED 1) 4) 3 RN seed
	+C. PHOSTA 1) 4) 3 Status information
	+C. PHOKEY 1) 2) 3) 7 Keys for nonstandard application
	+C. PHOVER 1) 1 Version info for outside
	+C. HEPEVT 2) 2 PDG common
	+C. PH_HEPEVT2) 8 PDG common internal
	+C. PHOEVT 2) 3) 10 PDG branch
	+C. PHOIF 2) 3) 2 emission flags for PDG branch
	+C. PHOMOM 3) 5 param of char-neutr system
	+C. PHOPHS 3) 5 photon momentum parameters
	+C. PHOPRO 3) 4 var. for photon rep. (in branch)
	+C. PHOCMS 2) 3 parameters of boost to branch CMS
	+C. PHNUM 4) 1 event number from outside
	+C.----------------------------------------------------------------------
	+ SUBROUTINE PHOINI
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays INItialisation
	+C.
	+C. Purpose: Initialisation routine for the PHOTOS QED radiation
	+C. package. Should be called at least once before a call
	+C. to the steering program 'PHOTOS' is made.
	+C.
	+C. Input Parameters: None
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	+C. Last Update: 12/04/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER INIT,IDUM,IPHQRK,IPHEKL
	+ SAVE INIT
	+ DATA INIT/ 0/
	+C--
	+C-- Return if already initialized...
	+ IF (INIT.NE.0) RETURN
	+ INIT=1
	+C--
	+C-- all the following parameter setters can be called after PHOINI.
	+C-- Initialization of kinematic correction against rounding errors.
	+C-- The set values will be used later if called wit zero.
	+C-- Default parameter is 1 (no correction) optionally 2, 3, 4
	+C-- In case of exponentiation new version 5 is needed in most cases.
	+C-- Definition given here will be thus overwritten in such a case
	+C-- below in routine PHOCIN
	+ CALL PHCORK(1)
	+C-- blocks emission from quarks if parameter is 1 (enables if 2),
	+C-- physical treatment
	+C-- will be 3, option 2 is not realistic and for tests only,
	+ IDUM= IPHQRK(1) ! default is 1
	+C-- blocks emission in pi0 to gamma e+ e- if parameter is gt.1
	+C-- (enables otherwise)
	+ IDUM= IPHEKL(2) ! default is 1
	+C--
	+C-- Preset parameters in PHOTOS commons
	+ CALL PHOCIN
	+C--
	+C-- Print info
	+ CALL PHOINF
	+
	+C--
	+C-- Initialize Marsaglia and Zaman random number generator
	+ CALL PHORIN
	+ RETURN
	+ END
	+ SUBROUTINE PHOCIN
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton Common INitialisation
	+C.
	+C. Purpose: Initialisation of parameters in common blocks.
	+C.
	+C. Input Parameters: None
	+C.
	+C. Output Parameters: Commons /PHOLUN/, /PHOPHO/, /PHOCOP/, /PHPICO/
	+C. and /PHSEED/.
	+C.
	+C. Author(s): B. van Eijk Created at: 26/11/89
	+C. Z. Was Last Update: 29/01/05
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER d_h_NMXHEP
	+
	+
	+
	+ PARAMETER (d_h_NMXHEP=4000)
	+ LOGICAL QEDRAD
	+ COMMON/PHOQED/QEDRAD(d_h_NMXHEP)
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+ double precision ALPHA,XPHCUT
	+ COMMON/PHOCOP/ALPHA,XPHCUT
	+ double precision PI,TWOPI
	+ COMMON/PHPICO/PI,TWOPI
	+ INTEGER ISEED,I97,J97
	+ double precision URAN,CRAN,CDRAN,CMRAN
	+ COMMON/PHSEED/ISEED(2),I97,J97,URAN(97),CRAN,CDRAN,CMRAN
	+ INTEGER PHOMES
	+ PARAMETER (PHOMES=10)
	+ INTEGER STATUS
	+ COMMON/PHOSTA/STATUS(PHOMES)
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ INTEGER INIT,I
	+ SAVE INIT
	+ DATA INIT/ 0/
	+C--
	+C-- Return if already initialized...
	+ IF (INIT.NE.0) RETURN
	+ INIT=1
	+C--
	+C-- Preset switch for photon emission to 'TRUE' for each particle in
	+C-- /PH_HEPEVT/, this interface is needed for KORALB and KORALZ...
	+ DO 10 I=1,d_h_NMXHEP
	+ 10 QEDRAD(I)=.TRUE.
	+C--
	+C-- Logical output unit for printing of PHOTOS error messages
	+ PHLUN=6
	+C--
	+C-- Set cut parameter for photon radiation
	+ XPHCUT=0.01 D0 ! 0.0001D0! to go to low valuex (IEXP excepted)
	+C-- ! switch to - VARIANT B
	+C--
	+C-- Define some constants
	+ ALPHA=0.00729735039D0
	+ PI=3.14159265358979324D0
	+ TWOPI=6.28318530717958648D0
	+C--
	+C-- Default seeds Marsaglia and Zaman random number generator
	+ ISEED(1)=1802
	+ ISEED(2)=9373
	+C--
	+C-- Iitialization for extra options
	+C-- (1)
	+C-- Interference weight now universal.
	+ INTERF=.TRUE.
	+C-- (2)
	+C-- Second order - double photon switch
	+ ISEC=.TRUE.
	+C-- Third/fourth order - triple (or quatric) photon switch,
	+C-- see dipswitch ifour
	+ ITRE=.FALSE.
	+C-- Exponentiation on:
	+ IEXP=.FALSE. !.TRUE.
	+ IF (IEXP) THEN
	+ ISEC=.FALSE.
	+ ITRE=.FALSE.
	+ CALL PHCORK(5) ! in case of exponentiation correction of ph space
	+ ! is a default mandatory
	+ XPHCUT=0.000 000 1
	+ EXPEPS=1D-4
	+ ENDIF
	+C-- (3)
	+C-- Emision in the hard process g g (q qbar) --> t tbar
	+C-- t --> W b
	+ IFTOP=.TRUE.
	+C--
	+C-- further initialization done automatically
	+C-- see places with - VARIANT A - VARIANT B - all over
	+C-- to switch between options.
	+C ----------- SLOWER VARIANT A, but stable ------------------
	+C --- it is limiting choice for small XPHCUT in fixed orer
	+C --- modes of operation
	+ IF (INTERF) THEN
	+C-- best choice is if FINT=2**N where N+1 is maximal number
	+C-- of charged daughters
	+C-- see report on overweihted events
	+C FINT=2.0D0
	+ FINT=2.5D0
	+ ELSE
	+ FINT=1.0D0
	+ ENDIF
	+C ----------- FASTER VARIANT B ------------------
	+C -- it is good for tests of fixed order and small XPHCUT
	+C -- but is less promising for more complex cases of interference
	+C -- sometimes fails because of that
	+C
	+C IF (INTERF) THEN
	+C FINT=1.80D0
	+C ELSE
	+C FINT=0.0D0
	+C ENDIF
	+C----------END VARIANTS A B -----------------------
	+
	+C-- Effects of initial state charge (in leptonic W decays)
	+C--
	+ IFW=.TRUE.
	+C-- Initialise status counter for warning messages
	+ DO 20 I=1,PHOMES
	+ 20 STATUS(I)=0
	+ RETURN
	+ END
	+ SUBROUTINE PHOINF
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays general INFo
	+C.
	+C. Purpose: Print PHOTOS info
	+C.
	+C. Input Parameters: PHOLUN
	+C.
	+C. Output Parameters: PHOVN1, PHOVN2
	+C.
	+C. Author(s): B. van Eijk Created at: 12/04/90
	+C. Last Update: 27/06/04
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER IV1,IV2,IV3
	+ INTEGER PHOVN1,PHOVN2
	+ COMMON/PHOVER/PHOVN1,PHOVN2
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision ALPHA,XPHCUT
	+ COMMON/PHOCOP/ALPHA,XPHCUT
	+C--
	+C-- PHOTOS version number and release date
	+ PHOVN1=215
	+ PHOVN2=111005
	+C--
	+C-- Print info
	+ WRITE(PHLUN,9000)
	+ WRITE(PHLUN,9020)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9030)
	+ IV1=PHOVN1/100
	+ IV2=PHOVN1-IV1*100
	+ WRITE(PHLUN,9040) IV1,IV2
	+ IV1=PHOVN2/10000
	+ IV2=(PHOVN2-IV1*10000)/100
	+ IV3=PHOVN2-IV110000-IV2100
	+ WRITE(PHLUN,9050) IV1,IV2,IV3
	+ WRITE(PHLUN,9030)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9060)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9070)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9020)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9064) INTERF,ISEC,ITRE,IEXP,IFTOP,IFW,ALPHA,XPHCUT
	+ WRITE(PHLUN,9010)
	+ IF (INTERF) WRITE(PHLUN,9061)
	+ IF (ISEC) WRITE(PHLUN,9062)
	+ IF (ITRE) WRITE(PHLUN,9066)
	+ IF (IEXP) WRITE(PHLUN,9067) EXPEPS
	+ IF (IFTOP) WRITE(PHLUN,9063)
	+ IF (IFW) WRITE(PHLUN,9065)
	+ WRITE(PHLUN,9080)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9020)
	+ RETURN
	+ 9000 FORMAT(1H1)
	+ 9010 FORMAT(1H ,'',T81,'')
	+ 9020 FORMAT(1H ,80('*'))
	+ 9030 FORMAT(1H ,'',26X,26('='),T81,'')
	+ 9040 FORMAT(1H ,'',28X,'PHOTOS, Version: ',I2,'.',I2,T81,'')
	+ 9050 FORMAT(1H ,'',28X,'Released at: ',I2,'/',I2,'/',I2,T81,'')
	+ 9060 FORMAT(1H ,'*',18X,'PHOTOS QED Corrections in Particle Decays',
	+ &T81,'*')
	+ 9061 FORMAT(1H ,'*',18X,'option with interference is active ',
	+ &T81,'*')
	+ 9062 FORMAT(1H ,'*',18X,'option with double photons is active ',
	+ &T81,'*')
	+ 9066 FORMAT(1H ,'*',18X,'option with triple/quatric photons is active',
	+ &T81,'*')
	+ 9067 FORMAT(1H ,'*',18X,'option with exponentiation is active EPSEXP=',
	+ &E10.4,T81,'*')
	+ 9063 FORMAT(1H ,'*',18X,'emision in t tbar production is active ',
	+ &T81,'*')
	+ 9064 FORMAT(1H ,'',18X,'Internal input parameters:',T81,''
	+ &,/, 1H ,'',T81,''
	+ &,/, 1H ,'*',18X,'INTERF=',L2,' ISEC=',L2,' ITRE=',L2,
	+ & ' IEXP=',L2,' IFTOP=',L2,
	+ & ' IFW=',L2,T81,'*'
	+ &,/, 1H ,'',18X,'ALPHA_QED=',F8.5,' XPHCUT=',E8.3,T81,'')
	+ 9065 FORMAT(1H ,'*',18X,'correction wt in decay of W is active ',
	+ &T81,'*')
	+ 9070 FORMAT(1H ,'*',9X,
	+ &'Monte Carlo Program - by E. Barberio, B. van Eijk and Z. Was',
	+ & T81,'*',/,
	+ & 1H ,'',9X,'Version 2.09 - by P. Golonka and Z.W.',T81,'')
	+ 9080 FORMAT( 1H ,'',9X,' ',T81,'',/,
	+ & 1H ,'*',9X,
	+ & ' WARNING (1): /HEPEVT/ is not anymore the standard common block'
	+ & ,T81,'*',/,
	+ & 1H ,'',9X,' ',T81,'',/,
	+ & 1H ,'*',9X,
	+ & ' PHOTOS expects /HEPEVT/ to have REAL*8 variables. To change to'
	+ & ,T81,'',/, 1H ,'',9X,
	+ & ' REAL*4 modify its declaration in subr. PHOTOS_GET PHOTOS_SET:'
	+ & ,T81,'',/, 1H ,'',9X,
	+ & ' REAL*8 d_h_phep, d_h_vhep'
	+ & ,T81,'',/, 1H ,'',9X,
	+ & ' WARNING (2): check dims. of /hepevt/ /phoqed/ /ph_hepevt/.'
	+ & ,T81,'',/, 1H ,'',9X,
	+ & ' HERE: d_h_nmxhep=4000 and NMXHEP=10000'
	+ & ,T81,'*')
	+ END
	+ SUBROUTINE PHOTOS(ID)
	+ IMPLICIT double precision(A-H,O-Z)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: General search routine + _GET + _SET
	+C.
	+C. Purpose: /HEPEVT/ is not anymore a standard at least
	+C. REAL8 REAL4 are in use. PHOTOS_GET and PHOTOS_SET
	+C. were to be introduced.
	+C.
	+C.
	+C. Input Parameters: ID see routine PHOTOS_MAKE
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): Z. Was Created at: 21/07/98
	+C. Last Update: 21/07/98
	+C.
	+C.----------------------------------------------------------------------
	+ COMMON /PHLUPY/ IPOIN,IPOINM
	+ INTEGER IPOIN,IPOINM
	+ COMMON /PHNUM/ IEV
	+ INTEGER IEV
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+
	+ IF (1.GT.IPOINM.AND.1.LT.IPOIN ) THEN
	+ WRITE(PHLUN,*) 'EVENT NR=',IEV,
	+ $ 'WE ARE TESTING /HEPEVT/ at IPOINT=1 (input)'
	+ CALL PHODMP
	+ ENDIF
	+ CALL PHOTOS_GET
	+ CALL PHOTOS_MAKE(ID)
	+ CALL PHOTOS_SET
	+ IF (1.GT.IPOINM.AND.1.LT.IPOIN ) THEN
	+ WRITE(PHLUN,*) 'EVENT NR=',IEV,
	+ $ 'WE ARE TESTING /HEPEVT/ at IPOINT=1 (output)'
	+ CALL PHODMP
	+ ENDIF
	+
	+ END
	+
	+ SUBROUTINE PHOTOS_GET
	+C.----------------------------------------------------------------------
	+C.
	+C. Getter for PHOTOS:
	+C.
	+C. Purpose: Copies /HEPEVT/ into /PH_HEPEVT/
	+C.
	+C.
	+C. Input Parameters: None
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): Z. Was Created at: 21/07/98
	+C. Last Update: 21/07/98
	+C.
	+C.----------------------------------------------------------------------
	+
	+ IMPLICIT NONE
	+ INTEGER d_h_nmxhep ! maximum number of particles
	+ PARAMETER (d_h_NMXHEP=4000)
	+ double precision d_h_phep, d_h_vhep
	+ INTEGER d_h_nevhep,d_h_nhep,d_h_isthep,d_h_idhep,d_h_jmohep,
	+ $ d_h_jdahep
	+ COMMON /hepevt/
	+ $ d_h_nevhep, ! serial number
	+ $ d_h_nhep, ! number of particles
	+ $ d_h_isthep(d_h_nmxhep), ! status code
	+ $ d_h_idhep(d_h_nmxhep), ! particle ident KF
	+ $ d_h_jmohep(2,d_h_nmxhep), ! parent particles
	+ $ d_h_jdahep(2,d_h_nmxhep), ! childreen particles
	+ $ d_h_phep(5,d_h_nmxhep), ! four-momentum, mass [GeV]
	+ $ d_h_vhep(4,d_h_nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL d_h_qedrad
	+ COMMON /phoqed/
	+ $ d_h_qedrad(d_h_nmxhep) ! Photos flag
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ LOGICAL QEDRAD
	+ COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	+ integer k,l
	+ nevhep= d_h_nevhep ! serial number
	+ nhep = d_h_nhep ! number of particles
	+ DO K=1,nhep
	+ isthep(k) =d_h_isthep(k) ! status code
	+ idhep(k) =d_h_idhep(k) ! particle ident KF
	+ jmohep(1,k) =d_h_jmohep(1,k) ! parent particles
	+ jdahep(1,k) =d_h_jdahep(1,k) ! childreen particles
	+ jmohep(2,k) =d_h_jmohep(2,k) ! parent particles
	+ jdahep(2,k) =d_h_jdahep(2,k) ! childreen particles
	+ DO l=1,4
	+ phep(l,k) =d_h_phep(l,k) ! four-momentum, mass [GeV]
	+ vhep(l,k) =d_h_vhep(l,k) ! vertex [mm]
	+ ENDDO
	+ phep(5,k) =d_h_phep(5,k) ! four-momentum, mass [GeV]
	+ qedrad(k) =d_h_qedrad(k) ! Photos special flag
	+ ENDDO
	+ END
	+
	+
	+ SUBROUTINE PHOTOS_SET
	+C.----------------------------------------------------------------------
	+C.
	+C. Setter for PHOTOS:
	+C.
	+C. Purpose: Copies /PH_HEPEVT/ into /HEPEVT/
	+C.
	+C.
	+C. Input Parameters: None
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): Z. Was Created at: 21/07/98
	+C. Last Update: 21/07/98
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER d_h_nmxhep ! maximum number of particles
	+ PARAMETER (d_h_NMXHEP=4000)
	+ double precision d_h_phep, d_h_vhep
	+ INTEGER d_h_nevhep,d_h_nhep,d_h_isthep,d_h_idhep,d_h_jmohep,
	+ $ d_h_jdahep
	+ COMMON /hepevt/
	+ $ d_h_nevhep, ! serial number
	+ $ d_h_nhep, ! number of particles
	+ $ d_h_isthep(d_h_nmxhep), ! status code
	+ $ d_h_idhep(d_h_nmxhep), ! particle ident KF
	+ $ d_h_jmohep(2,d_h_nmxhep), ! parent particles
	+ $ d_h_jdahep(2,d_h_nmxhep), ! childreen particles
	+ $ d_h_phep(5,d_h_nmxhep), ! four-momentum, mass [GeV]
	+ $ d_h_vhep(4,d_h_nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL d_h_qedrad
	+ COMMON /phoqed/
	+ $ d_h_qedrad(d_h_nmxhep) ! Photos flag
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ LOGICAL QEDRAD
	+ COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	+ INTEGER K,L
	+
	+ d_h_nevhep= nevhep ! serial number
	+ d_h_nhep = nhep ! number of particles
	+ DO K=1,nhep
	+ d_h_isthep(k) =isthep(k) ! status code
	+ d_h_idhep(k) =idhep(k) ! particle ident KF
	+ d_h_jmohep(1,k) =jmohep(1,k) ! parent particles
	+ d_h_jdahep(1,k) =jdahep(1,k) ! childreen particles
	+ d_h_jmohep(2,k) =jmohep(2,k) ! parent particles
	+ d_h_jdahep(2,k) =jdahep(2,k) ! childreen particles
	+ DO l=1,4
	+ d_h_phep(l,k) =phep(l,k) ! four-momentum, mass [GeV]
	+ d_h_vhep(l,k) =vhep(l,k) ! vertex [mm]
	+ ENDDO
	+ d_h_phep(5,k) =phep(5,k) ! four-momentum, mass [GeV]
	+ d_h_qedrad(k) =qedrad(k) ! Photos special flag
	+ ENDDO
	+ END
	+ SUBROUTINE PHOTOS_MAKE(IPARR)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS_MAKE: General search routine
	+C.
	+C. Purpose: Search through the /PH_HEPEVT/ standard HEP common, sta-
	+C. rting from the IPPAR-th particle. Whenevr branching
	+C. point is found routine PHTYPE(IP) is called.
	+C. Finally if calls on PHTYPE(IP) modified entries, common
	+C /PH_HEPEVT/ is ordered.
	+C.
	+C. Input Parameter: IPPAR: Pointer to decaying particle in
	+C. /PH_HEPEVT/ and the common itself,
	+C.
	+C. Output Parameters: Common /PH_HEPEVT/, either with or without
	+C. new particles added.
	+C.
	+C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	+C. Last Update: 30/08/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ double precision PHOTON(5)
	+ INTEGER IP,IPARR,IPPAR,I,J,K,L,NLAST
	+ DOUBLE PRECISION DATA
	+ INTEGER MOTHER,POSPHO
	+ LOGICAL CASCAD
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ LOGICAL QEDRAD
	+ COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER ISTACK(0:NMXPHO),NUMIT,NTRY,KK,LL,II,NA,FIRST,LAST
	+ INTEGER FIRSTA,LASTA,IPP,IDA1,IDA2,MOTHER2,IDPHO,ISPHO
	+ double precision PORIG(5,NMXPHO)
	+C--
	+ IPPAR=ABS(IPARR)
	+C-- Store pointers for cascade treatement...
	+ IP=IPPAR
	+ NLAST=NHEP
	+ CASCAD=.FALSE.
	+C--
	+C-- Check decay multiplicity and minimum of correctness..
	+ IF ((JDAHEP(1,IP).EQ.0).OR.(JMOHEP(1,JDAHEP(1,IP)).NE.IP)) RETURN
	+C--
	+C-- single branch mode
	+C-- we start looking for the decay points in the cascade
	+C-- IPPAR is original position where the program was called
	+ ISTACK(0)=IPPAR
	+C-- NUMIT denotes number of secondary decay branches
	+ NUMIT=0
	+C-- NTRY denotes number of secondary branches already checked for
	+C-- for existence of further branches
	+ NTRY=0
	+C-- let-s search if IPARR does not prevent searching.
	+ IF (IPARR.GT.0) THEN
	+ 30 CONTINUE
	+ DO I=JDAHEP(1,IP),JDAHEP(2,IP)
	+ IF (JDAHEP(1,I).NE.0.AND.JMOHEP(1,JDAHEP(1,I)).EQ.I) THEN
	+ NUMIT=NUMIT+1
	+ IF (NUMIT.GT.NMXPHO) THEN
	+ DATA=NUMIT
	+ CALL PHOERR(7,'PHOTOS',DATA)
	+ ENDIF
	+ ISTACK(NUMIT)=I
	+ ENDIF
	+ ENDDO
	+ IF(NUMIT.GT.NTRY) THEN
	+ NTRY=NTRY+1
	+ IP=ISTACK(NTRY)
	+ GOTO 30
	+ ENDIF
	+ ENDIF
	+C-- let-s do generation
	+ DO 25 KK=0,NUMIT
	+ NA=NHEP
	+ FIRST=JDAHEP(1,ISTACK(KK))
	+ LAST=JDAHEP(2,ISTACK(KK))
	+ DO II=1,LAST-FIRST+1
	+ DO LL=1,5
	+ PORIG(LL,II)=PHEP(LL,FIRST+II-1)
	+ ENDDO
	+ ENDDO
	+C--
	+ CALL PHTYPE(ISTACK(KK))
	+C--
	+C-- Correct energy/momentum of cascade daughters
	+ IF(NHEP.GT.NA) THEN
	+ DO II=1,LAST-FIRST+1
	+ IPP=FIRST+II-1
	+ FIRSTA=JDAHEP(1,IPP)
	+ LASTA=JDAHEP(2,IPP)
	+ IF(JMOHEP(1,IPP).EQ.ISTACK(KK))
	+ $ CALL PHOBOS(IPP,PORIG(1,II),PHEP(1,IPP),FIRSTA,LASTA)
	+ ENDDO
	+ ENDIF
	+ 25 CONTINUE
	+C--
	+C-- rearrange /PH_HEPEVT/ to get correct order..
	+ IF (NHEP.GT.NLAST) THEN
	+ DO 160 I=NLAST+1,NHEP
	+C--
	+C-- Photon mother and position...
	+ MOTHER=JMOHEP(1,I)
	+ POSPHO=JDAHEP(2,MOTHER)+1
	+C-- Intermediate save of photon energy/momentum and pointers
	+ DO 90 J=1,5
	+ 90 PHOTON(J)=PHEP(J,I)
	+ ISPHO =ISTHEP(I)
	+ IDPHO =IDHEP(I)
	+ MOTHER2 =JMOHEP(2,I)
	+ IDA1 =JDAHEP(1,I)
	+ IDA2 =JDAHEP(2,I)
	+C--
	+C-- Exclude photon in sequence !
	+ IF (POSPHO.NE.NHEP) THEN
	+C--
	+C--
	+C-- Order /PH_HEPEVT/
	+ DO 120 K=I,POSPHO+1,-1
	+ ISTHEP(K)=ISTHEP(K-1)
	+ QEDRAD(K)=QEDRAD(K-1)
	+ IDHEP(K)=IDHEP(K-1)
	+ DO 100 L=1,2
	+ JMOHEP(L,K)=JMOHEP(L,K-1)
	+ 100 JDAHEP(L,K)=JDAHEP(L,K-1)
	+ DO 110 L=1,5
	+ 110 PHEP(L,K)=PHEP(L,K-1)
	+ DO 120 L=1,4
	+ 120 VHEP(L,K)=VHEP(L,K-1)
	+C--
	+C-- Correct pointers assuming most dirty /PH_HEPEVT/...
	+ DO 130 K=1,NHEP
	+ DO 130 L=1,2
	+ IF ((JMOHEP(L,K).NE.0).AND.(JMOHEP(L,K).GE.
	+ & POSPHO)) JMOHEP(L,K)=JMOHEP(L,K)+1
	+ IF ((JDAHEP(L,K).NE.0).AND.(JDAHEP(L,K).GE.
	+ & POSPHO)) JDAHEP(L,K)=JDAHEP(L,K)+1
	+ 130 CONTINUE
	+C--
	+C-- Store photon energy/momentum
	+ DO 140 J=1,5
	+ 140 PHEP(J,POSPHO)=PHOTON(J)
	+ ENDIF
	+C--
	+C-- Store pointers for the photon...
	+ JDAHEP(2,MOTHER)=POSPHO
	+ ISTHEP(POSPHO)=ISPHO
	+ IDHEP(POSPHO)=IDPHO
	+ JMOHEP(1,POSPHO)=MOTHER
	+ JMOHEP(2,POSPHO)=MOTHER2
	+ JDAHEP(1,POSPHO)=IDA1
	+ JDAHEP(2,POSPHO)=IDA2
	+C--
	+C-- Get photon production vertex position
	+ DO 150 J=1,4
	+ 150 VHEP(J,POSPHO)=VHEP(J,POSPHO-1)
	+ 160 CONTINUE
	+ ENDIF
	+ RETURN
	+ END
	+ SUBROUTINE PHOBOS(IP,PBOOS1,PBOOS2,FIRST,LAST)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOBOS: PHOton radiation in decays BOoSt routine
	+C.
	+C. Purpose: Boost particles in cascade decay to parent rest frame
	+C. and boost back with modified boost vector.
	+C.
	+C. Input Parameters: IP: pointer of particle starting chain
	+C. to be boosted
	+C. PBOOS1: Boost vector to rest frame,
	+C. PBOOS2: Boost vector to modified frame,
	+C. FIRST: Pointer to first particle to be boos-
	+C. ted (/PH_HEPEVT/),
	+C. LAST: Pointer to last particle to be boos-
	+C. ted (/PH_HEPEVT/).
	+C.
	+C. Output Parameters: Common /PH_HEPEVT/.
	+C.
	+C. Author(s): B. van Eijk Created at: 13/02/90
	+C. Z. Was Last Update: 16/11/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION BET1(3),BET2(3),GAM1,GAM2,PB,DATA
	+ INTEGER I,J,FIRST,LAST,MAXSTA,NSTACK,IP
	+ PARAMETER (MAXSTA=10000)
	+ INTEGER STACK(MAXSTA)
	+ double precision PBOOS1(5),PBOOS2(5)
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ IF ((LAST.EQ.0).OR.(LAST.LT.FIRST)) RETURN
	+ NSTACK=0
	+ DO 10 J=1,3
	+ BET1(J)=-PBOOS1(J)/PBOOS1(5)
	+ 10 BET2(J)=PBOOS2(J)/PBOOS2(5)
	+ GAM1=PBOOS1(4)/PBOOS1(5)
	+ GAM2=PBOOS2(4)/PBOOS2(5)
	+C--
	+C-- Boost vector to parent rest frame...
	+ 20 DO 50 I=FIRST,LAST
	+ PB=BET1(1)PHEP(1,I)+BET1(2)PHEP(2,I)+BET1(3)*PHEP(3,I)
	+ IF (JMOHEP(1,I).EQ.IP) THEN
	+ DO 30 J=1,3
	+ 30 PHEP(J,I)=PHEP(J,I)+BET1(J)*(PHEP(4,I)+PB/(GAM1+1.D0))
	+ PHEP(4,I)=GAM1*PHEP(4,I)+PB
	+C--
	+C-- ...and boost back to modified parent frame.
	+ PB=BET2(1)PHEP(1,I)+BET2(2)PHEP(2,I)+BET2(3)*PHEP(3,I)
	+ DO 40 J=1,3
	+ 40 PHEP(J,I)=PHEP(J,I)+BET2(J)*(PHEP(4,I)+PB/(GAM2+1.D0))
	+ PHEP(4,I)=GAM2*PHEP(4,I)+PB
	+ IF (JDAHEP(1,I).NE.0) THEN
	+ NSTACK=NSTACK+1
	+C--
	+C-- Check on stack length...
	+ IF (NSTACK.GT.MAXSTA) THEN
	+ DATA=NSTACK
	+ CALL PHOERR(7,'PHOBOS',DATA)
	+ ENDIF
	+ STACK(NSTACK)=I
	+ ENDIF
	+ ENDIF
	+ 50 CONTINUE
	+ IF (NSTACK.NE.0) THEN
	+C--
	+C-- Now go one step further in the decay tree...
	+ FIRST=JDAHEP(1,STACK(NSTACK))
	+ LAST=JDAHEP(2,STACK(NSTACK))
	+ IP=STACK(NSTACK)
	+ NSTACK=NSTACK-1
	+ GOTO 20
	+ ENDIF
	+ RETURN
	+ END
	+ SUBROUTINE PHOIN(IP,BOOST,NHEP0)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOIN: PHOtos INput
	+C.
	+C. Purpose: copies IP branch of the common /PH_HEPEVT/ into /PHOEVT/
	+C. moves branch into its CMS system.
	+C.
	+C. Input Parameters: IP: pointer of particle starting branch
	+C. to be copied
	+C. BOOST: Flag whether boost to CMS was or was
	+C . not performed.
	+C.
	+C. Output Parameters: Commons: /PHOEVT/, /PHOCMS/
	+C.
	+C. Author(s): Z. Was Created at: 24/05/93
	+C. Last Update: 16/11/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ INTEGER IP,IP2,I,FIRST,LAST,LL,NA
	+ LOGICAL BOOST
	+ INTEGER J,NHEP0
	+ DOUBLE PRECISION BET(3),GAM,PB
	+ COMMON /PHOCMS/ BET,GAM
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+C--
	+C let-s calculate size of the little common entry
	+ FIRST=JDAHEP(1,IP)
	+ LAST =JDAHEP(2,IP)
	+ NPHO=3+LAST-FIRST+NHEP-NHEP0
	+ NEVPHO=NPHO
	+C let-s take in decaying particle
	+ IDPHO(1)=IDHEP(IP)
	+ JDAPHO(1,1)=3
	+ JDAPHO(2,1)=3+LAST-FIRST
	+ DO I=1,5
	+ PPHO(I,1)=PHEP(I,IP)
	+ ENDDO
	+C let-s take in eventual second mother
	+ IP2=JMOHEP(2,JDAHEP(1,IP))
	+ IF((IP2.NE.0).AND.(IP2.NE.IP)) THEN
	+ IDPHO(2)=IDHEP(IP2)
	+ JDAPHO(1,2)=3
	+ JDAPHO(2,2)=3+LAST-FIRST
	+ DO I=1,5
	+ PPHO(I,2)=PHEP(I,IP2)
	+ ENDDO
	+ ELSE
	+ IDPHO(2)=0
	+ DO I=1,5
	+ PPHO(I,2)=0.0D0
	+ ENDDO
	+ ENDIF
	+C let-s take in daughters
	+ DO LL=0,LAST-FIRST
	+ IDPHO(3+LL)=IDHEP(FIRST+LL)
	+ JMOPHO(1,3+LL)=JMOHEP(1,FIRST+LL)
	+ IF (JMOHEP(1,FIRST+LL).EQ.IP) JMOPHO(1,3+LL)=1
	+ DO I=1,5
	+ PPHO(I,3+LL)=PHEP(I,FIRST+LL)
	+ ENDDO
	+ ENDDO
	+ IF (NHEP.GT.NHEP0) THEN
	+C let-s take in illegitimate daughters
	+ NA=3+LAST-FIRST
	+ DO LL=1,NHEP-NHEP0
	+ IDPHO(NA+LL)=IDHEP(NHEP0+LL)
	+ JMOPHO(1,NA+LL)=JMOHEP(1,NHEP0+LL)
	+ IF (JMOHEP(1,NHEP0+LL).EQ.IP) JMOPHO(1,NA+LL)=1
	+ DO I=1,5
	+ PPHO(I,NA+LL)=PHEP(I,NHEP0+LL)
	+ ENDDO
	+ ENDDO
	+C-- there is NHEP-NHEP0 daugters more.
	+ JDAPHO(2,1)=3+LAST-FIRST+NHEP-NHEP0
	+ ENDIF
	+ IF(IDPHO(NPHO).EQ.22)CALL PHLUPA(100001)
	+! IF(IDPHO(NPHO).EQ.22) stop
	+ CALL PHCORK(0)
	+ IF(IDPHO(NPHO).EQ.22)CALL PHLUPA(100002)
	+C special case of t tbar production process
	+ IF(IFTOP) CALL PHOTWO(0)
	+ BOOST=.FALSE.
	+C-- Check whether parent is in its rest frame...
	+ IF ( (ABS(PPHO(4,1)-PPHO(5,1)).GT.PPHO(5,1)*1.D-8)
	+ $ .AND.(PPHO(5,1).NE.0)) THEN
	+ BOOST=.TRUE.
	+C--
	+C-- Boost daughter particles to rest frame of parent...
	+C-- Resultant neutral system already calculated in rest frame !
	+ DO 10 J=1,3
	+ 10 BET(J)=-PPHO(J,1)/PPHO(5,1)
	+ GAM=PPHO(4,1)/PPHO(5,1)
	+ DO 30 I=JDAPHO(1,1),JDAPHO(2,1)
	+ PB=BET(1)PPHO(1,I)+BET(2)PPHO(2,I)+BET(3)*PPHO(3,I)
	+ DO 20 J=1,3
	+ 20 PPHO(J,I)=PPHO(J,I)+BET(J)*(PPHO(4,I)+PB/(GAM+1.D0))
	+ 30 PPHO(4,I)=GAM*PPHO(4,I)+PB
	+C-- Finally boost mother as well
	+ I=1
	+ PB=BET(1)PPHO(1,I)+BET(2)PPHO(2,I)+BET(3)*PPHO(3,I)
	+ DO J=1,3
	+ PPHO(J,I)=PPHO(J,I)+BET(J)*(PPHO(4,I)+PB/(GAM+1.D0))
	+ ENDDO
	+ PPHO(4,I)=GAM*PPHO(4,I)+PB
	+ ENDIF
	+C special case of t tbar production process
	+ IF(IFTOP) CALL PHOTWO(1)
	+ CALL PHLUPA(2)
	+ IF(IDPHO(NPHO).EQ.22) CALL PHLUPA(10000)
	+! IF(IDPHO(NPHO-1).EQ.22) stop
	+ END
	+ SUBROUTINE PHOTWO(MODE)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTWO: PHOtos but TWO mothers allowed
	+C.
	+C. Purpose: Combines two mothers into one in /PHOEVT/
	+C. necessary eg in case of g g (q qbar) --> t tbar
	+C.
	+C. Input Parameters: Common /PHOEVT/ (/PHOCMS/)
	+C.
	+C. Output Parameters: Common /PHOEVT/, (stored mothers)
	+C.
	+C. Author(s): Z. Was Created at: 5/08/93
	+C. Last Update:10/08/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ DOUBLE PRECISION BET(3),GAM
	+ COMMON /PHOCMS/ BET,GAM
	+ INTEGER I,MODE
	+ double precision MPASQR
	+ LOGICAL IFRAD
	+C logical IFRAD is used to tag cases when two mothers may be
	+C merged to the sole one.
	+C So far used in case:
	+C 1) of t tbar production
	+C
	+C t tbar case
	+ IF(MODE.EQ.0) THEN
	+ IFRAD=(IDPHO(1).EQ.21).AND.(IDPHO(2).EQ.21)
	+ IFRAD=IFRAD.OR.(IDPHO(1).EQ.-IDPHO(2).AND.ABS(IDPHO(1)).LE.6)
	+ IFRAD=IFRAD
	+ & .AND.(ABS(IDPHO(3)).EQ.6).AND.(ABS(IDPHO(4)).EQ.6)
	+ MPASQR= (PPHO(4,1)+PPHO(4,2))2-(PPHO(3,1)+PPHO(3,2))2
	+ & -(PPHO(2,1)+PPHO(2,2))2-(PPHO(1,1)+PPHO(1,2))2
	+ IFRAD=IFRAD.AND.(MPASQR.GT.0.0D0)
	+ IF(IFRAD) THEN
	+c.....combining first and second mother
	+ DO I=1,4
	+ PPHO(I,1)=PPHO(I,1)+PPHO(I,2)
	+ ENDDO
	+ PPHO(5,1)=SQRT(MPASQR)
	+c.....removing second mother,
	+ DO I=1,5
	+ PPHO(I,2)=0.0D0
	+ ENDDO
	+ ENDIF
	+ ELSE
	+C boosting of the mothers to the reaction frame not implemented yet.
	+C to do it in mode 0 original mothers have to be stored in new comon (?)
	+C and in mode 1 boosted to cms.
	+ ENDIF
	+ END
	+ SUBROUTINE PHOOUT(IP,BOOST,NHEP0)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOOUT: PHOtos OUTput
	+C.
	+C. Purpose: copies back IP branch of the common /PH_HEPEVT/ from
	+C. /PHOEVT/ moves branch back from its CMS system.
	+C.
	+C. Input Parameters: IP: pointer of particle starting branch
	+C. to be given back.
	+C. BOOST: Flag whether boost to CMS was or was
	+C . not performed.
	+C.
	+C. Output Parameters: Common /PHOEVT/,
	+C.
	+C. Author(s): Z. Was Created at: 24/05/93
	+C. Last Update:
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ INTEGER IP,LL,FIRST,LAST,I
	+ LOGICAL BOOST
	+ INTEGER NN,J,K,NHEP0,NA
	+ DOUBLE PRECISION BET(3),GAM,PB
	+ COMMON /PHOCMS/ BET,GAM
	+ IF(NPHO.EQ.NEVPHO) RETURN
	+C-- When parent was not in its rest-frame, boost back...
	+ CALL PHLUPA(10)
	+ IF (BOOST) THEN
	+ DO 110 J=JDAPHO(1,1),JDAPHO(2,1)
	+ PB=-BET(1)PPHO(1,J)-BET(2)PPHO(2,J)-BET(3)*PPHO(3,J)
	+ DO 100 K=1,3
	+ 100 PPHO(K,J)=PPHO(K,J)-BET(K)*(PPHO(4,J)+PB/(GAM+1.D0))
	+ 110 PPHO(4,J)=GAM*PPHO(4,J)+PB
	+C-- ...boost photon, or whatever else has shown up
	+ DO NN=NEVPHO+1,NPHO
	+ PB=-BET(1)PPHO(1,NN)-BET(2)PPHO(2,NN)-BET(3)*PPHO(3,NN)
	+ DO 120 K=1,3
	+ 120 PPHO(K,NN)=PPHO(K,NN)-BET(K)*(PPHO(4,NN)+PB/(GAM+1.D0))
	+ PPHO(4,NN)=GAM*PPHO(4,NN)+PB
	+ ENDDO
	+ ENDIF
	+ FIRST=JDAHEP(1,IP)
	+ LAST =JDAHEP(2,IP)
	+C let-s take in original daughters
	+ DO LL=0,LAST-FIRST
	+ IDHEP(FIRST+LL) = IDPHO(3+LL)
	+ DO I=1,5
	+ PHEP(I,FIRST+LL) = PPHO(I,3+LL)
	+ ENDDO
	+ ENDDO
	+C let-s take newcomers to the end of HEPEVT.
	+ NA=3+LAST-FIRST
	+ DO LL=1,NPHO-NA
	+ IDHEP(NHEP0+LL) = IDPHO(NA+LL)
	+ ISTHEP(NHEP0+LL)=ISTPHO(NA+LL)
	+ JMOHEP(1,NHEP0+LL)=IP
	+ JMOHEP(2,NHEP0+LL)=JMOHEP(2,JDAHEP(1,IP))
	+ JDAHEP(1,NHEP0+LL)=0
	+ JDAHEP(2,NHEP0+LL)=0
	+ DO I=1,5
	+ PHEP(I,NHEP0+LL) = PPHO(I,NA+LL)
	+ ENDDO
	+ ENDDO
	+ NHEP=NHEP+NPHO-NEVPHO
	+ CALL PHLUPA(20)
	+ END
	+ SUBROUTINE PHOCHK(JFIRST)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOCHK: checking branch.
	+C.
	+C. Purpose: checks whether particles in the common block /PHOEVT/
	+C. can be served by PHOMAK.
	+C. JFIRST is the position in /PH_HEPEVT/ (!) of the first
	+C. daughter of sub-branch under action.
	+C.
	+C.
	+C. Author(s): Z. Was Created at: 22/10/92
	+C. Last Update: 11/12/00
	+C.
	+C.----------------------------------------------------------------------
	+C ********************
	+ IMPLICIT NONE
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ LOGICAL CHKIF
	+ COMMON/PHOIF/CHKIF(NMXPHO)
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ LOGICAL QEDRAD
	+ COMMON/PH_PHOQED/QEDRAD(NMXHEP)
	+ INTEGER JFIRST
	+ LOGICAL F
	+ INTEGER IDABS,NLAST,I,IPPAR
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW,IFNPI0,IFKL
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ LOGICAL IFRAD
	+ INTEGER IDENT,K,IQRK,IPHQRK,IEKL,IPHEKL
	+C these are OK .... if you do not like somebody else, add here.
	+ F(IDABS)=
	+ & ( ((IDABS.GT.9.OR.IQRK.NE.1).AND.(IDABS.LE.40))
	+ & .OR.(IDABS.GT.100) )
	+ & .AND.(IDABS.NE.21)
	+ $ .AND.(IDABS.NE.2101).AND.(IDABS.NE.3101).AND.(IDABS.NE.3201)
	+ & .AND.(IDABS.NE.1103).AND.(IDABS.NE.2103).AND.(IDABS.NE.2203)
	+ & .AND.(IDABS.NE.3103).AND.(IDABS.NE.3203).AND.(IDABS.NE.3303)
	+C
	+ IQRK=IPHQRK(0) ! switch for emission from quark
	+ IEKL=IPHEKL(0)
	+ NLAST = NPHO
	+C
	+ IPPAR=1
	+C checking for good particles
	+ IFNPI0=.TRUE.
	+ IF (IEKL.GT.1) THEN ! exclude radiative corr in decay of pi0
	+C ! and Kl --> ee gamma
	+ IFNPI0= (IDPHO(1).NE.111) ! pi0
	+ IFKL = ((IDPHO(1).EQ.130).AND. ! Kl --> ee gamma
	+ $ ((IDPHO(3).EQ.22).OR.(IDPHO(4).EQ.22).OR.
	+ $ (IDPHO(5).EQ.22)).AND.
	+ $ ((IDPHO(3).EQ.11).OR.(IDPHO(4).EQ.11).OR.
	+ $ (IDPHO(5).EQ.11)) )
	+
	+ IFNPI0=(IFNPI0.AND.(.NOT.IFKL))
	+ ENDIF
	+ DO 10 I=IPPAR,NLAST
	+ IDABS = ABS(IDPHO(I))
	+C possibly call on PHZODE is a dead (to be omitted) code.
	+ CHKIF(I)= F(IDABS) .AND.F(ABS(IDPHO(1)))
	+ & .AND. (IDPHO(2).EQ.0)
	+ IF(I.GT.2) CHKIF(I)=CHKIF(I).AND.QEDRAD(JFIRST+I-IPPAR-2)
	+ & .AND.IFNPI0
	+ 10 CONTINUE
	+C--
	+C now we go to special cases, where CHKIF(I) will be overwritten
	+C--
	+ IF(IFTOP) THEN
	+C special case of top pair production
	+ DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	+ IF(IDPHO(K).NE.22) THEN
	+ IDENT=K
	+ GOTO 15
	+ ENDIF
	+ ENDDO
	+ 15 CONTINUE
	+ IFRAD=((IDPHO(1).EQ.21).AND.(IDPHO(2).EQ.21))
	+ & .OR. ((ABS(IDPHO(1)).LE.6).AND.((IDPHO(2)).EQ.(-IDPHO(1))))
	+ IFRAD=IFRAD
	+ & .AND.(ABS(IDPHO(3)).EQ.6).AND.((IDPHO(4)).EQ.(-IDPHO(3)))
	+ & .AND.(IDENT.EQ.4)
	+ IF(IFRAD) THEN
	+ DO 20 I=IPPAR,NLAST
	+ CHKIF(I)= .TRUE.
	+ IF(I.GT.2) CHKIF(I)=CHKIF(I).AND.QEDRAD(JFIRST+I-IPPAR-2)
	+ 20 CONTINUE
	+ ENDIF
	+ ENDIF
	+C--
	+C--
	+ IF(IFTOP) THEN
	+C special case of top decay
	+ DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	+ IF(IDPHO(K).NE.22) THEN
	+ IDENT=K
	+ GOTO 25
	+ ENDIF
	+ ENDDO
	+ 25 CONTINUE
	+ IFRAD=((ABS(IDPHO(1)).EQ.6).AND.(IDPHO(2).EQ.0))
	+ IFRAD=IFRAD
	+ & .AND.((ABS(IDPHO(3)).EQ.24).AND.(ABS(IDPHO(4)).EQ.5)
	+ & .OR.(ABS(IDPHO(3)).EQ.5).AND.(ABS(IDPHO(4)).EQ.24))
	+ & .AND.(IDENT.EQ.4)
	+ IF(IFRAD) THEN
	+ DO 30 I=IPPAR,NLAST
	+ CHKIF(I)= .TRUE.
	+ IF(I.GT.2) CHKIF(I)=CHKIF(I).AND.QEDRAD(JFIRST+I-IPPAR-2)
	+ 30 CONTINUE
	+ ENDIF
	+ ENDIF
	+C--
	+C--
	+ END
	+ SUBROUTINE PHTYPE(ID)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHTYPE: Central manadgement routine.
	+C.
	+C. Purpose: defines what kind of the
	+C. actions will be performed at point ID.
	+C.
	+C. Input Parameters: ID: pointer of particle starting branch
	+C. in /PH_HEPEVT/ to be treated.
	+C.
	+C. Output Parameters: Common /PH_HEPEVT/.
	+C.
	+C. Author(s): Z. Was Created at: 24/05/93
	+C. P. Golonka Last Update: 27/06/04
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ LOGICAL EXPINI
	+ INTEGER NX,K,NCHAN
	+ PARAMETER (NX=10)
	+ double precision PRO,PRSUM,ESU
	+ COMMON /PHOEXP/ PRO(NX),NCHAN,EXPINI
	+
	+ INTEGER ID,NHEP0
	+ LOGICAL IPAIR
	+ double precision RN,PHORAN,SUM
	+ INTEGER WTDUM
	+ LOGICAL IFOUR
	+C--
	+ IFOUR=(.TRUE.).AND.(ITRE) ! we can make internal choice whether
	+ ! we want 3 or four photons at most.
	+ IPAIR=.TRUE.
	+C-- Check decay multiplicity..
	+ IF (JDAHEP(1,ID).EQ.0) RETURN
	+C IF (JDAHEP(1,ID).EQ.JDAHEP(2,ID)) RETURN
	+C--
	+ NHEP0=NHEP
	+C--
	+ IF (IEXP) THEN
	+ EXPINI=.TRUE. ! Initialization/cleaning
	+ DO NCHAN=1,NX
	+ PRO(NCHAN)=0.D0
	+ ENDDO
	+ NCHAN=0
	+
	+ FSEC=1.0D0
	+ CALL PHOMAK(ID,NHEP0)! Initialization/crude formfactors into
	+ ! PRO(NCHAN)
	+ EXPINI=.FALSE.
	+ RN=PHORAN(WTDUM)
	+ PRSUM=0
	+ DO K=1,NX
	+ PRSUM=PRSUM+PRO(K)
	+ ENDDO
	+ ESU=EXP(-PRSUM) ! exponent for crude Poissonian multiplicity
	+ ! distribution, will be later overwritten
	+ ! to give probability for k
	+ SUM=ESU ! distribuant for the crude Poissonian
	+ ! at first for k=0
	+ DO K=1,100 ! hard coded max (photon) multiplicity is 100
	+ IF(RN.LT.SUM) GOTO 100
	+ ESU=ESUPRSUM/K ! we get at K ESU=EXP(-PRSUM)PRSUM**K/K!
	+ SUM=SUM+ESU ! thus we get distribuant at K.
	+ NCHAN=0
	+ CALL PHOMAK(ID,NHEP0) ! LOOPING
	+ IF(SUM.GT.1D0-EXPEPS) GOTO 100
	+ ENDDO
	+ 100 CONTINUE
	+ ELSEIF(IFOUR) THEN
	+C-- quatro photon emission
	+ FSEC=1.0D0
	+ RN=PHORAN(WTDUM)
	+ IF (RN.GE.23.D0/24D0) THEN
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ ELSEIF (RN.GE.17.D0/24D0) THEN
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ ELSEIF (RN.GE.9.D0/24D0) THEN
	+ CALL PHOMAK(ID,NHEP0)
	+ ENDIF
	+ ELSEIF(ITRE) THEN
	+C-- triple photon emission
	+ FSEC=1.0D0
	+ RN=PHORAN(WTDUM)
	+ IF (RN.GE.5.D0/6D0) THEN
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ ELSEIF (RN.GE.2.D0/6D0) THEN
	+ CALL PHOMAK(ID,NHEP0)
	+ ENDIF
	+ ELSEIF(ISEC) THEN
	+C-- double photon emission
	+ FSEC=1.0D0
	+ RN=PHORAN(WTDUM)
	+ IF (RN.GE.0.5D0) THEN
	+ CALL PHOMAK(ID,NHEP0)
	+ CALL PHOMAK(ID,NHEP0)
	+ ENDIF
	+ ELSE
	+C-- single photon emission
	+ FSEC=1.0D0
	+ CALL PHOMAK(ID,NHEP0)
	+ ENDIF
	+C--
	+C-- electron positron pair (coomented out for a while
	+C IF (IPAIR) CALL PHOPAR(ID,NHEP0)
	+ END
	+ SUBROUTINE PHOMAK(IPPAR,NHEP0)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOMAK: PHOtos MAKe
	+C.
	+C. Purpose: Single or double bremstrahlung radiative corrections
	+C. are generated in the decay of the IPPAR-th particle in
	+C. the HEP common /PH_HEPEVT/. Example of the use of
	+C. general tools.
	+C.
	+C. Input Parameter: IPPAR: Pointer to decaying particle in
	+C. /PH_HEPEVT/ and the common itself
	+C.
	+C. Output Parameters: Common /PH_HEPEVT/, either with or without
	+C. particles added.
	+C.
	+C. Author(s): Z. Was, Created at: 26/05/93
	+C. Last Update: 29/01/05
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION DATA
	+ double precision PHORAN
	+ INTEGER IP,IPPAR,NCHARG
	+ INTEGER WTDUM,IDUM,NHEP0
	+ INTEGER NCHARB,NEUDAU
	+ double precision RN,WT,PHINT
	+ LOGICAL BOOST
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=10000)
	+ INTEGER IDHEP,ISTHEP,JDAHEP,JMOHEP,NEVHEP,NHEP
	+ double precision PHEP,VHEP
	+ COMMON/PH_HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+C--
	+ IP=IPPAR
	+ IDUM=1
	+ NCHARG=0
	+C--
	+ CALL PHOIN(IP,BOOST,NHEP0)
	+ CALL PHOCHK(JDAHEP(1,IP))
	+ WT=0.0D0
	+ CALL PHOPRE(1,WT,NEUDAU,NCHARB)
	+
	+ IF (WT.EQ.0.0D0) RETURN
	+ RN=PHORAN(WTDUM)
	+C PHODO is caling PHORAN, thus change of series if it is moved before if
	+ CALL PHODO(1,NCHARB,NEUDAU)
	+C we eliminate /FINT in variant B.
	+ IF (INTERF) WT=WT*PHINT(IDUM) /FINT ! FINT must be in variant A
	+ IF (IFW) CALL PHOBW(WT) ! extra weight for leptonic W decay
	+ DATA=WT
	+ IF (WT.GT.1.0D0) CALL PHOERR(3,'WT_INT',DATA)
	+C weighting
	+ IF (RN.LE.WT) THEN
	+ CALL PHOOUT(IP,BOOST,NHEP0)
	+ ENDIF
	+ RETURN
	+ END
	+ FUNCTION PHINT1(IDUM)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHINT: PHotos INTerference (Old version kept for tests only.
	+C.
	+C. Purpose: Calculates interference between emission of photons from
	+C. different possible chaged daughters stored in
	+C. the HEP common /PHOEVT/.
	+C.
	+C. Input Parameter: commons /PHOEVT/ /PHOMOM/ /PHOPHS/
	+C.
	+C.
	+C. Output Parameters:
	+C.
	+C.
	+C. Author(s): Z. Was, Created at: 10/08/93
	+C. Last Update: 15/03/99
	+C.
	+C.----------------------------------------------------------------------
	+
	+ IMPLICIT NONE
	+ double precision PHINT,phint1
	+ double precision PHOCHA
	+ INTEGER IDUM
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ DOUBLE PRECISION MCHSQR,MNESQR
	+ double precision PNEUTR
	+ COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	+ DOUBLE PRECISION COSTHG,SINTHG
	+ double precision XPHMAX,XPHOTO
	+ COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	+ double precision MPASQR,XX,BETA
	+ LOGICAL IFINT
	+ INTEGER K,IDENT
	+C
	+ DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	+ IF(IDPHO(K).NE.22) THEN
	+ IDENT=K
	+ GOTO 20
	+ ENDIF
	+ ENDDO
	+ 20 CONTINUE
	+C check if there is a photon
	+ IFINT= NPHO.GT.IDENT
	+C check if it is two body + gammas reaction
	+ IFINT= IFINT.AND.(IDENT-JDAPHO(1,1)).EQ.1
	+C check if two body was particle antiparticle
	+ IFINT= IFINT.AND.IDPHO(JDAPHO(1,1)).EQ.-IDPHO(IDENT)
	+C check if particles were charged
	+ IFINT= IFINT.AND.PHOCHA(IDPHO(IDENT)).NE.0
	+C calculates interference weight contribution
	+ IF(IFINT) THEN
	+ MPASQR = PPHO(5,1)**2
	+ XX=4.D0MCHSQR/MPASQR(1.D0-XPHOTO)/(1.D0-XPHOTO+(MCHSQR-MNESQR)
	+ & /MPASQR)**2
	+ BETA=SQRT(1.D0-XX)
	+ PHINT = 2D0/(1D0+COSTHG*2BETA**2)
	+ ELSE
	+ PHINT = 1D0
	+ ENDIF
	+ phint1=1
	+ END
	+
	+ FUNCTION PHINT2(IDUM)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHINT: PHotos INTerference
	+C.
	+C. Purpose: Calculates interference between emission of photons from
	+C. different possible chaged daughters stored in
	+C. the HEP common /PHOEVT/.
	+C.
	+C. Input Parameter: commons /PHOEVT/ /PHOMOM/ /PHOPHS/
	+C.
	+C.
	+C. Output Parameters:
	+C.
	+C.
	+C. Author(s): Z. Was, Created at: 10/08/93
	+C. Last Update:
	+C.
	+C.----------------------------------------------------------------------
	+
	+ IMPLICIT NONE
	+ double precision PHINT,PHINT1,PHINT2
	+ double precision PHOCHA
	+ INTEGER IDUM
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ DOUBLE PRECISION MCHSQR,MNESQR
	+ double precision PNEUTR
	+ COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	+ DOUBLE PRECISION COSTHG,SINTHG
	+ double precision XPHMAX,XPHOTO
	+ COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	+ double precision MPASQR,XX,BETA,PQ1(4),PQ2(4),PPHOT(4)
	+ double precision SS,PP2,PP,E1,E2,Q1,Q2,COSTHE
	+ LOGICAL IFINT
	+ INTEGER K,IDENT
	+C
	+ DO K=JDAPHO(2,1),JDAPHO(1,1),-1
	+ IF(IDPHO(K).NE.22) THEN
	+ IDENT=K
	+ GOTO 20
	+ ENDIF
	+ ENDDO
	+ 20 CONTINUE
	+C check if there is a photon
	+ IFINT= NPHO.GT.IDENT
	+C check if it is two body + gammas reaction
	+ IFINT= IFINT.AND.(IDENT-JDAPHO(1,1)).EQ.1
	+C check if two body was particle antiparticle (we improve on it !
	+C IFINT= IFINT.AND.IDPHO(JDAPHO(1,1)).EQ.-IDPHO(IDENT)
	+C check if particles were charged
	+ IFINT= IFINT.AND.abs(PHOCHA(IDPHO(IDENT))).GT.0.01D0
	+C check if they have both charge
	+ IFINT= IFINT.AND.
	+ $ abs(PHOCHA(IDPHO(JDAPHO(1,1)))).gt.0.01D0
	+C calculates interference weight contribution
	+ IF(IFINT) THEN
	+ MPASQR = PPHO(5,1)**2
	+ XX=4.D0MCHSQR/MPASQR(1.-XPHOTO)/(1.-XPHOTO+(MCHSQR-MNESQR)/
	+ & MPASQR)**2
	+ BETA=SQRT(1.D0-XX)
	+ PHINT = 2D0/(1D0+COSTHG*2BETA**2)
	+ SS =MPASQR*(1.D0-XPHOTO)
	+ PP2=((SS-MCHSQR-MNESQR)*2-4MCHSQR*MNESQR)/SS/4
	+ PP =SQRT(PP2)
	+ E1 =SQRT(PP2+MCHSQR)
	+ E2 =SQRT(PP2+MNESQR)
	+ PHINT= (E1+E2)*2/((E2+COSTHGPP)*2+(E1-COSTHGPP)**2)
	+C
	+ q1=PHOCHA(IDPHO(JDAPHO(1,1)))
	+ q2=PHOCHA(IDPHO(IDENT))
	+ do k=1,4
	+ pq1(k)=ppho(k,JDAPHO(1,1))
	+ pq2(k)=ppho(k,JDAPHO(1,1)+1)
	+ pphot(k)=ppho(k,npho)
	+ enddo
	+ costhe=(pphot(1)pq1(1)+pphot(2)pq1(2)+pphot(3)*pq1(3))
	+ costhe=costhe/sqrt(pq1(1)2+pq1(2)2+pq1(3)**2)
	+ costhe=costhe/sqrt(pphot(1)2+pphot(2)2+pphot(3)**2)
	+C
	+! --- this IF checks whether JDAPHO(1,1) was MCH or MNE.
	+! --- COSTHG angle (and in-generation variables) may be better choice
	+! --- than costhe. note that in the formulae below amplitudes were
	+! --- multiplied by (E2+COSTHGPP)(E1-COSTHG*PP).
	+ IF (costhg*costhe.GT.0) then
	+
	+ PHINT= (q1(E2+COSTHGPP)-q2(E1-COSTHGPP))**2
	+ & /(q1*2(E2+COSTHGPP)2+q22(E1-COSTHGPP)*2)
	+ ELSE
	+
	+ PHINT= (q1(E1-COSTHGPP)-q2(E2+COSTHGPP))**2
	+ & /(q1*2(E1-COSTHGPP)2+q22(E2+COSTHGPP)*2)
	+ ENDIF
	+ ELSE
	+ PHINT = 1D0
	+ ENDIF
	+ phint1=1
	+ phint2=1
	+ END
	+
	+
	+ SUBROUTINE PHOPRE(IPARR,WT,NEUDAU,NCHARB)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: Photon radiation in decays
	+C.
	+C. Purpose: Order (alpha) radiative corrections are generated in
	+C. the decay of the IPPAR-th particle in the HEP-like
	+C. common /PHOEVT/. Photon radiation takes place from one
	+C. of the charged daughters of the decaying particle IPPAR
	+C. WT is calculated, eventual rejection will be performed
	+C. later after inclusion of interference weight.
	+C.
	+C. Input Parameter: IPPAR: Pointer to decaying particle in
	+C. /PHOEVT/ and the common itself,
	+C.
	+C. Output Parameters: Common /PHOEVT/, either with or without a
	+C. photon(s) added.
	+C. WT weight of the configuration
	+C.
	+C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	+C. Last Update: 29/01/05
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION MINMAS,MPASQR,MCHREN
	+ DOUBLE PRECISION BETA,EPS,DEL1,DEL2,DATA,BIGLOG
	+ double precision PHOCHA,PHOSPI,PHORAN,PHOCOR,MASSUM
	+ INTEGER IP,IPARR,IPPAR,I,J,ME,NCHARG,NEUPOI,NLAST,THEDUM
	+ INTEGER IDABS,IDUM
	+ INTEGER NCHARB,NEUDAU
	+ double precision WT,WGT
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ LOGICAL CHKIF
	+ COMMON/PHOIF/CHKIF(NMXPHO)
	+ INTEGER CHAPOI(NMXPHO)
	+ DOUBLE PRECISION MCHSQR,MNESQR
	+ double precision PNEUTR
	+ COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	+ DOUBLE PRECISION COSTHG,SINTHG
	+ double precision XPHMAX,XPHOTO
	+ COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	+ double precision ALPHA,XPHCUT
	+ COMMON/PHOCOP/ALPHA,XPHCUT
	+ INTEGER IREP
	+ double precision PROBH,CORWT,XF
	+ COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	+C may be it is not the best place, but ...
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+
	+C--
	+ IPPAR=IPARR
	+C-- Store pointers for cascade treatement...
	+ IP=IPPAR
	+ NLAST=NPHO
	+ IDUM=1
	+C--
	+C-- Check decay multiplicity..
	+ IF (JDAPHO(1,IP).EQ.0) RETURN
	+C--
	+C-- Loop over daughters, determine charge multiplicity
	+ 10 NCHARG=0
	+ IREP=0
	+ MINMAS=0.D0
	+ MASSUM=0.D0
	+ DO 20 I=JDAPHO(1,IP),JDAPHO(2,IP)
	+C--
	+C--
	+C-- Exclude marked particles, quarks and gluons etc...
	+ IDABS=ABS(IDPHO(I))
	+ IF (CHKIF(I-JDAPHO(1,IP)+3)) THEN
	+ IF (PHOCHA(IDPHO(I)).NE.0) THEN
	+ NCHARG=NCHARG+1
	+ IF (NCHARG.GT.NMXPHO) THEN
	+ DATA=NCHARG
	+ CALL PHOERR(1,'PHOTOS',DATA)
	+ ENDIF
	+ CHAPOI(NCHARG)=I
	+ ENDIF
	+ MINMAS=MINMAS+PPHO(5,I)**2
	+ ENDIF
	+ MASSUM=MASSUM+PPHO(5,I)
	+ 20 CONTINUE
	+ IF (NCHARG.NE.0) THEN
	+C--
	+C-- Check that sum of daughter masses does not exceed parent mass
	+ IF ((PPHO(5,IP)-MASSUM)/PPHO(5,IP).GT.2.D0*XPHCUT) THEN
	+C--
	+C-- Order charged particles according to decreasing mass, this to
	+C-- increase efficiency (smallest mass is treated first).
	+ IF (NCHARG.GT.1) CALL PHOOMA(1,NCHARG,CHAPOI)
	+C--
	+ 30 CONTINUE
	+ DO 70 J=1,3
	+ 70 PNEUTR(J)=-PPHO(J,CHAPOI(NCHARG))
	+ PNEUTR(4)=PPHO(5,IP)-PPHO(4,CHAPOI(NCHARG))
	+C--
	+C-- Calculate invariant mass of 'neutral' etc. systems
	+ MPASQR=PPHO(5,IP)**2
	+ MCHSQR=PPHO(5,CHAPOI(NCHARG))**2
	+ IF ((JDAPHO(2,IP)-JDAPHO(1,IP)).EQ.1) THEN
	+ NEUPOI=JDAPHO(1,IP)
	+ IF (NEUPOI.EQ.CHAPOI(NCHARG)) NEUPOI=JDAPHO(2,IP)
	+ MNESQR=PPHO(5,NEUPOI)**2
	+ PNEUTR(5)=PPHO(5,NEUPOI)
	+ ELSE
	+ MNESQR=PNEUTR(4)2-PNEUTR(1)2-PNEUTR(2)2-PNEUTR(3)2
	+ MNESQR=MAX(MNESQR,MINMAS-MCHSQR)
	+ PNEUTR(5)=SQRT(MNESQR)
	+ ENDIF
	+C--
	+C-- Determine kinematical limit...
	+ XPHMAX=(MPASQR-(PNEUTR(5)+PPHO(5,CHAPOI(NCHARG)))**2)/MPASQR
	+C--
	+C-- Photon energy fraction...
	+ CALL PHOENE(MPASQR,MCHREN,BETA,BIGLOG,IDPHO(CHAPOI(NCHARG)))
	+C--
	+ IF (XPHOTO.LT.-4D0) THEN
	+ NCHARG=0 ! we really stop trials
	+ XPHOTO=0d0! in this case !!
	+C-- Energy fraction not too large (very seldom) ? Define angle.
	+ ELSEIF ((XPHOTO.LT.XPHCUT).OR.(XPHOTO.GT.XPHMAX)) THEN
	+C--
	+C-- No radiation was accepted, check for more daughters that may ra-
	+C-- diate and correct radiation probability...
	+ NCHARG=NCHARG-1
	+ IF (NCHARG.GT.0) THEN
	+ IREP=IREP+1
	+ GOTO 30
	+ ENDIF
	+ ELSE
	+C--
	+C-- Angle is generated in the frame defined by charged vector and
	+C-- PNEUTR, distribution is taken in the infrared limit...
	+ EPS=MCHREN/(1.D0+BETA)
	+C--
	+C-- Calculate sin(theta) and cos(theta) from interval variables
	+ DEL1=(2.D0-EPS)(EPS/(2.D0-EPS))*PHORAN(THEDUM)
	+ DEL2=2.D0-DEL1
	+
	+C ----------- VARIANT B ------------------
	+CC corrections for more efiicient interference correction,
	+CC instead of doubling crude distribution, we add flat parallel channel
	+C IF (PHORAN(THEDUM).LT.BIGLOG/BETA/(BIGLOG/BETA+2*FINT)) THEN
	+C COSTHG=(1.D0-DEL1)/BETA
	+C SINTHG=SQRT(DEL1*DEL2-MCHREN)/BETA
	+C ELSE
	+C COSTHG=-1D0+2*PHORAN(THEDUM)
	+C SINTHG= SQRT(1D0-COSTHG**2)
	+C ENDIF
	+C
	+C IF (FINT.GT.1.0D0) THEN
	+C
	+C WGT=1D0/(1D0-BETA*COSTHG)
	+C WGT=WGT/(WGT+FINT)
	+C ! WGT=1D0 ! ??
	+C
	+C ELSE
	+C WGT=1D0
	+C ENDIF
	+C
	+C ----------- END OF VARIANT B ------------------
	+
	+C ----------- VARIANT A ------------------
	+ COSTHG=(1.D0-DEL1)/BETA
	+ SINTHG=SQRT(DEL1*DEL2-MCHREN)/BETA
	+ WGT=1D0
	+C ----------- END OF VARIANT A ------------------
	+
	+C--
	+C-- Determine spin of particle and construct code for matrix element
	+ ME=2.D0*PHOSPI(IDPHO(CHAPOI(NCHARG)))+1.D0
	+C--
	+C-- Weighting procedure with 'exact' matrix element, reconstruct kine-
	+C-- matics for photon, neutral and charged system and update /PHOEVT/.
	+C-- Find pointer to the first component of 'neutral' system
	+ DO I=JDAPHO(1,IP),JDAPHO(2,IP)
	+ IF (I.NE.CHAPOI(NCHARG)) THEN
	+ NEUDAU=I
	+ GOTO 51
	+ ENDIF
	+ ENDDO
	+C--
	+C-- Pointer not found...
	+ DATA=NCHARG
	+ CALL PHOERR(5,'PHOKIN',DATA)
	+ 51 CONTINUE
	+ NCHARB=CHAPOI(NCHARG)
	+ NCHARB=NCHARB-JDAPHO(1,IP)+3
	+ NEUDAU=NEUDAU-JDAPHO(1,IP)+3
	+ WT=PHOCOR(MPASQR,MCHREN,ME)*WGT
	+ ENDIF
	+ ELSE
	+ DATA=PPHO(5,IP)-MASSUM
	+ CALL PHOERR(10,'PHOTOS',DATA)
	+ ENDIF
	+ ENDIF
	+C--
	+ RETURN
	+ END
	+ SUBROUTINE PHOOMA(IFIRST,ILAST,POINTR)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays Order MAss vector
	+C.
	+C. Purpose: Order the contents of array 'POINTR' according to the
	+C. decreasing value in the array 'MASS'.
	+C.
	+C. Input Parameters: IFIRST, ILAST: Pointers to the vector loca-
	+C. tion be sorted,
	+C. POINTR: Unsorted array with pointers to
	+C. /PHOEVT/.
	+C.
	+C. Output Parameter: POINTR: Sorted arrays with respect to
	+C. particle mass 'PPHO(5,*)'.
	+C.
	+C. Author(s): B. van Eijk Created at: 28/11/89
	+C. Last Update: 27/05/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ INTEGER IFIRST,ILAST,I,J,BUFPOI,POINTR(NMXPHO)
	+ double precision BUFMAS,MASS(NMXPHO)
	+ IF (IFIRST.EQ.ILAST) RETURN
	+C--
	+C-- Copy particle masses
	+ DO 10 I=IFIRST,ILAST
	+ 10 MASS(I)=PPHO(5,POINTR(I))
	+C--
	+C-- Order the masses in a decreasing series
	+ DO 30 I=IFIRST,ILAST-1
	+ DO 20 J=I+1,ILAST
	+ IF (MASS(J).LE.MASS(I)) GOTO 20
	+ BUFPOI=POINTR(J)
	+ POINTR(J)=POINTR(I)
	+ POINTR(I)=BUFPOI
	+ BUFMAS=MASS(J)
	+ MASS(J)=MASS(I)
	+ MASS(I)=BUFMAS
	+ 20 CONTINUE
	+ 30 CONTINUE
	+ RETURN
	+ END
	+ SUBROUTINE PHOENE(MPASQR,MCHREN,BETA,BIGLOG,IDENT)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays calculation of photon ENErgy
	+C. fraction
	+C.
	+C. Purpose: Subroutine returns photon energy fraction (in (parent
	+C. mass)/2 units) for the decay bremsstrahlung.
	+C.
	+C. Input Parameters: MPASQR: Mass of decaying system squared,
	+C. XPHCUT: Minimum energy fraction of photon,
	+C. XPHMAX: Maximum energy fraction of photon.
	+C.
	+C. Output Parameter: MCHREN: Renormalised mass squared,
	+C. BETA: Beta factor due to renormalisation,
	+C. XPHOTO: Photon energy fraction,
	+C. XF: Correction factor for PHOFAC.
	+C.
	+C. Author(s): S. Jadach, Z. Was Created at: 01/01/89
	+C. B. van Eijk, P.Golonka Last Update: 29/01/05
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION MPASQR,MCHREN,BIGLOG,BETA,DATA
	+ INTEGER IWT1,IRN,IWT2
	+ double precision PRSOFT,PRHARD,PHORAN,PHOFAC
	+ DOUBLE PRECISION MCHSQR,MNESQR
	+ double precision PNEUTR
	+ INTEGER IDENT
	+ double precision PHOCHA,PRKILL,RRR
	+ COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	+ DOUBLE PRECISION COSTHG,SINTHG
	+ double precision XPHMAX,XPHOTO
	+ COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	+ double precision ALPHA,XPHCUT
	+ COMMON/PHOCOP/ALPHA,XPHCUT
	+ double precision PI,TWOPI
	+ COMMON/PHPICO/PI,TWOPI
	+ INTEGER IREP
	+ double precision PROBH,CORWT,XF
	+ COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ INTEGER NX,NCHAN,K
	+ PARAMETER (NX=10)
	+ LOGICAL EXPINI
	+ double precision PRO,PRSUM
	+ COMMON /PHOEXP/ PRO(NX),NCHAN,EXPINI
	+C--
	+ IF (XPHMAX.LE.XPHCUT) THEN
	+ BETA=PHOFAC(-1) ! to zero counter, here beta is dummy
	+ XPHOTO=0.0D0
	+ RETURN
	+ ENDIF
	+C-- Probabilities for hard and soft bremstrahlung...
	+ MCHREN=4.D0MCHSQR/MPASQR/(1.D0+MCHSQR/MPASQR)*2
	+ BETA=SQRT(1.D0-MCHREN)
	+
	+C ----------- VARIANT B ------------------
	+CC we replace 1D0/BETABIGLOG with (1D0/BETABIGLOG+2*FINT)
	+CC for integral of new crude
	+C BIGLOG=LOG(MPASQR/MCHSQR(1.D0+BETA)2/4.D0
	+C & (1.D0+MCHSQR/MPASQR)**2)
	+C PRHARD=ALPHA/PI(1D0/BETABIGLOG+2FINT)(LOG(XPHMAX/XPHCUT)
	+C &-.75D0+XPHCUT/XPHMAX-.25D0XPHCUT2/XPHMAX*2)
	+C PRHARD=PRHARDPHOCHA(IDENT)2FSEC
	+C ----------- END OF VARIANT B ------------------
	+
	+C ----------- VARIANT A ------------------
	+ BIGLOG=LOG(MPASQR/MCHSQR(1.D0+BETA)2/4.D0
	+ & (1.D0+MCHSQR/MPASQR)**2)
	+ PRHARD=ALPHA/PI(1D0/BETABIGLOG)*
	+ &(LOG(XPHMAX/XPHCUT)-.75D0+XPHCUT/XPHMAX-.25D0XPHCUT2/XPHMAX*2)
	+ PRHARD=PRHARDPHOCHA(IDENT)2FSEC*FINT
	+C ----------- END OF VARIANT A ------------------
	+ IF (IREP.EQ.0) PROBH=0.D0
	+ PRKILL=0d0
	+ IF (IEXP) THEN ! IEXP
	+ NCHAN=NCHAN+1
	+ IF (EXPINI) THEN ! EXPINI
	+ PRO(NCHAN)=PRHARD+0.05*(1.0+FINT) ! we store hard photon emission prob
	+ !for leg NCHAN
	+ PRHARD=0D0 ! to kill emission at initialization call
	+ PROBH=PRHARD
	+ ELSE ! EXPINI
	+ PRSUM=0
	+ DO K=NCHAN,NX
	+ PRSUM=PRSUM+PRO(K)
	+ ENDDO
	+ PRHARD=PRHARD/PRSUM ! note that PRHARD may be smaller than
	+ !PRO(NCHAN) because it is calculated
	+ ! for kinematical configuartion as is
	+ ! (with effects of previous photons)
	+ PRKILL=PRO(NCHAN)/PRSUM-PRHARD !
	+
	+ ENDIF ! EXPINI
	+ PRSOFT=1.D0-PRHARD
	+ ELSE ! IEXP
	+ PRHARD=PRHARD*PHOFAC(0) ! PHOFAC is used to control eikonal
	+ ! formfactors for non exp version only
	+ ! here PHOFAC(0)=1 at least now.
	+ PROBH=PRHARD
	+ ENDIF ! IEXP
	+ PRSOFT=1.D0-PRHARD
	+C--
	+C-- Check on kinematical bounds
	+ IF (IEXP) THEN
	+ IF (PRSOFT.LT.-5.0D-8) THEN
	+ DATA=PRSOFT
	+ CALL PHOERR(2,'PHOENE',DATA)
	+ ENDIF
	+ ELSE
	+ IF (PRSOFT.LT.0.1D0) THEN
	+ DATA=PRSOFT
	+ CALL PHOERR(2,'PHOENE',DATA)
	+ ENDIF
	+ ENDIF
	+
	+ RRR=PHORAN(IWT1)
	+ IF (RRR.LT.PRSOFT) THEN
	+C--
	+C-- No photon... (ie. photon too soft)
	+ XPHOTO=0.D0
	+ IF (RRR.LT.PRKILL) XPHOTO=-5d0 ! No photon...no further trials
	+ ELSE
	+C--
	+C-- Hard photon... (ie. photon hard enough).
	+C-- Calculate Altarelli-Parisi Kernel
	+ 10 XPHOTO=EXP(PHORAN(IRN)*LOG(XPHCUT/XPHMAX))
	+ XPHOTO=XPHOTO*XPHMAX
	+ IF (PHORAN(IWT2).GT.((1.D0+(1.D0-XPHOTO/XPHMAX)**2)/2.D0))
	+ & GOTO 10
	+ ENDIF
	+C--
	+C-- Calculate parameter for PHOFAC function
	+ XF=4.D0MCHSQRMPASQR/(MPASQR+MCHSQR-MNESQR)**2
	+ RETURN
	+ END
	+ FUNCTION PHOCOR(MPASQR,MCHREN,ME)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays CORrection weight from
	+C. matrix elements
	+C.
	+C. Purpose: Calculate photon angle. The reshaping functions will
	+C. have to depend on the spin S of the charged particle.
	+C. We define: ME = 2 * S + 1 !
	+C.
	+C. Input Parameters: MPASQR: Parent mass squared,
	+C. MCHREN: Renormalised mass of charged system,
	+C. ME: 2 * spin + 1 determines matrix element
	+C.
	+C. Output Parameter: Function value.
	+C.
	+C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	+C. Last Update: 21/03/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION MPASQR,MCHREN,BETA,XX,YY,DATA
	+ INTEGER ME
	+ double precision PHOCOR,PHOFAC,WT1,WT2,WT3
	+ DOUBLE PRECISION MCHSQR,MNESQR
	+ double precision PNEUTR
	+ COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	+ DOUBLE PRECISION COSTHG,SINTHG
	+ double precision XPHMAX,XPHOTO
	+ COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	+ INTEGER IREP
	+ double precision PROBH,CORWT,XF
	+ COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	+C--
	+C-- Shaping (modified by ZW)...
	+ XX=4.D0MCHSQR/MPASQR(1.D0-XPHOTO)/(1.D0-XPHOTO+(MCHSQR-MNESQR)/
	+ &MPASQR)**2
	+ IF (ME.EQ.1) THEN
	+ YY=1.D0
	+ WT3=(1.D0-XPHOTO/XPHMAX)/((1.D0+(1.D0-XPHOTO/XPHMAX)**2)/2.D0)
	+ ELSEIF (ME.EQ.2) THEN
	+ YY=0.5D0*(1.D0-XPHOTO/XPHMAX+1.D0/(1.D0-XPHOTO/XPHMAX))
	+ WT3=1.D0
	+ ELSEIF ((ME.EQ.3).OR.(ME.EQ.4).OR.(ME.EQ.5)) THEN
	+ YY=1.D0
	+ WT3=(1.D0+(1.D0-XPHOTO/XPHMAX)2-(XPHOTO/XPHMAX)3)/
	+ & (1.D0+(1.D0-XPHOTO/XPHMAX)** 2)
	+ ELSE
	+ DATA=(ME-1.D0)/2.D0
	+ CALL PHOERR(6,'PHOCOR',DATA)
	+ YY=1.D0
	+ WT3=1.D0
	+ ENDIF
	+ BETA=SQRT(1.D0-XX)
	+ WT1=(1.D0-COSTHGSQRT(1.D0-MCHREN))/(1.D0-COSTHGBETA)
	+ WT2=(1.D0-XX/YY/(1.D0-BETA*2COSTHG*2))(1.D0+COSTHG*BETA)/2.D0
	+ WT2=WT2*PHOFAC(1)
	+ PHOCOR=WT1WT2WT3
	+ CORWT=PHOCOR
	+ IF (PHOCOR.GT.1.D0) THEN
	+ DATA=PHOCOR
	+ CALL PHOERR(3,'PHOCOR',DATA)
	+ ENDIF
	+ RETURN
	+ END
	+ FUNCTION PHOFAC(MODE)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays control FACtor
	+C.
	+C. Purpose: This is the control function for the photon spectrum and
	+C. final weighting. It is called from PHOENE for genera-
	+C. ting the raw photon energy spectrum (MODE=0) and in PHO-
	+C. COR to scale the final weight (MODE=1). The factor con-
	+C. sists of 3 terms. Addition of the factor FF which mul-
	+C. tiplies PHOFAC for MODE=0 and divides PHOFAC for MODE=1,
	+C. does not affect the results for the MC generation. An
	+C. appropriate choice for FF can speed up the calculation.
	+C. Note that a too small value of FF may cause weight over-
	+C. flow in PHOCOR and will generate a warning, halting the
	+C. execution. PRX should be included for repeated calls
	+C. for the same event, allowing more particles to radiate
	+C. photons. At the first call IREP=0, for more than 1
	+C. charged decay products, IREP >= 1. Thus, PRSOFT (no
	+C. photon radiation probability in the previous calls)
	+C. appropriately scales the strength of the bremsstrahlung.
	+C.
	+C. Input Parameters: MODE, PROBH, XF
	+C.
	+C. Output Parameter: Function value
	+C.
	+C. Author(s): S. Jadach, Z. Was Created at: 01/01/89
	+C. B. van Eijk, P.Golonka Last Update: 26/06/04
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ double precision PHOFAC,FF,PRX
	+ INTEGER MODE
	+ INTEGER IREP
	+ double precision PROBH,CORWT,XF
	+ COMMON/PHOPRO/PROBH,CORWT,XF,IREP
	+ LOGICAL INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ double precision FINT,FSEC,EXPEPS
	+ COMMON /PHOKEY/ FSEC,FINT,EXPEPS,INTERF,ISEC,ITRE,IEXP,IFTOP,IFW
	+ SAVE PRX,FF
	+ DATA PRX,FF/ 0.D0, 0.D0/
	+ IF (IEXP) THEN ! In case of exponentiation this routine is useles
	+ PHOFAC=1
	+ RETURN
	+ ENDIF
	+ IF (MODE.EQ.-1) THEN
	+ PRX=1.D0
	+ FF=1.D0
	+ PROBH=0.0
	+ ELSEIF (MODE.EQ.0) THEN
	+ IF (IREP.EQ.0) PRX=1.D0
	+ PRX=PRX/(1.D0-PROBH)
	+ FF=1.D0
	+C--
	+C-- Following options are not considered for the time being...
	+C-- (1) Good choice, but does not save very much time:
	+C-- FF=(1.0D0-SQRT(XF)/2.0D0)/(1.0+SQRT(XF)/2.0D0)
	+C-- (2) Taken from the blue, but works without weight overflows...
	+C-- FF=(1.D0-XF/(1-(1-SQRT(XF))*2))(1+(1-SQRT(XF))/SQRT(1-XF))/2
	+ PHOFAC=FF*PRX
	+ ELSE
	+ PHOFAC=1.D0/FF
	+ ENDIF
	+ END
	+ SUBROUTINE PHOBW(WT)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOtos Boson W correction weight
	+C.
	+C. Purpose: calculates correction weight due to amplitudes of
	+C. emission from W boson.
	+C.
	+C.
	+C.
	+C.
	+C.
	+C. Input Parameters: Common /PHOEVT/, with photon added.
	+C. wt to be corrected
	+C.
	+C.
	+C.
	+C. Output Parameters: wt
	+C.
	+C. Author(s): G. Nanava, Z. Was Created at: 13/03/03
	+C. Last Update: 13/03/03
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION WT
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ INTEGER I
	+ DOUBLE PRECISION EMU,MCHREN,BETA,COSTHG,MPASQR,XPH
	+C--
	+ IF (ABS(IDPHO(1)).EQ.24.AND.
	+ $ ABS(IDPHO(JDAPHO(1,1) )).GE.11.AND.
	+ $ ABS(IDPHO(JDAPHO(1,1) )).LE.16.AND.
	+ $ ABS(IDPHO(JDAPHO(1,1)+1)).GE.11.AND.
	+ $ ABS(IDPHO(JDAPHO(1,1)+1)).LE.16 ) THEN
	+
	+ IF(
	+ $ ABS(IDPHO(JDAPHO(1,1) )).EQ.11.OR.
	+ $ ABS(IDPHO(JDAPHO(1,1) )).EQ.13.OR.
	+ $ ABS(IDPHO(JDAPHO(1,1) )).EQ.15 ) THEN
	+ I=JDAPHO(1,1)
	+ ELSE
	+ I=JDAPHO(1,1)+1
	+ ENDIF
	+ EMU=PPHO(4,I)
	+ MCHREN=ABS(PPHO(4,I)2-PPHO(3,I)2
	+ $ -PPHO(2,I)2-PPHO(1,I)2)
	+ BETA=SQRT(1- MCHREN/ PPHO(4,I)**2)
	+ COSTHG=(PPHO(3,I)PPHO(3,NPHO)+PPHO(2,I)PPHO(2,NPHO)
	+ $ +PPHO(1,I)*PPHO(1,NPHO))/
	+ $ SQRT(PPHO(3,I)2+PPHO(2,I)2+PPHO(1,I)**2) /
	+ $ SQRT(PPHO(3,NPHO)2+PPHO(2,NPHO)2+PPHO(1,NPHO)**2)
	+ MPASQR=PPHO(4,1)**2
	+ XPH=PPHO(4,NPHO)
	+ WT=WT(1-8EMUXPH(1-COSTHGBETA)
	+ $ (MCHREN+2XPHSQRT(MPASQR))/
	+ $ MPASQR**2/(1-MCHREN/MPASQR)/(4-MCHREN/MPASQR))
	+ ENDIF
	+c write(,) IDPHO(1),IDPHO(JDAPHO(1,1)),IDPHO(JDAPHO(1,1)+1)
	+c write(,) emu,xph,costhg,beta,mpasqr,mchren
	+
	+ END
	+ SUBROUTINE PHODO(IP,NCHARB,NEUDAU)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays DOing of KINematics
	+C.
	+C. Purpose: Starting from the charged particle energy/momentum,
	+C. PNEUTR, photon energy fraction and photon angle with
	+C. respect to the axis formed by charged particle energy/
	+C. momentum vector and PNEUTR, scale the energy/momentum,
	+C. keeping the original direction of the neutral system in
	+C. the lab. frame untouched.
	+C.
	+C. Input Parameters: IP: Pointer to decaying particle in
	+C. /PHOEVT/ and the common itself
	+C. NCHARB: pointer to the charged radiating
	+C. daughter in /PHOEVT/.
	+C. NEUDAU: pointer to the first neutral daughter
	+C. Output Parameters: Common /PHOEVT/, with photon added.
	+C.
	+C. Author(s): Z. Was, B. van Eijk Created at: 26/11/89
	+C. Last Update: 27/05/93
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION PHOAN1,PHOAN2,ANGLE,FI1,FI3,FI4,FI5,TH1,TH3,TH4
	+ DOUBLE PRECISION PARNE,QNEW,QOLD,DATA
	+ INTEGER IP,FI3DUM,I,J,NEUDAU,FIRST,LAST
	+ INTEGER NCHARB
	+ double precision EPHOTO,PMAVIR,PHOTRI
	+ double precision GNEUT,PHORAN,CCOSTH,SSINTH,PVEC(4)
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ DOUBLE PRECISION MCHSQR,MNESQR
	+ double precision PNEUTR
	+ COMMON/PHOMOM/MCHSQR,MNESQR,PNEUTR(5)
	+ DOUBLE PRECISION COSTHG,SINTHG
	+ double precision XPHMAX,XPHOTO
	+ COMMON/PHOPHS/XPHMAX,XPHOTO,COSTHG,SINTHG
	+ double precision PI,TWOPI
	+ COMMON/PHPICO/PI,TWOPI
	+C--
	+ EPHOTO=XPHOTO*PPHO(5,IP)/2.D0
	+ PMAVIR=SQRT(PPHO(5,IP)(PPHO(5,IP)-2.D0EPHOTO))
	+C--
	+C-- Reconstruct kinematics of charged particle and neutral system
	+ FI1=PHOAN1(PNEUTR(1),PNEUTR(2))
	+C--
	+C-- Choose axis along z of PNEUTR, calculate angle between x and y
	+C-- components and z and x-y plane and perform Lorentz transform...
	+ TH1=PHOAN2(PNEUTR(3),SQRT(PNEUTR(1)2+PNEUTR(2)2))
	+ CALL PHORO3(-FI1,PNEUTR(1))
	+ CALL PHORO2(-TH1,PNEUTR(1))
	+C--
	+C-- Take away photon energy from charged particle and PNEUTR ! Thus
	+C-- the onshell charged particle decays into virtual charged particle
	+C-- and photon. The virtual charged particle mass becomes:
	+C-- SQRT(PPHO(5,IP)(PPHO(5,IP)-2EPHOTO)). Construct new PNEUTR mo-
	+C-- mentum in the rest frame of the parent:
	+C-- 1) Scaling parameters...
	+ QNEW=PHOTRI(PMAVIR,PNEUTR(5),PPHO(5,NCHARB))
	+ QOLD=PNEUTR(3)
	+ GNEUT=(QNEW2+QOLD2+MNESQR)/(QNEWQOLD+SQRT((QNEW2+MNESQR)
	+ &(QOLD**2+MNESQR)))
	+ IF (GNEUT.LT.1.D0) THEN
	+ DATA=0.D0
	+ CALL PHOERR(4,'PHOKIN',DATA)
	+ ENDIF
	+ PARNE=GNEUT-SQRT(MAX(GNEUT**2-1.0D0,0.D0))
	+C--
	+C-- 2) ...reductive boost...
	+ CALL PHOBO3(PARNE,PNEUTR)
	+C--
	+C-- ...calculate photon energy in the reduced system...
	+ NPHO=NPHO+1
	+ ISTPHO(NPHO)=1
	+ IDPHO(NPHO) =22
	+C-- Photon mother and daughter pointers !
	+ JMOPHO(1,NPHO)=IP
	+ JMOPHO(2,NPHO)=0
	+ JDAPHO(1,NPHO)=0
	+ JDAPHO(2,NPHO)=0
	+ PPHO(4,NPHO)=EPHOTO*PPHO(5,IP)/PMAVIR
	+C--
	+C-- ...and photon momenta
	+ CCOSTH=-COSTHG
	+ SSINTH=SINTHG
	+ TH3=PHOAN2(CCOSTH,SSINTH)
	+ FI3=TWOPI*PHORAN(FI3DUM)
	+ PPHO(1,NPHO)=PPHO(4,NPHO)SINTHGCOS(FI3)
	+ PPHO(2,NPHO)=PPHO(4,NPHO)SINTHGSIN(FI3)
	+C--
	+C-- Minus sign because axis opposite direction of charged particle !
	+ PPHO(3,NPHO)=-PPHO(4,NPHO)*COSTHG
	+ PPHO(5,NPHO)=0.D0
	+C--
	+C-- Rotate in order to get photon along z-axis
	+ CALL PHORO3(-FI3,PNEUTR(1))
	+ CALL PHORO3(-FI3,PPHO(1,NPHO))
	+ CALL PHORO2(-TH3,PNEUTR(1))
	+ CALL PHORO2(-TH3,PPHO(1,NPHO))
	+ ANGLE=EPHOTO/PPHO(4,NPHO)
	+C--
	+C-- Boost to the rest frame of decaying particle
	+ CALL PHOBO3(ANGLE,PNEUTR(1))
	+ CALL PHOBO3(ANGLE,PPHO(1,NPHO))
	+C--
	+C-- Back in the parent rest frame but PNEUTR not yet oriented !
	+ FI4=PHOAN1(PNEUTR(1),PNEUTR(2))
	+ TH4=PHOAN2(PNEUTR(3),SQRT(PNEUTR(1)2+PNEUTR(2)2))
	+ CALL PHORO3(FI4,PNEUTR(1))
	+ CALL PHORO3(FI4,PPHO(1,NPHO))
	+C--
	+ DO 60 I=2,4
	+ 60 PVEC(I)=0.D0
	+ PVEC(1)=1.D0
	+ CALL PHORO3(-FI3,PVEC)
	+ CALL PHORO2(-TH3,PVEC)
	+ CALL PHOBO3(ANGLE,PVEC)
	+ CALL PHORO3(FI4,PVEC)
	+ CALL PHORO2(-TH4,PNEUTR)
	+ CALL PHORO2(-TH4,PPHO(1,NPHO))
	+ CALL PHORO2(-TH4,PVEC)
	+ FI5=PHOAN1(PVEC(1),PVEC(2))
	+C--
	+C-- Charged particle restores original direction
	+ CALL PHORO3(-FI5,PNEUTR)
	+ CALL PHORO3(-FI5,PPHO(1,NPHO))
	+ CALL PHORO2(TH1,PNEUTR(1))
	+ CALL PHORO2(TH1,PPHO(1,NPHO))
	+ CALL PHORO3(FI1,PNEUTR)
	+ CALL PHORO3(FI1,PPHO(1,NPHO))
	+C-- See whether neutral system has multiplicity larger than 1...
	+ IF ((JDAPHO(2,IP)-JDAPHO(1,IP)).GT.1) THEN
	+C-- Find pointers to components of 'neutral' system
	+C--
	+ FIRST=NEUDAU
	+ LAST=JDAPHO(2,IP)
	+ DO 70 I=FIRST,LAST
	+ IF (I.NE.NCHARB.AND.(JMOPHO(1,I).EQ.IP)) THEN
	+C--
	+C-- Reconstruct kinematics...
	+ CALL PHORO3(-FI1,PPHO(1,I))
	+ CALL PHORO2(-TH1,PPHO(1,I))
	+C--
	+C-- ...reductive boost
	+ CALL PHOBO3(PARNE,PPHO(1,I))
	+C--
	+C-- Rotate in order to get photon along z-axis
	+ CALL PHORO3(-FI3,PPHO(1,I))
	+ CALL PHORO2(-TH3,PPHO(1,I))
	+C--
	+C-- Boost to the rest frame of decaying particle
	+ CALL PHOBO3(ANGLE,PPHO(1,I))
	+C--
	+C-- Back in the parent rest-frame but PNEUTR not yet oriented.
	+ CALL PHORO3(FI4,PPHO(1,I))
	+ CALL PHORO2(-TH4,PPHO(1,I))
	+C--
	+C-- Charged particle restores original direction
	+ CALL PHORO3(-FI5,PPHO(1,I))
	+ CALL PHORO2(TH1,PPHO(1,I))
	+ CALL PHORO3(FI1,PPHO(1,I))
	+ ENDIF
	+ 70 CONTINUE
	+ ELSE
	+C--
	+C-- ...only one 'neutral' particle in addition to photon!
	+ DO 80 J=1,4
	+ 80 PPHO(J,NEUDAU)=PNEUTR(J)
	+ ENDIF
	+C--
	+C-- All 'neutrals' treated, fill /PHOEVT/ for charged particle...
	+ DO 90 J=1,3
	+ 90 PPHO(J,NCHARB)=-(PPHO(J,NPHO)+PNEUTR(J))
	+ PPHO(4,NCHARB)=PPHO(5,IP)-(PPHO(4,NPHO)+PNEUTR(4))
	+C--
	+ END
	+ FUNCTION PHOTRI(A,B,C)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays calculation of TRIangle fie
	+C.
	+C. Purpose: Calculation of triangle function for phase space.
	+C.
	+C. Input Parameters: A, B, C (Virtual) particle masses.
	+C.
	+C. Output Parameter: Function value =
	+C. SQRT(LAMBDA(A2,B2,C*2))/(2A)
	+C.
	+C. Author(s): B. van Eijk Created at: 15/11/89
	+C. Last Update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION DA,DB,DC,DAPB,DAMB,DTRIAN
	+ double precision A,B,C,PHOTRI
	+ DA=A
	+ DB=B
	+ DC=C
	+ DAPB=DA+DB
	+ DAMB=DA-DB
	+ DTRIAN=SQRT((DAMB-DC)(DAPB+DC)(DAMB+DC)*(DAPB-DC))
	+ PHOTRI=DTRIAN/(DA+DA)
	+ RETURN
	+ END
	+ FUNCTION PHOAN1(X,Y)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays calculation of ANgle '1'
	+C.
	+C. Purpose: Calculate angle from X and Y
	+C.
	+C. Input Parameters: X, Y
	+C.
	+C. Output Parameter: Function value
	+C.
	+C. Author(s): S. Jadach Created at: 01/01/89
	+C. B. van Eijk Last Update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION PHOAN1
	+ double precision X,Y
	+ double precision PI,TWOPI
	+ COMMON/PHPICO/PI,TWOPI
	+ IF (ABS(Y).LT.ABS(X)) THEN
	+ PHOAN1=ATAN(ABS(Y/X))
	+ IF (X.LE.0.D0) PHOAN1=PI-PHOAN1
	+ ELSE
	+ PHOAN1=ACOS(X/SQRT(X2+Y2))
	+ ENDIF
	+ IF (Y.LT.0.D0) PHOAN1=TWOPI-PHOAN1
	+ RETURN
	+ END
	+ FUNCTION PHOAN2(X,Y)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays calculation of ANgle '2'
	+C.
	+C. Purpose: Calculate angle from X and Y
	+C.
	+C. Input Parameters: X, Y
	+C.
	+C. Output Parameter: Function value
	+C.
	+C. Author(s): S. Jadach Created at: 01/01/89
	+C. B. van Eijk Last Update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION PHOAN2
	+ double precision X,Y
	+ double precision PI,TWOPI
	+ COMMON/PHPICO/PI,TWOPI
	+ IF (ABS(Y).LT.ABS(X)) THEN
	+ PHOAN2=ATAN(ABS(Y/X))
	+ IF (X.LE.0.D0) PHOAN2=PI-PHOAN2
	+ ELSE
	+ PHOAN2=ACOS(X/SQRT(X2+Y2))
	+ ENDIF
	+ RETURN
	+ END
	+ SUBROUTINE PHOBO3(ANGLE,PVEC)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays BOost routine '3'
	+C.
	+C. Purpose: Boost vector PVEC along z-axis where ANGLE = EXP(ETA),
	+C. ETA is the hyperbolic velocity.
	+C.
	+C. Input Parameters: ANGLE, PVEC
	+C.
	+C. Output Parameter: PVEC
	+C.
	+C. Author(s): S. Jadach Created at: 01/01/89
	+C. B. van Eijk Last Update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION QPL,QMI,ANGLE
	+ double precision PVEC(4)
	+ QPL=(PVEC(4)+PVEC(3))*ANGLE
	+ QMI=(PVEC(4)-PVEC(3))/ANGLE
	+ PVEC(3)=(QPL-QMI)/2.D0
	+ PVEC(4)=(QPL+QMI)/2.D0
	+ RETURN
	+ END
	+ SUBROUTINE PHORO2(ANGLE,PVEC)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays ROtation routine '2'
	+C.
	+C. Purpose: Rotate x and z components of vector PVEC around angle
	+C. 'ANGLE'.
	+C.
	+C. Input Parameters: ANGLE, PVEC
	+C.
	+C. Output Parameter: PVEC
	+C.
	+C. Author(s): S. Jadach Created at: 01/01/89
	+C. B. van Eijk Last Update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION CS,SN,ANGLE
	+ double precision PVEC(4)
	+ CS=COS(ANGLE)PVEC(1)+SIN(ANGLE)PVEC(3)
	+ SN=-SIN(ANGLE)PVEC(1)+COS(ANGLE)PVEC(3)
	+ PVEC(1)=CS
	+ PVEC(3)=SN
	+ RETURN
	+ END
	+ SUBROUTINE PHORO3(ANGLE,PVEC)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays ROtation routine '3'
	+C.
	+C. Purpose: Rotate x and y components of vector PVEC around angle
	+C. 'ANGLE'.
	+C.
	+C. Input Parameters: ANGLE, PVEC
	+C.
	+C. Output Parameter: PVEC
	+C.
	+C. Author(s): S. Jadach Created at: 01/01/89
	+C. B. van Eijk Last Update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION CS,SN,ANGLE
	+ double precision PVEC(4)
	+ CS=COS(ANGLE)PVEC(1)-SIN(ANGLE)PVEC(2)
	+ SN=SIN(ANGLE)PVEC(1)+COS(ANGLE)PVEC(2)
	+ PVEC(1)=CS
	+ PVEC(2)=SN
	+ RETURN
	+ END
	+ SUBROUTINE PHORIN
	+ RETURN
	+ END
	+ FUNCTION PHORAN(IDUM)
	+ IMPLICIT NONE
	+ double precision PHORAN
	+ INTEGER IDUM
	+ double precision PYR
	+ PHORAN=PYR(IDUM)
	+ RETURN
	+ END
	+ FUNCTION PHOCHA(IDHEP)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays CHArge determination
	+C.
	+C. Purpose: Calculate the charge of particle with code IDHEP. The
	+C. code of the particle is defined by the Particle Data
	+C. Group in Phys. Lett. B204 (1988) 1.
	+C.
	+C. Input Parameter: IDHEP
	+C.
	+C. Output Parameter: Funtion value = charge of particle with code
	+C. IDHEP
	+C.
	+C. Author(s): E. Barberio and B. van Eijk Created at: 29/11/89
	+C. Last update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ double precision PHOCHA
	+ INTEGER IDHEP,IDABS,Q1,Q2,Q3
	+C--
	+C-- Array 'CHARGE' contains the charge of the first 101 particles ac-
	+C-- cording to the PDG particle code... (0 is added for convenience)
	+ double precision CHARGE(0:100)
	+ DATA CHARGE/ 0.D0,
	+ &-0.3333333333D0, 0.6666666667D0, -0.3333333333D0, 0.6666666667D0,
	+ &-0.3333333333D0, 0.6666666667D0, -0.3333333333D0, 0.6666666667D0,
	+ & 20.D0, -1.D0, 0.D0, -1.D0, 0.D0, -1.D0, 0.D0, -1.D0, 60.D0,
	+ & 1.D0, 120.D0, 1.D0, 630.D0/
	+ IDABS=ABS(IDHEP)
	+ IF (IDABS.LE.100) THEN
	+C--
	+C-- Charge of quark, lepton, boson etc....
	+ PHOCHA = CHARGE(IDABS)
	+ ELSE
	+C--
	+C-- Check on particle build out of quarks, unpack its code...
	+ Q3=MOD(IDABS/1000,10)
	+ Q2=MOD(IDABS/100,10)
	+ Q1=MOD(IDABS/10,10)
	+ IF (Q3.EQ.0) THEN
	+C--
	+C-- ...meson...
	+ IF(MOD(Q2,2).EQ.0) THEN
	+ PHOCHA=CHARGE(Q2)-CHARGE(Q1)
	+ ELSE
	+ PHOCHA=CHARGE(Q1)-CHARGE(Q2)
	+ ENDIF
	+ ELSE
	+C--
	+C-- ...diquarks or baryon.
	+ PHOCHA=CHARGE(Q1)+CHARGE(Q2)+CHARGE(Q3)
	+ ENDIF
	+ ENDIF
	+C--
	+C-- Find the sign of the charge...
	+ IF (IDHEP.LT.0.D0) PHOCHA=-PHOCHA
	+ IF (PHOCHA**2.lt.1d-6) PHOCHA=0.D0
	+ RETURN
	+ END
	+ FUNCTION PHOSPI(IDHEP)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays function for SPIn determina-
	+C. tion
	+C.
	+C. Purpose: Calculate the spin of particle with code IDHEP. The
	+C. code of the particle is defined by the Particle Data
	+C. Group in Phys. Lett. B204 (1988) 1.
	+C.
	+C. Input Parameter: IDHEP
	+C.
	+C. Output Parameter: Funtion value = spin of particle with code
	+C. IDHEP
	+C.
	+C. Author(s): E. Barberio and B. van Eijk Created at: 29/11/89
	+C. Last update: 02/01/90
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ double precision PHOSPI
	+ INTEGER IDHEP,IDABS
	+C--
	+C-- Array 'SPIN' contains the spin of the first 100 particles accor-
	+C-- ding to the PDG particle code...
	+ double precision SPIN(100)
	+ DATA SPIN/ 8.5D0, 1.D0, 0.D0, 8.5D0, 20.D0, 41.D0, 76*0.D0/
	+ IDABS=ABS(IDHEP)
	+C--
	+C-- Spin of quark, lepton, boson etc....
	+ IF (IDABS.LE.100) THEN
	+ PHOSPI=SPIN(IDABS)
	+ ELSE
	+C--
	+C-- ...other particles, however...
	+ PHOSPI=(MOD(IDABS,10)-1.D0)/2.D0
	+C--
	+C-- ...K_short and K_long are special !!
	+ PHOSPI=MAX(PHOSPI,0.D0)
	+ ENDIF
	+ RETURN
	+ END
	+ SUBROUTINE PHOERR(IMES,TEXT,DATA)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays ERRror handling
	+C.
	+C. Purpose: Inform user about (fatal) errors and warnings generated
	+C. by either the user or the program.
	+C.
	+C. Input Parameters: IMES, TEXT, DATA
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): B. van Eijk Created at: 29/11/89
	+C. Last Update: 10/01/92
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ DOUBLE PRECISION DATA
	+ INTEGER IMES,IERROR
	+ double precision SDATA
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+ INTEGER PHOMES
	+ PARAMETER (PHOMES=10)
	+ INTEGER STATUS
	+ COMMON/PHOSTA/STATUS(PHOMES)
	+ CHARACTER TEXT()
	+ SAVE IERROR
	+C-- security STOP switch
	+ LOGICAL ISEC
	+ SAVE ISEC
	+C DATA ISEC /.TRUE./
	+ DATA ISEC /.FALSE./
	+ DATA IERROR/ 0/
	+ IF (IMES.LE.PHOMES) STATUS(IMES)=STATUS(IMES)+1
	+C--
	+C-- Count number of non-fatal errors...
	+ IF ((IMES.EQ. 6).AND.(STATUS(IMES).GE.2)) RETURN
	+ IF ((IMES.EQ.10).AND.(STATUS(IMES).GE.2)) RETURN
	+ SDATA=DATA
	+ WRITE(PHLUN,9000)
	+ WRITE(PHLUN,9120)
	+ GOTO (10,20,30,40,50,60,70,80,90,100),IMES
	+ WRITE(PHLUN,9130) IMES
	+ GOTO 120
	+ 10 WRITE(PHLUN,9010) TEXT,INT(SDATA)
	+ GOTO 110
	+ 20 WRITE(PHLUN,9020) TEXT,SDATA
	+ GOTO 110
	+ 30 WRITE(PHLUN,9030) TEXT,SDATA
	+ GOTO 110
	+ 40 WRITE(PHLUN,9040) TEXT
	+ GOTO 110
	+ 50 WRITE(PHLUN,9050) TEXT,INT(SDATA)
	+ GOTO 110
	+ 60 WRITE(PHLUN,9060) TEXT,SDATA
	+ GOTO 130
	+ 70 WRITE(PHLUN,9070) TEXT,INT(SDATA)
	+ GOTO 110
	+ 80 WRITE(PHLUN,9080) TEXT,INT(SDATA)
	+ GOTO 110
	+ 90 WRITE(PHLUN,9090) TEXT,INT(SDATA)
	+ GOTO 110
	+ 100 WRITE(PHLUN,9100) TEXT,SDATA
	+ GOTO 130
	+ 110 CONTINUE
	+ WRITE(PHLUN,9140)
	+ WRITE(PHLUN,9120)
	+ WRITE(PHLUN,9000)
	+ IF (ISEC) THEN
	+ STOP
	+ ELSE
	+ GOTO 130
	+ ENDIF
	+ 120 IERROR=IERROR+1
	+ IF (IERROR.GE.10) THEN
	+ WRITE(PHLUN,9150)
	+ WRITE(PHLUN,9120)
	+ WRITE(PHLUN,9000)
	+ IF (ISEC) THEN
	+ STOP
	+ ELSE
	+ GOTO 130
	+ ENDIF
	+ ENDIF
	+ 130 WRITE(PHLUN,9120)
	+ WRITE(PHLUN,9000)
	+ RETURN
	+ 9000 FORMAT(1H ,80('*'))
	+ 9010 FORMAT(1H ,'* ',A,': Too many charged Particles, NCHARG =',I6,T81,
	+ &'*')
	+ 9020 FORMAT(1H ,'* ',A,': Too much Bremsstrahlung required, PRSOFT = ',
	+ &F15.6,T81,'*')
	+ 9030 FORMAT(1H ,'* ',A,': Combined Weight is exceeding 1., Weight = ',
	+ &F15.6,T81,'*')
	+ 9040 FORMAT(1H ,'* ',A,
	+ &': Error in Rescaling charged and neutral Vectors',T81,'*')
	+ 9050 FORMAT(1H ,'* ',A,
	+ &': Non matching charged Particle Pointer, NCHARG = ',I5,T81,'*')
	+ 9060 FORMAT(1H ,'* ',A,
	+ &': Do you really work with a Particle of Spin: ',F4.1,' ?',T81,
	+ &'*')
	+ 9070 FORMAT(1H ,'* ',A, ': Stack Length exceeded, NSTACK = ',I5 ,T81,
	+ &'*')
	+ 9080 FORMAT(1H ,'* ',A,
	+ &': Random Number Generator Seed(1) out of Range: ',I8,T81,'*')
	+ 9090 FORMAT(1H ,'* ',A,
	+ &': Random Number Generator Seed(2) out of Range: ',I8,T81,'*')
	+ 9100 FORMAT(1H ,'* ',A,
	+ &': Available Phase Space below Cut-off: ',F15.6,' GeV/c^2',T81,
	+ &'*')
	+ 9120 FORMAT(1H ,'',T81,'')
	+ 9130 FORMAT(1H ,'* Funny Error Message: ',I4,' ! What to do ?',T81,'*')
	+ 9140 FORMAT(1H ,'* Fatal Error Message, I stop this Run !',T81,'*')
	+ 9150 FORMAT(1H ,'* 10 Error Messages generated, I stop this Run !',T81,
	+ &'*')
	+ END
	+ SUBROUTINE PHOREP
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays run summary REPort
	+C.
	+C. Purpose: Inform user about success and/or restrictions of PHOTOS
	+C. encountered during execution.
	+C.
	+C. Input Parameters: Common /PHOSTA/
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): B. van Eijk Created at: 10/01/92
	+C. Last Update: 10/01/92
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+ INTEGER PHOMES
	+ PARAMETER (PHOMES=10)
	+ INTEGER STATUS
	+ COMMON/PHOSTA/STATUS(PHOMES)
	+ INTEGER I
	+ LOGICAL ERROR
	+ ERROR=.FALSE.
	+ WRITE(PHLUN,9000)
	+ WRITE(PHLUN,9010)
	+ WRITE(PHLUN,9020)
	+ WRITE(PHLUN,9030)
	+ WRITE(PHLUN,9040)
	+ WRITE(PHLUN,9030)
	+ WRITE(PHLUN,9020)
	+ DO 10 I=1,PHOMES
	+ IF (STATUS(I).EQ.0) GOTO 10
	+ IF ((I.EQ.6).OR.(I.EQ.10)) THEN
	+ WRITE(PHLUN,9050) I,STATUS(I)
	+ ELSE
	+ ERROR=.TRUE.
	+ WRITE(PHLUN,9060) I,STATUS(I)
	+ ENDIF
	+ 10 CONTINUE
	+ IF (.NOT.ERROR) WRITE(PHLUN,9070)
	+ WRITE(PHLUN,9020)
	+ WRITE(PHLUN,9010)
	+ RETURN
	+ 9000 FORMAT(1H1)
	+ 9010 FORMAT(1H ,80('*'))
	+ 9020 FORMAT(1H ,'',T81,'')
	+ 9030 FORMAT(1H ,'',26X,25('='),T81,'')
	+ 9040 FORMAT(1H ,'',30X,'PHOTOS Run Summary',T81,'')
	+ 9050 FORMAT(1H ,'',22X,'Warning #',I2,' occured',I6,' times',T81,'')
	+ 9060 FORMAT(1H ,'',23X,'Error #',I2,' occured',I6,' times',T81,'')
	+ 9070 FORMAT(1H ,'*',16X,'PHOTOS Execution has successfully terminated',
	+ &T81,'*')
	+ END
	+ SUBROUTINE PHLUPA(IPOINT)
	+ IMPLICIT NONE
	+C.----------------------------------------------------------------------
	+C.
	+C. PHLUPA: debugging tool
	+C.
	+C. Purpose: NONE, eventually may printout content of the
	+C. /PHOEVT/ common
	+C.
	+C. Input Parameters: Common /PHOEVT/ and /PHNUM/
	+C. latter may have number of the event.
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): Z. Was Created at: 30/05/93
	+C. Last Update: 09/10/05
	+C.
	+C.----------------------------------------------------------------------
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO,I,J,IPOINT
	+ INTEGER IPOIN,IPOIN0,IPOINM,IEV
	+ INTEGER IOUT
	+ double precision PPHO,VPHO,SUM
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ COMMON /PHNUM/ IEV
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+ DIMENSION SUM(5)
	+ DATA IPOIN0/ -5/
	+ COMMON /PHLUPY/ IPOIN,IPOINM
	+ SAVE IPOIN0
	+ IF (IPOIN0.LT.0) THEN
	+ IPOIN0=300 000 ! maximal no-print point
	+ IPOIN =IPOIN0
	+ IPOINM=300 001 ! minimal no-print point
	+ ENDIF
	+ IF (IPOINT.LE.IPOINM.OR.IPOINT.GE.IPOIN ) RETURN
	+ IOUT=56
	+ IF (IEV.LT.1000) THEN
	+ DO I=1,5
	+ SUM(I)=0.0D0
	+ ENDDO
	+ WRITE(PHLUN,*) 'EVENT NR=',IEV,
	+ $ 'WE ARE TESTING /PHOEVT/ at IPOINT=',IPOINT
	+ WRITE(PHLUN,10)
	+ I=1
	+ WRITE(PHLUN,20) IDPHO(I),PPHO(1,I),PPHO(2,I),PPHO(3,I),
	+ $ PPHO(4,I),PPHO(5,I),JDAPHO(1,I),JDAPHO(2,I)
	+ I=2
	+ WRITE(PHLUN,20) IDPHO(I),PPHO(1,I),PPHO(2,I),PPHO(3,I),
	+ $ PPHO(4,I),PPHO(5,I),JDAPHO(1,I),JDAPHO(2,I)
	+ WRITE(PHLUN,*) ' '
	+ DO I=3,NPHO
	+ WRITE(PHLUN,20) IDPHO(I),PPHO(1,I),PPHO(2,I),PPHO(3,I),
	+ $ PPHO(4,I),PPHO(5,I),JMOPHO(1,I),JMOPHO(2,I)
	+ DO J=1,4
	+ SUM(J)=SUM(J)+PPHO(J,I)
	+ ENDDO
	+ ENDDO
	+ SUM(5)=SQRT(ABS(SUM(4)2-SUM(1)2-SUM(2)2-SUM(3)2))
	+ WRITE(PHLUN,30) SUM
	+ 10 FORMAT(1X,' ID ','p_x ','p_y ','p_z ',
	+ $ 'E ','m ',
	+ $ 'ID-MO_DA1','ID-MO DA2' )
	+ 20 FORMAT(1X,I4,5(F14.9),2I9)
	+ 30 FORMAT(1X,' SUM',5(F14.9))
	+ ENDIF
	+ END
	+
	+
	+
	+ FUNCTION IPHQRK(MODCOR)
	+ implicit none
	+C.----------------------------------------------------------------------
	+C.
	+C. IPHQRK: enables blocks emision from quarks
	+C.
	+C
	+C. Input Parameters: MODCOR
	+C. MODCOR >0 type of action
	+C. =1 blocks
	+C. =2 enables
	+C. =0 execution mode (retrns stored value)
	+C.
	+C.
	+C. Author(s): Z. Was Created at: 11/12/00
	+C. Modified :
	+C.----------------------------------------------------------------------
	+ INTEGER IPHQRK
	+ INTEGER PHLUN,MODCOR,MODOP
	+ COMMON/PHOLUN/PHLUN
	+ DATA MODOP /0/
	+ IF (MODCOR.NE.0) THEN
	+C INITIALIZATION
	+ MODOP=MODCOR
	+
	+ WRITE(PHLUN,*)
	+ $ 'Message from PHOTOS: IPHQRK(MODCOR):: (re)initialization'
	+ IF (MODOP.EQ.1) THEN
	+ WRITE(PHLUN,*)
	+ $ 'MODOP=1 -- blocks emission from light quarks: DEFAULT'
	+ ELSEIF (MODOP.EQ.2) THEN
	+ WRITE(PHLUN,*)
	+ $ 'MODOP=2 -- enables emission from light quarks: TEST '
	+ ELSE
	+ WRITE(PHLUN,*) 'IPHQRK wrong MODCOR=',MODCOR
	+ STOP
	+ ENDIF
	+ RETURN
	+ ENDIF
	+
	+ IF (MODOP.EQ.0.AND.MODCOR.EQ.0) THEN
	+ WRITE(PHLUN,*) 'IPHQRK lack of initialization'
	+ STOP
	+ ENDIF
	+ IPHQRK=MODOP
	+ END
	+
	+
	+ FUNCTION IPHEKL(MODCOR)
	+ implicit none
	+C.----------------------------------------------------------------------
	+C.
	+C. IPHEKL: enables/blocks emision in: pi0 to gamma e+ e-
	+C.
	+C
	+C. Input Parameters: MODCOR
	+C. MODCOR >0 type of action
	+C. =1 blocks
	+C. =2 enables
	+C. =0 execution mode (retrns stored value)
	+C.
	+C.
	+C. Author(s): Z. Was Created at: 11/12/00
	+C. Modified :
	+C.----------------------------------------------------------------------
	+ INTEGER IPHEKL,MODCOR,MODOP
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+
	+ SAVE MODOP
	+ DATA MODOP /0/
	+
	+ IF (MODCOR.NE.0) THEN
	+C INITIALIZATION
	+ MODOP=MODCOR
	+
	+ WRITE(PHLUN,*)
	+ $ 'Message from PHOTOS: IPHEKL(MODCOR):: (re)initialization'
	+ IF (MODOP.EQ.2) THEN
	+ WRITE(PHLUN,*)
	+ $ 'MODOP=2 -- blocks emission in pi0 to gamma e+e-: DEFAULT'
	+ WRITE(PHLUN,*)
	+ $ 'MODOP=2 -- blocks emission in Kl to gamma e+e-: DEFAULT'
	+ ELSEIF (MODOP.EQ.1) THEN
	+ WRITE(PHLUN,*)
	+ $ 'MODOP=1 -- enables emission in pi0 to gamma e+e- : TEST '
	+ WRITE(PHLUN,*)
	+ $ 'MODOP=1 -- enables emission in Kl to gamma e+e- : TEST '
	+ ELSE
	+ WRITE(PHLUN,*) 'IPHEKL wrong MODCOR=',MODCOR
	+ STOP
	+ ENDIF
	+ RETURN
	+ ENDIF
	+
	+ IF (MODOP.EQ.0.AND.MODCOR.EQ.0) THEN
	+ WRITE(PHLUN,*) 'IPHELK lack of initialization'
	+ STOP
	+ ENDIF
	+ IPHEKL=MODOP
	+ END
	+
	+ SUBROUTINE PHCORK(MODCOR)
	+ implicit none
	+C.----------------------------------------------------------------------
	+C.
	+C. PHCORK: corrects kinmatics of subbranch needed if host program
	+C. produces events with the shaky momentum conservation
	+C
	+C. Input Parameters: Common /PHOEVT/, MODCOR
	+C. MODCOR >0 type of action
	+C. =1 no action
	+C. =2 corrects energy from mass
	+C. =3 corrects mass from energy
	+C. =4 corrects energy from mass for
	+C. particles up to .4 GeV mass,
	+C. for heavier ones corrects mass,
	+C. =5 most complete correct also of mother
	+C. often necessary for exponentiation.
	+C. =0 execution mode
	+C.
	+C. Output Parameters: corrected /PHOEVT/
	+C.
	+C. Author(s): P.Golonka, Z. Was Created at: 01/02/99
	+C. Modified : 08/02/99
	+C.----------------------------------------------------------------------
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+
	+ double precision M,P2,PX,PY,PZ,E,EN,MCUT,XMS
	+ INTEGER MODCOR,MODOP,I,IEV,IPRINT,K
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+
	+ COMMON /PHNUM/ IEV
	+ SAVE MODOP
	+ DATA MODOP /0/
	+ SAVE IPRINT
	+ DATA IPRINT /0/
	+ SAVE MCUT
	+ IF (MODCOR.NE.0) THEN
	+C INITIALIZATION
	+ MODOP=MODCOR
	+
	+ WRITE(PHLUN,*) 'Message from PHCORK(MODCOR):: initialization'
	+ IF (MODOP.EQ.1) THEN
	+ WRITE(PHLUN,*) 'MODOP=1 -- no corrections on event: DEFAULT'
	+ ELSEIF (MODOP.EQ.2) THEN
	+ WRITE(PHLUN,*) 'MODOP=2 -- corrects Energy from mass'
	+ ELSEIF (MODOP.EQ.3) THEN
	+ WRITE(PHLUN,*) 'MODOP=3 -- corrects mass from Energy'
	+ ELSEIF (MODOP.EQ.4) THEN
	+ WRITE(PHLUN,*) 'MODOP=4 -- corrects Energy from mass to Mcut'
	+ WRITE(PHLUN,*) ' and mass from energy above Mcut '
	+ MCUT=0.4
	+ WRITE(PHLUN,*) 'Mcut=',MCUT,'GeV'
	+ ELSEIF (MODOP.EQ.5) THEN
	+ WRITE(PHLUN,*) 'MODOP=5 -- corrects Energy from mass+flow'
	+
	+ ELSE
	+ WRITE(PHLUN,*) 'PHCORK wrong MODCOR=',MODCOR
	+ STOP
	+ ENDIF
	+ RETURN
	+ ENDIF
	+
	+ IF (MODOP.EQ.0.AND.MODCOR.EQ.0) THEN
	+ WRITE(PHLUN,*) 'PHCORK lack of initialization'
	+ STOP
	+ ENDIF
	+
	+C execution mode
	+C ==============
	+C ==============
	+
	+
	+ PX=0
	+ PY=0
	+ PZ=0
	+ E =0
	+
	+ IF (MODOP.EQ.1) THEN
	+C -----------------------
	+C In this case we do nothing
	+ RETURN
	+ ELSEIF(MODOP.EQ.2) THEN
	+C -----------------------
	+CC lets loop thru all daughters and correct their energies
	+CC according to E^2=p^2+m^2
	+
	+ DO I=3,NPHO
	+
	+ PX=PX+PPHO(1,I)
	+ PY=PY+PPHO(2,I)
	+ PZ=PZ+PPHO(3,I)
	+
	+ P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	+
	+ EN=SQRT( PPHO(5,I)**2 + P2)
	+
	+ IF (IPRINT.EQ.1)
	+ & WRITE(PHLUN,*) "CORRECTING ENERGY OF ",I,":",
	+ & PPHO(4,I),"=>",EN
	+
	+ PPHO(4,I)=EN
	+ E = E+PPHO(4,I)
	+
	+ ENDDO
	+
	+ ELSEIF(MODOP.EQ.5) THEN
	+C -----------------------
	+CC lets loop thru all daughters and correct their energies
	+CC according to E^2=p^2+m^2
	+
	+ DO I=3,NPHO
	+
	+ PX=PX+PPHO(1,I)
	+ PY=PY+PPHO(2,I)
	+ PZ=PZ+PPHO(3,I)
	+
	+ P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	+
	+ EN=SQRT( PPHO(5,I)**2 + P2)
	+
	+ IF (IPRINT.EQ.1)
	+ & WRITE(PHLUN,*) "CORRECTING ENERGY OF ",I,":",
	+ & PPHO(4,I),"=>",EN
	+
	+ PPHO(4,I)=EN
	+ E = E+PPHO(4,I)
	+
	+ ENDDO
	+ DO K=1,4
	+ PPHO(K,1)=0d0
	+ DO I=3,NPHO
	+ PPHO(K,1)=PPHO(K,1)+PPHO(K,I)
	+ ENDDO
	+ ENDDO
	+ XMS=SQRT(PPHO(4,1)2-PPHO(3,1)2-PPHO(2,1)2-PPHO(1,1)2)
	+ PPHO(5,1)=XMS
	+ ELSEIF(MODOP.EQ.3) THEN
	+C -----------------------
	+
	+CC lets loop thru all daughters and correct their masses
	+CC according to E^2=p^2+m^2
	+
	+ DO I=3,NPHO
	+
	+ PX=PX+PPHO(1,I)
	+ PY=PY+PPHO(2,I)
	+ PZ=PZ+PPHO(3,I)
	+ E = E+PPHO(4,I)
	+
	+ P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	+
	+ M=SQRT(ABS( PPHO(4,I)**2 - P2))
	+
	+ IF (IPRINT.EQ.1)
	+ & WRITE(PHLUN,*) "CORRECTING MASS OF ",I,":",
	+ & PPHO(5,I),"=>",M
	+
	+ PPHO(5,I)=M
	+
	+ ENDDO
	+
	+
	+ ELSEIF(MODOP.EQ.4) THEN
	+C -----------------------
	+
	+CC lets loop thru all daughters and correct their masses
	+CC or energies according to E^2=p^2+m^2
	+
	+ DO I=3,NPHO
	+
	+ PX=PX+PPHO(1,I)
	+ PY=PY+PPHO(2,I)
	+ PZ=PZ+PPHO(3,I)
	+
	+ P2=PPHO(1,I)2+PPHO(2,I)2+PPHO(3,I)**2
	+
	+ M=SQRT(ABS( PPHO(4,I)**2 - P2))
	+
	+ IF (M.GT.MCUT) THEN
	+ IF (IPRINT.EQ.1)
	+ & WRITE(PHLUN,*) "CORRECTING MASS OF ",I,":",
	+ & PPHO(5,I),"=>",M
	+ PPHO(5,I)=M
	+ E = E+PPHO(4,I)
	+ ELSE
	+
	+ EN=SQRT( PPHO(5,I)**2 + P2)
	+
	+ IF (IPRINT.EQ.1)
	+ & WRITE(PHLUN,*) "CORRECTING ENERGY OF ",I,":",
	+ & PPHO(4,I),"=>",EN
	+
	+ PPHO(4,I)=EN
	+ E = E+PPHO(4,I)
	+ ENDIF
	+
	+ ENDDO
	+ ENDIF
	+C -----
	+
	+ IF (IPRINT.EQ.1) THEN
	+ WRITE(PHLUN,*) "CORRECTING MOTHER"
	+ WRITE(PHLUN,*) "PX:",PPHO(1,1),"=>",PX-PPHO(1,2)
	+ WRITE(PHLUN,*) "PY:",PPHO(2,1),"=>",PY-PPHO(2,2)
	+ WRITE(PHLUN,*) "PZ:",PPHO(3,1),"=>",PZ-PPHO(3,2)
	+ WRITE(PHLUN,*) " E:",PPHO(4,1),"=>",E-PPHO(4,2)
	+ ENDIF
	+
	+ PPHO(1,1)=PX-PPHO(1,2)
	+ PPHO(2,1)=PY-PPHO(2,2)
	+ PPHO(3,1)=PZ-PPHO(3,2)
	+ PPHO(4,1)=E -PPHO(4,2)
	+
	+ P2=PPHO(1,1)2+PPHO(2,1)2+PPHO(3,1)**2
	+
	+ IF (PPHO(4,1)**2.GT.P2) THEN
	+ M=SQRT( PPHO(4,1)**2 - P2 )
	+ IF (IPRINT.EQ.1)
	+ & WRITE(PHLUN,*) " M:",PPHO(5,1),"=>",M
	+ PPHO(5,1)=M
	+ ENDIF
	+
	+ CALL PHLUPA(25)
	+
	+ END
	+
	+
	+
	+ FUNCTION PHINT(IDUM)
	+C --- can be used with VARIANT A. For B use PHINT1 or 2 --------------
	+C.----------------------------------------------------------------------
	+C.
	+C. PHINT: PHotos universal INTerference correction weight
	+C.
	+C. Purpose: calculates correction weight as expressed by
	+C formula (17) from CPC 79 (1994), 291.
	+C.
	+C. Input Parameters: Common /PHOEVT/, with photon added.
	+C.
	+C. Output Parameters: correction weight
	+C.
	+C. Author(s): Z. Was, P.Golonka Created at: 19/01/05
	+C. Last Update: 25/01/05
	+C.
	+C.----------------------------------------------------------------------
	+ IMPLICIT NONE
	+ double precision PHINT,PHINT2
	+ INTEGER IDUM
	+ INTEGER NMXPHO
	+ PARAMETER (NMXPHO=10000)
	+ INTEGER IDPHO,ISTPHO,JDAPHO,JMOPHO,NEVPHO,NPHO
	+ double precision PPHO,VPHO
	+ COMMON/PHOEVT/NEVPHO,NPHO,ISTPHO(NMXPHO),IDPHO(NMXPHO),
	+ &JMOPHO(2,NMXPHO),JDAPHO(2,NMXPHO),PPHO(5,NMXPHO),VPHO(4,NMXPHO)
	+ INTEGER I,K,L
	+ DOUBLE PRECISION EMU,MCHREN,BETA,COSTHG,MPASQR,XPH, XC1, XC2,XDENO
	+ DOUBLE PRECISION XNUM1,XNUM2
	+ DOUBLE PRECISION EPS1(4),EPS2(4),PH(4),PL(4)
	+ double precision PHOCHA
	+C--
	+
	+C Calculate polarimetric vector: ph, eps1, eps2 are orthogonal
	+
	+ DO K=1,4
	+ PH(K)=PPHO(K,NPHO)
	+ EPS2(K)=1D0
	+ ENDDO
	+
	+ CALL PHOEPS(PH,EPS2,EPS1)
	+ CALL PHOEPS(PH,EPS1,EPS2)
	+
	+
	+ XNUM1=0D0
	+ XNUM2=0D0
	+ XDENO=0D0
	+
	+ DO K=JDAPHO(1,1),NPHO-1 ! or JDAPHO(1,2)
	+
	+C momenta of charged particle in PL
	+ DO L=1,4
	+ PL(L)=PPHO(L,K)
	+ ENDDO
	+C scalar products: epsilonp/kp
	+
	+ XC1 = - PHOCHA(IDPHO(K)) *
	+ & ( PL(1)EPS1(1) + PL(2)EPS1(2) + PL(3)*EPS1(3) ) /
	+ & ( PH(4)PL(4) - PH(1)PL(1) - PH(2)PL(2) - PH(3)PL(3) )
	+
	+ XC2 = - PHOCHA(IDPHO(K)) *
	+ & ( PL(1)EPS2(1) + PL(2)EPS2(2) + PL(3)*EPS2(3) ) /
	+ & ( PH(4)PL(4) - PH(1)PL(1) - PH(2)PL(2) - PH(3)PL(3) )
	+
	+
	+C accumulate the currents
	+ XNUM1 = XNUM1+XC1
	+ XNUM2 = XNUM2+XC2
	+
	+ XDENO = XDENO + XC12 + XC22
	+
	+ ENDDO
	+
	+ PHINT=(XNUM12 + XNUM22) / XDENO
	+ PHINT2=PHINT
	+
	+ END
	+
	+
	+ SUBROUTINE PHOEPS (VEC1, VEC2, EPS)
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOEPS: PHOeps vector product (normalized to unity)
	+C.
	+C. Purpose: calculates vector product, then normalizes its length.
	+C used to generate orthogonal vectors, i.e. to
	+C generate polarimetric vectors for photons.
	+C.
	+C. Input Parameters: VEC1,VEC2 - input 4-vectors
	+C.
	+C. Output Parameters: EPS - normalized 4-vector, orthogonal to
	+C VEC1 and VEC2
	+C.
	+C. Author(s): Z. Was, P.Golonka Created at: 19/01/05
	+C. Last Update: 25/01/05
	+C.
	+C.----------------------------------------------------------------------
	+
	+ DOUBLE PRECISION VEC1(4), VEC2(4), EPS(4),XN
	+
	+ EPS(1)=VEC1(2)VEC2(3) - VEC1(3)VEC2(2)
	+ EPS(2)=VEC1(3)VEC2(1) - VEC1(1)VEC2(3)
	+ EPS(3)=VEC1(1)VEC2(2) - VEC1(2)VEC2(1)
	+ EPS(4)=0D0
	+
	+ XN=SQRT( EPS(1)2 +EPS(2)2 +EPS(3)**2)
	+
	+ EPS(1)=EPS(1)/XN
	+ EPS(2)=EPS(2)/XN
	+ EPS(3)=EPS(3)/XN
	+
	+
	+ END
	+ SUBROUTINE PHODMP
	+C.----------------------------------------------------------------------
	+C.
	+C. PHOTOS: PHOton radiation in decays event DuMP routine
	+C.
	+C. Purpose: Print event record.
	+C.
	+C. Input Parameters: Common /HEPEVT/
	+C.
	+C. Output Parameters: None
	+C.
	+C. Author(s): B. van Eijk Created at: 05/06/90
	+C. Last Update: 05/06/90
	+C.
	+C.----------------------------------------------------------------------
	+C IMPLICIT NONE
	+ DOUBLE PRECISION SUMVEC(5)
	+ INTEGER I,J
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+ INTEGER PHLUN
	+ COMMON/PHOLUN/PHLUN
	+ DO 10 I=1,5
	+ 10 SUMVEC(I)=0.
	+C--
	+C-- Print event number...
	+ WRITE(PHLUN,9000)
	+ WRITE(PHLUN,9010) NEVHEP
	+ WRITE(PHLUN,9080)
	+ WRITE(PHLUN,9020)
	+ DO 30 I=1,NHEP
	+C--
	+C-- For 'stable particle' calculate vector momentum sum
	+ IF (JDAHEP(1,I).EQ.0) THEN
	+ DO 20 J=1,4
	+ 20 SUMVEC(J)=SUMVEC(J)+PHEP(J,I)
	+ IF (JMOHEP(2,I).EQ.0) THEN
	+ WRITE(PHLUN,9030) I,IDHEP(I),JMOHEP(1,I),(PHEP(J,I),J=1,5)
	+ ELSE
	+ WRITE(PHLUN,9040) I,IDHEP(I),JMOHEP(1,I),JMOHEP(2,I),(PHEP
	+ & (J,I),J=1,5)
	+ ENDIF
	+ ELSE
	+ IF (JMOHEP(2,I).EQ.0) THEN
	+ WRITE(PHLUN,9050) I,IDHEP(I),JMOHEP(1,I),JDAHEP(1,I),
	+ & JDAHEP(2,I),(PHEP(J,I),J=1,5)
	+ ELSE
	+ WRITE(PHLUN,9060) I,IDHEP(I),JMOHEP(1,I),JMOHEP(2,I),
	+ & JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
	+ ENDIF
	+ ENDIF
	+ 30 CONTINUE
	+ SUMVEC(5)=SQRT(SUMVEC(4)2-SUMVEC(1)2-SUMVEC(2)**2-
	+ &SUMVEC(3)**2)
	+ WRITE(PHLUN,9070) (SUMVEC(J),J=1,5)
	+ RETURN
	+ 9000 FORMAT(1H0,80('='))
	+ 9010 FORMAT(1H ,29X,'Event No.:',I10)
	+ 9020 FORMAT(1H0,1X,'Nr',3X,'Type',3X,'Parent(s)',2X,'Daughter(s)',6X,
	+ &'Px',7X,'Py',7X,'Pz',7X,'E',4X,'Inv. M.')
	+ 9030 FORMAT(1H ,I4,I7,3X,I4,9X,'Stable',2X,5F9.2)
	+ 9040 FORMAT(1H ,I4,I7,I4,' - ',I4,5X,'Stable',2X,5F9.2)
	+ 9050 FORMAT(1H ,I4,I7,3X,I4,6X,I4,' - ',I4,5F9.2)
	+ 9060 FORMAT(1H ,I4,I7,I4,' - ',I4,2X,I4,' - ',I4,5F9.2)
	+ 9070 FORMAT(1H0,23X,'Vector Sum: ', 5F9.2)
	+ 9080 FORMAT(1H0,6X,'Particle Parameters')
	+ END
	Index: trunk/contrib/tauola/tauola_photos_ini.f
	===================================================================
	--- trunk/contrib/tauola/tauola_photos_ini.f (revision 0)
	+++ trunk/contrib/tauola/tauola_photos_ini.f (revision 8889)
	@@ -0,0 +1,802 @@
	+
	+
	+C this file is created by hand from taumain.F
	+C actions: Remove routines: TAUDEM DECTES TAUFIL FILHEP
	+C add: INIETC will not necesarily work fine ...
	+C replace TRALO4
	+C rename INIPHY to INIPHX
	+
	+ SUBROUTINE INIETC(jakk1,jakk2,itd,ifpho)
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+ COMMON / IDFC / IDFF
	+ COMMON / TAURAD / XK0DEC,ITDKRC
	+ DOUBLE PRECISION XK0DEC
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+ COMMON /PHOACT/ IFPHOT
	+ SAVE
	+C KTO=1 will denote tau+, thus :: IDFF=-15
	+ IDFF=-15
	+C XK0 for tau decays.
	+ XK0DEC=0.01
	+C radiative correction switch in tau --> e (mu) decays !
	+ ITDKRC=itd
	+C switches of tau+ tau- decay modes !!
	+ JAK1=jakk1
	+ JAK2=jakk2
	+C photos activation switch
	+ IFPHOT=IFPHO
	+ end
	+
	+ SUBROUTINE TRALO4(KTOS,PHOI,PHOF,AM)
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+!! Corrected 11.10.96 (ZW) tralor for KORALW.
	+!! better treatment is to cascade from tau rest-frame through W
	+!! restframe down to LAB.
	+ COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
	+ COMMON /TRALID/ idtra
	+ double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
	+ double precision P1QQ(4),P2QQ(4)
	+ double precision PIN(4),POUT(4),PBST(4),PBS1(4),QQ(4),PI
	+ double precision THET,PHI,EXE
	+ double precision PHOI(4),PHOF(4)
	+ SAVE
	+ DATA PI /3.141592653589793238462643D0/
	+ AM=SQRT(ABS
	+ $ (PHOI(4)2-PHOI(3)2-PHOI(2)2-PHOI(1)2))
	+ idtra=KTOS
	+ DO K=1,4
	+ PIN(K)=PHOI(K)
	+ PHOF(K)=PHOI(K)
	+ ENDDO
	+! write(,) idtra
	+ IF (idtra.EQ.1) THEN
	+ DO K=1,4
	+ PBST(K)=P1(K)
	+ QQ(K)=Q1(K)
	+ ENDDO
	+ ELSEIF(idtra.EQ.2) THEN
	+ DO K=1,4
	+ PBST(K)=P2(K)
	+ QQ(K)=Q1(K)
	+ ENDDO
	+ ELSEIF(idtra.EQ.3) THEN
	+ DO K=1,4
	+ PBST(K)=P3(K)
	+ QQ(K)=Q2(K)
	+ ENDDO
	+ ELSE
	+ DO K=1,4
	+ PBST(K)=P4(K)
	+ QQ(K)=Q2(K)
	+ ENDDO
	+ ENDIF
	+
	+
	+
	+ CALL BOSTDQ(1,QQ,PBST,PBST)
	+ CALL BOSTDQ(1,QQ,P1,P1QQ)
	+ CALL BOSTDQ(1,QQ,P2,P2QQ)
	+ PBS1(4)=PBST(4)
	+ PBS1(3)=SQRT(PBST(3)2+PBST(2)2+PBST(1)**2)
	+ PBS1(2)=0D0
	+ PBS1(1)=0D0
	+ EXE=(PBS1(4)+PBS1(3))/DSQRT(PBS1(4)2-PBS1(3)2)
	+C for KTOS=1 boost is antiparallel to 4-momentum of P2.
	+C restframes of tau+ tau- and 'first' frame of 'higgs' are all connected
	+C by boosts along z axis
	+ IF(KTOS.EQ.1) EXE=(PBS1(4)-PBS1(3))/DSQRT(PBS1(4)2-PBS1(3)2)
	+ CALL BOSTD3(EXE,PIN,POUT)
	+
	+C once in Z/gamma/Higgs rest frame we control further kinematics by P2QQ for KTOS=1,2
	+ THET=ACOS(P2QQ(3)/SQRT(P2QQ(3)2+P2QQ(2)2+P2QQ(1)**2))
	+c PHI=0D0
	+c PHI=ACOS(P2QQ(1)/SQRT(P2QQ(2)2+P2QQ(1)2))
	+c IF(P2QQ(2).LT.0D0) PHI=2*PI-PHI
	+c JRR: Catch numerical exceptions in boosts.
	+ if (ABS(P2QQ(1)) < 1D-11 .AND. ABS(P2QQ(1)) < 1D-11) then
	+ PHI=0
	+ ELSE
	+ PHI=ATAN2(P2QQ(2),P2QQ(1))
	+ ENDIF
	+
	+ CALL ROTPOX(THET,PHI,POUT)
	+ CALL BOSTDQ(-1,QQ,POUT,POUT)
	+ DO K=1,4
	+ PHOF(K)=POUT(K)
	+ ENDDO
	+ END
	+
	+
	+ SUBROUTINE CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
	+ $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ AMROP=1.1
	+ GAMROP=0.36
	+ AMOM=.782
	+ GAMOM=0.0084
	+C XXXXA CORRESPOND TO S2 CHANNEL !
	+ IF(MNUM.EQ.0) THEN
	+ PROB1=0.5
	+ PROB2=0.5
	+ AMRX =AMA1
	+ GAMRX=GAMA1
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ AMRB =AMRO
	+ GAMRB=GAMRO
	+ ELSEIF(MNUM.EQ.1) THEN
	+ PROB1=0.5
	+ PROB2=0.5
	+ AMRX =1.57
	+ GAMRX=0.9
	+ AMRB =AMKST
	+ GAMRB=GAMKST
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ ELSEIF(MNUM.EQ.2) THEN
	+ PROB1=0.5
	+ PROB2=0.5
	+ AMRX =1.57
	+ GAMRX=0.9
	+ AMRB =AMKST
	+ GAMRB=GAMKST
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ ELSEIF(MNUM.EQ.3) THEN
	+ PROB1=0.5
	+ PROB2=0.5
	+ AMRX =1.27
	+ GAMRX=0.3
	+ AMRA =AMKST
	+ GAMRA=GAMKST
	+ AMRB =AMKST
	+ GAMRB=GAMKST
	+ ELSEIF(MNUM.EQ.4) THEN
	+ PROB1=0.5
	+ PROB2=0.5
	+ AMRX =1.27
	+ GAMRX=0.3
	+ AMRA =AMKST
	+ GAMRA=GAMKST
	+ AMRB =AMKST
	+ GAMRB=GAMKST
	+ ELSEIF(MNUM.EQ.5) THEN
	+ PROB1=0.5
	+ PROB2=0.5
	+ AMRX =1.27
	+ GAMRX=0.3
	+ AMRA =AMKST
	+ GAMRA=GAMKST
	+ AMRB =AMRO
	+ GAMRB=GAMRO
	+ ELSEIF(MNUM.EQ.6) THEN
	+ PROB1=0.4
	+ PROB2=0.4
	+ AMRX =1.27
	+ GAMRX=0.3
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ AMRB =AMKST
	+ GAMRB=GAMKST
	+ ELSEIF(MNUM.EQ.7) THEN
	+ PROB1=0.0
	+ PROB2=1.0
	+ AMRX =1.27
	+ GAMRX=0.9
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ AMRB =AMRO
	+ GAMRB=GAMRO
	+ ELSEIF(MNUM.EQ.8) THEN
	+ PROB1=0.0
	+ PROB2=1.0
	+ AMRX =AMROP
	+ GAMRX=GAMROP
	+ AMRB =AMOM
	+ GAMRB=GAMOM
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ ELSEIF(MNUM.EQ.101) THEN
	+ PROB1=.35
	+ PROB2=.35
	+ AMRX =1.2
	+ GAMRX=.46
	+ AMRB =AMOM
	+ GAMRB=GAMOM
	+ AMRA =AMOM
	+ GAMRA=GAMOM
	+ ELSEIF(MNUM.EQ.102) THEN
	+ PROB1=0.0
	+ PROB2=0.0
	+ AMRX =1.4
	+ GAMRX=.6
	+ AMRB =AMOM
	+ GAMRB=GAMOM
	+ AMRA =AMOM
	+ GAMRA=GAMOM
	+ ELSE
	+ PROB1=0.0
	+ PROB2=0.0
	+ AMRX =AMA1
	+ GAMRX=GAMA1
	+ AMRA =AMRO
	+ GAMRA=GAMRO
	+ AMRB =AMRO
	+ GAMRB=GAMRO
	+ ENDIF
	+C
	+ IF (RR.LE.PROB1) THEN
	+ ICHAN=1
	+ ELSEIF(RR.LE.(PROB1+PROB2)) THEN
	+ ICHAN=2
	+ AX =AMRA
	+ GX =GAMRA
	+ AMRA =AMRB
	+ GAMRA=GAMRB
	+ AMRB =AX
	+ GAMRB=GX
	+ PX =PROB1
	+ PROB1=PROB2
	+ PROB2=PX
	+ ELSE
	+ ICHAN=3
	+ ENDIF
	+C
	+ PROB3=1.0-PROB1-PROB2
	+ END
	+ SUBROUTINE INITDK
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+* ----------------------------------------------------------------------
	+* INITIALISATION OF TAU DECAY PARAMETERS and routines
	+*
	+* called by : KORALZ
	+* ----------------------------------------------------------------------
	+
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+*
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
	+ COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	+ double precision BRA1,BRK0,BRK0B,BRKS
	+
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+
	+
	+
	+
	+
	+
	+ CHARACTER OLDNAMES(7)*31
	+ CHARACTER*80 bxINIT
	+ PARAMETER (
	+ $ bxINIT ='(1x,1h,g17.8, 16x, a31,a4,a4, 1x,1h)'
	+ $ )
	+ double precision PI,POL1(4)
	+*
	+*
	+* LIST OF BRANCHING RATIOS
	+CAM normalised to e nu nutau channel
	+CAM enu munu pinu rhonu A1nu Knu K*nu pi
	+CAM DATA JLIST / 1, 2, 3, 4, 5, 6, 7,
	+
	+CAM /0.1779,0.1731,0.1106,0.2530,0.1811,0.0072,0.0139
	+CAM DATA GAMPRT / 1.000,0.9732,0.6217,1.4221,1.0180,0.0405,0.0781
	+CAM DATA GAMPRT /1.000,0.9676,0.6154,1.3503,1.0225,0.0368,O.O758
	+CAM
	+C
	+C conventions of particles names
	+c
	+cam mode (JAK) 8 9
	+CAM channel pi- pi- pi0 pi+ 3pi0 pi-
	+cam particle code -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
	+CAM BR relative to electron .2414, .0601,
	+c
	+* 10 11
	+* 1 3pi+- 2pi0 5pi+-
	+* 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
	+* 1 .0281, .0045,
	+
	+* 12 13
	+* 2 5pi+- pi0 3pi+- 3pi0
	+* 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
	+* 2 .0010, .0062,
	+
	+* 14 15
	+* 3 K- pi- K+ K0 pi- KB
	+* 3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
	+* 3 .0096, .0169,
	+
	+* 16 17
	+* 4 K- pi0 K0 2pi0 K-
	+* 4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
	+* 4 .0056, .0045,
	+
	+* 18 19
	+* 5 K- pi- pi+ pi- KB pi0
	+* 5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
	+* 5 .0219, .0180,
	+
	+* 20 21
	+* 6 eta pi- pi0 pi- pi0 gamma
	+* 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
	+* 6 .0096, .0088,
	+
	+* 22 /
	+* 7 K- K0 /
	+* 7 -3, 4 /
	+* 7 .0146 /
	+C
	+ DIMENSION NOPIK(6,NMODE),NPIK(NMODE)
	+*AM outgoing multiplicity and flavors of multi-pion /multi-K modes
	+ DATA NPIK / 4, 4,
	+ 1 5, 5,
	+ 2 6, 6,
	+ 3 3, 3,
	+ 4 3, 3,
	+ 5 3, 3,
	+ 6 3, 3,
	+ 7 2 /
	+ DATA NOPIK / -1,-1, 2, 1, 0, 0, 2, 2, 2,-1, 0, 0,
	+ 1 -1,-1, 1, 2, 2, 0, -1,-1,-1, 1, 1, 0,
	+ 2 -1,-1,-1, 1, 1, 2, -1,-1, 1, 2, 2, 2,
	+ 3 -3,-1, 3, 0, 0, 0, 4,-1,-4, 0, 0, 0,
	+ 4 -3, 2, 4, 0, 0, 0, 2, 2,-3, 0, 0, 0,
	+ 5 -3,-1, 1, 0, 0, 0, -1,-4, 2, 0, 0, 0,
	+ 6 9,-1, 2, 0, 0, 0, -1, 2, 8, 0, 0, 0,
	+ 7 -3, 4, 0, 0, 0, 0 /
	+* LIST OF BRANCHING RATIOS
	+ NCHAN = NMODE + 7
	+ DO 1 I = 1,30
	+ IF (I.LE.NCHAN) THEN
	+ JLIST(I) = I
	+ IF(I.EQ. 1) GAMPRT(I) = 1.0000
	+ IF(I.EQ. 2) GAMPRT(I) = .9732
	+ IF(I.EQ. 3) GAMPRT(I) = .6217
	+ IF(I.EQ. 4) GAMPRT(I) = 1.4221
	+ IF(I.EQ. 5) GAMPRT(I) = 1.0180
	+ IF(I.EQ. 6) GAMPRT(I) = .0405
	+ IF(I.EQ. 7) GAMPRT(I) = .0781
	+ IF(I.EQ. 8) GAMPRT(I) = .2414
	+ IF(I.EQ. 9) GAMPRT(I) = .0601
	+ IF(I.EQ.10) GAMPRT(I) = .0281
	+ IF(I.EQ.11) GAMPRT(I) = .0045
	+ IF(I.EQ.12) GAMPRT(I) = .0010
	+ IF(I.EQ.13) GAMPRT(I) = .0062
	+ IF(I.EQ.14) GAMPRT(I) = .0096
	+ IF(I.EQ.15) GAMPRT(I) = .0169
	+ IF(I.EQ.16) GAMPRT(I) = .0056
	+ IF(I.EQ.17) GAMPRT(I) = .0045
	+ IF(I.EQ.18) GAMPRT(I) = .0219
	+ IF(I.EQ.19) GAMPRT(I) = .0180
	+ IF(I.EQ.20) GAMPRT(I) = .0096
	+ IF(I.EQ.21) GAMPRT(I) = .0088
	+ IF(I.EQ.22) GAMPRT(I) = .0146
	+ IF(I.EQ. 1) OLDNAMES(I)=' TAU- --> E- '
	+ IF(I.EQ. 2) OLDNAMES(I)=' TAU- --> MU- '
	+ IF(I.EQ. 3) OLDNAMES(I)=' TAU- --> PI- '
	+ IF(I.EQ. 4) OLDNAMES(I)=' TAU- --> PI-, PI0 '
	+ IF(I.EQ. 5) OLDNAMES(I)=' TAU- --> A1- (two subch) '
	+ IF(I.EQ. 6) OLDNAMES(I)=' TAU- --> K- '
	+ IF(I.EQ. 7) OLDNAMES(I)=' TAU- --> K*- (two subch) '
	+ IF(I.EQ. 8) NAMES(I-7)=' TAU- --> 2PI-, PI0, PI+ '
	+ IF(I.EQ. 9) NAMES(I-7)=' TAU- --> 3PI0, PI- '
	+ IF(I.EQ.10) NAMES(I-7)=' TAU- --> 2PI-, PI+, 2PI0 '
	+ IF(I.EQ.11) NAMES(I-7)=' TAU- --> 3PI-, 2PI+, '
	+ IF(I.EQ.12) NAMES(I-7)=' TAU- --> 3PI-, 2PI+, PI0 '
	+ IF(I.EQ.13) NAMES(I-7)=' TAU- --> 2PI-, PI+, 3PI0 '
	+ IF(I.EQ.14) NAMES(I-7)=' TAU- --> K-, PI-, K+ '
	+ IF(I.EQ.15) NAMES(I-7)=' TAU- --> K0, PI-, K0B '
	+ IF(I.EQ.16) NAMES(I-7)=' TAU- --> K- PI0 K0 '
	+ IF(I.EQ.17) NAMES(I-7)=' TAU- --> PI0 PI0 K- '
	+ IF(I.EQ.18) NAMES(I-7)=' TAU- --> K- PI- PI+ '
	+ IF(I.EQ.19) NAMES(I-7)=' TAU- --> PI- K0B PI0 '
	+ IF(I.EQ.20) NAMES(I-7)=' TAU- --> ETA PI- PI0 '
	+ IF(I.EQ.21) NAMES(I-7)=' TAU- --> PI- PI0 GAM '
	+ IF(I.EQ.22) NAMES(I-7)=' TAU- --> K- K0 '
	+ ELSE
	+ JLIST(I) = 0
	+ GAMPRT(I) = 0.
	+ ENDIF
	+ 1 CONTINUE
	+ DO I=1,NMODE
	+ MULPIK(I)=NPIK(I)
	+ DO J=1,MULPIK(I)
	+ IDFFIN(J,I)=NOPIK(J,I)
	+ ENDDO
	+ ENDDO
	+*
	+*
	+* --- COEFFICIENTS TO FIX RATIO OF:
	+* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
	+* --- PROBABILITY OF K0 TO BE KS
	+* --- PROBABILITY OF K0B TO BE KS
	+* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
	+* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
	+* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
	+* --- NEGLECTS MASS-PHASE SPACE EFFECTS
	+ BRA1=0.5
	+ BRK0=0.5
	+ BRK0B=0.5
	+ BRKS=0.6667
	+*
	+
	+ GFERMI = 1.16637E-5
	+ CCABIB = 0.975
	+ GV = 1.0
	+ GA =-1.0
	+
	+
	+
	+* ZW 13.04.89 HERE WAS AN ERROR
	+ SCABIB = SQRT(1.-CCABIB**2)
	+ PI =4.*ATAN(1.)
	+ GAMEL = GFERMI*2AMTAU*5/(192PI**3)
	+*
	+ CALL DEXAY(-1,POL1)
	+*
	+ RETURN
	+ END
	+ double precision FUNCTION DCDMAS(IDENT)
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+*
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ IF (IDENT.EQ. 1) THEN
	+ APKMAS=AMPI
	+ ELSEIF (IDENT.EQ.-1) THEN
	+ APKMAS=AMPI
	+ ELSEIF (IDENT.EQ. 2) THEN
	+ APKMAS=AMPIZ
	+ ELSEIF (IDENT.EQ.-2) THEN
	+ APKMAS=AMPIZ
	+ ELSEIF (IDENT.EQ. 3) THEN
	+ APKMAS=AMK
	+ ELSEIF (IDENT.EQ.-3) THEN
	+ APKMAS=AMK
	+ ELSEIF (IDENT.EQ. 4) THEN
	+ APKMAS=AMKZ
	+ ELSEIF (IDENT.EQ.-4) THEN
	+ APKMAS=AMKZ
	+ ELSEIF (IDENT.EQ. 8) THEN
	+ APKMAS=0.0001
	+ ELSEIF (IDENT.EQ.-8) THEN
	+ APKMAS=0.0001
	+ ELSEIF (IDENT.EQ. 9) THEN
	+ APKMAS=0.5488
	+ ELSEIF (IDENT.EQ.-9) THEN
	+ APKMAS=0.5488
	+ ELSE
	+ PRINT *, 'STOP IN APKMAS, WRONG IDENT=',IDENT
	+ STOP
	+ ENDIF
	+ DCDMAS=APKMAS
	+ END
	+ integer FUNCTION LUNPIK(ID,ISGN)
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	+ double precision BRA1,BRK0,BRK0B,BRKS
	+ double precision XIO(1)
	+ IDENT=ID*ISGN
	+ IF (IDENT.EQ. 1) THEN
	+ IPKDEF= 211
	+ ELSEIF (IDENT.EQ.-1) THEN
	+ IPKDEF=-211
	+ ELSEIF (IDENT.EQ. 2) THEN
	+ IPKDEF= 111
	+ ELSEIF (IDENT.EQ.-2) THEN
	+ IPKDEF= 111
	+ ELSEIF (IDENT.EQ. 3) THEN
	+ IPKDEF= 321
	+ ELSEIF (IDENT.EQ.-3) THEN
	+ IPKDEF=-321
	+ ELSEIF (IDENT.EQ. 4) THEN
	+*
	+* K0 --> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
	+ CALL RANMAR(XIO,1)
	+ IF (XIO(1).GT.BRK0) THEN
	+ IPKDEF= 130
	+ ELSE
	+ IPKDEF= 310
	+ ENDIF
	+ ELSEIF (IDENT.EQ.-4) THEN
	+*
	+* K0B--> K0_LONG (IS 130) / K0_SHORT (IS 310) = 1/1
	+ CALL RANMAR(XIO,1)
	+ IF (XIO(1).GT.BRK0B) THEN
	+ IPKDEF= 130
	+ ELSE
	+ IPKDEF= 310
	+ ENDIF
	+ ELSEIF (IDENT.EQ. 8) THEN
	+ IPKDEF= 22
	+ ELSEIF (IDENT.EQ.-8) THEN
	+ IPKDEF= 22
	+ ELSEIF (IDENT.EQ. 9) THEN
	+ IPKDEF= 221
	+ ELSEIF (IDENT.EQ.-9) THEN
	+ IPKDEF= 221
	+ ELSE
	+ PRINT *, 'STOP IN IPKDEF, WRONG IDENT=',IDENT
	+ STOP
	+ ENDIF
	+ LUNPIK=IPKDEF
	+ END
	+
	+
	+
	+ SUBROUTINE TAURDF(KTO)
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+* THIS ROUTINE CAN BE CALLED BEFORE ANY TAU+ OR TAU- EVENT IS GENERATED
	+* IT CAN BE USED TO GENERATE TAU+ AND TAU- SAMPLES OF DIFFERENT
	+* CONTENTS
	+ COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	+ double precision BRA1,BRK0,BRK0B,BRKS
	+ COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
	+ IF (KTO.EQ.1) THEN
	+* ==================
	+* LIST OF BRANCHING RATIOS
	+ NCHAN = 19
	+ DO 1 I = 1,30
	+ IF (I.LE.NCHAN) THEN
	+ JLIST(I) = I
	+ IF(I.EQ. 1) GAMPRT(I) = .0000
	+ IF(I.EQ. 2) GAMPRT(I) = .0000
	+ IF(I.EQ. 3) GAMPRT(I) = .0000
	+ IF(I.EQ. 4) GAMPRT(I) = .0000
	+ IF(I.EQ. 5) GAMPRT(I) = .0000
	+ IF(I.EQ. 6) GAMPRT(I) = .0000
	+ IF(I.EQ. 7) GAMPRT(I) = .0000
	+ IF(I.EQ. 8) GAMPRT(I) = 1.0000
	+ IF(I.EQ. 9) GAMPRT(I) = 1.0000
	+ IF(I.EQ.10) GAMPRT(I) = 1.0000
	+ IF(I.EQ.11) GAMPRT(I) = 1.0000
	+ IF(I.EQ.12) GAMPRT(I) = 1.0000
	+ IF(I.EQ.13) GAMPRT(I) = 1.0000
	+ IF(I.EQ.14) GAMPRT(I) = 1.0000
	+ IF(I.EQ.15) GAMPRT(I) = 1.0000
	+ IF(I.EQ.16) GAMPRT(I) = 1.0000
	+ IF(I.EQ.17) GAMPRT(I) = 1.0000
	+ IF(I.EQ.18) GAMPRT(I) = 1.0000
	+ IF(I.EQ.19) GAMPRT(I) = 1.0000
	+ ELSE
	+ JLIST(I) = 0
	+ GAMPRT(I) = 0.
	+ ENDIF
	+ 1 CONTINUE
	+* --- COEFFICIENTS TO FIX RATIO OF:
	+* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
	+* --- PROBABILITY OF K0 TO BE KS
	+* --- PROBABILITY OF K0B TO BE KS
	+* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
	+* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
	+* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
	+* --- NEGLECTS MASS-PHASE SPACE EFFECTS
	+ BRA1=0.5
	+ BRK0=0.5
	+ BRK0B=0.5
	+ BRKS=0.6667
	+ ELSE
	+* ====
	+* LIST OF BRANCHING RATIOS
	+ NCHAN = 19
	+ DO 2 I = 1,30
	+ IF (I.LE.NCHAN) THEN
	+ JLIST(I) = I
	+ IF(I.EQ. 1) GAMPRT(I) = .0000
	+ IF(I.EQ. 2) GAMPRT(I) = .0000
	+ IF(I.EQ. 3) GAMPRT(I) = .0000
	+ IF(I.EQ. 4) GAMPRT(I) = .0000
	+ IF(I.EQ. 5) GAMPRT(I) = .0000
	+ IF(I.EQ. 6) GAMPRT(I) = .0000
	+ IF(I.EQ. 7) GAMPRT(I) = .0000
	+ IF(I.EQ. 8) GAMPRT(I) = 1.0000
	+ IF(I.EQ. 9) GAMPRT(I) = 1.0000
	+ IF(I.EQ.10) GAMPRT(I) = 1.0000
	+ IF(I.EQ.11) GAMPRT(I) = 1.0000
	+ IF(I.EQ.12) GAMPRT(I) = 1.0000
	+ IF(I.EQ.13) GAMPRT(I) = 1.0000
	+ IF(I.EQ.14) GAMPRT(I) = 1.0000
	+ IF(I.EQ.15) GAMPRT(I) = 1.0000
	+ IF(I.EQ.16) GAMPRT(I) = 1.0000
	+ IF(I.EQ.17) GAMPRT(I) = 1.0000
	+ IF(I.EQ.18) GAMPRT(I) = 1.0000
	+ IF(I.EQ.19) GAMPRT(I) = 1.0000
	+ ELSE
	+ JLIST(I) = 0
	+ GAMPRT(I) = 0.
	+ ENDIF
	+ 2 CONTINUE
	+* --- COEFFICIENTS TO FIX RATIO OF:
	+* --- A1 3CHARGED/ A1 1CHARGED 2 NEUTRALS MATRIX ELEMENTS (MASLESS LIM.)
	+* --- PROBABILITY OF K0 TO BE KS
	+* --- PROBABILITY OF K0B TO BE KS
	+* --- RATIO OF COEFFICIENTS FOR K*--> K0 PI-
	+* --- ALL COEFFICENTS SHOULD BE IN THE RANGE (0.0,1.0)
	+* --- THEY MEANING IS PROBABILITY OF THE FIRST CHOICE ONLY IF ONE
	+* --- NEGLECTS MASS-PHASE SPACE EFFECTS
	+ BRA1=0.5
	+ BRK0=0.5
	+ BRK0B=0.5
	+ BRKS=0.6667
	+ ENDIF
	+* =====
	+ END
	+
	+ SUBROUTINE INIPHX(XK00)
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+* ----------------------------------------------------------------------
	+* INITIALISATION OF PARAMETERS
	+* USED IN QED and/or GSW ROUTINES
	+* ----------------------------------------------------------------------
	+ COMMON / QEDPRM /ALFINV,ALFPI,XK0
	+ double precision ALFINV,ALFPI,XK0
	+ double precision PI8,XK00
	+*
	+ PI8 = 4.D0*DATAN(1.D0)
	+ ALFINV = 137.03604D0
	+ ALFPI = 1D0/(ALFINV*PI8)
	+ XK0=XK00
	+ END
	+
	+ SUBROUTINE INIMAS
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+C ----------------------------------------------------------------------
	+C INITIALISATION OF MASSES
	+C
	+C called by : KORALZ
	+C ----------------------------------------------------------------------
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+*
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+C IN-COMING / OUT-GOING FERMION MASSES
	+ AMTAU = 1.7842
	+C --- tau mass must be the same as in the host program, what-so-ever
	+ AMTAU = 1.777
	+ AMNUTA = 0.010
	+ AMEL = 0.0005111
	+ AMNUE = 0.0
	+ AMMU = 0.105659
	+ AMNUMU = 0.0
	+*
	+* MASSES USED IN TAU DECAYS
	+ AMPIZ = 0.134964
	+ AMPI = 0.139568
	+ AMRO = 0.7714
	+ GAMRO = 0.153
	+cam AMRO = 0.773
	+cam GAMRO = 0.145
	+ AMA1 = 1.251! PMAS(LUCOMP(ia1),1) ! AMA1 = 1.251
	+ GAMA1 = 0.599! PMAS(LUCOMP(ia1),2) ! GAMA1 = 0.599
	+ print *,'INIMAS a1 mass= ',ama1,gama1
	+ AMK = 0.493667
	+ AMKZ = 0.49772
	+ AMKST = 0.8921
	+ GAMKST = 0.0513
	+
	+ RETURN
	+ END
	+ subroutine bostdq(idir,vv,pp,q)
	+* *******************************
	+c Boost along arbitrary vector v (see eg. J.D. Jacson, Classical
	+c Electrodynamics).
	+c Four-vector pp is boosted from an actual frame to the rest frame
	+c of the four-vector v (for idir=1) or back (for idir=-1).
	+c q is a resulting four-vector.
	+c Note: v must be time-like, pp may be arbitrary.
	+c
	+c Written by: Wieslaw Placzek date: 22.07.1994
	+c Last update: 3/29/95 by: M.S.
	+c
	+ implicit DOUBLE PRECISION (a-h,o-z)
	+ parameter (nout=6)
	+ DOUBLE PRECISION v(4),p(4),q(4),pp(4),vv(4)
	+ save
	+!
	+ do 1 i=1,4
	+ v(i)=vv(i)
	+ 1 p(i)=pp(i)
	+ amv=(v(4)2-v(1)2-v(2)2-v(3)2)
	+ if (amv.le.0d0) then
	+ write(6,) 'bostdq: warning amv*2=',amv
	+ write(6,*) 'Skipping boost'
	+ q(1:4) = p(1:4)
	+ else
	+ amv=sqrt(abs(amv))
	+ if (idir.eq.-1) then
	+ q(4)=( p(1)v(1)+p(2)v(2)+p(3)v(3)+p(4)v(4))/amv
	+ wsp =(q(4)+p(4))/(v(4)+amv)
	+ elseif (idir.eq.1) then
	+ q(4)=(-p(1)v(1)-p(2)v(2)-p(3)v(3)+p(4)v(4))/amv
	+ wsp =-(q(4)+p(4))/(v(4)+amv)
	+ else
	+ write(nout,*)' >>> boostv: wrong value of idir = ',idir
	+ endif
	+ q(1)=p(1)+wsp*v(1)
	+ q(2)=p(2)+wsp*v(2)
	+ q(3)=p(3)+wsp*v(3)
	+ endif
	+ end
	+
	+ double precision FUNCTION DILOGY(X)
	+C *****************
	+ IMPLICIT double precision(A-H,O-Z)
	+CERN C304 VERSION 29/07/71 DILOG 59 C
	+ Z=-1.64493406684822
	+ IF(X .LT.-1.0) GO TO 1
	+ IF(X .LE. 0.5) GO TO 2
	+ IF(X .EQ. 1.0) GO TO 3
	+ IF(X .LE. 2.0) GO TO 4
	+ Z=3.2898681336964
	+ 1 T=1.0/X
	+ S=-0.5
	+ Z=Z-0.5* LOG(ABS(X))**2
	+ GO TO 5
	+ 2 T=X
	+ S=0.5
	+ Z=0.
	+ GO TO 5
	+ 3 DILOGY=1.64493406684822
	+ RETURN
	+ 4 T=1.0-X
	+ S=-0.5
	+ Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
	+ 5 Y=2.66666666666666 *T+0.66666666666666
	+ B= 0.00000 00000 00001
	+ A=Y*B +0.00000 00000 00004
	+ B=Y*A-B+0.00000 00000 00011
	+ A=Y*B-A+0.00000 00000 00037
	+ B=Y*A-B+0.00000 00000 00121
	+ A=Y*B-A+0.00000 00000 00398
	+ B=Y*A-B+0.00000 00000 01312
	+ A=Y*B-A+0.00000 00000 04342
	+ B=Y*A-B+0.00000 00000 14437
	+ A=Y*B-A+0.00000 00000 48274
	+ B=Y*A-B+0.00000 00001 62421
	+ A=Y*B-A+0.00000 00005 50291
	+ B=Y*A-B+0.00000 00018 79117
	+ A=Y*B-A+0.00000 00064 74338
	+ B=Y*A-B+0.00000 00225 36705
	+ A=Y*B-A+0.00000 00793 87055
	+ B=Y*A-B+0.00000 02835 75385
	+ A=Y*B-A+0.00000 10299 04264
	+ B=Y*A-B+0.00000 38163 29463
	+ A=Y*B-A+0.00001 44963 00557
	+ B=Y*A-B+0.00005 68178 22718
	+ A=Y*B-A+0.00023 20021 96094
	+ B=Y*A-B+0.00100 16274 96164
	+ A=Y*B-A+0.00468 63619 59447
	+ B=Y*A-B+0.02487 93229 24228
	+ A=Y*B-A+0.16607 30329 27855
	+ A=Y*A-B+1.93506 43008 6996
	+ DILOGY=ST(A-B)+Z
	+ RETURN
	+C=======================================================================
	+C===================END OF CPC PART ====================================
	+C=======================================================================
	+ END
	Index: trunk/contrib/tauola/tauface-jetset.f
	===================================================================
	--- trunk/contrib/tauola/tauface-jetset.f (revision 0)
	+++ trunk/contrib/tauola/tauface-jetset.f (revision 8889)
	@@ -0,0 +1,1744 @@
	+ SUBROUTINE TAUOLA(MODE,KEYPOL)
	+C *************************************
	+C general tauola interface, should work in every case until
	+C hepevt is OK, does not check if hepevt is 'clean'
	+C in particular will decay decayed taus...
	+C only longitudinal spin effects are included.
	+C in W decay v-a vertex is assumed
	+C date: 12 DEC 1998. date: 21 June 1999. date: 24 Jan 2001 date: 24 Aug 2001
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ IMPLICIT double precision(A-H,O-Z)
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+ COMMON /TAUPOS/ NP1, NP2
	+ double precision PHOI(4),PHOF(4)
	+ double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
	+ COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
	+* tauola, photos and jetset overall switches
	+ COMMON /LIBRA/ JAK1,JAK2,ITDKRC,IFPHOT,IFHADM,IFHADP
	+ double precision RRR(1)
	+ LOGICAL IFPSEUDO
	+ common /pseudocoup/ csc,ssc
	+ double precision csc,ssc
	+ save pseudocoup
	+ COMMON / INOUT / INUT,IOUT
	+
	+ double precision PLZAPX
	+
	+C to switch tau polarization OFF in taus
	+ DIMENSION POL1(4), POL2(4)
	+ double precision POL1x(4), POL2x(4)
	+ INTEGER ION(3)
	+ DATA POL1 /0.0D0,0.0D0,0.0D0,0.0D0/
	+ DATA POL2 /0.0D0,0.0D0,0.0D0,0.0D0/
	+ DATA PI /3.141592653589793238462643D0/
	+
	+C store decay vertexes
	+ DIMENSION IMOTHER (20)
	+ INTEGER KFHIGGS(3)
	+
	+C store daughter pointers
	+ INTEGER ISON
	+ COMMON /ISONS_TAU/ISON(2)
	+ SAVE /ISONS_TAU/
	+
	+ INTEGER NCN,NCNMX
	+ DATA NCN/0/
	+ DATA NCNMX/50/
	+ SAVE NCN,NCNMX
	+ IF(MODE.EQ.-1) THEN
	+C ***********************
	+
	+ JAK1 = 0 ! decay mode first tau
	+ JAK2 = 0 ! decay mode second tau
	+ ITDKRC=1.0 ! switch of radiative corrections in decay
	+ IFPHOT=1.0 ! PHOTOS switch
	+ IFHADM=1.0
	+ IFHADP=1.0
	+ POL=1.0 ! tau polarization dipswitch must be 1 or 0
	+
	+ KFHIGGS(1) = 25
	+ KFHIGGS(2) = 35
	+ KFHIGGS(3) = 36
	+ KFHIGCH = 37
	+ KFZ0 = 23
	+ KFGAM = 22
	+ KFTAU = 15
	+ KFNUE = 16
	+C couplings of the 'pseudoscalar higgs' as in CERN-TH/2003-166
	+ psi=0.5PI ! 0.15PI
	+ xmtau=1.777 ! tau mass
	+ xmh=120 ! higgs boson mass
	+ betah=sqrt(1d0-4xmtau2/xmh*2)
	+ csc=cos(psi)*betah
	+ ssc=sin(psi)
	+C write(,) ' scalar component=',csc,' pseudo-scalar component=',ssc
	+ IF (IFPHOT.EQ.1) CALL PHOINI ! this if PHOTOS was not initialized earlier
	+ CALL INIETC(JAK1,JAK2,ITDKRC,IFPHOT)
	+ CALL INIMAS
	+ CALL INIPHX(0.01d0)
	+ CALL INITDK
	+C activation of pi0 and eta decays: (1) means on, (0) off
	+ ION(1)=0
	+ ION(2)=0
	+ ION(3)=0
	+ CALL TAUPI0(-1,1,ION)
	+ CALL DEKAY(-1,POL1x)
	+ WRITE(IOUT,7001) pol,psi,ION(1),ION(2),ION(3)
	+ ELSEIF(MODE.EQ.0) THEN
	+C ***********************
	+ NCN=NCN+1
	+C
	+C..... find tau-s and fill common block /TAUPOS/
	+C this is to avoid LUND history fillings. This call is optional
	+ CALL PHYFIX(NSTOP,NSTART)
	+C clear mothers of the previous event
	+! print *, " tauola point 001 nstart,nhep= ", nstart,nhep
	+ DO II=1,20
	+ IMOTHER(II)=0
	+ ENDDO
	+
	+ DO II=1,2
	+ ISON(II)=0
	+ ENDDO
	+C ... and to find mothers giving taus.
	+ NDEC = 0
	+C(BPK)--> LOOK FOR MOTHER, CHECK THAT IT IS NOT THE HISTORY ENTRY (E.G. MSTP(128)=0)
	+ DO I=NSTART,NHEP
	+ IF(ABS(IDHEP(I)).EQ.KFTAU.AND.ISTHEP(I).EQ.1.AND.
	+ $ (ISTHEP(I).GE.125.OR.ISTHEP(I).LT.120)) THEN
	+ IMOTH=JMOHEP(1,I)
	+ DO WHILE (ABS(IDHEP(IMOTH)).EQ.KFTAU) ! KEEP WALKING UP
	+ IMOTH=JMOHEP(1,IMOTH)
	+ ENDDO
	+ IF (ISTHEP(IMOTH).EQ.3.OR.
	+ $ (ISTHEP(IMOTH).GE.120.AND.ISTHEP(IMOTH).LE.125)) THEN
	+ DO J=NSTART,NHEP ! WE HAVE WALKED INTO HARD RECORD
	+ IF (IDHEP(J).EQ.IDHEP(IMOTH).AND.
	+ $ JMOHEP(1,J).EQ.IMOTH.AND.
	+ $ ISTHEP(J).EQ.2) THEN
	+ JMOTH=J
	+ GOTO 66
	+ ENDIF
	+ ENDDO
	+ ELSE
	+ JMOTH=IMOTH
	+ ENDIF
	+ 66 CONTINUE
	+ DO II=1,NDEC
	+ IF(JMOTH.EQ.IMOTHER(II)) GOTO 9999
	+ ENDDO
	+C(BPK)--<
	+ NDEC=NDEC+1
	+ IMOTHER(NDEC)= JMOTH
	+ ENDIF
	+ 9999 CONTINUE
	+ ENDDO
	+
	+C ... taus of every mother are treated in this main loop
	+ DO II=1,NDEC
	+ IM=IMOTHER(II)
	+ NCOUNT=0
	+ NP1=0
	+ NP2=0
	+
	+
	+C(BPK)-->
	+C CORRECTING HEPEVT IS OUT OF QUESTION AT THIS POINT..
	+ IM0=IM
	+ IF (IDHEP(JMOHEP(1,IM0)).EQ.IDHEP(IM0)) IM0=JMOHEP(1,IM0)
	+ ISEL=-1
	+ DO I=NSTART,NHEP
	+ IF (ISTHEP(I).EQ.3.OR.
	+ $ (ISTHEP(I).GE.120.AND.ISTHEP(I).LE.125)) THEN ! HARD RECORD
	+ GOTO 76
	+ ENDIF
	+ IMOTH=JMOHEP(1,I)
	+ DO WHILE (IDHEP(IMOTH).EQ.IDHEP(I).OR.
	+ $ ABS(IDHEP(IMOTH)).EQ.KFTAU) ! KEEP WALKING UP
	+ IMOTH=JMOHEP(1,IMOTH)
	+ ENDDO
	+ IF ((IMOTH.EQ.IM0.OR.IMOTH.EQ.IM).AND.ISEL.EQ.-1) THEN
	+ ISON(1)=I
	+ ISEL=0
	+ ELSEIF ((IMOTH.EQ.IM0.OR.IMOTH.EQ.IM).AND.ISEL.EQ.0) THEN
	+ ISON(2)=I
	+ ELSEIF ((IMOTH.NE.IM0.AND.IMOTH.NE.IM).AND.ISEL.EQ.0) THEN
	+ ISEL=1
	+ GOTO 77
	+ ENDIF
	+ 76 CONTINUE
	+ ENDDO
	+ 77 CONTINUE
	+C(BPK)--<
	+
	+
	+C ... we correct HEPEVT (fix developped with Catherine BISCARAT)
	+c IF (JDAHEP(2,IM).EQ.0) THEN ! ID of second daughter was missing
	+c ISECU=1
	+c DO I=JDAHEP(1,IM)+1,NHEP ! OK lets look for it
	+c IF (JMOHEP(1,I).EQ.IM.AND.ISECU.EQ.1) THEN ! we have found one
	+c JDAHEP(2,IM)=I
	+c ELSEIF (JMOHEP(1,I).EQ.IM.AND.ISECU.NE.1) THEN ! we have found one after there
	+c JDAHEP(2,IM)=0 ! was something else, lets kill game
	+c ENDIF
	+c IF (JMOHEP(1,I).NE.IM) ISECU=0 ! other stuff starts
	+c ENDDO
	+c ENDIF
	+
	+C ... we check whether there are just two or more tau-likes
	+ DO I=ISON(1),ISON(2)
	+ IF(IDHEP(I).EQ.-KFTAU.OR.IDHEP(I).EQ.-KFNUE) NCOUNT=NCOUNT+1
	+ IF(IDHEP(I).EQ. KFTAU.OR.IDHEP(I).EQ. KFNUE) NCOUNT=NCOUNT+1
	+ ENDDO
	+
	+C ... if there will be more we will come here again
	+ 666 CONTINUE
	+
	+C(BPK)-->
	+ DO I=MAX(NP1+1,ISON(1)),ISON(2)
	+C(BPK)--<
	+ IF(IDHEP(I).EQ.-KFTAU.OR.IDHEP(I).EQ.-KFNUE) NP1=I
	+ ENDDO
	+C(BPK)-->
	+ DO I=MAX(NP2+1,ISON(1)),ISON(2)
	+C(BPK)--<
	+ IF(IDHEP(I).EQ. KFTAU.OR.IDHEP(I).EQ. KFNUE) NP2=I
	+ ENDDO
	+ DO I=1,4
	+ P1(I)= PHEP(I,NP1) !momentum of tau+
	+ P2(I)= PHEP(I,NP2) !momentum of tau-
	+ Q1(I)= P1(I)+P2(I)
	+ ENDDO
	+
	+ POL1(3)= 0D0
	+ POL2(3)= 0D0
	+
	+ IF(KEYPOL.EQ.1) THEN
	+c.....include polarisation effect
	+ CALL RANMAR(RRR,1)
	+
	+ IF(IDHEP(IM).EQ.KFHIGGS(1).OR.IDHEP(IM).EQ.KFHIGGS(2).OR.
	+ $ IDHEP(IM).EQ.KFHIGGS(3)) THEN ! case of Higgs
	+ IF(RRR(1).LT.0.5) THEN
	+ POL1(3)= POL
	+ POL2(3)=-POL
	+ ELSE
	+ POL1(3)=-POL
	+ POL2(3)= POL
	+ ENDIF
	+ ELSEIF((IDHEP(IM).EQ.KFZ0).OR.(IDHEP(IM).EQ.KFGAM)) THEN ! case of gamma/Z
	+C there is no angular dependence in gamma/Z polarization
	+C there is no s-dependence in gamma/Z polarization at all
	+C there is even no Z polarization in any form
	+C main reason is that nobody asked ...
	+C but it is prepared and longitudinal correlations
	+C can be included up to KORALZ standards
	+
	+ POLZ0=PLZAPX(.true.,IM,NP1,NP2)
	+ IF(RRR(1).LT.POLZ0) THEN
	+ POL1(3)= POL
	+ POL2(3)= POL
	+ ELSE
	+ POL1(3)=-POL
	+ POL2(3)=-POL
	+ ENDIF
	+ ELSEIF(IDHEP(NP1).EQ.-IDHEP(NP2))THEN ! undef orig. only s-dep poss.
	+ POLZ0=PLZAPX(.true.,IM,NP1,NP2)
	+ IF(RRR(1).LT.POLZ0) THEN
	+ POL1(3)= POL
	+ POL2(3)= POL
	+ ELSE
	+ POL1(3)=-POL
	+ POL2(3)=-POL
	+ ENDIF
	+ if(ncn.le.ncnmx) print *,
	+ & " rrr(1),polz0,pol1(3),pol2(3)= ",
	+ & rrr(1),polz0,pol1(3),pol2(3)
	+ ELSEIF(ABS(IDHEP(IM)).EQ.KFHIGCH) THEN ! case of charged Higgs
	+ POL1(3)= POL
	+ POL2(3)= POL
	+ ELSE ! case of W+ or W-
	+ POL1(3)= -POL
	+ POL2(3)= -POL
	+ ENDIF
	+c.....include polarisation effect
	+ ENDIF
	+
	+ IF(IDHEP(IM).EQ.KFHIGGS(1).OR.IDHEP(IM).EQ.KFHIGGS(2).OR.
	+ $ IDHEP(IM).EQ.KFHIGGS(3)) THEN
	+ IF(IDHEP(NP1).EQ.-KFTAU .AND.
	+ $ (JDAHEP(1,NP1).LE.NP1.OR.JDAHEP(1,NP1).GT.NHEP) .AND.
	+ $ IDHEP(NP2).EQ. KFTAU .AND.
	+ $ (JDAHEP(1,NP2).LE.NP2.OR.JDAHEP(1,NP2).GT.NHEP)
	+ $ ) THEN
	+ IF (IDHEP(IM).EQ.KFHIGGS(1)) THEN
	+ IFPSEUDO= .FALSE.
	+ ELSEIF (IDHEP(IM).EQ.KFHIGGS(2)) THEN
	+ IFPSEUDO= .FALSE.
	+ ELSEIF (IDHEP(IM).EQ.KFHIGGS(3)) THEN
	+ IFPSEUDO= .TRUE.
	+ ELSE
	+ WRITE(,) 'Warning from TAUOLA:'
	+ WRITE(,) 'I stop this run, wrong IDHEP(IM)=',
	+ $ IDHEP(IM)
	+ STOP
	+ ENDIF
	+ CALL SPINHIGGS(IM,NP1,NP2,IFPSEUDO,Pol1,Pol2)
	+ IF (IFPHOT.EQ.1) CALL PHOTOS(IM) ! Bremsstrahlung in Higgs decay
	+ ! AFTER adding taus !!
	+
	+
	+ ENDIF
	+ ELSE
	+ IF(IDHEP(NP1).EQ.-KFTAU.AND.
	+ $ (JDAHEP(1,NP1).LE.NP1.OR.JDAHEP(1,NP1).GT.NHEP)) THEN
	+C here check on if NP1 was not decayed should be verified
	+ CALL DEXAY(1,POL1)
	+ IF (IFPHOT.EQ.1) CALL PHOTOS(NP1)
	+ CALL TAUPI0(0,1,ION)
	+ ENDIF
	+
	+ IF(IDHEP(NP2).EQ. KFTAU.AND.
	+ $ (JDAHEP(1,NP2).LE.NP2.OR.JDAHEP(1,NP2).GT.NHEP)) THEN
	+C here check on if NP2 was not decayed should be added
	+ CALL DEXAY(2,POL2)
	+ IF (IFPHOT.EQ.1) CALL PHOTOS(NP2)
	+ CALL TAUPI0(0,2,ION)
	+ ENDIF
	+ ENDIF
	+ NCOUNT=NCOUNT-2
	+ IF (NCOUNT.GT.0) GOTO 666
	+ ENDDO
	+
	+ ELSEIF(MODE.EQ.1) THEN
	+C ***********************
	+C
	+ CALL DEXAY(100,POL1)
	+ CALL DEKAY(100,POL1x)
	+ WRITE(IOUT,7002)
	+ ENDIF
	+C *****
	+ 7001 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'**TAUOLA UNIVERSAL INTERFACE: ***',9X,1H,
	+ $ /,' ', 25X,'**VERSION 1.21, September 2005***',9X,1H,
	+ $ /,' ', 25X,'AUTHORS: P. Golonka, B. Kersevan, *',9X,1H,
	+ $ /,' ', 25X,'T. Pierzchala, E. Richter-Was, ****',9X,1H,
	+ $ /,' ', 25X,'*** Z. Was, M. Worek ************',9X,1H,
	+ $ /,' ', 25X,'USEFUL DISCUSSIONS, IN PARTICULAR *',9X,1H,
	+ $ /,' ', 25X,'WITH C. Biscarat and S. Slabospitzky*',9X,1H,
	+ $ /,' ', 25X,'*** are warmly acknowledged *****',9X,1H,
	+ $ /,' ', 25X,' ',9X,1H,
	+ $ /,' ', 25X,'******* INITIALIZATION *********',9X,1H,
	+ $ /,' ',F20.5,5X,'tau polarization switch must be 1 or 0 ',9X,1H,
	+ $ /,' ',F20.5,5X,'Higs scalar/pseudo mix CERN-TH/2003-166',9X,1H,
	+ $ /,' ',I10, 15X,'PI0 decay switch must be 1 or 0 ',9X,1H,
	+ $ /,' ',I10, 15X,'ETA decay switch must be 1 or 0 ',9X,1H,
	+ $ /,' ',I10, 15X,'K0S decay switch must be 1 or 0 ',9X,1H,
	+ $ /,1X,15(5H*****)/)
	+
	+ 7002 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'**TAUOLA UNIVERSAL INTERFACE: ***',9X,1H,
	+ $ /,' ', 25X,'**VERSION 1.21, September2005 ***',9X,1H,
	+ $ /,' ', 25X,'AUTHORS: P. Golonka, B. Kersevan, *',9X,1H,
	+ $ /,' ', 25X,'T. Pierzchala, E. Richter-Was, ****',9X,1H,
	+ $ /,' ', 25X,'*** Z. Was, M. Worek ************',9X,1H,
	+ $ /,' ', 25X,'USEFUL DISCUSSIONS, IN PARTICULAR *',9X,1H,
	+ $ /,' ', 25X,'WITH C. Biscarat and S. Slabospitzky*',9X,1H,
	+ $ /,' ', 25X,'*** are warmly acknowledged *****',9X,1H,
	+ $ /,' ', 25X,'*** END OF MODULE OPERATION *****',9X,1H,
	+ $ /,1X,15(5H*****)/)
	+
	+ END
	+
	+ SUBROUTINE SPINHIGGS(IM,NP1,NP2,IFPSEUDO,Pol1,Pol2)
	+ IMPLICIT double precision(A-H,O-Z)
	+ LOGICAL IFPSEUDO
	+ double precision HH1,HH2,wthiggs
	+ DIMENSION POL1(4), POL2(4),HH1(4),HH2(4), RRR(1)
	+! CALL DEXAY(1,POL1) ! Kept for tests
	+! CALL DEXAY(2,POL2) ! Kept for tests
	+ INTEGER ION(3)
	+ 10 CONTINUE
	+ CALL RANMAR(RRR,1)
	+ CALL DEKAY(1,HH1)
	+ CALL DEKAY(2,HH2)
	+ wt=wthiggs(IFPSEUDO,HH1,HH2)
	+ IF (RRR(1).GT.WT) GOTO 10
	+ CALL DEKAY(1+10,HH1)
	+ CALL TAUPI0(0,1,ION)
	+ CALL DEKAY(2+10,HH2)
	+ CALL TAUPI0(0,2,ION)
	+ END
	+ FUNCTION wthiggs(IFPSEUDO,HH1,HH2)
	+ IMPLICIT double precision(A-H,O-Z)
	+ LOGICAL IFPSEUDO
	+ common /pseudocoup/ csc,ssc
	+ double precision csc,ssc
	+ save pseudocoup
	+ double precision HH1(4),HH2(4),R(4,4),wthiggs
	+ DO K=1,4
	+ DO L=1,4
	+ R(K,L)=0
	+ ENDDO
	+ ENDDO
	+ WTHIGGS=0D0
	+
	+ R(4,4)= 1D0 ! unpolarized part
	+ R(3,3)=-1D0 ! longitudinal
	+ ! other missing
	+ IF (IFPSEUDO) THEN
	+ R(1,1)=-1
	+ R(2,2)= -1
	+ R(1,1)=(csc2-ssc2)/(csc2+ssc2)
	+ R(2,2)=(csc2-ssc2)/(csc2+ssc2)
	+ R(1,2)=2cscssc/(csc2+ssc2)
	+ R(2,1)=-2cscssc/(csc2+ssc2)
	+ ELSE
	+ R(1,1)=1
	+ R(2,2)=1
	+ ENDIF
	+
	+
	+
	+ DO K=1,4
	+ DO L=1,4
	+ WTHIGGS=WTHIGGS+R(K,L)HH1(K)HH2(L)
	+ ENDDO
	+ ENDDO
	+ WTHIGGS=WTHIGGS/4D0
	+ END
	+
	+ FUNCTION PLZAPX(HOPEin,IM0,NP1,NP2)
	+ IMPLICIT double precision(A-H,O-Z)
	+C IM0 NP1 NP2 are the positions of Z/gamma tau tau in hepevt common block.
	+C the purpose of this routine is to calculate polarization of Z along tau direction.
	+C this is highly non-trivial due to necessity of reading infromation from hard process
	+C history in HEPEVT, which is often written not up to the gramatic rules.
	+ double precision PLZAPX,PLZAP0,SVAR,COSTHE,sini,sfin,ZPROP2,
	+ $ P1(4),P2(4),Q1(4),Q2(4),QQ(4),PH(4),PD1(4),PD2(4),
	+ $ PQ1(4),PQ2(4),PB(4),PA(4)
	+ INTEGER IM
	+ LOGICAL HOPE,HOPEin
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+
	+C(BPK)--> BROTHERS OF TAU ALREADY FOUND
	+ INTEGER ISON
	+ COMMON /ISONS_TAU/ISON(2)
	+C(BPK)--<
	+C >>
	+C >> STEP 1: find where are particles in hepevent and pick them up
	+C >>
	+ print *, " plzapx point 001 im0,np1,np2 ",
	+ & im0,np1,np2
	+ HOPE=HOPEin
	+C sometimes shade Z of Z is its mother ...
	+ IM=IM0
	+ IM00=JMOHEP(1,IM0)
	+C to protect against check on mother of beam particles.
	+ IF (IM00.GT.0) THEN
	+ IF (IDHEP(IM0).EQ.IDHEP(IM00)) IM=JMOHEP(1,IM0)
	+ ENDIF
	+C
	+C find (host generator-level) incoming beam-bare-particles which form Z and co.
	+ IMO1=JMOHEP(1,IM)
	+ IMO2=JMOHEP(2,IM)
	+
	+C(BPK)--> IN HERWIG THE POINTER MIGHT BE TO HARD CMS
	+ IM00=IMO1
	+ IF (ISTHEP(IM00).EQ.120) THEN
	+ IMO1=JMOHEP(1,IM00)
	+ IMO2=JMOHEP(2,IM00)
	+ ENDIF
	+C(BPK)--<
	+
	+ print *, " plzapx point 001.5 im0,im,im00,im01,im02= ",
	+ & im0,im,im00,im01,im02
	+ IFFULL=0
	+C case when it was like e+e- --> tau+tau- gammas and e+e- were 'first' in hepevt.
	+ IF (IMO1.EQ.0.AND.IMO2.EQ.0) THEN
	+ IMO1=JMOHEP(1,NP1)
	+C(BPK)-->
	+ IF (IDHEP(IMO1).EQ.IDHEP(NP1)) IMO1=JMOHEP(1,IMO1) ! PROTECT AGAINST COPIES
	+C(BPK)--<
	+ IMO2=JMOHEP(2,NP1)
	+C(BPK)-->
	+ IF (IDHEP(IMO2).EQ.IDHEP(NP2)) IMO2=JMOHEP(1,IMO2) ! PROTECT AGAINST COPIES
	+C(BPK)--<
	+ IFFULL=1
	+C case when it was like qq --> tau+tau- gammas and qq were NOT 'first' in hepevt.
	+
	+ ELSEIF (IDHEP(IM).NE.22.AND.IDHEP(IM).NE.23) THEN
	+ IMO1=JMOHEP(1,NP1)
	+C(BPK)-->
	+ IF (IDHEP(IMO1).EQ.IDHEP(NP1)) IMO1=JMOHEP(1,IMO1) ! PROTECT AGAINST COPIES
	+C(BPK)--<
	+ IMO2=JMOHEP(2,NP1)
	+C(BPK)-->
	+ IF (IDHEP(IMO2).EQ.IDHEP(NP2)) IMO2=JMOHEP(1,IMO2) ! PROTECT AGAINST COPIES
	+C(BPK)--<
	+ IFFULL=1
	+ ENDIF
	+
	+
	+C and check if it really happened
	+ IF (IMO1.EQ.0) HOPE=.FALSE.
	+ IF (IMO2.EQ.0) HOPE=.FALSE.
	+ IF (IMO1.EQ.IMO2) HOPE=.FALSE.
	+
	+C
	+ DO I=1,4
	+ Q1(I)= PHEP(I,NP1) !momentum of tau+
	+ Q2(I)= PHEP(I,NP2) !momentum of tau-
	+ ENDDO
	+
	+C corrections due to possible differences in 4-momentum of shadow vs true Z.
	+C(BPK)-->
	+ IF (IM.EQ.JMOHEP(1,IM0).AND.
	+ $ (IDHEP(IM).EQ.22.OR.IDHEP(IM).EQ.23)) THEN
	+ DO K=1,4
	+ PB(K)=PHEP(K,IM)
	+ PA(K)=PHEP(K,IM0)
	+ ENDDO
	+C(BPK)--<
	+
	+ CALL BOSTDQ( 1,PA, Q1, Q1)
	+ CALL BOSTDQ( 1,PA, Q2, Q2)
	+ CALL BOSTDQ(-1,PB, Q1, Q1)
	+ CALL BOSTDQ(-1,PB, Q2, Q2)
	+
	+ ENDIF
	+
	+ DO I=1,4
	+ QQ(I)= Q1(I)+Q2(I) !momentum of Z
	+ IF (HOPE) P1(I)=PHEP(I,IMO1) !momentum of beam1
	+ IF (HOPE) P2(I)=PHEP(I,IMO2) !momentum of beam2
	+ PH(I)=0D0
	+ PD1(I)=0D0
	+ PD2(I)=0D0
	+ ENDDO
	+! These momenta correspond to quarks, gluons photons or taus
	+ IDFQ1=IDHEP(NP1)
	+ IDFQ2=IDHEP(NP2)
	+ IF (HOPE) IDFP1=IDHEP(IMO1)
	+ IF (HOPE) IDFP2=IDHEP(IMO2)
	+
	+ SVAR=QQ(4)2-QQ(3)2-QQ(2)2-QQ(1)2
	+ IF (.NOT.HOPE) THEN
	+C options which may be useful in some cases of two heavy boson production
	+C need individual considerations. To be developed.
	+C PLZAPX=PLZAP0(11,IDFQ1,SVAR,0D0) ! gamma/Z mixture as if produced from e beam
	+C PLZAPX=PLZAP0(12,IDFQ1,SVAR,0D0) ! pure Z
	+ PLZAPX=0.5 ! pure gamma
	+ print *, " plzapx point 002 svar,hope,plzapx= ",
	+ & svar,hope,plzapx
	+ RETURN
	+ ENDIF
	+C >>
	+C >> STEP 2 look for brothers of Z which have to be included in effective incoming particles
	+C >>
	+C let us define beginning and end of particles which are produced in parallel to Z
	+C in principle following should work
	+
	+C(BPK)--> ACCOMMODATE FOR HERWIG - IM00 POINTS TO BEAM PARTICLE OR HARD CMS
	+ NX1=JDAHEP(1,IM00)
	+ NX2=JDAHEP(2,IM00)
	+C but ...
	+ INBR=IM ! OK, HARD RECORD Z/GAMMA
	+ IF (IFFULL.EQ.1) INBR=NP1 ! OK, NO Z/GAMMA
	+ IF (IDHEP(JMOHEP(1,INBR)).EQ.IDHEP(INBR)) INBR=JMOHEP(1,INBR) ! FORCE HARD RECORD
	+C(BPK)--<
	+ IF(NX1.EQ.0.OR.NX2.EQ.0) THEN
	+ NX1=INBR
	+ NX2=INBR
	+ DO K=1,INBR-1
	+ IF(JMOHEP(1,INBR-K).EQ.JMOHEP(1,INBR)) THEN
	+ NX1=INBR-K
	+ ELSE
	+ GOTO 7
	+ ENDIF
	+ ENDDO
	+ 7 CONTINUE
	+
	+ DO K=INBR+1,NHEP
	+ IF(JMOHEP(1,K).EQ.JMOHEP(1,INBR)) THEN
	+ NX2=K
	+ ELSE
	+ GOTO 8
	+ ENDIF
	+ ENDDO
	+ 8 CONTINUE
	+ ENDIF
	+
	+C case of annihilation of two bosons is hopeles
	+ IF (ABS(IDFP1).GE.20.AND.ABS(IDFP2).GE.20) HOPE=.FALSE.
	+C case of annihilation of non-matching flavors is hopeless
	+ IF (ABS(IDFP1).LE.20.AND.ABS(IDFP2).LE.20.AND.IDFP1+IDFP2.NE.0)
	+ $ HOPE=.FALSE.
	+ IF (.NOT.HOPE) THEN
	+C options which may be useful in some cases of two heavy boson production
	+C need individual considerations. To be developed.
	+C PLZAPX=PLZAP0(11,IDFQ1,SVAR,0D0) ! gamma/Z mixture as if produced from e beam
	+C PLZAPX=PLZAP0(12,IDFQ1,SVAR,0D0) ! pure Z
	+ PLZAPX=0.5 ! pure gamma
	+ print *, " plzapx point 003 idfp1,idfp2,hope,plzapx= ",
	+ & idfp1,idfp2,hope,plzapx
	+ RETURN
	+ ENDIF
	+ IF (ABS(IDFP1).LT.20) IDE= IDFP1
	+ IF (ABS(IDFP2).LT.20) IDE=-IDFP2
	+
	+
	+C >>
	+C >> STEP 3 we combine gluons, photons into incoming effective beams
	+C >>
	+
	+C in the following we will ignore the possibility of photon emission from taus
	+C however at certain moment it will be necessary to take care of
	+
	+ DO L=1,4
	+ PD1(L)=P1(L)
	+ PD2(L)=P2(L)
	+ ENDDO
	+
	+ DO L=1,4
	+ PQ1(L)=Q1(L)
	+ PQ2(L)=Q2(L)
	+ ENDDO
	+
	+ IFLAV=min(ABS(IDFP1),ABS(IDFP2))
	+
	+*--------------------------------------------------------------------------
	+c IFLAV=min(ABS(IDFP1),ABS(IDFP2))
	+c that means that always quark or lepton i.e. process like
	+c f g(gamma) --> f Z0 --> tau tau
	+c we glue fermions to effective beams that is f f --> Z0 --> tau tau
	+c with gamma/g emission from initial fermion.
	+*---------------------------------------------------------------------------
	+
	+ IF (ABS(IDFP1).GE.20) THEN
	+ DO k=NX1,NX2
	+ IDP=IDHEP(k)
	+ IF (ABS(IDP).EQ.IFLAV) THEN
	+ DO L=1,4
	+ PD1(L)=-PHEP(L,K)
	+ ENDDO
	+ ENDIF
	+ ENDDO
	+ ENDIF
	+
	+ IF (ABS(IDFP2).GE.20) THEN
	+ DO k=NX1,NX2
	+ IDP=IDHEP(k)
	+ IF (ABS(IDP).EQ.IFLAV) THEN
	+ DO L=1,4
	+ PD2(L)=-PHEP(L,K)
	+ ENDDO
	+ ENDIF
	+ ENDDO
	+ ENDIF
	+
	+C if first beam was boson: gluing
	+
	+ IF (ABS(IDFP1).GE.20) THEN
	+ DO L=1,4
	+ PH(L)=P1(L)
	+ ENDDO
	+ xm1=abs((PD1(4)+PH(4))2-(PD1(3)+PH(3))2
	+ $ -(PD1(2)+PH(2))2-(PD1(1)+PH(1))2)
	+ xm2=abs((PD2(4)+PH(4))2-(PD2(3)+PH(3))2
	+ $ -(PD2(2)+PH(2))2-(PD2(1)+PH(1))2)
	+ IF (XM1.LT.XM2) THEN
	+ DO L=1,4
	+ PD1(L)=PD1(L)+P1(L)
	+ ENDDO
	+ ELSE
	+ DO L=1,4
	+ PD2(L)=PD2(L)+P1(L)
	+ ENDDO
	+ ENDIF
	+ ENDIF
	+
	+C if second beam was boson: gluing
	+
	+
	+ IF (ABS(IDFP2).GE.20) THEN
	+ DO L=1,4
	+ PH(L)=P2(L)
	+ ENDDO
	+ xm1=abs((PD1(4)+PH(4))2-(PD1(3)+PH(3))2
	+ $ -(PD1(2)+PH(2))2-(PD1(1)+PH(1))2)
	+ xm2=abs((PD2(4)+PH(4))2-(PD2(3)+PH(3))2
	+ $ -(PD2(2)+PH(2))2-(PD2(1)+PH(1))2)
	+ IF (XM1.LT.XM2) THEN
	+ DO L=1,4
	+ PD1(L)=PD1(L)+P2(L)
	+ ENDDO
	+ ELSE
	+ DO L=1,4
	+ PD2(L)=PD2(L)+P2(L)
	+ ENDDO
	+ ENDIF
	+ ENDIF
	+
	+C now spectators ...
	+
	+C(BPK)-->
	+ NPH1=NP1
	+ NPH2=NP2
	+ IF (IDHEP(JMOHEP(1,NP1)).EQ.IDHEP(NP1)) NPH1=JMOHEP(1,NP1) ! SHOULD PUT US IN HARD REC.
	+ IF (IDHEP(JMOHEP(1,NP2)).EQ.IDHEP(NP2)) NPH2=JMOHEP(1,NP2) ! SHOULD PUT US IN HARD REC.
	+C(BPK)--<
	+
	+ DO k=NX1,NX2
	+ IF (ABS(IDHEP(K)).NE.IFLAV.AND.K.NE.IM.AND.
	+C(BPK)-->
	+ $ K.NE.NPH1.AND.K.NE.NPH2) THEN
	+C(BPK)--<
	+ IF(IDHEP(K).EQ.22.AND.IFFULL.EQ.1) THEN
	+ DO L=1,4
	+ PH(L)=PHEP(L,K)
	+ ENDDO
	+ xm1=abs((PD1(4)-PH(4))2-(PD1(3)-PH(3))2
	+ $ -(PD1(2)-PH(2))2-(PD1(1)-PH(1))2)
	+ xm2=abs((PD2(4)-PH(4))2-(PD2(3)-PH(3))2
	+ $ -(PD2(2)-PH(2))2-(PD2(1)-PH(1))2)
	+ xm3=abs((PQ1(4)+PH(4))2-(PQ1(3)+PH(3))2
	+ $ -(PQ1(2)+PH(2))2-(PQ1(1)+PH(1))2)
	+ xm4=abs((PQ2(4)+PH(4))2-(PQ2(3)+PH(3))2
	+ $ -(PQ2(2)+PH(2))2-(PQ2(1)+PH(1))2)
	+
	+
	+ sini=abs((PD1(4)+PD2(4)-PH(4))2-(PD1(3)+PD2(3)-PH(3))2
	+ $ -(PD1(2)+PD2(2)-PH(2))2-(PD1(1)+PD2(1)-PH(1))2)
	+ sfin=abs((PD1(4)+PD2(4) )2-(PD1(3)+PD2(3) )2
	+ $ -(PD1(2)+PD2(2) )2-(PD1(1)+PD2(1) )2)
	+
	+ FACINI=ZPROP2(sini)
	+ FACFIN=ZPROP2(sfin)
	+
	+ XM1=XM1/FACINI
	+ XM2=XM2/FACINI
	+ XM3=XM3/FACFIN
	+ XM4=XM4/FACFIN
	+
	+ XM=MIN(XM1,XM2,XM3,XM4)
	+ IF (XM1.EQ.XM) THEN
	+ DO L=1,4
	+ PD1(L)=PD1(L)-PH(L)
	+ ENDDO
	+ ELSEIF (XM2.EQ.XM) THEN
	+ DO L=1,4
	+ PD2(L)=PD2(L)-PH(L)
	+ ENDDO
	+ ELSEIF (XM3.EQ.XM) THEN
	+ DO L=1,4
	+ Q1(L)=PQ1(L)+PH(L)
	+ ENDDO
	+ ELSE
	+ DO L=1,4
	+ Q2(L)=PQ2(L)+PH(L)
	+ ENDDO
	+ ENDIF
	+ ELSE
	+ DO L=1,4
	+ PH(L)=PHEP(L,K)
	+ ENDDO
	+ xm1=abs((PD1(4)-PH(4))2-(PD1(3)-PH(3))2
	+ $ -(PD1(2)-PH(2))2-(PD1(1)-PH(1))2)
	+ xm2=abs((PD2(4)-PH(4))2-(PD2(3)-PH(3))2
	+ $ -(PD2(2)-PH(2))2-(PD2(1)-PH(1))2)
	+ IF (XM1.LT.XM2) THEN
	+ DO L=1,4
	+ PD1(L)=PD1(L)-PH(L)
	+ ENDDO
	+ ELSE
	+ DO L=1,4
	+ PD2(L)=PD2(L)-PH(L)
	+ ENDDO
	+ ENDIF
	+ ENDIF
	+ ENDIF
	+ ENDDO
	+
	+
	+C >>
	+C >> STEP 4 look for brothers of tau (sons of Z!) which have to be included in
	+c >> effective outcoming taus
	+C >>
	+C let us define beginning and end of particles which are produced in
	+c parallel to tau
	+
	+
	+
	+C find outcoming particles which come from Z
	+
	+
	+
	+
	+C(BPK)--> OK, IT WOULD HAVE TO BE ALONG TAUS IN HARD RECORD WITH THE SAME MOTHER
	+ IF (ABS(IDHEP(IM0)).EQ.22.OR.abs(IDHEP(IM0)).EQ.23) THEN
	+ DO K=ISON(1),ISON(2)
	+ IF(ABS(IDHEP(K)).EQ.22) THEN
	+C(BPK)--<
	+
	+ do l=1,4
	+ ph(l)=phep(l,k)
	+ enddo
	+
	+ xm3=abs((PQ1(4)+PH(4))2-(PQ1(3)+PH(3))2
	+ $ -(PQ1(2)+PH(2))2-(PQ1(1)+PH(1))2)
	+ xm4=abs((PQ2(4)+PH(4))2-(PQ2(3)+PH(3))2
	+ $ -(PQ2(2)+PH(2))2-(PQ2(1)+PH(1))2)
	+
	+ XM=MIN(XM3,XM4)
	+
	+ IF (XM3.EQ.XM) THEN
	+ DO L=1,4
	+ Q1(L)=PQ1(L)+PH(L)
	+ ENDDO
	+ ELSE
	+ DO L=1,4
	+ Q2(L)=PQ2(L)+PH(L)
	+ ENDDO
	+ ENDIF
	+ endif
	+ enddo
	+ ENDIF
	+
	+
	+
	+*------------------------------------------------------------------------
	+
	+
	+C out of effective momenta we calculate COSTHE and later polarization
	+ CALL ANGULU(PD1,PD2,Q1,Q2,COSTHE)
	+
	+ PLZAPX=PLZAP0(IDE,IDFQ1,SVAR,COSTHE)
	+ print *, " plzapx point 004 ide,idfq1,svar,costhe,plzapx= ",
	+ & ide,idfq1,svar,costhe,plzapx
	+ END
	+
	+ SUBROUTINE ANGULU(PD1,PD2,Q1,Q2,COSTHE)
	+ IMPLICIT double precision(A-H,O-Z)
	+ double precision PD1(4),PD2(4),Q1(4),Q2(4),COSTHE,P(4),QQ(4),QT(4)
	+C take effective beam which is less massive, it should be irrelevant
	+C but in case HEPEVT is particulary dirty may help.
	+C this routine calculate reduced system transver and cosine of scattering
	+C angle.
	+
	+ XM1=ABS(PD1(4)2-PD1(3)2-PD1(2)2-PD1(1)2)
	+ XM2=ABS(PD2(4)2-PD2(3)2-PD2(2)2-PD2(1)2)
	+ IF (XM1.LT.XM2) THEN
	+ SIGN=1D0
	+ DO K=1,4
	+ P(K)=PD1(K)
	+ ENDDO
	+ ELSE
	+ SIGN=-1D0
	+ DO K=1,4
	+ P(K)=PD2(K)
	+ ENDDO
	+ ENDIF
	+C calculate space like part of P (in Z restframe)
	+ DO K=1,4
	+ QQ(K)=Q1(k)+Q2(K)
	+ QT(K)=Q1(K)-Q2(K)
	+ ENDDO
	+
	+ XMQQ=SQRT(QQ(4)2-QQ(3)2-QQ(2)2-QQ(1)2)
	+
	+ QTXQQ=QT(4)QQ(4)-QT(3)QQ(3)-QT(2)QQ(2)-QT(1)QQ(1)
	+ DO K=1,4
	+ QT(K)=QT(K)-QQ(K)QTXQQ/XMQQ*2
	+ ENDDO
	+
	+ PXQQ=P(4)QQ(4)-P(3)QQ(3)-P(2)QQ(2)-P(1)QQ(1)
	+ DO K=1,4
	+ P(K)=P(K)-QQ(K)PXQQ/XMQQ*2
	+ ENDDO
	+C calculate costhe
	+ PXP =SQRT(p(1)2+p(2)2+p(3)2-p(4)2)
	+ QTXQT=SQRT(QT(3)2+QT(2)2+QT(1)2-QT(4)2)
	+ PXQT =P(3)QT(3)+P(2)QT(2)+P(1)QT(1)-P(4)QT(4)
	+ COSTHE=PXQT/PXP/QTXQT
	+ COSTHE=COSTHE*SIGN
	+ END
	+
	+ FUNCTION PLZAP0(IDE,IDF,SVAR,COSTH0)
	+ IMPLICIT double precision(A-H,O-Z)
	+C this function calculates probability for the helicity +1 +1 configuration
	+C of taus for given Z/gamma transfer and COSTH0 cosine of scattering angle
	+ double precision PLZAP0,SVAR,COSTHE,COSTH0
	+ double precision T_BORN
	+
	+ COSTHE=COSTH0
	+C >>>>> IF (IDE*IDF.LT.0) COSTHE=-COSTH0 ! this is probably not needed ID
	+C >>>>> of first beam is used by T_GIVIZ0 including sign
	+ print *, " plzap0 point 001 ide,idf,svar,costh0= ",
	+ & ide,idf,svar,costh0
	+
	+ IF (IDF.GT.0) THEN
	+ CALL INITWK(IDE,IDF,SVAR)
	+ ELSE
	+ CALL INITWK(-IDE,-IDF,SVAR)
	+ ENDIF
	+ PLZAP0=T_BORN(0,SVAR,COSTHE,1D0,1D0)
	+ $ /(T_BORN(0,SVAR,COSTHE,1D0,1D0)+T_BORN(0,SVAR,COSTHE,-1D0,-1D0))
	+
	+! PLZAP0=0.5
	+ END
	+ FUNCTION T_BORN(MODE,SVAR,COSTHE,TA,TB)
	+C ----------------------------------------------------------------------
	+C THIS ROUTINE PROVIDES BORN CROSS SECTION. IT HAS THE SAME
	+C STRUCTURE AS FUNTIS AND FUNTIH, THUS CAN BE USED AS SIMPLER
	+C EXAMPLE OF THE METHOD APPLIED THERE
	+C INPUT PARAMETERS ARE: SVAR -- transfer
	+C COSTHE -- cosine of angle between tau+ and 1st beam
	+C TA,TB -- helicity states of tau+ tau-
	+C
	+C called by : BORNY, BORAS, BORNV, WAGA, WEIGHT
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision(A-H,O-Z)
	+ COMMON / T_BEAMPM / ENE ,AMIN,AMFIN,IDE,IDF
	+ double precision ENE ,AMIN,AMFIN
	+ COMMON / T_GAUSPM /SS,POLN,T3E,QE,T3F,QF
	+ & ,XUPGI ,XUPZI ,XUPGF ,XUPZF
	+ & ,NDIAG0,NDIAGA,KEYA,KEYZ
	+ & ,ITCE,JTCE,ITCF,JTCF,KOLOR
	+ double precision SS,POLN,T3E,QE,T3F,QF
	+ & ,XUPGI(2),XUPZI(2),XUPGF(2),XUPZF(2)
	+ double precision SEPS1,SEPS2
	+C=====================================================================
	+ COMMON / T_GSWPRM /SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	+ double precision SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	+C SWSQ = sin2 (theta Weinberg)
	+C AMW,AMZ = W & Z boson masses respectively
	+C AMH = the Higgs mass
	+C AMTOP = the top mass
	+C GAMMZ = Z0 width
	+ COMPLEX*16 ABORN(2,2),APHOT(2,2),AZETT(2,2)
	+ COMPLEX*16 XUPZFP(2),XUPZIP(2)
	+ COMPLEX*16 ABORNM(2,2),APHOTM(2,2),AZETTM(2,2)
	+ COMPLEX*16 PROPA,PROPZ
	+ COMPLEX*16 XR,XI
	+ COMPLEX*16 XUPF,XUPI,XFF(4),XFEM,XFOTA,XRHO,XKE,XKF,XKEF
	+ COMPLEX*16 XTHING,XVE,XVF,XVEF
	+ DATA XI/(0.D0,1.D0)/,XR/(1.D0,0.D0)/
	+ DATA MODE0 /-5/
	+ DATA IDE0 /-55/
	+ DATA SVAR0,COST0 /-5.D0,-6.D0/
	+ DATA PI /3.141592653589793238462643D0/
	+ DATA SEPS1,SEPS2 /0D0,0D0/
	+C
	+C MEMORIZATION =========================================================
	+ IF ( MODE.NE.MODE0.OR.SVAR.NE.SVAR0.OR.COSTHE.NE.COST0
	+ $ .OR.IDE0.NE.IDE)THEN
	+C
	+ KEYGSW=1
	+C ** PROPAGATORS
	+ IDE0=IDE
	+ MODE0=MODE
	+ SVAR0=SVAR
	+ COST0=COSTHE
	+ SINTHE=SQRT(1.D0-COSTHE**2)
	+ BETA=SQRT(MAX(0D0,1D0-4D0AMFIN*2/SVAR))
	+C I MULTIPLY AXIAL COUPLING BY BETA FACTOR.
	+ XUPZFP(1)=0.5D0(XUPZF(1)+XUPZF(2))+0.5BETA*(XUPZF(1)-XUPZF(2))
	+ XUPZFP(2)=0.5D0(XUPZF(1)+XUPZF(2))-0.5BETA*(XUPZF(1)-XUPZF(2))
	+ XUPZIP(1)=0.5D0(XUPZI(1)+XUPZI(2))+0.5(XUPZI(1)-XUPZI(2))
	+ XUPZIP(2)=0.5D0(XUPZI(1)+XUPZI(2))-0.5(XUPZI(1)-XUPZI(2))
	+C FINAL STATE VECTOR COUPLING
	+ XUPF =0.5D0*(XUPZF(1)+XUPZF(2))
	+ XUPI =0.5D0*(XUPZI(1)+XUPZI(2))
	+ XTHING =0D0
	+
	+ PROPA =1D0/SVAR
	+ PROPZ =1D0/DCMPLX(SVAR-AMZ*2,SVAR/AMZGAMMZ)
	+ IF (KEYGSW.EQ.0) PROPZ=0.D0
	+ DO 50 I=1,2
	+ DO 50 J=1,2
	+ REGULA= (3-2I)(3-2*J) + COSTHE
	+ REGULM=-(3-2I)(3-2J) SINTHE 2.D0AMFIN/SQRT(SVAR)
	+ APHOT(I,J)=PROPA(XUPGI(I)XUPGF(J)*REGULA)
	+ AZETT(I,J)=PROPZ(XUPZIP(I)XUPZFP(J)+XTHING)*REGULA
	+ ABORN(I,J)=APHOT(I,J)+AZETT(I,J)
	+ APHOTM(I,J)=PROPADCMPLX(0D0,1D0)XUPGI(I)XUPGF(J)REGULM
	+ AZETTM(I,J)=PROPZDCMPLX(0D0,1D0)(XUPZIP(I)XUPF+XTHING)REGULM
	+ ABORNM(I,J)=APHOTM(I,J)+AZETTM(I,J)
	+ 50 CONTINUE
	+ ENDIF
	+C
	+C******************
	+C* IN CALCULATING CROSS SECTION ONLY DIAGONAL ELEMENTS
	+C* OF THE SPIN DENSITY MATRICES ENTER (LONGITUD. POL. ONLY.)
	+C* HELICITY CONSERVATION EXPLICITLY OBEYED
	+ POLAR1= (SEPS1)
	+ POLAR2= (-SEPS2)
	+ BORN=0D0
	+ DO 150 I=1,2
	+ HELIC= 3-2*I
	+ DO 150 J=1,2
	+ HELIT=3-2*J
	+ FACTOR=KOLOR(1D0+HELICPOLAR1)(1D0-HELICPOLAR2)/4D0
	+ FACTOM=FACTOR(1+HELITTA)(1-HELITTB)
	+ FACTOR=FACTOR(1+HELITTA)(1+HELITTB)
	+
	+ BORN=BORN+CDABS(ABORN(I,J))*2FACTOR
	+C MASS TERM IN BORN
	+ IF (MODE.GE.1) THEN
	+ BORN=BORN+CDABS(ABORNM(I,J))*2FACTOM
	+ ENDIF
	+
	+ 150 CONTINUE
	+C************
	+ FUNT=BORN
	+ IF(FUNT.LT.0.D0) FUNT=BORN
	+
	+C
	+ IF (SVAR.GT.4D0AMFIN*2) THEN
	+C PHASE SPACE THRESHOLD FACTOR
	+ THRESH=SQRT(1-4D0AMFIN*2/SVAR)
	+ T_BORN= FUNTSVAR2THRESH
	+ ELSE
	+ THRESH=0.D0
	+ T_BORN=0.D0
	+ ENDIF
	+C ZW HERE WAS AN ERROR 19. 05. 1989
	+! write(,) 'KKKK ',PROPA,PROPZ,XUPGI,XUPGF,XUPZI,XUPZF
	+! write(,) 'KKKK X',svar,costhe,TA,TB,T_BORN
	+ END
	+
	+ SUBROUTINE INITWK(IDEX,IDFX,SVAR)
	+! initialization routine coupling masses etc.
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / T_BEAMPM / ENE ,AMIN,AMFIN,IDE,IDF
	+ double precision ENE ,AMIN,AMFIN
	+ COMMON / T_GAUSPM /SS,POLN,T3E,QE,T3F,QF
	+ & ,XUPGI ,XUPZI ,XUPGF ,XUPZF
	+ & ,NDIAG0,NDIAGA,KEYA,KEYZ
	+ & ,ITCE,JTCE,ITCF,JTCF,KOLOR
	+ double precision SS,POLN,T3E,QE,T3F,QF
	+ & ,XUPGI(2),XUPZI(2),XUPGF(2),XUPZF(2)
	+ COMMON / T_GSWPRM /SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	+ double precision SWSQ,AMW,AMZ,AMH,AMTOP,GAMMZ
	+C SWSQ = sin2 (theta Weinberg)
	+C AMW,AMZ = W & Z boson masses respectively
	+C AMH = the Higgs mass
	+C AMTOP = the top mass
	+C GAMMZ = Z0 width
	+C
	+ print *, " initwk point 001 idex,idfx,svar= ", idex,idfx,svar
	+ ENE=SQRT(SVAR)/2
	+ AMIN=0.511D-3
	+ SWSQ=0.23147
	+ AMZ=91.1882
	+ GAMMZ=2.4952
	+ IF (IDFX.EQ. 15) then
	+ IDF=2 ! denotes tau +2 tau-
	+ AMFIN=1.77703 !this mass is irrelevant if small, used in ME only
	+ ELSEIF (IDFX.EQ.-15) then
	+ IDF=-2 ! denotes tau -2 tau-
	+ AMFIN=1.77703 !this mass is irrelevant if small, used in ME only
	+ ELSE
	+ WRITE(,) 'INITWK: WRONG IDFX'
	+ STOP
	+ ENDIF
	+
	+ IF (IDEX.EQ. 11) then !electron
	+ IDE= 2
	+ AMIN=0.511D-3
	+ ELSEIF (IDEX.EQ.-11) then !positron
	+ IDE=-2
	+ AMIN=0.511D-3
	+ ELSEIF (IDEX.EQ. 13) then !mu+
	+ IDE= 2
	+ AMIN=0.105659
	+ ELSEIF (IDEX.EQ.-13) then !mu-
	+ IDE=-2
	+ AMIN=0.105659
	+ ELSEIF (IDEX.EQ. 1) then !d
	+ IDE= 4
	+ AMIN=0.05D0
	+ ELSEIF (IDEX.EQ.- 1) then !d~
	+ IDE=-4
	+ AMIN=0.05D0
	+ ELSEIF (IDEX.EQ. 2) then !u
	+ IDE= 3
	+ AMIN=0.02D0
	+ ELSEIF (IDEX.EQ.- 2) then !u~
	+ IDE=-3
	+ AMIN=0.02D0
	+ ELSEIF (IDEX.EQ. 3) then !s
	+ IDE= 4
	+ AMIN=0.3
	+ ELSEIF (IDEX.EQ.- 3) then !s~
	+ IDE=-4
	+ AMIN=0.3
	+ ELSEIF (IDEX.EQ. 4) then !c
	+ IDE= 3
	+ AMIN=1.3
	+ ELSEIF (IDEX.EQ.- 4) then !c~
	+ IDE=-3
	+ AMIN=1.3
	+ ELSEIF (IDEX.EQ. 5) then !b
	+ IDE= 4
	+ AMIN=4.5
	+ ELSEIF (IDEX.EQ.- 5) then !b~
	+ IDE=-4
	+ AMIN=4.5
	+ ELSEIF (IDEX.EQ. 12) then !nu_e
	+ IDE= 1
	+ AMIN=0.1D-3
	+ ELSEIF (IDEX.EQ.- 12) then !nu_e~
	+ IDE=-1
	+ AMIN=0.1D-3
	+ ELSEIF (IDEX.EQ. 14) then !nu_mu
	+ IDE= 1
	+ AMIN=0.1D-3
	+ ELSEIF (IDEX.EQ.- 14) then !nu_mu~
	+ IDE=-1
	+ AMIN=0.1D-3
	+ ELSEIF (IDEX.EQ. 16) then !nu_tau
	+ IDE= 1
	+ AMIN=0.1D-3
	+ ELSEIF (IDEX.EQ.- 16) then !nu_tau~
	+ IDE=-1
	+ AMIN=0.1D-3
	+
	+ ELSE
	+ WRITE(,) 'INITWK: WRONG IDEX'
	+ STOP
	+ ENDIF
	+
	+C ----------------------------------------------------------------------
	+C
	+C INITIALISATION OF COUPLING CONSTANTS AND FERMION-GAMMA / Z0 VERTEX
	+C
	+C called by : KORALZ
	+C ----------------------------------------------------------------------
	+ ITCE=IDE/IABS(IDE)
	+ JTCE=(1-ITCE)/2
	+ ITCF=IDF/IABS(IDF)
	+ JTCF=(1-ITCF)/2
	+ CALL T_GIVIZO( IDE, 1,AIZOR,QE,KDUMM)
	+ print *, " initwk point 002 ide,aizor,qe= ", ide,aizor,qe
	+ CALL T_GIVIZO( IDE,-1,AIZOL,QE,KDUMM)
	+ print *, " initwk point 003 ide,aizol,qe= ", ide,aizor,qe
	+ XUPGI(1)=QE
	+ XUPGI(2)=QE
	+ T3E = AIZOL+AIZOR
	+ XUPZI(1)=(AIZOR-QESWSQ)/SQRT(SWSQ(1-SWSQ))
	+ XUPZI(2)=(AIZOL-QESWSQ)/SQRT(SWSQ(1-SWSQ))
	+ CALL T_GIVIZO( IDF, 1,AIZOR,QF,KOLOR)
	+ CALL T_GIVIZO( IDF,-1,AIZOL,QF,KOLOR)
	+ XUPGF(1)=QF
	+ XUPGF(2)=QF
	+ T3F = AIZOL+AIZOR
	+ XUPZF(1)=(AIZOR-QFSWSQ)/SQRT(SWSQ(1-SWSQ))
	+ XUPZF(2)=(AIZOL-QFSWSQ)/SQRT(SWSQ(1-SWSQ))
	+C
	+ NDIAG0=2
	+ NDIAGA=11
	+ KEYA = 1
	+ KEYZ = 1
	+C
	+C
	+ RETURN
	+ END
	+
	+ SUBROUTINE T_GIVIZO(IDFERM,IHELIC,SIZO3,CHARGE,KOLOR)
	+C ----------------------------------------------------------------------
	+C PROVIDES ELECTRIC CHARGE AND WEAK IZOSPIN OF A FAMILY FERMION
	+C IDFERM=1,2,3,4 DENOTES NEUTRINO, LEPTON, UP AND DOWN QUARK
	+C NEGATIVE IDFERM=-1,-2,-3,-4, DENOTES ANTIPARTICLE
	+C IHELIC=+1,-1 DENOTES RIGHT AND LEFT HANDEDNES ( CHIRALITY)
	+C SIZO3 IS THIRD PROJECTION OF WEAK IZOSPIN (PLUS MINUS HALF)
	+C AND CHARGE IS ELECTRIC CHARGE IN UNITS OF ELECTRON CHARGE
	+C KOLOR IS A QCD COLOUR, 1 FOR LEPTON, 3 FOR QUARKS
	+C
	+C called by : EVENTE, EVENTM, FUNTIH, .....
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision(A-H,O-Z)
	+C
	+ IF(IDFERM.EQ.0.OR.IABS(IDFERM).GT.4) GOTO 901
	+ IF(IABS(IHELIC).NE.1) GOTO 901
	+ IH =IHELIC
	+ IDTYPE =IABS(IDFERM)
	+ IC =IDFERM/IDTYPE
	+ LEPQUA=INT(IDTYPE*0.4999999D0)
	+ IUPDOW=IDTYPE-2*LEPQUA-1
	+ CHARGE =(-IUPDOW+2D0/3D0LEPQUA)IC
	+ SIZO3 =0.25D0(IC-IH)(1-2*IUPDOW)
	+ KOLOR=1+2*LEPQUA
	+C** NOTE THAT CONVENTIONALY Z0 COUPLING IS
	+C** XOUPZ=(SIZO3-CHARGESWSQ)/SQRT(SWSQ(1-SWSQ))
	+ RETURN
	+ 901 PRINT *,' STOP IN GIVIZO: WRONG PARAMS.'
	+ STOP
	+ END
	+ SUBROUTINE PHYFIX(NSTOP,NSTART)
	+ IMPLICIT double precision(A-H,O-Z)
	+ COMMON/LUJETS/N,K(4000,5),P(4000,5),V(4000,5)
	+ SAVE /LUJETS/
	+C NSTOP NSTART : when PHYTIA history ends and event starts.
	+ NSTOP=0
	+ NSTART=1
	+ DO I=1, N
	+ IF(K(I,1).NE.21) THEN
	+ NSTOP = I-1
	+ NSTART= I
	+ GOTO 500
	+ ENDIF
	+ ENDDO
	+ 500 CONTINUE
	+ END
	+ SUBROUTINE FILHEP(N,IST,ID,JMO1,JMO2,JDA1,JDA2,P4,PINV,PHFLAG)
	+C ----------------------------------------------------------------------
	+C this subroutine fills one entry into the HEPEVT common
	+C and updates the information for affected mother entries
	+C
	+C written by Martin W. Gruenewald (91/01/28)
	+C
	+C called by : ZTOHEP,BTOHEP,DWLUxy
	+C ----------------------------------------------------------------------
	+C
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ implicit none
	+ integer n, ist, id, jmo1, jmo2, jda1, jda2
	+ integer ihep, i, ip
	+ double precision pinv
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+
	+ LOGICAL PHFLAG
	+C
	+ double precision P4(4)
	+C
	+C check address mode
	+ IF (N.EQ.0) THEN
	+C
	+C append mode
	+ IHEP=NHEP+1
	+ ELSE IF (N.GT.0) THEN
	+C
	+C absolute position
	+ IHEP=N
	+ ELSE
	+C
	+C relative position
	+ IHEP=NHEP+N
	+ END IF
	+C
	+C check on IHEP
	+ IF ((IHEP.LE.0).OR.(IHEP.GT.NMXHEP)) RETURN
	+C
	+C add entry
	+ NHEP=IHEP
	+ ISTHEP(IHEP)=IST
	+ IDHEP(IHEP)=ID
	+ JMOHEP(1,IHEP)=JMO1
	+ IF(JMO1.LT.0)JMOHEP(1,IHEP)=JMOHEP(1,IHEP)+IHEP
	+ JMOHEP(2,IHEP)=JMO2
	+ IF(JMO2.LT.0)JMOHEP(2,IHEP)=JMOHEP(2,IHEP)+IHEP
	+ JDAHEP(1,IHEP)=JDA1
	+ JDAHEP(2,IHEP)=JDA2
	+C
	+ DO I=1,4
	+ PHEP(I,IHEP)=P4(I)
	+C
	+C KORAL-B and KORAL-Z do not provide vertex and/or lifetime informations
	+ VHEP(I,IHEP)=0.0D0
	+ END DO
	+ PHEP(5,IHEP)=PINV
	+C FLAG FOR PHOTOS...
	+ QEDRAD(IHEP)=PHFLAG
	+C
	+C update process:
	+ DO IP=JMOHEP(1,IHEP),JMOHEP(2,IHEP)
	+ IF(IP.GT.0)THEN
	+C
	+C if there is a daughter at IHEP, mother entry at IP has decayed
	+ IF(ISTHEP(IP).EQ.1)ISTHEP(IP)=2
	+C
	+C and daughter pointers of mother entry must be updated
	+ IF(JDAHEP(1,IP).EQ.0)THEN
	+ JDAHEP(1,IP)=IHEP
	+ JDAHEP(2,IP)=IHEP
	+ ELSE
	+ JDAHEP(2,IP)=MAX(IHEP,JDAHEP(2,IP))
	+ END IF
	+ END IF
	+ END DO
	+C
	+ RETURN
	+ END
	+
	+
	+ FUNCTION IHEPDIM(DUM)
	+ IMPLICIT double precision(A-H,O-Z)
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+ IHEPDIM=NHEP
	+ END
	+ FUNCTION ZPROP2(S)
	+ IMPLICIT double precision(A-H,O-Z)
	+ COMPLEX*16 CPRZ0,CPRZ0M
	+ AMZ=91.1882
	+ GAMMZ=2.49
	+ CPRZ0=DCMPLX((S-AMZ*2),S/AMZGAMMZ)
	+ CPRZ0M=1/CPRZ0
	+ ZPROP2=(ABS(CPRZ0M))**2
	+ END
	+
	+ SUBROUTINE TAUPI0(MODE,JAK,ION)
	+ IMPLICIT double precision(A-H,O-Z)
	+C no initialization required. Must be called once after every:
	+C 1) CALL DEKAY(1+10,...)
	+C 2) CALL DEKAY(2+10,...)
	+C 3) CALL DEXAY(1,...)
	+C 4) CALL DEXAY(2,...)
	+C subroutine to decay originating from TAUOLA's taus:
	+C 1) etas (with CALL TAUETA(JAK))
	+C 2) later pi0's from taus.
	+C 3) extensions to other applications possible.
	+C this routine belongs to >tauola universal interface<, but uses
	+C routines from >tauola< utilities as well. 25.08.2005
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+
	+C position of taus, must be defined by host program:
	+ COMMON /TAUPOS/ NP1,NP2
	+c
	+ double precision PHOT1(4),PHOT2(4)
	+ double precision R,X(4),Y(4),PI0(4)
	+ INTEGER JEZELI(3),ION(3)
	+ DATA JEZELI /0,0,0/
	+ SAVE JEZELI
	+ IF (MODE.EQ.-1) THEN
	+ JEZELI(1)=ION(1)
	+ JEZELI(2)=ION(2)
	+ JEZELI(3)=ION(3)
	+ RETURN
	+ ENDIF
	+ IF (JEZELI(1).EQ.0) RETURN
	+ IF (JEZELI(2).EQ.1) CALL TAUETA(JAK)
	+ IF (JEZELI(3).EQ.1) CALL TAUK0S(JAK)
	+C position of decaying particle:
	+ IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+ nhepM=nhep ! to avoid infinite loop
	+ DO K=JDAHEP(1,NPS),nhepM ! we search for pi0's from tau till eor.
	+ IF (IDHEP(K).EQ.111.AND.JDAHEP(1,K).LE.K) THEN ! IF we found pi0
	+ DO L=1,4
	+ PI0(L)= phep(L,K)
	+ ENDDO
	+! random 3 vector on the sphere, masless
	+ R=SQRT(PI0(4)2-PI0(3)2-PI0(2)2-PI0(1)2)/2D0
	+ CALL SPHERD(R,X)
	+ X(4)=R
	+ Y(4)=R
	+
	+ Y(1)=-X(1)
	+ Y(2)=-X(2)
	+ Y(3)=-X(3)
	+! boost to lab
	+ CALL bostdq(-1,PI0,X,X)
	+ CALL bostdq(-1,PI0,Y,Y)
	+ DO L=1,4
	+ PHOT1(L)=X(L)
	+ PHOT2(L)=Y(L)
	+ ENDDO
	+C to hepevt
	+ CALL FILHEP(0,1,22,K,K,0,0,PHOT1,0.0D0,.TRUE.)
	+ CALL FILHEP(0,1,22,K,K,0,0,PHOT2,0.0D0,.TRUE.)
	+ ENDIF
	+ ENDDO
	+C
	+ END
	+ SUBROUTINE TAUETA(JAK)
	+ IMPLICIT double precision(A-H,O-Z)
	+C subroutine to decay etas's from taus.
	+C this routine belongs to tauola universal interface, but uses
	+C routines from tauola utilities. Just flat phase space, but 4 channels.
	+C it is called at the beginning of SUBR. TAUPI0(JAK)
	+C and as far as hepevt search it is basically the same as TAUPI0. 25.08.2005
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+*
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+
	+C position of taus, must be defined by host program:
	+ COMMON /TAUPOS/ NP1,NP2
	+c
	+ double precision RRR(1),BRSUM(3), RR(2)
	+ double precision PHOT1(4),PHOT2(4),PHOT3(4)
	+ double precision X(4), Y(4), Z(4)
	+ double precision YM1,YM2,YM3
	+ double precision R,RU,PETA(4),XM1,XM2,XM3,XM,XLAM,AM2
	+ double precision a,b,c
	+ XLAM(a,b,c)=SQRT(ABS((a-b-c)*2-4.0b*c))
	+C position of decaying particle:
	+ IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+ nhepM=nhep ! to avoid infinite loop
	+ DO K=JDAHEP(1,NPS),nhepM ! we search for etas's from tau till eor.
	+ IF (IDHEP(K).EQ.221.AND.JDAHEP(1,K).LE.K) THEN ! IF we found eta
	+ DO L=1,4
	+ PETA(L)= phep(L,K) ! eta 4 momentum
	+ ENDDO
	+C eta cumulated branching ratios:
	+ BRSUM(1)=0.389 ! gamma gamma
	+ BRSUM(2)=BRSUM(1)+0.319 ! 3 pi0
	+ BRSUM(3)=BRSUM(2)+0.237 ! pi+ pi- pi0 rest is thus pi+pi-gamma
	+ CALL RANMAR(RRR,1)
	+
	+ IF (RRR(1).LT.BRSUM(1)) THEN ! gamma gamma channel exactly like pi0
	+! random 3 vector on the sphere, masless
	+ R=SQRT(PETA(4)2-PETA(3)2-PETA(2)2-PETA(1)2)/2D0
	+ CALL SPHERD(R,X)
	+ X(4)=R
	+ Y(4)=R
	+
	+ Y(1)=-X(1)
	+ Y(2)=-X(2)
	+ Y(3)=-X(3)
	+! boost to lab
	+ CALL bostdq(-1,PETA,X,X)
	+ CALL bostdq(-1,PETA,Y,Y)
	+ DO L=1,4
	+ PHOT1(L)=X(L)
	+ PHOT2(L)=Y(L)
	+ ENDDO
	+C to hepevt
	+ CALL FILHEP(0,1,22,K,K,0,0,PHOT1,0.0D0,.TRUE.)
	+ CALL FILHEP(0,1,22,K,K,0,0,PHOT2,0.0D0,.TRUE.)
	+ ELSE ! 3 body channels
	+ IF(RRR(1).LT.BRSUM(2)) THEN ! 3 pi0
	+ ID1= 111
	+ ID2= 111
	+ ID3= 111
	+ XM1=AMPIZ ! masses
	+ XM2=AMPIZ
	+ XM3=AMPIZ
	+ ELSEIF(RRR(1).LT.BRSUM(3)) THEN ! pi+ pi- pi0
	+ ID1= 211
	+ ID2=-211
	+ ID3= 111
	+ XM1=AMPI ! masses
	+ XM2=AMPI
	+ XM3=AMPIZ
	+ ELSE ! pi+ pi- gamma
	+ ID1= 211
	+ ID2=-211
	+ ID3= 22
	+ XM1=AMPI ! masses
	+ XM2=AMPI
	+ XM3=0.0D0
	+ ENDIF
	+ 7 CONTINUE ! we generate mass of the first pair:
	+ CALL RANMAR(RR,2)
	+ R=SQRT(PETA(4)2-PETA(3)2-PETA(2)2-PETA(1)2)
	+ AMIN=XM1+XM2
	+ AMAX=R-XM3
	+ AM2=SQRT(AMIN*2+RR(1)(AMAX2-AMIN2))
	+C weight for flat phase space
	+ WT=XLAM(R2,AM22,XM3*2)XLAM(AM22,XM12,XM2**2)
	+ & /R2 /AM22
	+ IF (RR(2).GT.WT) GOTO 7
	+
	+ RU=XLAM(AM22,XM12,XM2**2)/AM2/2 ! momenta of the
	+ ! first two products
	+ ! in the rest frame of that pair
	+ CALL SPHERD(RU,X)
	+ X(4)=SQRT(RU2+XM12)
	+ Y(4)=SQRT(RU2+XM22)
	+
	+ Y(1)=-X(1)
	+ Y(2)=-X(2)
	+ Y(3)=-X(3)
	+C generate momentum of that pair in rest frame of eta:
	+ RU=XLAM(R2,AM22,XM3**2)/R/2
	+ CALL SPHERD(RU,Z)
	+ Z(4)=SQRT(RU2+AM22)
	+C and boost first two decay products to rest frame of eta.
	+ CALL bostdq(-1,Z,X,X)
	+ CALL bostdq(-1,Z,Y,Y)
	+C redefine Z(4) to 4-momentum of the last decay product:
	+ Z(1)=-Z(1)
	+ Z(2)=-Z(2)
	+ Z(3)=-Z(3)
	+ Z(4)=SQRT(RU2+XM32)
	+C boost all to lab; also masses
	+ CALL bostdq(-1,PETA,X,X)
	+ CALL bostdq(-1,PETA,Y,Y)
	+ CALL bostdq(-1,PETA,Z,Z)
	+ DO L=1,4
	+ PHOT1(L)=X(L)
	+ PHOT2(L)=Y(L)
	+ PHOT3(L)=Z(L)
	+ ENDDO
	+ YM1=XM1
	+ YM2=XM2
	+ YM3=XM3
	+C to hepevt
	+ CALL FILHEP(0,1,ID1,K,K,0,0,PHOT1,YM1,.TRUE.)
	+ CALL FILHEP(0,1,ID2,K,K,0,0,PHOT2,YM2,.TRUE.)
	+ CALL FILHEP(0,1,ID3,K,K,0,0,PHOT3,YM3,.TRUE.)
	+ ENDIF
	+
	+ ENDIF
	+ ENDDO
	+C
	+ END
	+ SUBROUTINE TAUK0S(JAK)
	+ IMPLICIT double precision(A-H,O-Z)
	+C subroutine to decay K0S's from taus.
	+C this routine belongs to tauola universal interface, but uses
	+C routines from tauola utilities. Just flat phase space, but 4 channels.
	+C it is called at the beginning of SUBR. TAUPI0(JAK)
	+C and as far as hepevt search it is basically the same as TAUPI0. 25.08.2005
	+C this is the hepevt class in old style. No d_h_ class pre-name
	+ INTEGER NMXHEP
	+ PARAMETER (NMXHEP=4000)
	+ double precision phep, vhep
	+ INTEGER nevhep,nhep,isthep,idhep,jmohep,
	+ $ jdahep
	+ COMMON /hepevt/
	+ $ nevhep, ! serial number
	+ $ nhep, ! number of particles
	+ $ isthep(nmxhep), ! status code
	+ $ idhep(nmxhep), ! particle ident KF
	+ $ jmohep(2,nmxhep), ! parent particles
	+ $ jdahep(2,nmxhep), ! childreen particles
	+ $ phep(5,nmxhep), ! four-momentum, mass [GeV]
	+ $ vhep(4,nmxhep) ! vertex [mm]
	+* ----------------------------------------------------------------------
	+ LOGICAL qedrad
	+ COMMON /phoqed/
	+ $ qedrad(nmxhep) ! Photos flag
	+* ----------------------------------------------------------------------
	+ SAVE hepevt,phoqed
	+
	+
	+
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+*
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+
	+C position of taus, must be defined by host program:
	+ COMMON /TAUPOS/ NP1,NP2
	+c
	+ double precision RRR(1),BRSUM(3), RR(2)
	+ double precision PHOT1(4),PHOT2(4),PHOT3(4)
	+ double precision X(4), Y(4), Z(4)
	+ double precision YM1,YM2,YM3
	+ double precision R,RU,PETA(4),XM1,XM2,XM3,XM,XLAM
	+ double precision a,b,c
	+ XLAM(a,b,c)=SQRT(ABS((a-b-c)*2-4.0b*c))
	+C position of decaying particle:
	+ IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+ nhepM=nhep ! to avoid infinite loop
	+ DO K=JDAHEP(1,NPS),nhepM ! we search for K0S's from tau till eor.
	+ IF (IDHEP(K).EQ.310.AND.JDAHEP(1,K).LE.K) THEN ! IF we found K0S
	+
	+
	+ DO L=1,4
	+ PETA(L)= phep(L,K) ! K0S 4 momentum (this is cloned from eta decay)
	+ ENDDO
	+C K0S cumulated branching ratios:
	+ BRSUM(1)=0.313 ! 2 PI0
	+ BRSUM(2)=1.0 ! BRSUM(1)+0.319 ! Pi+ PI-
	+ BRSUM(3)=BRSUM(2)+0.237 ! pi+ pi- pi0 rest is thus pi+pi-gamma
	+ CALL RANMAR(RRR,1)
	+
	+ IF(RRR(1).LT.BRSUM(1)) THEN ! 2 pi0
	+ ID1= 111
	+ ID2= 111
	+ XM1=AMPIZ ! masses
	+ XM2=AMPIZ
	+ ELSEIF(RRR(1).LT.BRSUM(2)) THEN ! pi+ pi-
	+ ID1= 211
	+ ID2=-211
	+ XM1=AMPI ! masses
	+ XM2=AMPI
	+ ELSE ! gamma gamma unused !!!
	+ ID1= 22
	+ ID2= 22
	+ XM1= 0.0D0 ! masses
	+ XM2= 0.0D0
	+ ENDIF
	+
	+! random 3 vector on the sphere, of equal mass !!
	+ R=SQRT(PETA(4)2-PETA(3)2-PETA(2)2-PETA(1)2)/2D0
	+ R4=R
	+ R=SQRT(ABS(R2-XM12))
	+ CALL SPHERD(R,X)
	+ X(4)=R4
	+ Y(4)=R4
	+
	+ Y(1)=-X(1)
	+ Y(2)=-X(2)
	+ Y(3)=-X(3)
	+! boost to lab
	+ CALL bostdq(-1,PETA,X,X)
	+ CALL bostdq(-1,PETA,Y,Y)
	+ DO L=1,4
	+ PHOT1(L)=X(L)
	+ PHOT2(L)=Y(L)
	+ ENDDO
	+
	+ YM1=XM1
	+ YM2=XM2
	+C to hepevt
	+ CALL FILHEP(0,1,ID1,K,K,0,0,PHOT1,YM1,.TRUE.)
	+ CALL FILHEP(0,1,ID2,K,K,0,0,PHOT2,YM2,.TRUE.)
	+
	+C
	+ ENDIF
	+ ENDDO
	+
	+ END
	Index: trunk/contrib/tauola/Makefile.am
	===================================================================
	--- trunk/contrib/tauola/Makefile.am (revision 0)
	+++ trunk/contrib/tauola/Makefile.am (revision 8889)
	@@ -0,0 +1,80 @@
	+## Makefile.am -- Makefile for WHIZARD
	+##
	+## Process this file with automake to produce Makefile.in
	+##
	+########################################################################
	+#
	+# Copyright (C) 1999-2023 by
	+# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	+# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	+# Juergen Reuter <juergen.reuter@desy.de>
	+# with contributions from
	+# cf. main AUTHORS file
	+#
	+# WHIZARD is free software; you can redistribute it and/or modify it
	+# under the terms of the GNU General Public License as published by
	+# the Free Software Foundation; either version 2, or (at your option)
	+# any later version.
	+#
	+# WHIZARD is distributed in the hope that it will be useful, but
	+# WITHOUT ANY WARRANTY; without even the implied warranty of
	+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	+# GNU General Public License for more details.
	+#
	+# You should have received a copy of the GNU General Public License
	+# along with this program; if not, write to the Free Software
	+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	+#
	+########################################################################
	+
	+## The files in this directory end up in an auxiliary libtool library.
	+#AM_FFLAGS = -fno-automatic -ffixed-line-length-132 -fno-backslash -fPIC
	+AM_FFLAGS =
	+AM_FCFLAGS =
	+
	+if PYTHIA6_AVAILABLE
	+
	+if FC_IS_NAG
	+AM_FFLAGS += -dcfuns -w
	+AM_FCFLAGS += -dcfuns -w
	+endif
	+
	+noinst_LTLIBRARIES = libtauola_wo.la
	+
	+libtauola_wo_la_SOURCES = \
	+ tauface-jetset.f formf.f photos.f tauola.f tauola_photos_ini.f
	+
	+else
	+
	+noinst_LTLIBRARIES = libtauola_wo_dummy.la
	+libtauola_wo_dummy_la_SOURCES = tauola_dummy.f90
	+
	+endif
	+########################################################################
	+## Default Fortran compiler options
	+
	+## Profiling
	+if FC_USE_PROFILING
	+AM_FFLAGS += $(FCFLAGS_PROFILING)
	+AM_FCFLAGS += $(FCFLAGS_PROFILING)
	+endif
	+
	+## OpenMP
	+if FC_USE_OPENMP
	+AM_FFLAGS += $(FCFLAGS_OPENMP)
	+AM_FCFLAGS += $(FCFLAGS_OPENMP)
	+endif
	+
	+########################################################################
	+## Non-standard cleanup tasks
	+
	+## Remove F90 module files
	+clean-local:
	+ -rm -f *.$(FC_MODULE_EXT)
	+if FC_SUBMODULES
	+ -rm -f *.smod
	+endif
	+
	+## Remove backup files
	+maintainer-clean-local:
	+ -rm -f *~
	Index: trunk/contrib/tauola/tauola.f
	===================================================================
	--- trunk/contrib/tauola/tauola.f (revision 0)
	+++ trunk/contrib/tauola/tauola.f (revision 8889)
	@@ -0,0 +1,5325 @@
	+ SUBROUTINE JAKER(JAK)
	+ IMPLICIT double precision (A-H,O-Z)
	+C *********************
	+C
	+C **********************************************************************
	+C *
	+
	+C *******TAUOLA LIBRARY: VERSION 2.7 ****** *
	+C ************DECEMBER 1993**************** *
	+
	+
	+
	+
	+C AUTHORS: S.JADACH, Z.WAS *** *
	+C R. DECKER, M. JEZABEK, J.H.KUEHN, *** *
	+C ******AVAILABLE FROM: WASM AT CERNVM **** *
	+C *****PUBLISHED IN COMP. PHYS. COMM.****** *
	+C * PREPRINT CERN-TH-5856 SEPTEMBER 1990 ** *
	+C * PREPRINT CERN-TH-6195 OCTOBER 1991 ** *
	+C * PREPRINT CERN-TH-6793 NOVEMBER 1992 ** *
	+C **********************************************************************
	+C
	+C ----------------------------------------------------------------------
	+c SUBROUTINE JAKER,
	+C CHOOSES DECAY MODE ACCORDING TO LIST OF BRANCHING RATIOS
	+C JAK=1 ELECTRON MODE
	+C JAK=2 MUON MODE
	+C JAK=3 PION MODE
	+C JAK=4 RHO MODE
	+C JAK=5 A1 MODE
	+C JAK=6 K MODE
	+C JAK=7 K* MODE
	+
	+C JAK=8-13 npi modes
	+C JAK=14-19 KKpi & Kpipi modes
	+C JAK=20-21 eta pi pi; gamma pi pi modes
	+
	+
	+
	+C
	+C called by : DEXAY
	+C ----------------------------------------------------------------------
	+ COMMON / TAUBRA / GAMPRT(30),JLIST(30),NCHAN
	+ logical condition
	+ double precision CUMUL(30),RRR(1)
	+C
	+ IF(NCHAN.LE.0.OR.NCHAN.GT.30) GOTO 902
	+ CALL RANMAR(RRR,1)
	+ SUM=0
	+ DO 20 I=1,NCHAN
	+ SUM=SUM+GAMPRT(I)
	+ 20 CUMUL(I)=SUM
	+ DO 25 I=NCHAN,1,-1
	+ if(cumul(nchan) > 0) then
	+ condition = RRR(1).LT.CUMUL(I)/CUMUL(NCHAN)
	+ else
	+ condition = .true.
	+ end if
	+ IF(condition) JI=I
	+ 25 CONTINUE
	+ JAK=JLIST(JI)
	+ RETURN
	+ 902 PRINT 9020
	+ 9020 FORMAT(' ----- JAKER: WRONG NCHAN')
	+ STOP
	+ END
	+ SUBROUTINE DEKAY(KTO,HX)
	+C ***********************
	+C THIS DEKAY IS IN SPIRIT OF THE 'DECAY' WHICH
	+C WAS INCLUDED IN KORAL-B PROGRAM, COMP. PHYS. COMMUN.
	+C VOL. 36 (1985) 191, SEE COMMENTS ON GENERAL PHILOSOPHY THERE.
	+C KTO=0 INITIALISATION (OBLIGATORY)
	+C KTO=1,11 DENOTES TAU+ AND KTO=2,12 TAU-
	+C DEKAY(1,H) AND DEKAY(2,H) IS CALLED INTERNALLY BY MC GENERATOR.
	+C H DENOTES THE POLARIMETRIC VECTOR, USED BY THE HOST PROGRAM FOR
	+C CALCULATION OF THE SPIN WEIGHT.
	+C USER MAY OPTIONALLY CALL DEKAY(11,H) DEKAY(12,H) IN ORDER
	+C TO TRANSFORM DECAY PRODUCTS TO CMS AND WRITE LUND RECORD IN /LUJETS/.
	+C KTO=100, PRINT FINAL REPORT (OPTIONAL).
	+C DECAY MODES:
	+C JAK=1 ELECTRON DECAY
	+C JAK=2 MU DECAY
	+C JAK=3 PI DECAY
	+C JAK=4 RHO DECAY
	+C JAK=5 A1 DECAY
	+C JAK=6 K DECAY
	+C JAK=7 K* DECAY
	+
	+C JAK= 8-13 npi modes
	+C JAK=14-19 KKpi & Kpipi modes
	+C JAK=20-21 eta pi pi; gamma pi pi modes
	+C JAK=0 INCLUSIVE: JAK=1-21
	+
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision H(4)
	+ double precision HX(4)
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+
	+ COMMON / IDFC / IDFF
	+
	+ COMMON /TAUPOS/ NP1,NP2
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+ COMMON / INOUT / INUT,IOUT
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),
	+ * PDUM4(4),PDUM5(4),HDUM(4),PDUM(4)
	+ double precision PDUMX(4,9)
	+ DATA IWARM/0/
	+ save iwarn, nevtot, nev1, nev2
	+ save h, hk
	+
	+ do 51 i=1, 4
	+ H(i)=0.0
	+51 continue
	+ KTOM=KTO
	+ IDF = IDFF
	+
	+ IF(KTO.EQ.-1) THEN
	+C ==================
	+C INITIALISATION OR REINITIALISATION
	+C first or second tau positions in HEPEVT as in KORALB/Z
	+ NP1=3
	+ NP2=4
	+ KTOM=1
	+ IF (IWARM.EQ.1) X=5/(IWARM-1)
	+ IWARM=1
	+ WRITE(IOUT,7001) JAK1,JAK2
	+ NEVTOT=0
	+ NEV1=0
	+ NEV2=0
	+ IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	+ CALL DADMEL(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DADMMU(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DADMPI(-1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DADMRO(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	+ CALL DADMAA(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
	+ CALL DADMKK(-1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DADMKS(-1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
	+ CALL DADNEW(-1,IDUM,HDUM,PDUM1,PDUM2,PDUMX,JDUM)
	+ ENDIF
	+ DO 21 I=1,30
	+ NEVDEC(I)=0
	+ GAMPMC(I)=0
	+ 21 GAMPER(I)=0
	+ ELSEIF(KTO.EQ.1) THEN
	+C =====================
	+C DECAY OF TAU+ IN THE TAU REST FRAME
	+ NEVTOT=NEVTOT+1
	+ IF(IWARM.EQ.0) GOTO 902
	+ ISGN= IDF/IABS(IDF)
	+
	+ CALL DEKAY1(0,H,ISGN)
	+ ELSEIF(KTO.EQ.2) THEN
	+C =================================
	+C DECAY OF TAU- IN THE TAU REST FRAME
	+ NEVTOT=NEVTOT+1
	+ IF(IWARM.EQ.0) GOTO 902
	+ ISGN=-IDF/IABS(IDF)
	+
	+ CALL DEKAY2(0,H,ISGN)
	+ ELSEIF(KTO.EQ.11) THEN
	+C ======================
	+C REST OF DECAY PROCEDURE FOR ACCEPTED TAU+ DECAY
	+ NEV1=NEV1+1
	+ ISGN= IDF/IABS(IDF)
	+ CALL DEKAY1(1,H,ISGN)
	+ ELSEIF(KTO.EQ.12) THEN
	+C ======================
	+C REST OF DECAY PROCEDURE FOR ACCEPTED TAU- DECAY
	+ NEV2=NEV2+1
	+ ISGN=-IDF/IABS(IDF)
	+ CALL DEKAY2(1,H,ISGN)
	+ ELSEIF(KTO.EQ.100) THEN
	+C =======================
	+ IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	+ CALL DADMEL( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DADMMU( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DADMPI( 1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DADMRO( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	+ CALL DADMAA( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
	+ CALL DADMKK( 1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DADMKS( 1,IDUM,HDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
	+ CALL DADNEW( 1,IDUM,HDUM,PDUM1,PDUM2,PDUMX,JDUM)
	+ WRITE(IOUT,7010) NEV1,NEV2,NEVTOT
	+ WRITE(IOUT,7011) (NEVDEC(I),GAMPMC(I),GAMPER(I),I= 1,7)
	+ WRITE(IOUT,7012)
	+ $ (NEVDEC(I),GAMPMC(I),GAMPER(I),NAMES(I-7),I=8,7+NMODE)
	+ WRITE(IOUT,7013)
	+ ENDIF
	+ ELSE
	+C ====
	+ GOTO 910
	+ ENDIF
	+C =====
	+ DO 78 K=1,4
	+ 78 HX(K)=H(K)
	+ RETURN
	+ 7001 FORMAT(///1X,15(5H*****)
	+
	+ $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	+ $ /,' ', 25X,'DEC 1993; ALEPH fixes introd. dec 98 ',9X,1H,
	+ $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	+ $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	+ $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	+ $ /,' ', 25X,'Physics initialization by ALEPH collab ',9X,1H,
	+ $ /,' ', 25X,'it is suggested to use this version ',9X,1H,
	+ $ /,' ', 25X,' with the help of the collab. advice ',9X,1H,
	+ $ /,' ', 25X,'****CERN TH-6793 NOVEMBER 1992**',9X,1H,
	+ $ /,' ', 25X,'5 or more pi dec.: precision limited ',9X,1H,
	+ $ /,' ', 25X,'*DEKAY ROUTINE: INITIALIZATION***',9X,1H,
	+ $ /,' ',I20 ,5X,'JAK1 = DECAY MODE TAU+ ',9X,1H,
	+ $ /,' ',I20 ,5X,'JAK2 = DECAY MODE TAU- ',9X,1H,
	+ $ /,1X,15(5H*****)/)
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	+ $ /,' ', 25X,'********DECEMBER 1993************',9X,1H,
	+ $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	+ $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	+ $ /,' ', 25X,'AVAILABLE FROM: WASM AT CERNVM ****',9X,1H,
	+ $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	+ $ /,' ', 25X,'****CERN-TH-5856 SEPTEMBER 1990**',9X,1H,
	+ $ /,' ', 25X,'****CERN-TH-6195 SEPTEMBER 1991**',9X,1H,
	+ $ /,' ', 25X,'****CERN TH-6793 NOVEMBER 1992**',9X,1H,
	+ $ /,' ', 25X,'**DEKAY ROUTINE: FINAL REPORT****',9X,1H,
	+ $ /,' ',I20 ,5X,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9X,1H,
	+ $ /,' ',I20 ,5X,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9X,1H,
	+ $ /,' ',I20 ,5X,'NEVTOT = SUM ',9X,1H,
	+ $ /,' *',' NOEVTS ',
	+ $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9X,1H*)
	+ 7011 FORMAT(1X,'*'
	+ $ ,I10,2F12.7 ,' DADMEL ELECTRON ',9X,1H*
	+ $ /,' ',I10,2F12.7 ,' DADMMU MUON ',9X,1H
	+ $ /,' ',I10,2F12.7 ,' DADMPI PION ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMRO RHO (->2PI) ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMAA A1 (->3PI) ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMKK KAON ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMKS K ',9X,1H*)
	+ 7012 FORMAT(1X,'*'
	+ $ ,I10,2F12.7,A31 ,8X,1H*)
	+ 7013 FORMAT(1X,'*'
	+ $ ,20X,'THE ERROR IS RELATIVE AND PART.WIDTH ',10X,1H*
	+ $ /,' ',20X,'IN UNITS GFERMI2MASS5/192/PI3 ',10X,1H*
	+ $ /,1X,15(5H*****)/)
	+ 902 PRINT 9020
	+ 9020 FORMAT(' ----- DEKAY: LACK OF INITIALISATION')
	+ STOP
	+ 910 PRINT 9100
	+ 9100 FORMAT(' ----- DEKAY: WRONG VALUE OF KTO ')
	+ STOP
	+ END
	+ SUBROUTINE DEKAY1(IMOD,HH,ISGN)
	+C *******************************
	+C THIS ROUTINE SIMULATES TAU+ DECAY
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / DECP4 / PP1(4),PP2(4),KFF1,KFF2
	+ double precision PP1 ,PP2
	+ INTEGER KFF1,KFF2
	+ double precision HH(4)
	+ double precision HV(4),PNU(4),PPI(4)
	+ double precision PWB(4),PMU(4),PNM(4)
	+ double precision PRHO(4),PIC(4),PIZ(4)
	+ double precision PAA(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PKK(4),PKS(4)
	+ double precision PNPI(4,9)
	+ double precision PHOT(4)
	+ double precision PDUM(4)
	+ DATA NEV,NPRIN/0,10/
	+ save nev, nprin, kto
	+ save hv, pnu, ppi, pwb, pmu, pnm
	+ save prho, pic, piz, paa, pim1, pim2, pipl
	+ save pkk, pks, pnpi, phot, pdum
	+ save jak, imd
	+
	+ KTO=1
	+ IF(JAK1.EQ.-1) RETURN
	+ IMD=IMOD
	+ IF(IMD.EQ.0) THEN
	+C =================
	+ JAK=JAK1
	+ IF(JAK1.EQ.0) CALL JAKER(JAK)
	+ IF(JAK.EQ.1) THEN
	+ CALL DADMEL(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	+ ELSEIF(JAK.EQ.2) THEN
	+ CALL DADMMU(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	+ ELSEIF(JAK.EQ.3) THEN
	+ CALL DADMPI(0, ISGN,HV,PPI,PNU)
	+ ELSEIF(JAK.EQ.4) THEN
	+ CALL DADMRO(0, ISGN,HV,PNU,PRHO,PIC,PIZ)
	+ ELSEIF(JAK.EQ.5) THEN
	+ CALL DADMAA(0, ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ ELSEIF(JAK.EQ.6) THEN
	+ CALL DADMKK(0, ISGN,HV,PKK,PNU)
	+ ELSEIF(JAK.EQ.7) THEN
	+ CALL DADMKS(0, ISGN,HV,PNU,PKS ,PKK,PPI,JKST)
	+ ELSE
	+ CALL DADNEW(0, ISGN,HV,PNU,PWB,PNPI,JAK-7)
	+ ENDIF
	+ DO 33 I=1,3
	+ 33 HH(I)=HV(I)
	+ HH(4)=1.0
	+
	+ ELSEIF(IMD.EQ.1) THEN
	+C =====================
	+ NEV=NEV+1
	+ IF (JAK.LT.31) THEN
	+ NEVDEC(JAK)=NEVDEC(JAK)+1
	+ ENDIF
	+ DO 34 I=1,4
	+ 34 PDUM(I)=.0
	+ IF(JAK.EQ.1) THEN
	+ CALL DWLUEL(1,ISGN,PNU,PWB,PMU,PNM)
	+ CALL DWRPH(KTOM,PHOT)
	+ DO 10 I=1,4
	+ 10 PP1(I)=PMU(I)
	+
	+ ELSEIF(JAK.EQ.2) THEN
	+ CALL DWLUMU(1,ISGN,PNU,PWB,PMU,PNM)
	+ CALL DWRPH(KTOM,PHOT)
	+ DO 20 I=1,4
	+ 20 PP1(I)=PMU(I)
	+
	+ ELSEIF(JAK.EQ.3) THEN
	+ CALL DWLUPI(1,ISGN,PPI,PNU)
	+ DO 30 I=1,4
	+ 30 PP1(I)=PPI(I)
	+
	+ ELSEIF(JAK.EQ.4) THEN
	+ CALL DWLURO(1,ISGN,PNU,PRHO,PIC,PIZ)
	+ DO 40 I=1,4
	+ 40 PP1(I)=PRHO(I)
	+
	+ ELSEIF(JAK.EQ.5) THEN
	+ CALL DWLUAA(1,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ DO 50 I=1,4
	+ 50 PP1(I)=PAA(I)
	+ ELSEIF(JAK.EQ.6) THEN
	+ CALL DWLUKK(1,ISGN,PKK,PNU)
	+ DO 60 I=1,4
	+ 60 PP1(I)=PKK(I)
	+ ELSEIF(JAK.EQ.7) THEN
	+ CALL DWLUKS(1,ISGN,PNU,PKS,PKK,PPI,JKST)
	+ DO 70 I=1,4
	+ 70 PP1(I)=PKS(I)
	+ ELSE
	+CAM MULTIPION DECAY
	+ CALL DWLNEW(1,ISGN,PNU,PWB,PNPI,JAK)
	+ DO 80 I=1,4
	+ 80 PP1(I)=PWB(I)
	+ ENDIF
	+
	+ ENDIF
	+C =====
	+ END
	+ SUBROUTINE DEKAY2(IMOD,HH,ISGN)
	+C *******************************
	+C THIS ROUTINE SIMULATES TAU- DECAY
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / DECP4 / PP1(4),PP2(4),KFF1,KFF2
	+ double precision PP1 ,PP2
	+ INTEGER KFF1,KFF2
	+ double precision HH(4)
	+ double precision HV(4),PNU(4),PPI(4)
	+ double precision PWB(4),PMU(4),PNM(4)
	+ double precision PRHO(4),PIC(4),PIZ(4)
	+ double precision PAA(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PKK(4),PKS(4)
	+ double precision PNPI(4,9)
	+ double precision PHOT(4)
	+ double precision PDUM(4)
	+ DATA NEV,NPRIN/0,10/
	+ save nev, nprin, kto
	+ save hhm hv, pnu, ppi, pwb, pmu, pnm
	+ save prho, pic, piz, paa, pim1, pim2, pipl
	+ save pkk, pks, pnpi, phot, pdum
	+ save jak, imd
	+
	+ KTO=2
	+ IF(JAK2.EQ.-1) RETURN
	+ IMD=IMOD
	+ IF(IMD.EQ.0) THEN
	+C =================
	+ JAK=JAK2
	+ IF(JAK2.EQ.0) CALL JAKER(JAK)
	+ IF(JAK.EQ.1) THEN
	+ CALL DADMEL(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	+ ELSEIF(JAK.EQ.2) THEN
	+ CALL DADMMU(0, ISGN,HV,PNU,PWB,PMU,PNM,PHOT)
	+ ELSEIF(JAK.EQ.3) THEN
	+ CALL DADMPI(0, ISGN,HV,PPI,PNU)
	+ ELSEIF(JAK.EQ.4) THEN
	+ CALL DADMRO(0, ISGN,HV,PNU,PRHO,PIC,PIZ)
	+ ELSEIF(JAK.EQ.5) THEN
	+ CALL DADMAA(0, ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ ELSEIF(JAK.EQ.6) THEN
	+ CALL DADMKK(0, ISGN,HV,PKK,PNU)
	+ ELSEIF(JAK.EQ.7) THEN
	+ CALL DADMKS(0, ISGN,HV,PNU,PKS ,PKK,PPI,JKST)
	+ ELSE
	+ CALL DADNEW(0, ISGN,HV,PNU,PWB,PNPI,JAK-7)
	+ ENDIF
	+ DO 33 I=1,3
	+ 33 HH(I)=HV(I)
	+ HH(4)=1.0
	+ ELSEIF(IMD.EQ.1) THEN
	+C =====================
	+ NEV=NEV+1
	+ IF (JAK.LT.31) THEN
	+ NEVDEC(JAK)=NEVDEC(JAK)+1
	+ ENDIF
	+ DO 34 I=1,4
	+ 34 PDUM(I)=.0
	+ IF(JAK.EQ.1) THEN
	+ CALL DWLUEL(2,ISGN,PNU,PWB,PMU,PNM)
	+ CALL DWRPH(KTOM,PHOT)
	+ DO 10 I=1,4
	+ 10 PP2(I)=PMU(I)
	+
	+ ELSEIF(JAK.EQ.2) THEN
	+ CALL DWLUMU(2,ISGN,PNU,PWB,PMU,PNM)
	+ CALL DWRPH(KTOM,PHOT)
	+ DO 20 I=1,4
	+ 20 PP2(I)=PMU(I)
	+
	+ ELSEIF(JAK.EQ.3) THEN
	+ CALL DWLUPI(2,ISGN,PPI,PNU)
	+ DO 30 I=1,4
	+ 30 PP2(I)=PPI(I)
	+
	+ ELSEIF(JAK.EQ.4) THEN
	+ CALL DWLURO(2,ISGN,PNU,PRHO,PIC,PIZ)
	+ DO 40 I=1,4
	+ 40 PP2(I)=PRHO(I)
	+
	+ ELSEIF(JAK.EQ.5) THEN
	+ CALL DWLUAA(2,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ DO 50 I=1,4
	+ 50 PP2(I)=PAA(I)
	+ ELSEIF(JAK.EQ.6) THEN
	+ CALL DWLUKK(2,ISGN,PKK,PNU)
	+ DO 60 I=1,4
	+ 60 PP1(I)=PKK(I)
	+ ELSEIF(JAK.EQ.7) THEN
	+ CALL DWLUKS(2,ISGN,PNU,PKS,PKK,PPI,JKST)
	+ DO 70 I=1,4
	+ 70 PP1(I)=PKS(I)
	+ ELSE
	+CAM MULTIPION DECAY
	+ CALL DWLNEW(2,ISGN,PNU,PWB,PNPI,JAK)
	+ DO 80 I=1,4
	+ 80 PP1(I)=PWB(I)
	+ ENDIF
	+C
	+ ENDIF
	+C =====
	+ END
	+ SUBROUTINE DEXAY(KTO,POL)
	+C ----------------------------------------------------------------------
	+C THIS 'DEXAY' IS A ROUTINE WHICH GENERATES DECAY OF THE SINGLE
	+C POLARIZED TAU, POL IS A POLARIZATION VECTOR (NOT A POLARIMETER
	+C VECTOR AS IN DEKAY) OF THE TAU AND IT IS AN INPUT PARAMETER.
	+C KTO=0 INITIALISATION (OBLIGATORY)
	+C KTO=1 DENOTES TAU+ AND KTO=2 TAU-
	+C DEXAY(1,POL) AND DEXAY(2,POL) ARE CALLED INTERNALLY BY MC GENERATOR.
	+C DECAY PRODUCTS ARE TRANSFORMED READILY
	+C TO CMS AND WRITEN IN THE LUND RECORD IN /LUJETS/
	+C KTO=100, PRINT FINAL REPORT (OPTIONAL).
	+C
	+C called by : KORALZ
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+ COMMON / IDFC / IDFF
	+ COMMON /TAUPOS/ NP1,NP2
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4)
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	+ double precision PDUM(4)
	+ double precision PDUMI(4,9)
	+ DATA IWARM/0/
	+
	+ save iwarn
	+ save pdum1, pdum2, pdum3, pdum4, pdum5
	+ save pdum, pdumi
	+ save nevtot, nev1, nev2
	+
	+ KTOM=KTO
	+C
	+ IF(KTO.EQ.-1) THEN
	+C ==================
	+
	+C INITIALISATION OR REINITIALISATION
	+C first or second tau positions in HEPEVT as in KORALB/Z
	+ NP1=3
	+ NP2=4
	+ IWARM=1
	+ WRITE(IOUT, 7001) JAK1,JAK2
	+ NEVTOT=0
	+ NEV1=0
	+ NEV2=0
	+ IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	+ CALL DEXEL(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DEXMU(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DEXPI(-1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DEXRO(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	+ CALL DEXAA(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JDUM)
	+ CALL DEXKK(-1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DEXKS(-1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,JDUM)
	+ CALL DEXNEW(-1,IDUM,PDUM,PDUM1,PDUM2,PDUMI,JDUM)
	+ ENDIF
	+ DO 21 I=1,30
	+ NEVDEC(I)=0
	+ GAMPMC(I)=0
	+ 21 GAMPER(I)=0
	+ ELSEIF(KTO.EQ.1) THEN
	+C =====================
	+C DECAY OF TAU+ IN THE TAU REST FRAME
	+ NEVTOT=NEVTOT+1
	+ NEV1=NEV1+1
	+ IF(IWARM.EQ.0) GOTO 902
	+ ISGN=IDFF/IABS(IDFF)
	+CAM CALL DEXAY1(POL,ISGN)
	+ CALL DEXAY1(KTO,JAK1,JAKP,POL,ISGN)
	+ ELSEIF(KTO.EQ.2) THEN
	+C =================================
	+C DECAY OF TAU- IN THE TAU REST FRAME
	+ NEVTOT=NEVTOT+1
	+ NEV2=NEV2+1
	+ IF(IWARM.EQ.0) GOTO 902
	+ ISGN=-IDFF/IABS(IDFF)
	+CAM CALL DEXAY2(POL,ISGN)
	+ CALL DEXAY1(KTO,JAK2,JAKM,POL,ISGN)
	+ ELSEIF(KTO.EQ.100) THEN
	+C =======================
	+ IF(JAK1.NE.-1.OR.JAK2.NE.-1) THEN
	+ CALL DEXEL( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DEXMU( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ CALL DEXPI( 1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DEXRO( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4)
	+ CALL DEXAA( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,IDUM)
	+ CALL DEXKK( 1,IDUM,PDUM,PDUM1,PDUM2)
	+ CALL DEXKS( 1,IDUM,PDUM,PDUM1,PDUM2,PDUM3,PDUM4,IDUM)
	+ CALL DEXNEW( 1,IDUM,PDUM,PDUM1,PDUM2,PDUMI,IDUM)
	+ WRITE(IOUT,7010) NEV1,NEV2,NEVTOT
	+ WRITE(IOUT,7011) (NEVDEC(I),GAMPMC(I),GAMPER(I),I= 1,7)
	+ WRITE(IOUT,7012)
	+ $ (NEVDEC(I),GAMPMC(I),GAMPER(I),NAMES(I-7),I=8,7+NMODE)
	+ WRITE(IOUT,7013)
	+ ENDIF
	+ ELSE
	+ GOTO 910
	+ ENDIF
	+ RETURN
	+ 7001 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	+ $ /,' ', 25X,'DEC 1993; ALEPH fixes introd. dec 98 ',9X,1H,
	+ $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	+ $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	+ $ /,' ', 25X,'Physics initialization by ALEPH collab ',9X,1H,
	+ $ /,' ', 25X,'it is suggested to use this version ',9X,1H,
	+ $ /,' ', 25X,' with the help of the collab. advice ',9X,1H,
	+ $ /,' ', 25X,'AVAILABLE FROM: WASM AT CERNVM ****',9X,1H,
	+ $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	+ $ /,' ', 25X,'****CERN-TH-6793 NOVEMBER 1992**',9X,1H,
	+ $ /,' ', 25X,'5 or more pi dec.: precision limited ',9X,1H,
	+ $ /,' ', 25X,'***DEXAY ROUTINE: INITIALIZATION*',9X,1H
	+ $ /,' ',I20 ,5X,'JAK1 = DECAY MODE FERMION1 (TAU+) ',9X,1H
	+ $ /,' ',I20 ,5X,'JAK2 = DECAY MODE FERMION2 (TAU-) ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+CHBU format 7010 had more than 19 continuation lines
	+CHBU split into two
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'**TAUOLA LIBRARY: VERSION 2.7 ***',9X,1H,
	+ $ /,' ', 25X,'********DECEMBER 1993************',9X,1H,
	+ $ /,' ', 25X,'AUTHORS: S.JADACH, Z.WAS***********',9X,1H,
	+ $ /,' ', 25X,'R. DECKER, M. JEZABEK, J.H.KUEHN***',9X,1H,
	+ $ /,' ', 25X,'AVAILABLE FROM: WASM AT CERNVM ****',9X,1H,
	+ $ /,' ', 25X,'** PUBLISHED IN COMP. PHYS. COMM.',9X,1H,
	+ $ /,' ', 25X,'****CERN-TH-5856 SEPTEMBER 1990**',9X,1H,
	+ $ /,' ', 25X,'****CERN-TH-6195 SEPTEMBER 1991**',9X,1H,
	+ $ /,' ', 25X,'****CERN-TH-6793 NOVEMBER 1992**',9X,1H,
	+ $ /,' ', 25X,'***DEXAY ROUTINE: FINAL REPORT***',9X,1H
	+ $ /,' ',I20 ,5X,'NEV1 = NO. OF TAU+ DECS. ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEV2 = NO. OF TAU- DECS. ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVTOT = SUM ',9X,1H
	+ $ /,' *',' NOEVTS ',
	+ $ ' PART.WIDTH ERROR ROUTINE DECAY MODE ',9X,1H*)
	+ 7011 FORMAT(1X,'*'
	+ $ ,I10,2F12.7 ,' DADMEL ELECTRON ',9X,1H*
	+ $ /,' ',I10,2F12.7 ,' DADMMU MUON ',9X,1H
	+ $ /,' ',I10,2F12.7 ,' DADMPI PION ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMRO RHO (->2PI) ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMAA A1 (->3PI) ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMKK KAON ',9X,1H
	+ $ /,' ',I10,2F12.7, ' DADMKS K ',9X,1H*)
	+ 7012 FORMAT(1X,'*'
	+ $ ,I10,2F12.7,A31 ,8X,1H*)
	+ 7013 FORMAT(1X,'*'
	+ $ ,20X,'THE ERROR IS RELATIVE AND PART.WIDTH ',10X,1H*
	+ $ /,' ',20X,'IN UNITS GFERMI2MASS5/192/PI3 ',10X,1H*
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DEXAY: LACK OF INITIALISATION')
	+ STOP
	+ 910 WRITE(IOUT, 9100)
	+ 9100 FORMAT(' ----- DEXAY: WRONG VALUE OF KTO ')
	+ STOP
	+ END
	+ SUBROUTINE DEXAY1(KTO,JAKIN,JAK,POL,ISGN)
	+C ---------------------------------------------------------------------
	+C THIS ROUTINE SIMULATES TAU+- DECAY
	+C
	+C called by : DEXAY
	+C ---------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4),POLAR(4)
	+ double precision PNU(4),PPI(4)
	+ double precision PRHO(4),PIC(4),PIZ(4)
	+ double precision PWB(4),PMU(4),PNM(4)
	+ double precision PAA(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PKK(4),PKS(4)
	+ double precision PNPI(4,9)
	+ double precision PHOT(4)
	+ double precision PDUM(4)
	+C
	+ save polar, pnu, ppi, prho, pic, piz, pwb, pmu, pnm
	+ save paa, pim1, pim2, pipl, pkk, pks, pnpi, phot, pdum
	+
	+ IF(JAKIN.EQ.-1) RETURN
	+ DO 33 I=1,3
	+ 33 POLAR(I)=POL(I)
	+ POLAR(4)=0.
	+ DO 34 I=1,4
	+ 34 PDUM(I)=.0
	+ JAK=JAKIN
	+ IF(JAK.EQ.0) CALL JAKER(JAK)
	+CAM
	+ IF(JAK.EQ.1) THEN
	+ CALL DEXEL(0, ISGN,POLAR,PNU,PWB,PMU,PNM,PHOT)
	+ CALL DWLUEL(KTO,ISGN,PNU,PWB,PMU,PNM)
	+ CALL DWRPH(KTO,PHOT )
	+ ELSEIF(JAK.EQ.2) THEN
	+ CALL DEXMU(0, ISGN,POLAR,PNU,PWB,PMU,PNM,PHOT)
	+ CALL DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
	+ CALL DWRPH(KTO,PHOT )
	+ ELSEIF(JAK.EQ.3) THEN
	+ CALL DEXPI(0, ISGN,POLAR,PPI,PNU)
	+ CALL DWLUPI(KTO,ISGN,PPI,PNU)
	+ ELSEIF(JAK.EQ.4) THEN
	+ CALL DEXRO(0, ISGN,POLAR,PNU,PRHO,PIC,PIZ)
	+ CALL DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
	+ ELSEIF(JAK.EQ.5) THEN
	+ CALL DEXAA(0, ISGN,POLAR,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ CALL DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ ELSEIF(JAK.EQ.6) THEN
	+ CALL DEXKK(0, ISGN,POLAR,PKK,PNU)
	+ CALL DWLUKK(KTO,ISGN,PKK,PNU)
	+ ELSEIF(JAK.EQ.7) THEN
	+ CALL DEXKS(0, ISGN,POLAR,PNU,PKS,PKK,PPI,JKST)
	+ CALL DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
	+ ELSE
	+ JNPI=JAK-7
	+ CALL DEXNEW(0, ISGN,POLAR,PNU,PWB,PNPI,JNPI)
	+ CALL DWLNEW(KTO,ISGN,PNU,PWB,PNPI,JAK)
	+ ENDIF
	+ NEVDEC(JAK)=NEVDEC(JAK)+1
	+ END
	+ SUBROUTINE DEXEL(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
	+C ----------------------------------------------------------------------
	+C THIS SIMULATES TAU DECAY IN TAU REST FRAME
	+C INTO ELECTRON AND TWO NEUTRINOS
	+C
	+C called by : DEXAY,DEXAY1
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision POL(4),HV(4),PWB(4),PNU(4),Q1(4),
	+ * Q2(4),PH(4),RN(1)
	+ DATA IWARM/0/
	+ save iwarn
	+ save hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ CALL DADMEL( -1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	+CC CALL HBOOK1(813,'WEIGHT DISTRIBUTION DEXEL $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DADMEL( 0,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(813,WT)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ CALL DADMEL( 1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	+CC CALL HPRINT(813)
	+ ENDIF
	+C =====
	+ RETURN
	+ 902 PRINT 9020
	+ 9020 FORMAT(' ----- DEXEL: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DEXMU(MODE,ISGN,POL,PNU,PWB,Q1,Q2,PH)
	+C ----------------------------------------------------------------------
	+C THIS SIMULATES TAU DECAY IN ITS REST FRAME
	+C INTO MUON AND TWO NEUTRINOS
	+C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+C PWB W-BOSON
	+C Q1 MUON
	+C Q2 MUON-NEUTRINO
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4),HV(4),PWB(4),PNU(4)
	+ double precision Q1(4),Q2(4),PH(4),RN(1)
	+ DATA IWARM/0/
	+ save iwarn, hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ CALL DADMMU( -1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	+CC CALL HBOOK1(814,'WEIGHT DISTRIBUTION DEXMU $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DADMMU( 0,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(814,WT)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ CALL DADMMU( 1,ISGN,HV,PNU,PWB,Q1,Q2,PH)
	+CC CALL HPRINT(814)
	+ ENDIF
	+C =====
	+ RETURN
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DEXMU: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DADMEL(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
	+C ----------------------------------------------------------------------
	+C
	+C called by : DEXEL,(DEKAY,DEKAY1)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision PHX(4)
	+ double precision HHV(4),HV(4),PWB(4),PNU(4),Q1(4),Q2(4)
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	+ double precision RRR(3)
	+ double precision SWT, SSWT
	+ DATA PI /3.141592653589793238462643/
	+ DATA IWARM/0/
	+ save iwarn, nevraw, nevacc, nevovr, swt, sswt, wtmax
	+ save hv, pdum1, pdum2, pdum3, pdum4, pdum5
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ NEVRAW=0
	+ NEVACC=0
	+ NEVOVR=0
	+ SWT=0
	+ SSWT=0
	+ WTMAX=1E-20
	+ DO 15 I=1,500
	+ CALL DPHSEL(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	+15 CONTINUE
	+CC CALL HBOOK1(803,'WEIGHT DISTRIBUTION DADMEL $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ NEVRAW=NEVRAW+1
	+ CALL DPHSEL(WT,HV,PNU,PWB,Q1,Q2,PHX)
	+CC CALL HFILL(803,WT/WTMAX)
	+ SWT=SWT+WT
	+ SSWT=SSWT+WT**2
	+ CALL RANMAR(RRR,3)
	+ RN=RRR(1)
	+ IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	+ IF(RN*WTMAX.GT.WT) GOTO 300
	+C ROTATIONS TO BASIC TAU REST FRAME
	+ RR2=RRR(2)
	+ COSTHE=-1.+2.*RR2
	+ THET=ACOS(COSTHE)
	+ RR3=RRR(3)
	+ PHI =2PIRR3
	+ CALL ROTOR2(THET,PNU,PNU)
	+ CALL ROTOR3( PHI,PNU,PNU)
	+ CALL ROTOR2(THET,PWB,PWB)
	+ CALL ROTOR3( PHI,PWB,PWB)
	+ CALL ROTOR2(THET,Q1,Q1)
	+ CALL ROTOR3( PHI,Q1,Q1)
	+ CALL ROTOR2(THET,Q2,Q2)
	+ CALL ROTOR3( PHI,Q2,Q2)
	+ CALL ROTOR2(THET,HV,HV)
	+ CALL ROTOR3( PHI,HV,HV)
	+ CALL ROTOR2(THET,PHX,PHX)
	+ CALL ROTOR3( PHI,PHX,PHX)
	+ DO 44,I=1,3
	+ 44 HHV(I)=-ISGN*HV(I)
	+ NEVACC=NEVACC+1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVRAW.EQ.0) RETURN
	+ PARGAM=SWT/FLOAT(NEVRAW+1)
	+ ERROR=0
	+ IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	+ RAT=PARGAM/GAMEL
	+ WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	+CC CALL HPRINT(803)
	+ GAMPMC(1)=RAT
	+ GAMPER(1)=ERROR
	+CAM NEVDEC(1)=NEVACC
	+ ENDIF
	+C =====
	+ RETURN
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMEL FINAL REPORT ****** ',9X,1H*
	+ $ /,' ',I20 ,5X,'NEVRAW = NO. OF EL DECAYS TOTAL ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVACC = NO. OF EL DECS. ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH ( ELECTRON) IN GEV UNITS ',9X,1H
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.9,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	+ $ /,' ',25X, 'COMPLETE QED CORRECTIONS INCLUDED ',9X,1H
	+ $ /,' ',25X, 'BUT ONLY V-A CUPLINGS ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DADMEL: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DADMMU(MODE,ISGN,HHV,PNU,PWB,Q1,Q2,PHX)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision PHX(4)
	+ double precision HHV(4),HV(4),PNU(4),PWB(4),Q1(4),Q2(4)
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	+ double precision RRR(3)
	+ double precision SWT, SSWT
	+ DATA PI /3.141592653589793238462643/
	+ DATA IWARM /0/
	+ save iwarn, nevraw, nevacc, nevovr, swt, sswt, wtmax, hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ NEVRAW=0
	+ NEVACC=0
	+ NEVOVR=0
	+ SWT=0
	+ SSWT=0
	+ WTMAX=1E-20
	+ DO 15 I=1,500
	+ CALL DPHSMU(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5)
	+ IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	+15 CONTINUE
	+CC CALL HBOOK1(802,'WEIGHT DISTRIBUTION DADMMU $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ NEVRAW=NEVRAW+1
	+ CALL DPHSMU(WT,HV,PNU,PWB,Q1,Q2,PHX)
	+CC CALL HFILL(802,WT/WTMAX)
	+ SWT=SWT+WT
	+ SSWT=SSWT+WT**2
	+ CALL RANMAR(RRR,3)
	+ RN=RRR(1)
	+ IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	+ IF(RN*WTMAX.GT.WT) GOTO 300
	+C ROTATIONS TO BASIC TAU REST FRAME
	+ COSTHE=-1.+2.*RRR(2)
	+ THET=ACOS(COSTHE)
	+ PHI =2PIRRR(3)
	+ CALL ROTOR2(THET,PNU,PNU)
	+ CALL ROTOR3( PHI,PNU,PNU)
	+ CALL ROTOR2(THET,PWB,PWB)
	+ CALL ROTOR3( PHI,PWB,PWB)
	+ CALL ROTOR2(THET,Q1,Q1)
	+ CALL ROTOR3( PHI,Q1,Q1)
	+ CALL ROTOR2(THET,Q2,Q2)
	+ CALL ROTOR3( PHI,Q2,Q2)
	+ CALL ROTOR2(THET,HV,HV)
	+ CALL ROTOR3( PHI,HV,HV)
	+ CALL ROTOR2(THET,PHX,PHX)
	+ CALL ROTOR3( PHI,PHX,PHX)
	+ DO 44,I=1,3
	+ 44 HHV(I)=-ISGN*HV(I)
	+ NEVACC=NEVACC+1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVRAW.EQ.0) RETURN
	+ PARGAM=SWT/FLOAT(NEVRAW+1)
	+ ERROR=0
	+ IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	+ RAT=PARGAM/GAMEL
	+ WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	+CC CALL HPRINT(802)
	+ GAMPMC(2)=RAT
	+ GAMPER(2)=ERROR
	+CAM NEVDEC(2)=NEVACC
	+ ENDIF
	+C =====
	+ RETURN
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMMU FINAL REPORT ****** ',9X,1H*
	+ $ /,' ',I20 ,5X,'NEVRAW = NO. OF MU DECAYS TOTAL ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVACC = NO. OF MU DECS. ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH (MU DECAY) IN GEV UNITS ',9X,1H
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.9,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	+ $ /,' ',25X, 'COMPLETE QED CORRECTIONS INCLUDED ',9X,1H
	+ $ /,' ',25X, 'BUT ONLY V-A CUPLINGS ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DADMMU: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DPHSEL(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
	+C XNX,XNA was flipped in parameters of dphsel and dphsmu
	+C *********************************************************************
	+C * ELECTRON DECAY MODE *
	+C *********************************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PHX(4)
	+ double precision HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
	+ double precision HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
	+ double precision DGAMT
	+ IELMU=1
	+ CALL DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
	+ DO 7 K=1,4
	+ HVX(K)=HV(K)
	+ PHX(K)=PH(K)
	+ PAAX(K)=PAA(K)
	+ XAX(K)=XA(K)
	+ QPX(K)=QP(K)
	+ XNX(K)=XN(K)
	+ 7 CONTINUE
	+ DGAMX=DGAMT
	+ END
	+ SUBROUTINE DPHSMU(DGAMX,HVX,XNX,PAAX,QPX,XAX,PHX)
	+C XNX,XNA was flipped in parameters of dphsel and dphsmu
	+C *********************************************************************
	+C * MUON DECAY MODE *
	+C *********************************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PHX(4)
	+ double precision HVX(4),PAAX(4),XAX(4),QPX(4),XNX(4)
	+ double precision HV(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
	+ double precision DGAMT
	+ IELMU=2
	+ CALL DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
	+ DO 7 K=1,4
	+ HVX(K)=HV(K)
	+ PHX(K)=PH(K)
	+ PAAX(K)=PAA(K)
	+ XAX(K)=XA(K)
	+ QPX(K)=QP(K)
	+ XNX(K)=XN(K)
	+ 7 CONTINUE
	+ DGAMX=DGAMT
	+ END
	+ SUBROUTINE DRCMU(DGAMT,HV,PH,PAA,XA,QP,XN,IELMU)
	+ IMPLICIT double precision (A-H,O-Z)
	+C ----------------------------------------------------------------------
	+* IT SIMULATES E,MU CHANNELS OF TAU DECAY IN ITS REST FRAME WITH
	+* QED ORDER ALPHA CORRECTIONS
	+C ----------------------------------------------------------------------
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ COMMON / TAURAD / XK0DEC,ITDKRC
	+ double precision XK0DEC
	+ double precision HV(4),PT(4),PH(4),PAA(4),XA(4),QP(4),XN(4)
	+ double precision PR(4)
	+ double precision RRR(6)
	+ LOGICAL IHARD
	+ DATA PI /3.141592653589793238462643D0/
	+ !XLAM(X,Y,Z)=SQRT((X-Y-Z)*2-4.0Y*Z)
	+C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
	+C
	+C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	+ PHSPAC=1./217/PI8
	+ AMTAX=AMTAU
	+C TAU MOMENTUM
	+ PT(1)=0.D0
	+ PT(2)=0.D0
	+ PT(3)=0.D0
	+ PT(4)=AMTAX
	+C
	+ CALL RANMAR(RRR,6)
	+C
	+ IF (IELMU.EQ.1) THEN
	+ AMU=AMEL
	+ ELSE
	+ AMU=AMMU
	+ ENDIF
	+C
	+ PRHARD=0.30D0
	+ IF ( ITDKRC.EQ.0) PRHARD=0D0
	+ PRSOFT=1.-PRHARD
	+ IF(PRSOFT.LT.0.1) THEN
	+ PRINT *, 'ERROR IN DRCMU; PRSOFT=',PRSOFT
	+ STOP
	+ ENDIF
	+C
	+ RR5=RRR(5)
	+ IHARD=(RR5.GT.PRSOFT)
	+ IF (IHARD) THEN
	+C TAU DECAY TO 'TAU+photon'
	+ RR1=RRR(1)
	+ AMS1=(AMU+AMNUTA)**2
	+ AMS2=(AMTAX)**2
	+ XK1=1-AMS1/AMS2
	+ XL1=LOG(XK1/2/XK0DEC)
	+ XL0=LOG(2*XK0DEC)
	+ XK=EXP(XL1*RR1+XL0)
	+ AM3SQ=(1-XK)*AMS2
	+ AM3 =SQRT(AM3SQ)
	+ PHSPAC=PHSPACAMS2XL1*XK
	+ PHSPAC=PHSPAC/PRHARD
	+ ELSE
	+ AM3=AMTAX
	+ PHSPAC=PHSPAC26PI**3
	+ PHSPAC=PHSPAC/PRSOFT
	+ ENDIF
	+C MASS OF NEUTRINA SYSTEM
	+ RR2=RRR(2)
	+ AMS1=(AMNUTA)**2
	+ AMS2=(AM3-AMU)**2
	+CAM
	+CAM
	+* FLAT PHASE SPACE;
	+ AM2SQ=AMS1+ RR2*(AMS2-AMS1)
	+ AM2 =SQRT(AM2SQ)
	+ PHSPAC=PHSPAC*(AMS2-AMS1)
	+* NEUTRINA REST FRAME, DEFINE XN AND XA
	+ ENQ1=(AM2SQ+AMNUTA*2)/(2AM2)
	+ ENQ2=(AM2SQ-AMNUTA*2)/(2AM2)
	+ PPI= ENQ12-AMNUTA2
	+ PPPI=SQRT(ABS(ENQ12-AMNUTA2))
	+ PHSPAC=PHSPAC(4PI)(2PPPI/AM2)
	+* NU TAU IN NUNU REST FRAME
	+ CALL SPHERD(PPPI,XN)
	+ XN(4)=ENQ1
	+* NU LIGHT IN NUNU REST FRAME
	+ DO 30 I=1,3
	+ 30 XA(I)=-XN(I)
	+ XA(4)=ENQ2
	+* TAU-prim REST FRAME, DEFINE QP (muon
	+* NUNU MOMENTUM
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1.D0/(2AM3)(AM32+AM22-AMU**2)
	+ PR(3)= SQRT(ABS(PR(4)2-AM22))
	+ PPI = PR(4)2-AM22
	+* MUON MOMENTUM
	+ QP(1)=0
	+ QP(2)=0
	+ QP(4)=1.D0/(2AM3)(AM32-AM22+AMU**2)
	+ QP(3)=-PR(3)
	+ PHSPAC=PHSPAC(4PI)(2PR(3)/AM3)
	+* NEUTRINA BOOSTED FROM THEIR FRAME TO TAU-prim REST FRAME
	+ EXE=(PR(4)+PR(3))/AM2
	+ CALL BOSTD3(EXE,XN,XN)
	+ CALL BOSTD3(EXE,XA,XA)
	+ RR3=RRR(3)
	+ RR4=RRR(4)
	+ IF (IHARD) THEN
	+ EPS=4(AMU/AMTAX)*2
	+ XL1=LOG((2+EPS)/EPS)
	+ XL0=LOG(EPS)
	+ ETA =EXP(XL1*RR3+XL0)
	+ CTHET=1+EPS-ETA
	+ THET =ACOS(CTHET)
	+ PHSPAC=PHSPACXL1/2ETA
	+ PHI = 2PIRR4
	+ CALL ROTPOX(THET,PHI,XN)
	+ CALL ROTPOX(THET,PHI,XA)
	+ CALL ROTPOX(THET,PHI,QP)
	+ CALL ROTPOX(THET,PHI,PR)
	+C
	+* NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
	+* tau-prim MOMENTUM
	+ PAA(1)=0
	+ PAA(2)=0
	+ PAA(4)=1/(2AMTAX)(AMTAX2+AM32)
	+ PAA(3)= SQRT(ABS(PAA(4)2-AM32))
	+ PPI = PAA(4)2-AM32
	+ PHSPAC=PHSPAC(4PI)(2PAA(3)/AMTAX)
	+* GAMMA MOMENTUM
	+ PH(1)=0
	+ PH(2)=0
	+ PH(4)=PAA(3)
	+ PH(3)=-PAA(3)
	+* ALL MOMENTA BOOSTED FROM TAU-prim REST FRAME TO TAU REST FRAME
	+* Z-AXIS ANTIPARALLEL TO PHOTON MOMENTUM
	+ EXE=(PAA(4)+PAA(3))/AM3
	+ CALL BOSTD3(EXE,XN,XN)
	+ CALL BOSTD3(EXE,XA,XA)
	+ CALL BOSTD3(EXE,QP,QP)
	+ CALL BOSTD3(EXE,PR,PR)
	+ ELSE
	+ THET =ACOS(-1.+2*RR3)
	+ PHI = 2PIRR4
	+ CALL ROTPOX(THET,PHI,XN)
	+ CALL ROTPOX(THET,PHI,XA)
	+ CALL ROTPOX(THET,PHI,QP)
	+ CALL ROTPOX(THET,PHI,PR)
	+C
	+* NOW TO THE TAU REST FRAME, DEFINE TAU-prim AND GAMMA MOMENTA
	+* tau-prim MOMENTUM
	+ PAA(1)=0
	+ PAA(2)=0
	+ PAA(4)=AMTAX
	+ PAA(3)=0
	+* GAMMA MOMENTUM
	+ PH(1)=0
	+ PH(2)=0
	+ PH(4)=0
	+ PH(3)=0
	+ ENDIF
	+C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
	+ CALL DAMPRY(ITDKRC,XK0DEC,PH,XA,QP,XN,AMPLIT,HV)
	+ DGAMT=1/(2.AMTAX)AMPLIT*PHSPAC
	+ END
	+ SUBROUTINE DAMPRY(ITDKRC,XK0DEC,XK,XA,QP,XN,AMPLIT,HV)
	+ IMPLICIT double precision (A-H,O-Z)
	+C ----------------------------------------------------------------------
	+C IT CALCULATES MATRIX ELEMENT FOR THE
	+C TAU --> MU(E) NU NUBAR DECAY MODE
	+C INCLUDING COMPLETE ORDER ALPHA QED CORRECTIONS.
	+C ----------------------------------------------------------------------
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ double precision HV(4),QP(4),XN(4),XA(4),XK(4)
	+C
	+ HV(4)=1.D0
	+ AK0=XK0DEC*AMTAU
	+ IF(XK(4).LT.0.1D0*AK0) THEN
	+ AMPLIT=THB(ITDKRC,QP,XN,XA,AK0,HV)
	+ ELSE
	+ AMPLIT=SQM2(ITDKRC,QP,XN,XA,XK,AK0,HV)
	+ ENDIF
	+ RETURN
	+ END
	+ double precision FUNCTION SQM2(ITDKRC,QP,XN,XA,XK,AK0,HV)
	+C
	+C **********************************************************************
	+C REAL PHOTON MATRIX ELEMENT SQUARED *
	+C PARAMETERS: *
	+C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
	+C QP,XN,XA,XK - 4-momenta of electron (muon), NU, NUBAR and PHOTON *
	+C All four-vectors in TAU rest frame (in GeV) *
	+C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS (GEV) *
	+C SQM2 - value for S=0 *
	+C see Eqs. (2.9)-(2.10) from CJK ( Nucl.Phys.B(1991) ) *
	+C **********************************************************************
	+C
	+ IMPLICIT double precision(A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / QEDPRM /ALFINV,ALFPI,XK0
	+ double precision ALFINV,ALFPI,XK0
	+ double precision QP(4),XN(4),XA(4),XK(4)
	+ double precision R(4)
	+ double precision HV(4)
	+ double precision S0(3),RXA(3),RXK(3),RQP(3)
	+ DATA PI /3.141592653589793238462643D0/
	+C
	+ TMASS=AMTAU
	+ GF=GFERMI
	+ ALPHAI=ALFINV
	+ TMASS2=TMASS**2
	+ EMASS2=QP(4)2-QP(1)2-QP(2)2-QP(3)2
	+ R(4)=TMASS
	+C SCALAR PRODUCTS OF FOUR-MOMENTA
	+ DO 7 I=1,3
	+ R(1)=0.D0
	+ R(2)=0.D0
	+ R(3)=0.D0
	+ R(I)=TMASS
	+ RXA(I)=R(4)XA(4)-R(1)XA(1)-R(2)XA(2)-R(3)XA(3)
	+C RXN(I)=R(4)XN(4)-R(1)XN(1)-R(2)XN(2)-R(3)XN(3)
	+ RXK(I)=R(4)XK(4)-R(1)XK(1)-R(2)XK(2)-R(3)XK(3)
	+ RQP(I)=R(4)QP(4)-R(1)QP(1)-R(2)QP(2)-R(3)QP(3)
	+ 7 CONTINUE
	+ QPXN=QP(4)XN(4)-QP(1)XN(1)-QP(2)XN(2)-QP(3)XN(3)
	+ QPXA=QP(4)XA(4)-QP(1)XA(1)-QP(2)XA(2)-QP(3)XA(3)
	+ QPXK=QP(4)XK(4)-QP(1)XK(1)-QP(2)XK(2)-QP(3)XK(3)
	+c XNXA=XN(4)XA(4)-XN(1)XA(1)-XN(2)XA(2)-XN(3)XA(3)
	+ XNXK=XN(4)XK(4)-XN(1)XK(1)-XN(2)XK(2)-XN(3)XK(3)
	+ XAXK=XA(4)XK(4)-XA(1)XK(1)-XA(2)XK(2)-XA(3)XK(3)
	+ TXN=TMASS*XN(4)
	+ TXA=TMASS*XA(4)
	+ TQP=TMASS*QP(4)
	+ TXK=TMASS*XK(4)
	+C
	+ X= XNXK/QPXN
	+ Z= TXK/TQP
	+ A= 1+X
	+ B= 1+ X*(1+Z)/2+Z/2
	+ S1= QPXNTXA( -EMASS2/QPXK*2A + 2TQP/(QPXKTXK)*B-
	+ $TMASS2/TXK**2) +
	+ $QPXN/TXK*2 ( TMASS2XAXK - TXATXK+ XAXK*TXK) -
	+ $TXATXN/TXK - QPXN/(QPXKTXK)* (TQPXAXK-TXKQPXA)
	+ CONST4=256PI/ALPHAIGF**2
	+ IF (ITDKRC.EQ.0) CONST4=0D0
	+ SQM2=S1*CONST4
	+ DO 5 I=1,3
	+ S0(I) = QPXNRXA(I)(-EMASS2/QPXK*2A + 2TQP/(QPXKTXK)*B-
	+ $ TMASS2/TXK**2) +
	+ $ QPXN/TXK*2 (TMASS2XAXK - TXARXK(I)+ XAXK*RXK(I))-
	+ $ RXA(I)TXN/TXK - QPXN/(QPXKTXK)(RQP(I)XAXK- RXK(I)*QPXA)
	+ 5 HV(I)=S0(I)/S1-1.D0
	+ RETURN
	+ END
	+ double precision FUNCTION THB(ITDKRC,QP,XN,XA,AK0,HV)
	+C
	+C **********************************************************************
	+C BORN +VIRTUAL+SOFT PHOTON MATRIX ELEMENT*2 O(ALPHA)
	+C PARAMETERS: *
	+C HV- POLARIMETRIC FOUR-VECTOR OF TAU *
	+C QP,XN,XA - FOUR-MOMENTA OF ELECTRON (MUON), NU AND NUBAR IN GEV *
	+C ALL FOUR-VECTORS IN TAU REST FRAME *
	+C AK0 - INFRARED CUTOFF, MINIMAL ENERGY OF HARD PHOTONS *
	+C THB - VALUE FOR S=0 *
	+C SEE EQS. (2.2),(2.4)-(2.5) FROM CJK (NUCL.PHYS.B351(1991)70 *
	+C AND (C.2) FROM JK (NUCL.PHYS.B320(1991)20 ) *
	+C **********************************************************************
	+C
	+ IMPLICIT double precision(A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / QEDPRM /ALFINV,ALFPI,XK0
	+ double precision ALFINV,ALFPI,XK0
	+ DIMENSION QP(4),XN(4),XA(4)
	+ double precision HV(4)
	+ DIMENSION R(4)
	+ double precision RXA(3),RXN(3),RQP(3)
	+ double precision BORNPL(3),AM3POL(3),XM3POL(3)
	+ DATA PI /3.141592653589793238462643D0/
	+C
	+ TMASS=AMTAU
	+ GF=GFERMI
	+ ALPHAI=ALFINV
	+C
	+ TMASS2=TMASS**2
	+ R(4)=TMASS
	+ DO 7 I=1,3
	+ R(1)=0.D0
	+ R(2)=0.D0
	+ R(3)=0.D0
	+ R(I)=TMASS
	+ RXA(I)=R(4)XA(4)-R(1)XA(1)-R(2)XA(2)-R(3)XA(3)
	+ RXN(I)=R(4)XN(4)-R(1)XN(1)-R(2)XN(2)-R(3)XN(3)
	+C RXK(I)=R(4)XK(4)-R(1)XK(1)-R(2)XK(2)-R(3)XK(3)
	+ RQP(I)=R(4)QP(4)-R(1)QP(1)-R(2)QP(2)-R(3)QP(3)
	+ 7 CONTINUE
	+C QUASI TWO-BODY VARIABLES
	+ U0=QP(4)/TMASS
	+ U3=SQRT(QP(1)2+QP(2)2+QP(3)**2)/TMASS
	+ W3=U3
	+ W0=(XN(4)+XA(4))/TMASS
	+ UP=U0+U3
	+ UM=U0-U3
	+ WP=W0+W3
	+ WM=W0-W3
	+ YU=LOG(UP/UM)/2
	+ YW=LOG(WP/WM)/2
	+ EPS2=U02-U32
	+ EPS=SQRT(EPS2)
	+ Y=W02-W32
	+ AL=AK0/TMASS
	+C FORMFACTORS
	+ F0=2U0/U3( DILOGT(1-(UMWM/(UPWP)))- DILOGT(1-WM/WP) +
	+ $DILOGT(1-UM/UP) -2YU+ 2LOG(UP)*(YW+YU) ) +
	+ $1/Y* ( 2U3YU + (1-EPS2- 2Y)LOG(EPS) ) +
	+ $ 2 - 4(U0/U3YU -1)* LOG(2*AL)
	+ FP= YU/(2U3)(1 + (1-EPS2)/Y ) + LOG(EPS)/Y
	+ FM= YU/(2U3)(1 - (1-EPS2)/Y ) - LOG(EPS)/Y
	+ F3= EPS2*(FP+FM)/2
	+C SCALAR PRODUCTS OF FOUR-MOMENTA
	+ QPXN=QP(4)XN(4)-QP(1)XN(1)-QP(2)XN(2)-QP(3)XN(3)
	+ QPXA=QP(4)XA(4)-QP(1)XA(1)-QP(2)XA(2)-QP(3)XA(3)
	+ XNXA=XN(4)XA(4)-XN(1)XA(1)-XN(2)XA(2)-XN(3)XA(3)
	+ TXN=TMASS*XN(4)
	+ TXA=TMASS*XA(4)
	+ TQP=TMASS*QP(4)
	+C DECAY DIFFERENTIAL WIDTH WITHOUT AND WITH POLARIZATION
	+ CONST3=1/(2ALPHAIPI)64GF**2
	+ IF (ITDKRC.EQ.0) CONST3=0D0
	+ XM3= -( F0* QPXNTXA + FPEPS2* TXN*TXA +
	+ $FM* QPXNQPXA + F3 TMASS2*XNXA )
	+ AM3=XM3*CONST3
	+C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
	+ BRAK= (GV+GA)*2TQPXNXA+(GV-GA)2TXA*QPXN
	+ & -(GV2-GA2)TMASSAMNUTA*QPXA
	+ BORN= 32(GFERMI2/2.)BRAK
	+ DO 5 I=1,3
	+ XM3POL(I)= -( F0* QPXNRXA(I) + FPEPS2* TXN*RXA(I) +
	+ $ FM* QPXN* (QPXA + (RXA(I)TQP-TXARQP(I))/TMASS2 ) +
	+ $ F3* (TMASS2XNXA +TXNRXA(I) -RXN(I)*TXA) )
	+ AM3POL(I)=XM3POL(I)*CONST3
	+C V-A AND V+A COUPLINGS, BUT IN THE BORN PART ONLY
	+ BORNPL(I)=BORN+(
	+ & (GV+GA)*2TMASSXNXAQP(I)
	+ & -(GV-GA)*2TMASSQPXNXA(I)
	+ & +(GV2-GA2)AMNUTATXA*QP(I)
	+ & -(GV2-GA2)AMNUTATQPXA(I) )
	+ & 32(GFERMI*2/2.)
	+ 5 HV(I)=(BORNPL(I)+AM3POL(I))/(BORN+AM3)-1.D0
	+ THB=BORN+AM3
	+ IF (THB/BORN.LT.0.1D0) THEN
	+ PRINT *, 'ERROR IN THB, THB/BORN=',THB/BORN
	+ STOP
	+ ENDIF
	+ RETURN
	+ END
	+ SUBROUTINE DEXPI(MODE,ISGN,POL,PPI,PNU)
	+C ----------------------------------------------------------------------
	+C TAU DECAY INTO PION AND TAU-NEUTRINO
	+C IN TAU REST FRAME
	+C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+C PPI PION CHARGED
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision POL(4),HV(4),PNU(4),PPI(4),RN(1)
	+ save hv
	+CC
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ CALL DADMPI(-1,ISGN,HV,PPI,PNU)
	+CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
	+
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ CALL DADMPI( 0,ISGN,HV,PPI,PNU)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(815,WT)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ CALL DADMPI( 1,ISGN,HV,PPI,PNU)
	+CC CALL HPRINT(815)
	+ ENDIF
	+C =====
	+ RETURN
	+ END
	+ SUBROUTINE DADMPI(MODE,ISGN,HV,PPI,PNU)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision PPI(4),PNU(4),HV(4)
	+ DATA PI /3.141592653589793238462643/
	+ save nevtot
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ NEVTOT=0
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+ NEVTOT=NEVTOT+1
	+ EPI= (AMTAU2+AMPI2-AMNUTA*2)/(2AMTAU)
	+ ENU= (AMTAU2-AMPI2+AMNUTA*2)/(2AMTAU)
	+ XPI= SQRT(EPI2-AMPI2)
	+C PI MOMENTUM
	+ CALL SPHERA(XPI,PPI)
	+ PPI(4)=EPI
	+C TAU-NEUTRINO MOMENTUM
	+ DO 30 I=1,3
	+30 PNU(I)=-PPI(I)
	+ PNU(4)=ENU
	+ PXQ=AMTAU*EPI
	+ PXN=AMTAU*ENU
	+ QXN=PPI(4)PNU(4)-PPI(1)PNU(1)-PPI(2)PNU(2)-PPI(3)PNU(3)
	+ BRAK=(GV2+GA2)(2PXQQXN-AMPI2PXN)
	+ & +(GV2-GA2)AMTAUAMNUTAAMPI*2
	+ DO 40 I=1,3
	+40 HV(I)=-ISGN2GAGVAMTAU(2PPI(I)QXN-PNU(I)AMPI**2)/BRAK
	+ HV(4)=1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVTOT.EQ.0) RETURN
	+ FPI=0.1284
	+C GAMM=(GFERMIFPI)2/(16.PI)AMTAU3
	+C * (BRAK/AMTAU4)2
	+CZW 7.02.93 here was an error affecting non standard model
	+C configurations only
	+ GAMM=(GFERMIFPI)2/(16.PI)AMTAU3
	+ $ (BRAK/AMTAU*4)
	+ $ SQRT((AMTAU2-AMPI2-AMNUTA2)2
	+ $ -4AMPI2AMNUTA2 )/AMTAU2
	+ ERROR=0
	+ RAT=GAMM/GAMEL
	+ WRITE(IOUT, 7010) NEVTOT,GAMM,RAT,ERROR
	+ GAMPMC(3)=RAT
	+ GAMPER(3)=ERROR
	+CAM NEVDEC(3)=NEVTOT
	+ ENDIF
	+C =====
	+ RETURN
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMPI FINAL REPORT ****** ',9X,1H*
	+ $ /,' ',I20 ,5X,'NEVTOT = NO. OF PI DECAYS TOTAL ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH ( PI DECAY) IN GEV UNITS ',9X,1H
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ END
	+ SUBROUTINE DEXRO(MODE,ISGN,POL,PNU,PRO,PIC,PIZ)
	+C ----------------------------------------------------------------------
	+C THIS SIMULATES TAU DECAY IN TAU REST FRAME
	+C INTO NU RHO, NEXT RHO DECAYS INTO PION PAIR.
	+C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+C PRO RHO
	+C PIC PION CHARGED
	+C PIZ PION ZERO
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4),HV(4),PRO(4),PNU(4),PIC(4),PIZ(4),RN(1)
	+ DATA IWARM/0/
	+ save iwarn, hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ CALL DADMRO( -1,ISGN,HV,PNU,PRO,PIC,PIZ)
	+CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXRO $',100,0,2)
	+CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXRO $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DADMRO( 0,ISGN,HV,PNU,PRO,PIC,PIZ)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(816,WT)
	+CC XHELP=HV(1)2+HV(2)2+HV(3)**2
	+CC CALL HFILL(916,XHELP)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ CALL DADMRO( 1,ISGN,HV,PNU,PRO,PIC,PIZ)
	+CC CALL HPRINT(816)
	+CC CALL HPRINT(916)
	+ ENDIF
	+C =====
	+ RETURN
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DEXRO: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DADMRO(MODE,ISGN,HHV,PNU,PRO,PIC,PIZ)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision HHV(4)
	+ double precision HV(4),PRO(4),PNU(4),PIC(4),PIZ(4)
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
	+ double precision RRR(3)
	+ double precision WT, SWT, SSWT
	+ SAVE NEVRAW, NEVACC, NEVOVR, WT, SWT, SSWT, WTMAX
	+ DATA PI /3.141592653589793238462643/
	+ DATA IWARM/0/
	+ save iwarn, hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ NEVRAW=0
	+ NEVACC=0
	+ NEVOVR=0
	+ SWT=0
	+ SSWT=0
	+ WTMAX=1E-20
	+ DO 15 I=1,500
	+ CALL DPHSRO(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4)
	+ IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	+15 CONTINUE
	+CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMRO $',100,0,2)
	+CC PRINT 7003,WTMAX
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DPHSRO(WT,HV,PNU,PRO,PIC,PIZ)
	+CC CALL HFILL(801,WT/WTMAX)
	+ NEVRAW=NEVRAW+1
	+ SWT=SWT+WT
	+ SSWT=SSWT+WT**2
	+ CALL RANMAR(RRR,3)
	+ RN=RRR(1)
	+ IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	+ IF(RN*WTMAX.GT.WT) GOTO 300
	+C ROTATIONS TO BASIC TAU REST FRAME
	+ COSTHE=-1.+2.*RRR(2)
	+ THET=ACOS(COSTHE)
	+ PHI =2PIRRR(3)
	+ CALL ROTOR2(THET,PNU,PNU)
	+ CALL ROTOR3( PHI,PNU,PNU)
	+ CALL ROTOR2(THET,PRO,PRO)
	+ CALL ROTOR3( PHI,PRO,PRO)
	+ CALL ROTOR2(THET,PIC,PIC)
	+ CALL ROTOR3( PHI,PIC,PIC)
	+ CALL ROTOR2(THET,PIZ,PIZ)
	+ CALL ROTOR3( PHI,PIZ,PIZ)
	+ CALL ROTOR2(THET,HV,HV)
	+ CALL ROTOR3( PHI,HV,HV)
	+ DO 44 I=1,3
	+ 44 HHV(I)=-ISGN*HV(I)
	+ NEVACC=NEVACC+1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVRAW.EQ.0) RETURN
	+ PARGAM=SWT/FLOAT(NEVRAW+1)
	+ ERROR=0
	+ IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	+ RAT=PARGAM/GAMEL
	+ WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	+CC CALL HPRINT(801)
	+ GAMPMC(4)=RAT
	+ GAMPER(4)=ERROR
	+CAM NEVDEC(4)=NEVACC
	+ ENDIF
	+C =====
	+ RETURN
	+ 7003 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMRO INITIALISATION *****',9X,1H
	+ $ /,' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMRO FINAL REPORT ****** ',9X,1H*
	+ $ /,' ',I20 ,5X,'NEVRAW = NO. OF RHO DECAYS TOTAL ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVACC = NO. OF RHO DECS. ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH (RHO DECAY) IN GEV UNITS ',9X,1H
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DADMRO: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DPHSRO(DGAMT,HV,PN,PR,PIC,PIZ)
	+C ----------------------------------------------------------------------
	+C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
	+C Z-AXIS ALONG RHO MOMENTUM
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision HV(4),PT(4),PN(4),PR(4),
	+ * PIC(4),PIZ(4),QQ(4),RR1(1)
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+C
	+C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+ PHSPAC=1./211/PI5
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+C MASS OF (REAL/VIRTUAL) RHO
	+ AMS1=(AMPI+AMPIZ)**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+C FLAT PHASE SPACE
	+C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	+C AMX=SQRT(AMX2)
	+C PHSPAC=PHSPAC*(AMS2-AMS1)
	+C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
	+ ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
	+ ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
	+CAM
	+ 100 CONTINUE
	+ CALL RANMAR(RR1,1)
	+ ALP=ALP1+RR1(1)*(ALP2-ALP1)
	+ AMX2=AMRO*2+AMROGAMRO*TAN(ALP)
	+ AMX=SQRT(AMX2)
	+ IF(AMX.LT.2.*AMPI) GO TO 100
	+CAM
	+ PHSPAC=PHSPAC((AMX2-AMRO2)2+(AMROGAMRO)*2)/(AMROGAMRO)
	+ PHSPAC=PHSPAC*(ALP2-ALP1)
	+C
	+C TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	+ PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	+C RHO MOMENTUM
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	+ PR(3)=-PN(3)
	+ PHSPAC=PHSPAC(4PI)(2PR(3)/AMTAU)
	+C
	+CAM
	+ ENQ1=(AMX2+AMPI2-AMPIZ2)/(2.*AMX)
	+ ENQ2=(AMX2-AMPI2+AMPIZ2)/(2.*AMX)
	+ PPPI=SQRT((ENQ1-AMPI)*(ENQ1+AMPI))
	+ PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	+C CHARGED PI MOMENTUM IN RHO REST FRAME
	+ CALL SPHERA(PPPI,PIC)
	+ PIC(4)=ENQ1
	+C NEUTRAL PI MOMENTUM IN RHO REST FRAME
	+ DO 20 I=1,3
	+20 PIZ(I)=-PIC(I)
	+ PIZ(4)=ENQ2
	+ EXE=(PR(4)+PR(3))/AMX
	+C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
	+ CALL BOSTR3(EXE,PIC,PIC)
	+ CALL BOSTR3(EXE,PIZ,PIZ)
	+ DO 30 I=1,4
	+30 QQ(I)=PIC(I)-PIZ(I)
	+C AMPLITUDE
	+ PRODPQ=PT(4)*QQ(4)
	+ PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	+ PRODPN=PT(4)*PN(4)
	+ QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	+ BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	+ & +(GV2-GA2)AMTAUAMNUTA*QQ2
	+ AMPLIT=(GFERMICCABIB)2BRAK2FPIRHO(AMX)
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+ DO 40 I=1,3
	+ 40 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	+ RETURN
	+ END
	+ SUBROUTINE DEXAA(MODE,ISGN,POL,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+C ----------------------------------------------------------------------
	+* THIS SIMULATES TAU DECAY IN TAU REST FRAME
	+* INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
	+* OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+* PAA A1
	+* PIM1 PION MINUS (OR PI0) 1 (FOR TAU MINUS)
	+* PIM2 PION MINUS (OR PI0) 2
	+* PIPL PION PLUS (OR PI-)
	+* (PIPL,PIM1) FORM A RHO
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4),HV(4),PAA(4),PNU(4),
	+ * PIM1(4),PIM2(4),PIPL(4),RN(1)
	+ DATA IWARM/0/
	+ save iwarn, hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ CALL DADMAA( -1,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXAA $',100,-2.,2.)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+* =======================
	+ 300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DADMAA( 0,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(816,WT)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+* =======================
	+ CALL DADMAA( 1,ISGN,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+CC CALL HPRINT(816)
	+ ENDIF
	+C =====
	+ RETURN
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DEXAA: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DADMAA(MODE,ISGN,HHV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+C ----------------------------------------------------------------------
	+* A1 DECAY UNWEIGHTED EVENTS
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision HHV(4)
	+ double precision HV(4),PAA(4),PNU(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4),PDUM5(4)
	+ double precision RRR(3)
	+ double precision SWT, SSWT
	+ SAVE IWARM,NEVRAW,NEVACC,NEVOVR,SWT,SSWT,WTMAX
	+ DATA PI /3.141592653589793238462643/
	+ DATA IWARM/0/
	+ save hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ NEVRAW=0
	+ NEVACC=0
	+ NEVOVR=0
	+ SWT=0
	+ SSWT=0
	+ WTMAX=1E-20
	+ DO 15 I=1,500
	+ CALL DPHSAA(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,PDUM5,JAA)
	+ IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	+15 CONTINUE
	+CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMAA $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DPHSAA(WT,HV,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+CC CALL HFILL(801,WT/WTMAX)
	+ NEVRAW=NEVRAW+1
	+ SWT=SWT+WT
	+ SSWT=SSWT+WT**2
	+ CALL RANMAR(RRR,3)
	+ RN=RRR(1)
	+ IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	+ IF(RN*WTMAX.GT.WT) GOTO 300
	+C ROTATIONS TO BASIC TAU REST FRAME
	+ COSTHE=-1.+2.*RRR(2)
	+ THET=ACOS(COSTHE)
	+ PHI =2PIRRR(3)
	+ CALL ROTPOL(THET,PHI,PNU)
	+ CALL ROTPOL(THET,PHI,PAA)
	+ CALL ROTPOL(THET,PHI,PIM1)
	+ CALL ROTPOL(THET,PHI,PIM2)
	+ CALL ROTPOL(THET,PHI,PIPL)
	+ CALL ROTPOL(THET,PHI,HV)
	+ DO 44 I=1,3
	+ 44 HHV(I)=-ISGN*HV(I)
	+ NEVACC=NEVACC+1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVRAW.EQ.0) RETURN
	+ PARGAM=SWT/FLOAT(NEVRAW+1)
	+ ERROR=0
	+ IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	+ RAT=PARGAM/GAMEL
	+ WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	+CC CALL HPRINT(801)
	+ GAMPMC(5)=RAT
	+ GAMPER(5)=ERROR
	+CAM NEVDEC(5)=NEVACC
	+ ENDIF
	+C =====
	+ RETURN
	+ 7003 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMAA INITIALISATION *****',9X,1H
	+ $ /,' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMAA FINAL REPORT ****** ',9X,1H*
	+ $ /,' ',I20 ,5X,'NEVRAW = NO. OF A1 DECAYS TOTAL ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVACC = NO. OF A1 DECS. ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH (A1 DECAY) IN GEV UNITS ',9X,1H
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DADMAA: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DPHSAA(DGAMT,HV,PN,PAA,PIM1,PIM2,PIPL,JAA)
	+C ----------------------------------------------------------------------
	+* IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
	+* Z-AXIS ALONG A1 MOMENTUM
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	+ double precision BRA1,BRK0,BRK0B,BRKS
	+ double precision HV(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
	+
	+
	+ double precision RRR(1)
	+C MATRIX ELEMENT NUMBER:
	+ MNUM=0
	+C TYPE OF THE GENERATION:
	+ KEYT=1
	+ CALL RANMAR(RRR,1)
	+ RMOD=RRR(1)
	+ IF (RMOD.LT.BRA1) THEN
	+ JAA=1
	+ AMP1=AMPI
	+ AMP2=AMPI
	+ AMP3=AMPI
	+ ELSE
	+ JAA=2
	+ AMP1=AMPIZ
	+ AMP2=AMPIZ
	+ AMP3=AMPI
	+ ENDIF
	+ CALL
	+ $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMP1,PIM2,AMP2,PIPL,AMP3,KEYT,MNUM)
	+ END
	+ SUBROUTINE DEXKK(MODE,ISGN,POL,PKK,PNU)
	+C ----------------------------------------------------------------------
	+C TAU DECAY INTO KAON AND TAU-NEUTRINO
	+C IN TAU REST FRAME
	+C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+C PKK KAON CHARGED
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision POL(4),HV(4),PNU(4),PKK(4),RN(1)
	+ save hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ CALL DADMKK(-1,ISGN,HV,PKK,PNU)
	+CC CALL HBOOK1(815,'WEIGHT DISTRIBUTION DEXPI $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ CALL DADMKK( 0,ISGN,HV,PKK,PNU)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(815,WT)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ CALL DADMKK( 1,ISGN,HV,PKK,PNU)
	+CC CALL HPRINT(815)
	+ ENDIF
	+C =====
	+ RETURN
	+ END
	+ SUBROUTINE DADMKK(MODE,ISGN,HV,PKK,PNU)
	+C ----------------------------------------------------------------------
	+C FZ
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / INOUT / INUT,IOUT
	+ double precision PKK(4),PNU(4),HV(4)
	+ DATA PI /3.141592653589793238462643/
	+ save nevtot
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ NEVTOT=0
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+ NEVTOT=NEVTOT+1
	+ EKK= (AMTAU2+AMK2-AMNUTA*2)/(2AMTAU)
	+ ENU= (AMTAU2-AMK2+AMNUTA*2)/(2AMTAU)
	+ XKK= SQRT(EKK2-AMK2)
	+C K MOMENTUM
	+ CALL SPHERA(XKK,PKK)
	+ PKK(4)=EKK
	+C TAU-NEUTRINO MOMENTUM
	+ DO 30 I=1,3
	+30 PNU(I)=-PKK(I)
	+ PNU(4)=ENU
	+ PXQ=AMTAU*EKK
	+ PXN=AMTAU*ENU
	+ QXN=PKK(4)PNU(4)-PKK(1)PNU(1)-PKK(2)PNU(2)-PKK(3)PNU(3)
	+ BRAK=(GV2+GA2)(2PXQQXN-AMK2PXN)
	+ & +(GV2-GA2)AMTAUAMNUTAAMK*2
	+ DO 40 I=1,3
	+40 HV(I)=-ISGN2GAGVAMTAU(2PKK(I)QXN-PNU(I)AMK**2)/BRAK
	+ HV(4)=1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVTOT.EQ.0) RETURN
	+ FKK=0.0354
	+CFZ THERE WAS BRAK/AMTAU**4 BEFORE
	+C GAMM=(GFERMIFKK)2/(16.PI)AMTAU3
	+C * (BRAK/AMTAU4)2
	+CZW 7.02.93 here was an error affecting non standard model
	+C configurations only
	+ GAMM=(GFERMIFKK)2/(16.PI)AMTAU3
	+ $ (BRAK/AMTAU*4)
	+ $ SQRT((AMTAU2-AMK2-AMNUTA2)2
	+ $ -4AMK2AMNUTA2 )/AMTAU2
	+ ERROR=0
	+
	+ ERROR=0
	+ RAT=GAMM/GAMEL
	+ WRITE(IOUT, 7010) NEVTOT,GAMM,RAT,ERROR
	+ GAMPMC(6)=RAT
	+ GAMPER(6)=ERROR
	+CAM NEVDEC(6)=NEVTOT
	+ ENDIF
	+C =====
	+ RETURN
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMKK FINAL REPORT *****',9X,1H
	+ $ /,' ',I20 ,5X,'NEVTOT = NO. OF K DECAYS TOTAL ',9X,1H,
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH ( K DECAY) IN GEV UNITS ',9X,1H,
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH (STAT.)',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ END
	+ SUBROUTINE DEXKS(MODE,ISGN,POL,PNU,PKS,PKK,PPI,JKST)
	+C ----------------------------------------------------------------------
	+C THIS SIMULATES TAU DECAY IN TAU REST FRAME
	+C INTO NU K, THEN K DECAYS INTO PI0,K+-(JKST=20)
	+C OR PI+-,K0(JKST=10).
	+C OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+C PKS K* CHARGED
	+C PK0 K ZERO
	+C PKC K CHARGED
	+C PIC PION CHARGED
	+C PIZ PION ZERO
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4),HV(4),PKS(4),PNU(4),PKK(4),PPI(4),RN(1)
	+ DATA IWARM/0/
	+ save iwarn, hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+CFZ INITIALISATION DONE WITH THE GHARGED PION NEUTRAL KAON MODE(JKST=10
	+ CALL DADMKS( -1,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
	+CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXKS $',100,0,2)
	+CC CALL HBOOK1(916,'ABS2 OF HV IN ROUTINE DEXKS $',100,0,2)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DADMKS( 0,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(816,WT)
	+CC XHELP=HV(1)2+HV(2)2+HV(3)**2
	+CC CALL HFILL(916,XHELP)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C ======================================
	+ CALL DADMKS( 1,ISGN,HV,PNU,PKS,PKK,PPI,JKST)
	+CC CALL HPRINT(816)
	+CC CALL HPRINT(916)
	+ ENDIF
	+C =====
	+ RETURN
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DEXKS: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DADMKS(MODE,ISGN,HHV,PNU,PKS,PKK,PPI,JKST)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	+ double precision BRA1,BRK0,BRK0B,BRKS
	+ COMMON / INOUT / INUT,IOUT
	+ double precision HHV(4)
	+ double precision HV(4),PKS(4),PNU(4),PKK(4),PPI(4)
	+ double precision PDUM1(4),PDUM2(4),PDUM3(4),PDUM4(4)
	+ double precision RRR(3),RMOD(1)
	+ double precision SWT, SSWT
	+ DATA PI /3.141592653589793238462643/
	+ DATA IWARM/0/
	+ save iwarn, nevraw, nevacc, nevovr, swt, sswt, wtmax
	+ save hv
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ NEVRAW=0
	+ NEVACC=0
	+ NEVOVR=0
	+ SWT=0
	+ SSWT=0
	+ WTMAX=1E-20
	+ DO 15 I=1,500
	+C THE INITIALISATION IS DONE WITH THE 66.7% MODE
	+ JKST=10
	+ CALL DPHSKS(WT,HV,PDUM1,PDUM2,PDUM3,PDUM4,JKST)
	+ IF(WT.GT.WTMAX/1.2) WTMAX=WT*1.2
	+15 CONTINUE
	+CC CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADMKS $',100,0,2)
	+CC PRINT 7003,WTMAX
	+CC CALL HBOOK1(112,'-------- K* MASS -------- $',100,0.,2.)
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =====================================
	+ IF(IWARM.EQ.0) GOTO 902
	+C HERE WE CHOOSE RANDOMLY BETWEEN K0 PI+_ (66.7%)
	+C AND K+_ PI0 (33.3%)
	+ DEC1=BRKS
	+400 CONTINUE
	+ CALL RANMAR(RMOD,1)
	+ IF(RMOD(1).LT.DEC1) THEN
	+ JKST=10
	+ ELSE
	+ JKST=20
	+ ENDIF
	+ CALL DPHSKS(WT,HV,PNU,PKS,PKK,PPI,JKST)
	+ CALL RANMAR(RRR,3)
	+ RN=RRR(1)
	+ IF(WT.GT.WTMAX) NEVOVR=NEVOVR+1
	+ NEVRAW=NEVRAW+1
	+ SWT=SWT+WT
	+ SSWT=SSWT+WT**2
	+ IF(RN*WTMAX.GT.WT) GOTO 400
	+C ROTATIONS TO BASIC TAU REST FRAME
	+ COSTHE=-1.+2.*RRR(2)
	+ THET=ACOS(COSTHE)
	+ PHI =2PIRRR(3)
	+ CALL ROTOR2(THET,PNU,PNU)
	+ CALL ROTOR3( PHI,PNU,PNU)
	+ CALL ROTOR2(THET,PKS,PKS)
	+ CALL ROTOR3( PHI,PKS,PKS)
	+ CALL ROTOR2(THET,PKK,PKK)
	+ CALL ROTOR3(PHI,PKK,PKK)
	+ CALL ROTOR2(THET,PPI,PPI)
	+ CALL ROTOR3( PHI,PPI,PPI)
	+ CALL ROTOR2(THET,HV,HV)
	+ CALL ROTOR3( PHI,HV,HV)
	+ DO 44 I=1,3
	+ 44 HHV(I)=-ISGN*HV(I)
	+ NEVACC=NEVACC+1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ IF(NEVRAW.EQ.0) RETURN
	+ PARGAM=SWT/FLOAT(NEVRAW+1)
	+ ERROR=0
	+ IF(NEVRAW.NE.0) ERROR=SQRT(SSWT/SWT**2-1./FLOAT(NEVRAW))
	+ RAT=PARGAM/GAMEL
	+ WRITE(IOUT, 7010) NEVRAW,NEVACC,NEVOVR,PARGAM,RAT,ERROR
	+CC CALL HPRINT(801)
	+ GAMPMC(7)=RAT
	+ GAMPER(7)=ERROR
	+CAM NEVDEC(7)=NEVACC
	+ ENDIF
	+C =====
	+ RETURN
	+ 7003 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMKS INITIALISATION *****',9X,1H
	+ $ /,' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADMKS FINAL REPORT *****',9X,1H
	+ $ /,' ',I20 ,5X,'NEVRAW = NO. OF K DECAYS TOTAL ',9X,1H*,
	+ $ /,' ',I20 ,5X,'NEVACC = NO. OF K DECS. ACCEPTED ',9X,1H*,
	+ $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH (K DECAY) IN GEV UNITS ',9X,1H*,
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DADMKS: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DPHSKS(DGAMT,HV,PN,PKS,PKK,PPI,JKST)
	+C ----------------------------------------------------------------------
	+C IT SIMULATES KAON* DECAY IN TAU REST FRAME WITH
	+C Z-AXIS ALONG KAON* MOMENTUM
	+C JKST=10 FOR K* --->K0 + PI+-
	+C JKST=20 FOR K* --->K+- + PI0
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision HV(4),PT(4),PN(4),PKS(4),
	+ * PKK(4),PPI(4),QQ(4),RR1(1)
	+cam double complex BWIGS
	+ double complex BWIGM
	+ DATA PI /3.141592653589793238462643/
	+C
	+ DATA ICONT /0/
	+ save icont, pt, qq
	+C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+ PHSPAC=1./211/PI5
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+ CALL RANMAR(RR1,1)
	+C HERE BEGIN THE K0,PI+_ DECAY
	+ IF(JKST.EQ.10)THEN
	+C ==================
	+C MASS OF (REAL/VIRTUAL) K*
	+ AMS1=(AMPI+AMKZ)**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+C FLAT PHASE SPACE
	+C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	+C AMX=SQRT(AMX2)
	+C PHSPAC=PHSPAC*(AMS2-AMS1)
	+C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
	+ ALP1=ATAN((AMS1-AMKST**2)/AMKST/GAMKST)
	+ ALP2=ATAN((AMS2-AMKST**2)/AMKST/GAMKST)
	+ ALP=ALP1+RR1(1)*(ALP2-ALP1)
	+ AMX2=AMKST*2+AMKSTGAMKST*TAN(ALP)
	+ AMX=SQRT(AMX2)
	+ PHSPAC=PHSPAC((AMX2-AMKST2)2+(AMKSTGAMKST)**2)
	+ & /(AMKST*GAMKST)
	+ PHSPAC=PHSPAC*(ALP2-ALP1)
	+C
	+C TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	+ PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	+C
	+C K* MOMENTUM
	+ PKS(1)=0
	+ PKS(2)=0
	+ PKS(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	+ PKS(3)=-PN(3)
	+ PHSPAC=PHSPAC(4PI)(2PKS(3)/AMTAU)
	+C
	+CAM
	+ ENPI=( AMX2+AMPI2-AMKZ*2 ) / ( 2AMX )
	+ PPPI=SQRT((ENPI-AMPI)*(ENPI+AMPI))
	+ PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	+C CHARGED PI MOMENTUM IN KAON* REST FRAME
	+ CALL SPHERA(PPPI,PPI)
	+ PPI(4)=ENPI
	+C NEUTRAL KAON MOMENTUM IN K* REST FRAME
	+ DO 20 I=1,3
	+20 PKK(I)=-PPI(I)
	+ PKK(4)=( AMX2+AMKZ2-AMPI*2 ) / ( 2AMX )
	+ EXE=(PKS(4)+PKS(3))/AMX
	+C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
	+ CALL BOSTR3(EXE,PPI,PPI)
	+ CALL BOSTR3(EXE,PKK,PKK)
	+ DO 30 I=1,4
	+30 QQ(I)=PPI(I)-PKK(I)
	+C QQ transverse to PKS
	+ PKSD =PKS(4)PKS(4)-PKS(3)PKS(3)-PKS(2)PKS(2)-PKS(1)PKS(1)
	+ QQPKS=PKS(4)* QQ(4)-PKS(3)* QQ(3)-PKS(2)* QQ(2)-PKS(1)* QQ(1)
	+ DO 31 I=1,4
	+31 QQ(I)=QQ(I)-PKS(I)*QQPKS/PKSD
	+C AMPLITUDE
	+ PRODPQ=PT(4)*QQ(4)
	+ PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	+ PRODPN=PT(4)*PN(4)
	+ QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	+ BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	+ & +(GV2-GA2)AMTAUAMNUTA*QQ2
	+C A SIMPLE BREIT-WIGNER IS CHOSEN FOR K* RESONANCE
	+cam FKS=ABS(BWIGS(AMX2,AMKST,GAMKST))**2
	+ FKS=ABS(BWIGM(AMX2,AMKST,GAMKST,AMPI,AMKZ))**2
	+ AMPLIT=(GFERMISCABIB)2BRAK2FKS
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+ DO 40 I=1,3
	+ 40 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	+C
	+C HERE BEGIN THE K+-,PI0 DECAY
	+ ELSEIF(JKST.EQ.20)THEN
	+C ======================
	+C MASS OF (REAL/VIRTUAL) K*
	+ AMS1=(AMPIZ+AMK)**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+C FLAT PHASE SPACE
	+C AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	+C AMX=SQRT(AMX2)
	+C PHSPAC=PHSPAC*(AMS2-AMS1)
	+C PHASE SPACE WITH SAMPLING FOR K* RESONANCE
	+ ALP1=ATAN((AMS1-AMKST**2)/AMKST/GAMKST)
	+ ALP2=ATAN((AMS2-AMKST**2)/AMKST/GAMKST)
	+ ALP=ALP1+RR1(1)*(ALP2-ALP1)
	+ AMX2=AMKST*2+AMKSTGAMKST*TAN(ALP)
	+ AMX=SQRT(AMX2)
	+ PHSPAC=PHSPAC((AMX2-AMKST2)2+(AMKSTGAMKST)**2)
	+ & /(AMKST*GAMKST)
	+ PHSPAC=PHSPAC*(ALP2-ALP1)
	+C
	+C TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	+ PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	+C KAON* MOMENTUM
	+ PKS(1)=0
	+ PKS(2)=0
	+ PKS(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	+ PKS(3)=-PN(3)
	+ PHSPAC=PHSPAC(4PI)(2PKS(3)/AMTAU)
	+C
	+CAM
	+ ENPI=( AMX2+AMPIZ2-AMK*2 ) / ( 2AMX )
	+ PPPI=SQRT((ENPI-AMPIZ)*(ENPI+AMPIZ))
	+ PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	+C NEUTRAL PI MOMENTUM IN K* REST FRAME
	+ CALL SPHERA(PPPI,PPI)
	+ PPI(4)=ENPI
	+C CHARGED KAON MOMENTUM IN K* REST FRAME
	+ DO 50 I=1,3
	+50 PKK(I)=-PPI(I)
	+ PKK(4)=( AMX2+AMK2-AMPIZ*2 ) / ( 2AMX )
	+ EXE=(PKS(4)+PKS(3))/AMX
	+C PION AND K BOOSTED FROM K* REST FRAME TO TAU REST FRAME
	+ CALL BOSTR3(EXE,PPI,PPI)
	+ CALL BOSTR3(EXE,PKK,PKK)
	+ DO 60 I=1,4
	+60 QQ(I)=PKK(I)-PPI(I)
	+C QQ transverse to PKS
	+ PKSD =PKS(4)PKS(4)-PKS(3)PKS(3)-PKS(2)PKS(2)-PKS(1)PKS(1)
	+ QQPKS=PKS(4)* QQ(4)-PKS(3)* QQ(3)-PKS(2)* QQ(2)-PKS(1)* QQ(1)
	+ DO 61 I=1,4
	+61 QQ(I)=QQ(I)-PKS(I)*QQPKS/PKSD
	+C AMPLITUDE
	+ PRODPQ=PT(4)*QQ(4)
	+ PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	+ PRODPN=PT(4)*PN(4)
	+ QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	+ BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	+ & +(GV2-GA2)AMTAUAMNUTA*QQ2
	+C A SIMPLE BREIT-WIGNER IS CHOSEN FOR THE K* RESONANCE
	+cam FKS=ABS(BWIGS(AMX2,AMKST,GAMKST))**2
	+ FKS=ABS(BWIGM(AMX2,AMKST,GAMKST,AMK,AMPIZ))**2
	+ AMPLIT=(GFERMISCABIB)2BRAK2FKS
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+ DO 70 I=1,3
	+ 70 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	+ ENDIF
	+ RETURN
	+ END
	+
	+
	+
	+ SUBROUTINE DPHNPI(DGAMT,HV,PN,PR,PPI,JNPI)
	+C ----------------------------------------------------------------------
	+C IT SIMULATES MULTIPI DECAY IN TAU REST FRAME WITH
	+C Z-AXIS OPPOSITE TO NEUTRINO MOMENTUM
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+C
	+ double precision PN(4),PR(4),PPI(4,9),HV(4)
	+ double precision PV(5,9),PT(4),UE(3),BE(3)
	+ double precision RRR(9),RORD(9),RR1(1)
	+ double precision dpar(8)
	+C
	+ DATA PI /3.141592653589793238462643/
	+ DATA DPAR/2.,5.,15.,60.,250.,1500.,1.2E4,1.2E5/
	+C
	+C PAWT(A,B,C)=SQRT((A2-(B+C)2)(A2-(B-C)2))/(2.A)
	+ PAWT(A,B,C)=SQRT(MAX(0.,(A2-(B+C)2)(A2-(B-C)2)))/(2.A)
	+C
	+ AMPIK(I,J)=DCDMAS(IDFFIN(I,J))
	+C
	+C
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+C
	+C MASS OF VIRTUAL W
	+ ND=MULPIK(JNPI)
	+ PS=0.
	+ PHSPAC = 1./2.5 /PI2
	+ DO 4 I=1,ND
	+4 PS =PS+AMPIK(I,JNPI)
	+ CALL RANMAR(RR1,1)
	+ AMS1=PS**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+C
	+C
	+ AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	+ AMX =SQRT(AMX2)
	+ AMW =AMX
	+ PHSPAC=PHSPAC * (AMS2-AMS1)
	+C
	+C TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX2)
	+ PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	+C W MOMENTUM
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX2)
	+ PR(3)=-PN(3)
	+ PHSPAC=PHSPAC * (4.PI) (2.*PR(3)/AMTAU)
	+C
	+C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
	+C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
	+C
	+ PXQ=AMTAU*PR(4)
	+ PXN=AMTAU*PN(4)
	+ QXN=PR(4)PN(4)-PR(1)PN(1)-PR(2)PN(2)-PR(3)PN(3)
	+ BRAK=2(GV2+GA2)(2PXQQXN+AMX2*PXN)
	+ & -6(GV2-GA2)AMTAUAMNUTAAMX2
	+CAM Assume neutrino mass=0. and sum over final polarisation
	+C BRAK= 2(AMTAU2-AMX2) (AMTAU*2+2.AMX2)
	+ AMPLIT=CCABIB*2GFERMI*2/2. BRAK * AMX2*SIGEE(AMX2,JNPI)
	+ DGAMT=1./(2.AMTAU)AMPLIT*PHSPAC
	+C
	+C ISOTROPIC W DECAY IN W REST FRAME
	+ PHSPAC = 1./2.*(6ND-7) /PI*(3ND-4)
	+ PHSMAX = 1./dpar(nd-2)
	+ DO 200 I=1,4
	+ 200 PV(I,1)=PR(I)
	+ PV(5,1)=AMW
	+ PV(5,ND)=AMPIK(ND,JNPI)
	+C COMPUTE MAX. PHASE SPACE FACTOR
	+ PMAX=AMW-PS+AMPIK(ND,JNPI)
	+ PMIN=.0
	+ DO 220 IL=ND-1,1,-1
	+ PMAX=PMAX+AMPIK(IL,JNPI)
	+ PMIN=PMIN+AMPIK(IL+1,JNPI)
	+ 220 PHSMAX=PHSMAX*PAWT(PMAX,PMIN,AMPIK(IL,JNPI))
	+CAM GENERATE ND-2 EFFECTIVE MASSES (cf LUDECY)
	+ PHSPAC = 1./2.*(6ND-7) /PI*(3ND-4)
	+ 240 RORD(1)=1.
	+ CALL RANMAR(RRR,ND-1)
	+ DO 260 IL=2,ND-1
	+ RSAV=RRR(IL)
	+ DO 250 JL=IL-1,1,-1
	+ IF(RSAV.LE.RORD(JL)) GOTO 260
	+ 250 RORD(JL+1)=RORD(JL)
	+ 260 RORD(JL+1)=RSAV
	+ RORD(ND)=0.
	+ PHS=1.
	+ DO 270 IL=ND-1,1,-1
	+ PV(5,IL)=PV(5,IL+1)+AMPIK(IL,JNPI)
	+ & +(RORD(IL)-RORD(IL+1))*(PV(5,1)-PS)
	+ 270 PHS=PHS*PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
	+ RN = RRR(1)
	+ IF(PHS.LT.RN*PHSMAX) GOTO 240
	+C...PERFORM SUCCESSIVE TWO-PARTICLE DECAYS IN RESPECTIVE CM FRAME
	+ 280 DO 300 IL=1,ND-1
	+ PA=PAWT(PV(5,IL),PV(5,IL+1),AMPIK(IL,JNPI))
	+ CALL RANMAR(RRR,2)
	+ UE(3)=2.*RRR(1)-1.
	+ PHI=2.PIRRR(2)
	+ UE(1)=SQRT(1.-UE(3)*2)COS(PHI)
	+ UE(2)=SQRT(1.-UE(3)*2)SIN(PHI)
	+ DO 290 J=1,3
	+ PPI(J,IL)=PA*UE(J)
	+ 290 PV(J,IL+1)=-PA*UE(J)
	+ PPI(4,IL)=SQRT(PA2+AMPIK(IL,JNPI)2)
	+ PV(4,IL+1)=SQRT(PA2+PV(5,IL+1)2)
	+ PHSPAC=PHSPAC (4.PI)(2.PA/PV(5,IL))
	+ 300 CONTINUE
	+C...LORENTZ TRANSFORM DECAY PRODUCTS TO TAU FRAME
	+ DO 310 J=1,4
	+ 310 PPI(J,ND)=PV(J,ND)
	+ DO 340 IL=ND-1,1,-1
	+ DO 320 J=1,3
	+ 320 BE(J)=PV(J,IL)/PV(4,IL)
	+ GAM=PV(4,IL)/PV(5,IL)
	+ DO 340 I=IL,ND
	+ BEP=BE(1)PPI(1,I)+BE(2)PPI(2,I)+BE(3)*PPI(3,I)
	+ DO 330 J=1,3
	+ 330 PPI(J,I)=PPI(J,I)+GAM(GAMBEP/(1.+GAM)+PPI(4,I))*BE(J)
	+ PPI(4,I)=GAM*(PPI(4,I)+BEP)
	+ 340 CONTINUE
	+C
	+ HV(4)=1.
	+ HV(3)=0.
	+ HV(2)=0.
	+ HV(1)=0.
	+ RETURN
	+ END
	+ double precision FUNCTION SIGEE(Q2,JNP)
	+C ----------------------------------------------------------------------
	+C e+e- cross section in the (1.GEV2,AMTAU**2) region
	+C normalised to sig0 = 4/3 pi alfa2
	+C used in matrix element for multipion tau decays
	+C cf YS.Tsai Phys.Rev D4 ,2821(1971)
	+C F.Gilman et al Phys.Rev D17,1846(1978)
	+C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
	+C DATSIG(*,1) = e+e- -> pi+pi-2pi0
	+C DATSIG(*,2) = e+e- -> 2pi+2pi-
	+C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
	+C (Phys Lett 78B,623(1978)
	+C DATSIG(*,5) = e+e- -> 6pi
	+C
	+C 4- and 6-pion cross sections from data
	+C 5-pion contribution related to 4-pion cross section
	+C
	+C Called by DPHNPI
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ double precision DATSIG(17,6)
	+C
	+ DATA DATSIG/
	+ 1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
	+ 2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
	+ 3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
	+ 4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
	+ 5 17*.0,
	+ 6 17*.0,
	+ 7 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25,
	+ 8 17*.0/
	+ DATA SIG0 / 86.8 /
	+ DATA PI /3.141592653589793238462643/
	+ DATA INIT / 0 /
	+ save init, jnpi, ampi2, fpi, datsig
	+ save s,fact,s2,t,t2
	+C
	+ JNPI=JNP
	+ IF(JNP.EQ.4) JNPI=3
	+ IF(JNP.EQ.3) JNPI=4
	+ IF(INIT.EQ.0) THEN
	+ INIT=1
	+ AMPI2=AMPI**2
	+ FPI = .943*AMPI
	+ DO 100 I=1,17
	+ DATSIG(I,2) = DATSIG(I,2)/2.
	+ DATSIG(I,1) = DATSIG(I,1) + DATSIG(I,2)
	+ S = 1.025+(I-1)*.05
	+ FACT=0.
	+ S2=S**2
	+ DO 200 J=1,17
	+ T= 1.025+(J-1)*.05
	+ IF(T . GT. S-AMPI ) GO TO 201
	+ T2=T**2
	+ FACT=(T2/S2)*2SQRT((S2-T2-AMPI2)*2-4.T2AMPI2)/S2 2.T.05
	+ FACT = FACT * (DATSIG(J,1)+DATSIG(J+1,1))
	+ 200 DATSIG(I,3) = DATSIG(I,3) + FACT
	+ 201 DATSIG(I,3) = DATSIG(I,3) /(2PIFPI)**2
	+ DATSIG(I,4) = DATSIG(I,3)
	+ DATSIG(I,6) = DATSIG(I,5)
	+ 100 CONTINUE
	+C WRITE(6,1000) DATSIG
	+ 1000 FORMAT(///1X,' EE SIGMA USED IN MULTIPI DECAYS'/
	+ % (17F7.2/))
	+ ENDIF
	+ Q=SQRT(Q2)
	+ QMIN=1.
	+ IF(Q.LT.QMIN) THEN
	+ SIGEE=DATSIG(1,JNPI)+
	+ & (DATSIG(2,JNPI)-DATSIG(1,JNPI))*(Q-1.)/.05
	+ ELSEIF(Q.LT.1.8) THEN
	+ DO 1 I=1,16
	+ QMAX = QMIN + .05
	+ IF(Q.LT.QMAX) GO TO 2
	+ QMIN = QMIN + .05
	+ 1 CONTINUE
	+ 2 SIGEE=DATSIG(I,JNPI)+
	+ & (DATSIG(I+1,JNPI)-DATSIG(I,JNPI)) * (Q-QMIN)/.05
	+ ELSEIF(Q.GT.1.8) THEN
	+ SIGEE=DATSIG(17,JNPI)+
	+ & (DATSIG(17,JNPI)-DATSIG(16,JNPI)) * (Q-1.8)/.05
	+ ENDIF
	+ IF(SIGEE.LT..0) SIGEE=0.
	+C
	+ SIGEE = SIGEE/(6.PI2SIG0)
	+C
	+ RETURN
	+ END
	+
	+ double precision FUNCTION SIGOLD(Q2,JNPI)
	+C ----------------------------------------------------------------------
	+C e+e- cross section in the (1.GEV2,AMTAU**2) region
	+C normalised to sig0 = 4/3 pi alfa2
	+C used in matrix element for multipion tau decays
	+C cf YS.Tsai Phys.Rev D4 ,2821(1971)
	+C F.Gilman et al Phys.Rev D17,1846(1978)
	+C C.Kiesling, to be pub. in High Energy e+e- Physics (1988)
	+C DATSIG(*,1) = e+e- -> pi+pi-2pi0
	+C DATSIG(*,2) = e+e- -> 2pi+2pi-
	+C DATSIG(*,3) = 5-pion contribution (a la TN.Pham et al)
	+C (Phys Lett 78B,623(1978)
	+C DATSIG(*,4) = e+e- -> 6pi
	+C
	+C 4- and 6-pion cross sections from data
	+C 5-pion contribution related to 4-pion cross section
	+C
	+C Called by DPHNPI
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ double precision DATSIG(17,4)
	+C
	+ DATA DATSIG/
	+ 1 7.40,12.00,16.15,21.25,24.90,29.55,34.15,37.40,37.85,37.40,
	+ 2 36.00,33.25,30.50,27.70,24.50,21.25,18.90,
	+ 3 1.24, 2.50, 3.70, 5.40, 7.45,10.75,14.50,18.20,22.30,28.90,
	+ 4 29.35,25.60,22.30,18.60,14.05,11.60, 9.10,
	+ 5 17*.0,
	+ 6 9*.0,.65,1.25,2.20,3.15,5.00,5.75,7.80,8.25/
	+ DATA SIG0 / 86.8 /
	+ DATA PI /3.141592653589793238462643/
	+ DATA INIT / 0 /
	+ save init, ampi2, fpi, datsig, s, fact, s2, t, t2
	+C
	+ IF(INIT.EQ.0) THEN
	+ INIT=1
	+ AMPI2=AMPI**2
	+ FPI = .943*AMPI
	+ DO 100 I=1,17
	+ DATSIG(I,2) = DATSIG(I,2)/2.
	+ DATSIG(I,1) = DATSIG(I,1) + DATSIG(I,2)
	+ S = 1.025+(I-1)*.05
	+ FACT=0.
	+ S2=S**2
	+ DO 200 J=1,17
	+ T= 1.025+(J-1)*.05
	+ IF(T . GT. S-AMPI ) GO TO 201
	+ T2=T**2
	+ FACT=(T2/S2)*2SQRT((S2-T2-AMPI2)*2-4.T2AMPI2)/S2 2.T.05
	+ FACT = FACT * (DATSIG(J,1)+DATSIG(J+1,1))
	+ 200 DATSIG(I,3) = DATSIG(I,3) + FACT
	+ 201 DATSIG(I,3) = DATSIG(I,3) /(2PIFPI)**2
	+ 100 CONTINUE
	+C WRITE(6,1000) DATSIG
	+ 1000 FORMAT(///1X,' EE SIGMA USED IN MULTIPI DECAYS'/
	+ % (17F7.2/))
	+ ENDIF
	+ Q=SQRT(Q2)
	+ QMIN=1.
	+ IF(Q.LT.QMIN) THEN
	+ SIGEE=DATSIG(1,JNPI)+
	+ & (DATSIG(2,JNPI)-DATSIG(1,JNPI))*(Q-1.)/.05
	+ ELSEIF(Q.LT.1.8) THEN
	+ DO 1 I=1,16
	+ QMAX = QMIN + .05
	+ IF(Q.LT.QMAX) GO TO 2
	+ QMIN = QMIN + .05
	+ 1 CONTINUE
	+ 2 SIGEE=DATSIG(I,JNPI)+
	+ & (DATSIG(I+1,JNPI)-DATSIG(I,JNPI)) * (Q-QMIN)/.05
	+ ELSEIF(Q.GT.1.8) THEN
	+ SIGEE=DATSIG(17,JNPI)+
	+ & (DATSIG(17,JNPI)-DATSIG(16,JNPI)) * (Q-1.8)/.05
	+ ENDIF
	+ IF(SIGEE.LT..0) SIGEE=0.
	+C
	+ SIGEE = SIGEE/(6.PI2SIG0)
	+ SIGOLD=SIGEE
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DPHSPK(DGAMT,HV,PN,PAA,PNPI,JAA)
	+C ----------------------------------------------------------------------
	+* IT SIMULATES THREE PI (K) DECAY IN THE TAU REST FRAME
	+* Z-AXIS ALONG HADRONIC SYSTEM
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+
	+ double precision HV(4),PN(4),PAA(4),PIM1(4),
	+ * PIM2(4),PIPL(4),PNPI(4,9)
	+C MATRIX ELEMENT NUMBER:
	+ MNUM=JAA
	+C TYPE OF THE GENERATION:
	+ KEYT=4
	+ IF(JAA.EQ.7) KEYT=3
	+C --- MASSES OF THE DECAY PRODUCTS
	+ AMP1=DCDMAS(IDFFIN(1,JAA+NM4+NM5+NM6))
	+ AMP2=DCDMAS(IDFFIN(2,JAA+NM4+NM5+NM6))
	+ AMP3=DCDMAS(IDFFIN(3,JAA+NM4+NM5+NM6))
	+ CALL
	+ $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMP1,PIM2,AMP2,PIPL,AMP3,KEYT,MNUM)
	+ DO I=1,4
	+ PNPI(I,1)=PIM1(I)
	+ PNPI(I,2)=PIM2(I)
	+ PNPI(I,3)=PIPL(I)
	+ ENDDO
	+ END
	+
	+
	+
	+
	+ SUBROUTINE
	+ $ DPHTRE(DGAMT,HV,PN,PAA,PIM1,AMPA,PIM2,AMPB,PIPL,AMP3,KEYT,MNUM)
	+C ----------------------------------------------------------------------
	+* IT SIMULATES A1 DECAY IN TAU REST FRAME WITH
	+* Z-AXIS ALONG A1 MOMENTUM
	+* it can be also used to generate K K pi and K pi pi tau decays.
	+* INPUT PARAMETERS
	+* KEYT - algorithm controlling switch
	+* 2 - flat phase space PIM1 PIM2 symmetrized statistical factor 1/2
	+* 1 - like 1 but peaked around a1 and rho (two channels) masses.
	+* 3 - peaked around omega, all particles different
	+* other- flat phase space, all particles different
	+* AMP1 - mass of first pi, etc. (1-3)
	+* MNUM - matrix element type
	+* 0 - a1 matrix element
	+* 1-6 - matrix element for K pi pi, K K pi decay modes
	+* 7 - pi- pi0 gamma matrix element
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision HV(4),PT(4),PN(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PR(4)
	+ double precision RRR(5)
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+
	+ save icont
	+ XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)*2-4.0Y*Z))
	+C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
	+C
	+C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	+ PHSPAC=1./217/PI8
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+C
	+ CALL RANMAR(RRR,5)
	+ RR=RRR(5)
	+C
	+ CALL CHOICE(MNUM,RR,ICHAN,PROB1,PROB2,PROB3,
	+ $ AMRX,GAMRX,AMRA,GAMRA,AMRB,GAMRB)
	+ IF (ICHAN.EQ.1) THEN
	+ AMP1=AMPB
	+ AMP2=AMPA
	+ ELSEIF (ICHAN.EQ.2) THEN
	+ AMP1=AMPA
	+ AMP2=AMPB
	+ ELSE
	+ AMP1=AMPB
	+ AMP2=AMPA
	+ ENDIF
	+CAM
	+ RR1=RRR(1)
	+ AMS1=(AMP1+AMP2+AMP3)**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+C phase space with sampling for a1 resonance
	+ ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	+ ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	+ ALP=ALP1+RR1*(ALP2-ALP1)
	+ AM3SQ =AMRX*2+AMRXGAMRX*TAN(ALP)
	+ AM3 =SQRT(AM3SQ)
	+ PHSPAC=PHSPAC((AM3SQ-AMRX2)2+(AMRXGAMRX)*2)/(AMRXGAMRX)
	+ PHSPAC=PHSPAC*(ALP2-ALP1)
	+C MASS OF (REAL/VIRTUAL) RHO -
	+ RR2=RRR(2)
	+ AMS1=(AMP2+AMP3)**2
	+ AMS2=(AM3-AMP1)**2
	+ IF (ICHAN.LE.2) THEN
	+C phase space with sampling for rho resonance,
	+ ALP1=ATAN((AMS1-AMRA**2)/AMRA/GAMRA)
	+ ALP2=ATAN((AMS2-AMRA**2)/AMRA/GAMRA)
	+ ALP=ALP1+RR2*(ALP2-ALP1)
	+ AM2SQ =AMRA*2+AMRAGAMRA*TAN(ALP)
	+ AM2 =SQRT(AM2SQ)
	+C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
	+C PHSPAC=PHSPAC*(ALP2-ALP1)
	+C PHSPAC=PHSPAC((AM2SQ-AMRA2)2+(AMRAGAMRA)*2)/(AMRAGAMRA)
	+C----------------------------------------------------------------------
	+ ELSE
	+C flat phase space;
	+ AM2SQ=AMS1+ RR2*(AMS2-AMS1)
	+ AM2 =SQRT(AM2SQ)
	+ PHF0=(AMS2-AMS1)
	+ ENDIF
	+C rho restframe, define pipl and pim1
	+ ENQ1=(AM2SQ-AMP22+AMP32)/(2*AM2)
	+ ENQ2=(AM2SQ+AMP22-AMP32)/(2*AM2)
	+ PPI= ENQ12-AMP32
	+ PPPI=SQRT(ABS(ENQ12-AMP32))
	+C --- this part of jacobian will be recovered later
	+ PHF1=(4PI)(2*PPPI/AM2)
	+C pi minus momentum in rho rest frame
	+ CALL SPHERA(PPPI,PIPL)
	+ PIPL(4)=ENQ1
	+C pi0 1 momentum in rho rest frame
	+ DO 30 I=1,3
	+ 30 PIM1(I)=-PIPL(I)
	+ PIM1(4)=ENQ2
	+C a1 rest frame, define pim2
	+* RHO MOMENTUM
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1./(2AM3)(AM32+AM22-AMP1**2)
	+ PR(3)= SQRT(ABS(PR(4)2-AM22))
	+ PPI = PR(4)2-AM22
	+* PI0 2 MOMENTUM
	+ PIM2(1)=0
	+ PIM2(2)=0
	+ PIM2(4)=1./(2AM3)(AM32-AM22+AMP1**2)
	+ PIM2(3)=-PR(3)
	+ PHF2=(4PI)(2*PR(3)/AM3)
	+C old pions boosted from rho rest frame to a1 rest frame
	+ EXE=(PR(4)+PR(3))/AM2
	+ CALL BOSTR3(EXE,PIPL,PIPL)
	+ CALL BOSTR3(EXE,PIM1,PIM1)
	+ RR3=RRR(3)
	+ RR4=RRR(4)
	+ THET =ACOS(-1.+2*RR3)
	+ PHI = 2PIRR4
	+ CALL ROTPOL(THET,PHI,PIPL)
	+ CALL ROTPOL(THET,PHI,PIM1)
	+ CALL ROTPOL(THET,PHI,PIM2)
	+ CALL ROTPOL(THET,PHI,PR)
	+C
	+* NOW TO THE TAU REST FRAME, DEFINE A1 AND NEUTRINO MOMENTA
	+* A1 MOMENTUM
	+ PAA(1)=0
	+ PAA(2)=0
	+ PAA(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AM3**2)
	+ PAA(3)= SQRT(ABS(PAA(4)2-AM32))
	+ PPI = PAA(4)2-AM32
	+ PHSPAC=PHSPAC(4PI)(2PAA(3)/AMTAU)
	+* TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AM3**2)
	+ PN(3)=-PAA(3)
	+C HERE WE CORRECT FOR THE JACOBIANS OF THE TWO CHAINS
	+C ---FIRST CHANNEL ------- PIM1+PIPL
	+ AMS1=(AMP2+AMP3)**2
	+ AMS2=(AM3-AMP1)**2
	+ ALP1=ATAN((AMS1-AMRA**2)/AMRA/GAMRA)
	+ ALP2=ATAN((AMS2-AMRA**2)/AMRA/GAMRA)
	+ XPRO = (PIM1(3)+PIPL(3))**2
	+ $ +(PIM1(2)+PIPL(2))2+(PIM1(1)+PIPL(1))2
	+ AM2SQ=-XPRO+(PIM1(4)+PIPL(4))**2
	+C JACOBIAN OF SPEEDING
	+ FF1 = ((AM2SQ-AMRA2)2+(AMRAGAMRA)2)/(AMRAGAMRA)
	+ FF1 =FF1 *(ALP2-ALP1)
	+C LAMBDA OF RHO DECAY
	+ GG1 = (4PI)(XLAM(AM2SQ,AMP22,AMP32)/AM2SQ)
	+C LAMBDA OF A1 DECAY
	+ GG1 =GG1 (4PI)SQRT(4XPRO/AM3SQ)
	+ XJAJE=GG1*(AMS2-AMS1)
	+C ---SECOND CHANNEL ------ PIM2+PIPL
	+ AMS1=(AMP1+AMP3)**2
	+ AMS2=(AM3-AMP2)**2
	+ ALP1=ATAN((AMS1-AMRB**2)/AMRB/GAMRB)
	+ ALP2=ATAN((AMS2-AMRB**2)/AMRB/GAMRB)
	+ XPRO = (PIM2(3)+PIPL(3))**2
	+ $ +(PIM2(2)+PIPL(2))2+(PIM2(1)+PIPL(1))2
	+ AM2SQ=-XPRO+(PIM2(4)+PIPL(4))**2
	+ FF2 = ((AM2SQ-AMRB2)2+(AMRBGAMRB)2)/(AMRBGAMRB)
	+ FF2 =FF2 *(ALP2-ALP1)
	+ GG2 = (4PI)(XLAM(AM2SQ,AMP12,AMP32)/AM2SQ)
	+ GG2 =GG2 (4PI)SQRT(4XPRO/AM3SQ)
	+ XJADW=GG2*(AMS2-AMS1)
	+C
	+ A1=0.0
	+ A2=0.0
	+ A3=0.0
	+ XJAC1=FF1*GG1
	+ XJAC2=FF2*GG2
	+ IF (ICHAN.EQ.2) THEN
	+ XJAC3=XJADW
	+ ELSE
	+ XJAC3=XJAJE
	+ ENDIF
	+ IF (XJAC1.NE.0.0) A1=PROB1/XJAC1
	+ IF (XJAC2.NE.0.0) A2=PROB2/XJAC2
	+ IF (XJAC3.NE.0.0) A3=PROB3/XJAC3
	+C
	+ IF (A1+A2+A3.NE.0.0) THEN
	+ PHSPAC=PHSPAC/(A1+A2+A3)
	+ ELSE
	+ PHSPAC=0.0
	+ ENDIF
	+ IF(ICHAN.EQ.2) THEN
	+ DO 70 I=1,4
	+ X=PIM1(I)
	+ PIM1(I)=PIM2(I)
	+ 70 PIM2(I)=X
	+ ENDIF
	+* ALL PIONS BOOSTED FROM A1 REST FRAME TO TAU REST FRAME
	+* Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
	+ EXE=(PAA(4)+PAA(3))/AM3
	+ CALL BOSTR3(EXE,PIPL,PIPL)
	+ CALL BOSTR3(EXE,PIM1,PIM1)
	+ CALL BOSTR3(EXE,PIM2,PIM2)
	+ CALL BOSTR3(EXE,PR,PR)
	+C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
	+ IF (MNUM.EQ.8) THEN
	+ CALL DAMPOG(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	+C ELSEIF (MNUM.EQ.0) THEN
	+C CALL DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	+ ELSE
	+ CALL DAMPPK(MNUM,PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	+ ENDIF
	+ IF (KEYT.EQ.1.OR.KEYT.EQ.2) THEN
	+C THE STATISTICAL FACTOR FOR IDENTICAL PI-S IS CANCELLED WITH
	+C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
	+Cam PHSPAC=PHSPAC*2.0
	+Cam PHSPAC=PHSPAC/2.
	+ ENDIF
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+ END
	+ SUBROUTINE DAMPAA(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	+C ----------------------------------------------------------------------
	+* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	+* FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
	+* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	+* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	+* THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
	+C
	+C called by : DPHSAA
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON /TESTA1/ KEYA1
	+ double precision HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PAA(4),VEC1(4),VEC2(4)
	+ double precision PIVEC(4),PIAKS(4),HVM(4)
	+ double complex BWIGN,HADCUR(4),FPIK
	+ DATA ICONT /1/
	+ save icont
	+C
	+* F CONSTANTS FOR A1, A1-RHO-PI, AND RHO-PI-PI
	+*
	+ DATA FPI /93.3E-3/
	+* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
	+ BWIGN(XM,AM,GAMMA)=1./CMPLX(XM2-AM2,GAMMA*AM)
	+C
	+* FOUR MOMENTUM OF A1
	+ DO 10 I=1,4
	+ 10 PAA(I)=PIM1(I)+PIM2(I)+PIPL(I)
	+* MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
	+ XMAA =SQRT(ABS(PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2))
	+ XMRO1 =SQRT(ABS((PIPL(4)+PIM1(4))2-(PIPL(1)+PIM1(1))2
	+ $ -(PIPL(2)+PIM1(2))2-(PIPL(3)+PIM1(3))2))
	+ XMRO2 =SQRT(ABS((PIPL(4)+PIM2(4))2-(PIPL(1)+PIM2(1))2
	+ $ -(PIPL(2)+PIM2(2))2-(PIPL(3)+PIM2(3))2))
	+* ELEMENTS OF HADRON CURRENT
	+ PROD1 =PAA(4)(PIM1(4)-PIPL(4))-PAA(1)(PIM1(1)-PIPL(1))
	+ $ -PAA(2)(PIM1(2)-PIPL(2))-PAA(3)(PIM1(3)-PIPL(3))
	+ PROD2 =PAA(4)(PIM2(4)-PIPL(4))-PAA(1)(PIM2(1)-PIPL(1))
	+ $ -PAA(2)(PIM2(2)-PIPL(2))-PAA(3)(PIM2(3)-PIPL(3))
	+ DO 40 I=1,4
	+ VEC1(I)= PIM1(I)-PIPL(I) -PAA(I)PROD1/XMAA*2
	+ 40 VEC2(I)= PIM2(I)-PIPL(I) -PAA(I)PROD2/XMAA*2
	+* HADRON CURRENT SATURATED WITH A1 AND RHO RESONANCES
	+ IF (KEYA1.EQ.1) THEN
	+ FA1=9.87
	+ FAROPI=1.0
	+ FRO2PI=1.0
	+ FNORM=FA1/SQRT(2.)FAROPIFRO2PI
	+ DO 45 I=1,4
	+ HADCUR(I)= CMPLX(FNORM) AMA12BWIGN(XMAA,AMA1,GAMA1)
	+ $ (CMPLX(VEC1(I))AMRO*2BWIGN(XMRO1,AMRO,GAMRO)
	+ $ +CMPLX(VEC2(I))AMRO2BWIGN(XMRO2,AMRO,GAMRO))
	+ 45 CONTINUE
	+ ELSE
	+ FNORM=2.0*SQRT(2.)/3.0/FPI
	+ GAMAX=GAMA1GFUN(XMAA2)/GFUN(AMA1*2)
	+ DO 46 I=1,4
	+ HADCUR(I)= CMPLX(FNORM) AMA12BWIGN(XMAA,AMA1,GAMAX)
	+ $ (CMPLX(VEC1(I))FPIK(XMRO1)
	+ $ +CMPLX(VEC2(I))*FPIK(XMRO2))
	+ 46 CONTINUE
	+ ENDIF
	+C
	+* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	+ CALL CLVEC(HADCUR,PN,PIVEC)
	+ CALL CLAXI(HADCUR,PN,PIAKS)
	+ CALL CLNUT(HADCUR,BRAKM,HVM)
	+* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	+ BRAK= (GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	+ & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	+ AMPLIT=(GFERMICCABIB)2BRAK/2.
	+C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
	+C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
	+C POLARIMETER VECTOR IN TAU REST FRAME
	+ DO 90 I=1,3
	+ HV(I)=-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	+ & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	+C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	+ HV(I)=-HV(I)/BRAK
	+ 90 CONTINUE
	+ END
	+
	+ double precision FUNCTION GFUN(QKWA)
	+C ****************************************************************
	+C G-FUNCTION USED TO INRODUCE ENERGY DEPENDENCE IN A1 WIDTH
	+C ****************************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ IF (QKWA.LT.(AMRO+AMPI)**2) THEN
	+ GFUN=4.1(QKWA-9AMPIZ2)3
	+ $ (1.-3.3(QKWA-9AMPIZ2)+5.8(QKWA-9AMPIZ2)*2)
	+ ELSE
	+ GFUN=QKWA(1.623+10.38/QKWA-9.32/QKWA2+0.65/QKWA*3)
	+ ENDIF
	+ END
	+ double complex FUNCTION BWIGS(S,M,G)
	+C **********************************************************
	+C P-WAVE BREIT-WIGNER FOR K*
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision S,M,G
	+ double precision PI,PIM,QS,QM,W,GS,MK
	+ SAVE PI,PIM,MK
	+ DATA INIT /0/
	+ P(A,B,C)=SQRT(ABS(ABS(((A+B-C)*2-4.A*B)/4./A)
	+ $ +(((A+B-C)*2-4.A*B)/4./A))/2.0)
	+ save init
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0) THEN
	+ INIT=1
	+ PI=3.141592654
	+ PIM=.139
	+ MK=.493667
	+C ------- BREIT-WIGNER -----------------------
	+ ENDIF
	+ IF (S.GT.(PIM+MK)**2) THEN
	+ QS=P(S,PIM2,MK2)
	+ QM=P(M2,PIM2,MK**2)
	+ W=SQRT(S)
	+ GS=G(M/W)(QS/QM)**3
	+ ELSE
	+ GS=0.0
	+ ENDIF
	+ BWIGS=M2/CMPLX(M2-S,-M*GS)
	+ RETURN
	+ END
	+ double complex FUNCTION BWIG(S,M,G)
	+C **********************************************************
	+C P-WAVE BREIT-WIGNER FOR RHO
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision S,M,G
	+ double precision PI,PIM,QS,QM,W,GS,radicand
	+ DATA INIT /0/
	+ SAVE PI, PIM
	+ save init
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0) THEN
	+ INIT=1
	+ PI=3.141592654
	+ PIM=.139
	+C ------- BREIT-WIGNER -----------------------
	+ ENDIF
	+ IF (S.GT.4.PIM*2) THEN
	+ radicand = ABS(ABS(S/4.-PIM2)+(S/4.-PIM2))/2.0
	+ QS=SQRT(radicand)
	+ radicand = M2/4.-PIM2
	+ QM=SQRT(radicand)
	+ W=SQRT(S)
	+ GS=G(M/W)(QS/QM)**3
	+ ELSE
	+ GS=0.0
	+ ENDIF
	+ BWIG=M2/CMPLX(M2-S,-M*GS)
	+ RETURN
	+ END
	+ double complex FUNCTION FPIK(W)
	+C **********************************************************
	+C PION FORM FACTOR
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double complex BWIG
	+ double precision ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
	+ SAVE PI,PIM,ROM,ROG,ROM1,ROG1,BETA1
	+ EXTERNAL BWIG
	+ DATA INIT /0/
	+C
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0 ) THEN
	+ INIT=1
	+ PI=3.141592654
	+ PIM=.140
	+ ROM=0.773
	+ ROG=0.145
	+ ROM1=1.370
	+ ROG1=0.510
	+ BETA1=-0.145
	+ ENDIF
	+C -----------------------------------------------
	+ S=W**2
	+ FPIK= (BWIG(S,ROM,ROG)+BETA1*BWIG(S,ROM1,ROG1))
	+ & /(1+BETA1)
	+ RETURN
	+ END
	+ double precision FUNCTION FPIRHO(W)
	+C **********************************************************
	+C SQUARE OF PION FORM FACTOR
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision :: w
	+ double complex FPIK
	+ FPIRHO=ABS(FPIK(W))**2
	+ END
	+ SUBROUTINE CLVEC(HJ,PN,PIV)
	+C ----------------------------------------------------------------------
	+* CALCULATES THE "VECTOR TYPE" PI-VECTOR PIV
	+* NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
	+C
	+C called by : DAMPAA
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PIV(4),PN(4)
	+ double complex HJ(4),HN
	+C
	+ HN= HJ(4)CMPLX(PN(4))-HJ(3)CMPLX(PN(3))
	+ HH= REAL(HJ(4)CONJG(HJ(4))-HJ(3)CONJG(HJ(3))
	+ $ -HJ(2)CONJG(HJ(2))-HJ(1)CONJG(HJ(1)))
	+ DO 10 I=1,4
	+ 10 PIV(I)=4.REAL(HNCONJG(HJ(I)))-2.HHPN(I)
	+ RETURN
	+ END
	+ SUBROUTINE CLAXI(HJ,PN,PIA)
	+C ----------------------------------------------------------------------
	+* CALCULATES THE "AXIAL TYPE" PI-VECTOR PIA
	+* NOTE THAT THE NEUTRINO MOM. PN IS ASSUMED TO BE ALONG Z-AXIS
	+C SIGN is chosen +/- for decay of TAU +/- respectively
	+C called by : DAMPAA, CLNUT
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+ COMMON / IDFC / IDFF
	+ double precision PIA(4),PN(4)
	+ double complex HJ(4),HJC(4)
	+C DET2(I,J)=AIMAG(HJ(I)HJC(J)-HJ(J)HJC(I))
	+C -- here was an error (ZW, 21.11.1991)
	+ DET2(I,J)=AIMAG(HJC(I)HJ(J)-HJC(J)HJ(I))
	+C -- it was affecting sign of A_LR asymmetry in a1 decay.
	+C -- note also collision of notation of gamma_va as defined in
	+C -- TAUOLA paper and J.H. Kuhn and Santamaria Z. Phys C 48 (1990) 445
	+* -----------------------------------
	+ IF (KTOM.EQ.1.OR.KTOM.EQ.-1) THEN
	+ SIGN= IDFF/ABS(IDFF)
	+ ELSEIF (KTOM.EQ.2) THEN
	+ SIGN=-IDFF/ABS(IDFF)
	+ ELSE
	+ PRINT *, 'STOP IN CLAXI: KTOM=',KTOM
	+ STOP
	+ ENDIF
	+C
	+ DO 10 I=1,4
	+ 10 HJC(I)=CONJG(HJ(I))
	+ PIA(1)= -2.PN(3)DET2(2,4)+2.PN(4)DET2(2,3)
	+ PIA(2)= -2.PN(4)DET2(1,3)+2.PN(3)DET2(1,4)
	+ PIA(3)= 2.PN(4)DET2(1,2)
	+ PIA(4)= 2.PN(3)DET2(1,2)
	+C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
	+ DO 20 I=1,4
	+ 20 PIA(I)=PIA(I)*SIGN
	+ END
	+ SUBROUTINE CLNUT(HJ,B,HV)
	+C ----------------------------------------------------------------------
	+* CALCULATES THE CONTRIBUTION BY NEUTRINO MASS
	+* NOTE THE TAU IS ASSUMED TO BE AT REST
	+C
	+C called by : DAMPAA
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double complex HJ(4)
	+ double precision HV(4),P(4)
	+ DATA P /3*0.,1.0/
	+C
	+ CALL CLAXI(HJ,P,HV)
	+ B=REAL( HJ(4)AIMAG(HJ(4)) - HJ(3)AIMAG(HJ(3))
	+ & - HJ(2)AIMAG(HJ(2)) - HJ(1)AIMAG(HJ(1)) )
	+ RETURN
	+ END
	+ SUBROUTINE DAMPOG(PT,PN,PIM1,PIM2,PIPL,AMPLIT,HV)
	+C ----------------------------------------------------------------------
	+* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	+* FOR TAU DECAY INTO A1, A1 DECAYS NEXT INTO RHO+PI AND RHO INTO PI+PI.
	+* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	+* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	+* THE ROUTINE IS WRITEN FOR ZERO NEUTRINO MASS.
	+C
	+C called by : DPHTRE
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON /TESTA1/ KEYA1
	+ double precision HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIPL(4)
	+ double precision PAA(4),VEC1(4),VEC2(4)
	+ double precision PIVEC(4),PIAKS(4),HVM(4)
	+ double complex BWIGN,HADCUR(4),FNORM,FORMOM
	+ DATA ICONT /1/
	+ save icont
	+* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
	+ !BWIGN(XM,AM,GAMMA)=1./CMPLX(XM2-AM2,GAMMA*AM)
	+C
	+* FOUR MOMENTUM OF A1
	+ DO 10 I=1,4
	+ VEC1(I)=0.0
	+ VEC2(I)=0.0
	+ HV(I) =0.0
	+ 10 PAA(I)=PIM1(I)+PIM2(I)+PIPL(I)
	+ VEC1(1)=1.0
	+* MASSES OF A1, AND OF TWO PI-PAIRS WHICH MAY FORM RHO
	+ XMAA =SQRT(ABS(PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2))
	+ XMOM =SQRT(ABS( (PIM2(4)+PIPL(4))2-(PIM2(3)+PIPL(3))2
	+ $ -(PIM2(2)+PIPL(2))2-(PIM2(1)+PIPL(1))2 ))
	+ XMRO2 =(PIPL(1))2 +(PIPL(2))2 +(PIPL(3))**2
	+* ELEMENTS OF HADRON CURRENT
	+ PROD1 =VEC1(1)*PIPL(1)
	+ PROD2 =VEC2(2)*PIPL(2)
	+ P12 =PIM1(4)PIM2(4)-PIM1(1)PIM2(1)
	+ $ -PIM1(2)PIM2(2)-PIM1(3)PIM2(3)
	+ P1PL =PIM1(4)PIPL(4)-PIM1(1)PIPL(1)
	+ $ -PIM1(2)PIPL(2)-PIM1(3)PIPL(3)
	+ P2PL =PIPL(4)PIM2(4)-PIPL(1)PIM2(1)
	+ $ -PIPL(2)PIM2(2)-PIPL(3)PIM2(3)
	+ DO 40 I=1,3
	+ VEC1(I)= (VEC1(I)-PROD1/XMRO2*PIPL(I))
	+ 40 CONTINUE
	+ GNORM=SQRT(VEC1(1)2+VEC1(2)2+VEC1(3)**2)
	+ DO 41 I=1,3
	+ VEC1(I)= VEC1(I)/GNORM
	+ 41 CONTINUE
	+ VEC2(1)=(VEC1(2)PIPL(3)-VEC1(3)PIPL(2))/SQRT(XMRO2)
	+ VEC2(2)=(VEC1(3)PIPL(1)-VEC1(1)PIPL(3))/SQRT(XMRO2)
	+ VEC2(3)=(VEC1(1)PIPL(2)-VEC1(2)PIPL(1))/SQRT(XMRO2)
	+ P1VEC1 =PIM1(4)VEC1(4)-PIM1(1)VEC1(1)
	+ $ -PIM1(2)VEC1(2)-PIM1(3)VEC1(3)
	+ P2VEC1 =VEC1(4)PIM2(4)-VEC1(1)PIM2(1)
	+ $ -VEC1(2)PIM2(2)-VEC1(3)PIM2(3)
	+ P1VEC2 =PIM1(4)VEC2(4)-PIM1(1)VEC2(1)
	+ $ -PIM1(2)VEC2(2)-PIM1(3)VEC2(3)
	+ P2VEC2 =VEC2(4)PIM2(4)-VEC2(1)PIM2(1)
	+ $ -VEC2(2)PIM2(2)-VEC2(3)PIM2(3)
	+* HADRON CURRENT
	+ FNORM=FORMOM(XMAA,XMOM)
	+ BRAK=0.0
	+ DO 120 JJ=1,2
	+ DO 45 I=1,4
	+ IF (JJ.EQ.1) THEN
	+ HADCUR(I) = FNORM *(
	+ $ VEC1(I)(AMPI2P1PL-P2PL*(P12-P1PL))
	+ $ -PIM2(I)(P2VEC1P1PL-P1VEC1*P2PL)
	+ $ +PIPL(I)(P2VEC1P12 -P1VEC1(AMPI*2+P2PL)) )
	+ ELSE
	+ HADCUR(I) = FNORM *(
	+ $ VEC2(I)(AMPI2P1PL-P2PL*(P12-P1PL))
	+ $ -PIM2(I)(P2VEC2P1PL-P1VEC2*P2PL)
	+ $ +PIPL(I)(P2VEC2P12 -P1VEC2(AMPI*2+P2PL)) )
	+ ENDIF
	+ 45 CONTINUE
	+C
	+* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	+ CALL CLVEC(HADCUR,PN,PIVEC)
	+ CALL CLAXI(HADCUR,PN,PIAKS)
	+ CALL CLNUT(HADCUR,BRAKM,HVM)
	+* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	+ BRAK=BRAK+(GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	+ & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	+ DO 90 I=1,3
	+ HV(I)=HV(I)-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	+ & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	+ 90 CONTINUE
	+C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	+ 120 CONTINUE
	+ AMPLIT=(GFERMICCABIB)2BRAK/2.
	+C THE STATISTICAL FACTOR FOR IDENTICAL PI-S WAS CANCELLED WITH
	+C TWO, FOR TWO MODES OF A1 DECAY NAMELLY PI+PI-PI- AND PI-PI0PI0
	+C POLARIMETER VECTOR IN TAU REST FRAME
	+ DO 91 I=1,3
	+ HV(I)=-HV(I)/BRAK
	+ 91 CONTINUE
	+
	+ END
	+ SUBROUTINE DAMPPK(MNUM,PT,PN,PIM1,PIM2,PIM3,AMPLIT,HV)
	+C ----------------------------------------------------------------------
	+* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	+* FOR TAU DECAY INTO K K pi, K pi pi.
	+* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	+* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	+C MNUM DECAY MODE IDENTIFIER.
	+C
	+C called by : DPHTRE
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision HV(4),PT(4),PN(4),PIM1(4),PIM2(4),PIM3(4)
	+ double precision PAA(4),VEC1(4),VEC2(4),VEC3(4),VEC4(4),VEC5(4)
	+ double precision PIVEC(4),PIAKS(4),HVM(4)
	+ double precision FNORM(0:7),COEF(1:5,0:7)
	+ double complex HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5,UROJ
	+ EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
	+ SAVE UROJ,DWAPI0,FNORM,COEF
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+ save icont
	+C
	+ DATA FPI /93.3E-3/
	+ IF (ICONT.EQ.0) THEN
	+ ICONT=1
	+ UROJ=CMPLX(0.0,1.0)
	+ DWAPI0=SQRT(2.0)
	+ FNORM(0)=CCABIB/FPI
	+ FNORM(1)=CCABIB/FPI
	+ FNORM(2)=CCABIB/FPI
	+ FNORM(3)=CCABIB/FPI
	+ FNORM(4)=SCABIB/FPI/DWAPI0
	+ FNORM(5)=SCABIB/FPI
	+ FNORM(6)=SCABIB/FPI
	+ FNORM(7)=CCABIB/FPI
	+C
	+ COEF(1,0)= 2.0*SQRT(2.)/3.0
	+ COEF(2,0)=-2.0*SQRT(2.)/3.0
	+ COEF(3,0)= 0.0
	+ COEF(4,0)= FPI
	+ COEF(5,0)= 0.0
	+C
	+ COEF(1,1)=-SQRT(2.)/3.0
	+ COEF(2,1)= SQRT(2.)/3.0
	+ COEF(3,1)= 0.0
	+ COEF(4,1)= FPI
	+ COEF(5,1)= SQRT(2.)
	+C
	+ COEF(1,2)=-SQRT(2.)/3.0
	+ COEF(2,2)= SQRT(2.)/3.0
	+ COEF(3,2)= 0.0
	+ COEF(4,2)= 0.0
	+ COEF(5,2)=-SQRT(2.)
	+C
	+ COEF(1,3)= 0.0
	+ COEF(2,3)=-1.0
	+ COEF(3,3)= 0.0
	+ COEF(4,3)= 0.0
	+ COEF(5,3)= 0.0
	+C
	+ COEF(1,4)= 1.0/SQRT(2.)/3.0
	+ COEF(2,4)=-1.0/SQRT(2.)/3.0
	+ COEF(3,4)= 0.0
	+ COEF(4,4)= 0.0
	+ COEF(5,4)= 0.0
	+C
	+ COEF(1,5)=-SQRT(2.)/3.0
	+ COEF(2,5)= SQRT(2.)/3.0
	+ COEF(3,5)= 0.0
	+ COEF(4,5)= 0.0
	+ COEF(5,5)=-SQRT(2.)
	+C
	+ COEF(1,6)= 0.0
	+ COEF(2,6)=-1.0
	+ COEF(3,6)= 0.0
	+ COEF(4,6)= 0.0
	+ COEF(5,6)=-2.0
	+C
	+ COEF(1,7)= 0.0
	+ COEF(2,7)= 0.0
	+ COEF(3,7)= 0.0
	+ COEF(4,7)= 0.0
	+ COEF(5,7)=-SQRT(2.0/3.0)
	+C
	+ ENDIF
	+C
	+ DO 10 I=1,4
	+ 10 PAA(I)=PIM1(I)+PIM2(I)+PIM3(I)
	+ XMAA =SQRT(ABS(PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2))
	+ XMRO1 =SQRT(ABS((PIM3(4)+PIM2(4))2-(PIM3(1)+PIM2(1))2
	+ $ -(PIM3(2)+PIM2(2))2-(PIM3(3)+PIM2(3))2))
	+ XMRO2 =SQRT(ABS((PIM3(4)+PIM1(4))2-(PIM3(1)+PIM1(1))2
	+ $ -(PIM3(2)+PIM1(2))2-(PIM3(3)+PIM1(3))2))
	+ XMRO3 =SQRT(ABS((PIM1(4)+PIM2(4))2-(PIM1(1)+PIM2(1))2
	+ $ -(PIM1(2)+PIM2(2))2-(PIM1(3)+PIM2(3))2))
	+* ELEMENTS OF HADRON CURRENT
	+ PROD1 =PAA(4)(PIM2(4)-PIM3(4))-PAA(1)(PIM2(1)-PIM3(1))
	+ $ -PAA(2)(PIM2(2)-PIM3(2))-PAA(3)(PIM2(3)-PIM3(3))
	+ PROD2 =PAA(4)(PIM3(4)-PIM1(4))-PAA(1)(PIM3(1)-PIM1(1))
	+ $ -PAA(2)(PIM3(2)-PIM1(2))-PAA(3)(PIM3(3)-PIM1(3))
	+ PROD3 =PAA(4)(PIM1(4)-PIM2(4))-PAA(1)(PIM1(1)-PIM2(1))
	+ $ -PAA(2)(PIM1(2)-PIM2(2))-PAA(3)(PIM1(3)-PIM2(3))
	+ DO 40 I=1,4
	+ VEC1(I)= PIM2(I)-PIM3(I) -PAA(I)PROD1/XMAA*2
	+ VEC2(I)= PIM3(I)-PIM1(I) -PAA(I)PROD2/XMAA*2
	+ VEC3(I)= PIM1(I)-PIM2(I) -PAA(I)PROD3/XMAA*2
	+ 40 VEC4(I)= PIM1(I)+PIM2(I)+PIM3(I)
	+ CALL PROD5(PIM1,PIM2,PIM3,VEC5)
	+* HADRON CURRENT
	+C be aware that sign of vec2 is opposite to sign of vec1 in a1 case
	+ DO 45 I=1,4
	+ HADCUR(I)= CMPLX(FNORM(MNUM)) * (
	+ $CMPLX(VEC1(I)COEF(1,MNUM))FORM1(MNUM,XMAA2,XMRO12,XMRO2**2)+
	+ $CMPLX(VEC2(I)COEF(2,MNUM))FORM2(MNUM,XMAA2,XMRO22,XMRO1**2)+
	+ $CMPLX(VEC3(I)COEF(3,MNUM))FORM3(MNUM,XMAA2,XMRO32,XMRO1**2)+
	+ (-1.0UROJ)*
	+ $CMPLX(VEC4(I)COEF(4,MNUM))FORM4(MNUM,XMAA2,XMRO12,
	+ $ XMRO22,XMRO32) +
	+ $(-1.0)UROJ/4.0/PI2/FPI2
	+ $CMPLX(VEC5(I)COEF(5,MNUM))FORM5(MNUM,XMAA2,XMRO12,XMRO2**2))
	+ 45 CONTINUE
	+C
	+* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	+ CALL CLVEC(HADCUR,PN,PIVEC)
	+ CALL CLAXI(HADCUR,PN,PIAKS)
	+ CALL CLNUT(HADCUR,BRAKM,HVM)
	+* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	+ BRAK= (GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	+ & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	+ AMPLIT=(GFERMI)*2BRAK/2.
	+ IF (MNUM.GE.9) THEN
	+ PRINT *, 'MNUM=',MNUM
	+ ZNAK=-1.0
	+ XM1=0.0
	+ XM2=0.0
	+ XM3=0.0
	+ DO 77 K=1,4
	+ IF (K.EQ.4) ZNAK=1.0
	+ XM1=ZNAKPIM1(K)*2+XM1
	+ XM2=ZNAKPIM2(K)*2+XM2
	+ XM3=ZNAKPIM3(K)*2+XM3
	+ 77 PRINT *, 'PIM1=',PIM1(K),'PIM2=',PIM2(K),'PIM3=',PIM3(K)
	+ PRINT *, 'XM1=',SQRT(XM1),'XM2=',SQRT(XM2),'XM3=',SQRT(XM3)
	+ PRINT , '***********************************************'
	+ ENDIF
	+C POLARIMETER VECTOR IN TAU REST FRAME
	+ DO 90 I=1,3
	+ HV(I)=-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	+ & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	+C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	+ HV(I)=-HV(I)/BRAK
	+ 90 CONTINUE
	+ END
	+ SUBROUTINE PROD5(P1,P2,P3,PIA)
	+C ----------------------------------------------------------------------
	+C external product of P1, P2, P3 4-momenta.
	+C SIGN is chosen +/- for decay of TAU +/- respectively
	+C called by : DAMPAA, CLNUT
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / JAKI / JAK1,JAK2,JAKP,JAKM,KTOM
	+ COMMON / IDFC / IDFF
	+ double precision PIA(4),P1(4),P2(4),P3(4)
	+ DET2(I,J)=P1(I)P2(J)-P2(I)P1(J)
	+* -----------------------------------
	+ IF (KTOM.EQ.1.OR.KTOM.EQ.-1) THEN
	+ SIGN= IDFF/ABS(IDFF)
	+ ELSEIF (KTOM.EQ.2) THEN
	+ SIGN=-IDFF/ABS(IDFF)
	+ ELSE
	+ PRINT *, 'STOP IN PROD5: KTOM=',KTOM
	+ STOP
	+ ENDIF
	+C
	+C EPSILON( p1(1), p2(2), p3(3), (4) ) = 1
	+C
	+ PIA(1)= -P3(3)DET2(2,4)+P3(4)DET2(2,3)+P3(2)*DET2(3,4)
	+ PIA(2)= -P3(4)DET2(1,3)+P3(3)DET2(1,4)-P3(1)*DET2(3,4)
	+ PIA(3)= P3(4)DET2(1,2)-P3(2)DET2(1,4)+P3(1)*DET2(2,4)
	+ PIA(4)= P3(3)DET2(1,2)-P3(2)DET2(1,3)+P3(1)*DET2(2,3)
	+C ALL FOUR INDICES ARE UP SO PIA(3) AND PIA(4) HAVE SAME SIGN
	+ DO 20 I=1,4
	+ 20 PIA(I)=PIA(I)*SIGN
	+ END
	+
	+ SUBROUTINE DEXNEW(MODE,ISGN,POL,PNU,PAA,PNPI,JNPI)
	+C ----------------------------------------------------------------------
	+* THIS SIMULATES TAU DECAY IN TAU REST FRAME
	+* INTO NU A1, NEXT A1 DECAYS INTO RHO PI AND FINALLY RHO INTO PI PI.
	+* OUTPUT FOUR MOMENTA: PNU TAUNEUTRINO,
	+* PAA hadron 4-vector
	+* PNPI final state particles
	+* JNPI decay type
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / INOUT / INUT,IOUT
	+ double precision POL(4),HV(4),PAA(4),PNU(4),PNPI(4,9),RN(1)
	+ DATA IWARM/0/
	+ save iwarn
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+ IWARM=1
	+ CALL DADNEW( -1,ISGN,HV,PNU,PAA,PNPI,JDUMM)
	+CC CALL HBOOK1(816,'WEIGHT DISTRIBUTION DEXNEW $',100,-2.,2.)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+* =======================
	+ 300 CONTINUE
	+ IF(IWARM.EQ.0) GOTO 902
	+ CALL DADNEW( 0,ISGN,HV,PNU,PAA,PNPI,JNPI)
	+ WT=(1+POL(1)HV(1)+POL(2)HV(2)+POL(3)*HV(3))/2.
	+CC CALL HFILL(816,WT)
	+ CALL RANMAR(RN,1)
	+ IF(RN(1).GT.WT) GOTO 300
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+* =======================
	+ CALL DADNEW( 1,ISGN,HV,PNU,PAA,PNPI,JDUMM)
	+CC CALL HPRINT(816)
	+ ENDIF
	+C =====
	+ RETURN
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DEXNEW: LACK OF INITIALISATION')
	+ STOP
	+ END
	+ SUBROUTINE DADNEW(MODE,ISGN,HV,PNU,PWB,PNPI,JNPI)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON / TAUBMC / GAMPMC(30),GAMPER(30),NEVDEC(30)
	+ double precision GAMPMC ,GAMPER
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+ COMMON / INOUT / INUT,IOUT
	+
	+ double precision PNU(4),PWB(4),PNPI(4,9),HV(4),HHV(4)
	+ double precision PDUM1(4),PDUM2(4),PDUMI(4,9)
	+ double precision RRR(3)
	+ double precision WTMAX(NMODE)
	+ double precision SWT(NMODE),SSWT(NMODE)
	+ DIMENSION NEVRAW(NMODE),NEVOVR(NMODE),NEVACC(NMODE)
	+
	+ save wtmax, nevraw, nevovr, nevacc, swt, sswt
	+ save hhv, rrr, iwarn
	+
	+C
	+ DATA PI /3.141592653589793238462643/
	+ DATA IWARM/0/
	+C
	+ IF(MODE.EQ.-1) THEN
	+C ===================
	+C -- AT THE MOMENT ONLY TWO DECAY MODES OF MULTIPIONS HAVE M. ELEM
	+ NMOD=NMODE
	+ IWARM=1
	+C PRINT 7003
	+ DO 1 JNPI=1,NMOD
	+ NEVRAW(JNPI)=0
	+ NEVACC(JNPI)=0
	+ NEVOVR(JNPI)=0
	+ SWT(JNPI)=0
	+ SSWT(JNPI)=0
	+ WTMAX(JNPI)=-1.
	+ DO I=1,500
	+ IF (JNPI.LE.0) THEN
	+ GOTO 903
	+ ELSEIF(JNPI.LE.NM4) THEN
	+ CALL DPH4PI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
	+ ELSEIF(JNPI.LE.NM4+NM5) THEN
	+ CALL DPH5PI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
	+ ELSEIF(JNPI.LE.NM4+NM5+NM6) THEN
	+ CALL DPHNPI(WT,HV,PDUM1,PDUM2,PDUMI,JNPI)
	+ ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3) THEN
	+ INUM=JNPI-NM4-NM5-NM6
	+ CALL DPHSPK(WT,HV,PDUM1,PDUM2,PDUMI,INUM)
	+ ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3+NM2) THEN
	+ INUM=JNPI-NM4-NM5-NM6-NM3
	+ CALL DPHSRK(WT,HV,PDUM1,PDUM2,PDUMI,INUM)
	+ ELSE
	+ GOTO 903
	+ ENDIF
	+ IF(WT.GT.WTMAX(JNPI)/1.2) WTMAX(JNPI)=WT*1.2
	+ ENDDO
	+C CALL HBOOK1(801,'WEIGHT DISTRIBUTION DADNPI $',100,0.,2.,.0)
	+C PRINT 7004,WTMAX(JNPI)
	+1 CONTINUE
	+ WRITE(IOUT,7005)
	+C
	+ ELSEIF(MODE.EQ. 0) THEN
	+C =======================
	+ IF(IWARM.EQ.0) GOTO 902
	+C
	+300 CONTINUE
	+ IF (JNPI.LE.0) THEN
	+ GOTO 903
	+ ELSEIF(JNPI.LE.NM4) THEN
	+ CALL DPH4PI(WT,HHV,PNU,PWB,PNPI,JNPI)
	+ ELSEIF(JNPI.LE.NM4+NM5) THEN
	+ CALL DPH5PI(WT,HHV,PNU,PWB,PNPI,JNPI)
	+ ELSEIF(JNPI.LE.NM4+NM5+NM6) THEN
	+ CALL DPHNPI(WT,HHV,PNU,PWB,PNPI,JNPI)
	+ ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3) THEN
	+ INUM=JNPI-NM4-NM5-NM6
	+ CALL DPHSPK(WT,HHV,PNU,PWB,PNPI,INUM)
	+ ELSEIF(JNPI.LE.NM4+NM5+NM6+NM3+NM2) THEN
	+ INUM=JNPI-NM4-NM5-NM6-NM3
	+ CALL DPHSRK(WT,HHV,PNU,PWB,PNPI,INUM)
	+ ELSE
	+ GOTO 903
	+ ENDIF
	+ DO I=1,4
	+ HV(I)=-ISGN*HHV(I)
	+ ENDDO
	+C CALL HFILL(801,WT/WTMAX(JNPI))
	+ NEVRAW(JNPI)=NEVRAW(JNPI)+1
	+ SWT(JNPI)=SWT(JNPI)+WT
	+ SSWT(JNPI)=SSWT(JNPI)+WT**2
	+ CALL RANMAR(RRR,3)
	+ RN=RRR(1)
	+ IF(WT.GT.WTMAX(JNPI)) NEVOVR(JNPI)=NEVOVR(JNPI)+1
	+ IF(RN*WTMAX(JNPI).GT.WT) GOTO 300
	+C ROTATIONS TO BASIC TAU REST FRAME
	+ COSTHE=-1.+2.*RRR(2)
	+ THET=ACOS(COSTHE)
	+ PHI =2PIRRR(3)
	+ CALL ROTOR2(THET,PNU,PNU)
	+ CALL ROTOR3( PHI,PNU,PNU)
	+ CALL ROTOR2(THET,PWB,PWB)
	+ CALL ROTOR3( PHI,PWB,PWB)
	+ CALL ROTOR2(THET,HV,HV)
	+ CALL ROTOR3( PHI,HV,HV)
	+ ND=MULPIK(JNPI)
	+ DO 301 I=1,ND
	+ CALL ROTOR2(THET,PNPI(1,I),PNPI(1,I))
	+ CALL ROTOR3( PHI,PNPI(1,I),PNPI(1,I))
	+301 CONTINUE
	+ NEVACC(JNPI)=NEVACC(JNPI)+1
	+C
	+ ELSEIF(MODE.EQ. 1) THEN
	+C =======================
	+ DO 500 JNPI=1,NMOD
	+ IF(NEVRAW(JNPI).EQ.0) GOTO 500
	+ PARGAM=SWT(JNPI)/FLOAT(NEVRAW(JNPI)+1)
	+ ERROR=0
	+ IF(NEVRAW(JNPI).NE.0)
	+ & ERROR=SQRT(SSWT(JNPI)/SWT(JNPI)**2-1./FLOAT(NEVRAW(JNPI)))
	+ RAT=PARGAM/GAMEL
	+ WRITE(IOUT, 7010) NAMES(JNPI),
	+ & NEVRAW(JNPI),NEVACC(JNPI),NEVOVR(JNPI),PARGAM,RAT,ERROR
	+CC CALL HPRINT(801)
	+ GAMPMC(8+JNPI-1)=RAT
	+ GAMPER(8+JNPI-1)=ERROR
	+CAM NEVDEC(8+JNPI-1)=NEVACC(JNPI)
	+ 500 CONTINUE
	+ ENDIF
	+C =====
	+ RETURN
	+ 7003 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADNEW INITIALISATION *****',9X,1H
	+ $ )
	+ 7004 FORMAT(' ',E20.5,5X,'WTMAX = MAXIMUM WEIGHT ',9X,1H/)
	+ 7005 FORMAT(
	+ $ /,1X,15(5H*****)/)
	+ 7010 FORMAT(///1X,15(5H*****)
	+ $ /,' ', 25X,'***** DADNEW FINAL REPORT ****** ',9X,1H*
	+ $ /,' ', 25X,'CHANNEL:',A31 ,9X,1H
	+ $ /,' ',I20 ,5X,'NEVRAW = NO. OF DECAYS TOTAL ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVACC = NO. OF DECAYS ACCEPTED ',9X,1H
	+ $ /,' ',I20 ,5X,'NEVOVR = NO. OF OVERWEIGHTED EVENTS ',9X,1H
	+ $ /,' ',E20.5,5X,'PARTIAL WTDTH IN GEV UNITS ',9X,1H
	+ $ /,' ',F20.9,5X,'IN UNITS GFERMI2MASS5/192/PI3 ',9X,1H*
	+ $ /,' ',F20.8,5X,'RELATIVE ERROR OF PARTIAL WIDTH ',9X,1H
	+ $ /,1X,15(5H*****)/)
	+ 902 WRITE(IOUT, 9020)
	+ 9020 FORMAT(' ----- DADNEW: LACK OF INITIALISATION')
	+ STOP
	+ 903 WRITE(IOUT, 9030) JNPI,MODE
	+ 9030 FORMAT(' ----- DADNEW: WRONG JNPI',2I5)
	+ STOP
	+ END
	+
	+
	+ SUBROUTINE DPH4PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
	+C ----------------------------------------------------------------------
	+* IT SIMULATES 4pi DECAY IN TAU REST FRAME WITH
	+* Z-AXIS ALONG 4pi MOMENTUM
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+ double precision HV(4),PT(4),PN(4),PAA(4),PIM1(4),
	+ * PIM2(4),PIPL(4),PMULT(4,9)
	+ double precision PR(4),PIZ(4)
	+ double precision RRR(9)
	+ double precision UU,FF,FF1,FF2,FF3,FF4,GG1,GG2,GG3,GG4,RR
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+ save icont
	+ integer k
	+ XLAM(X,Y,Z)=SQRT(ABS((X-Y-Z)*2-4.0Y*Z))
	+C AMRO, GAMRO IS ONLY A PARAMETER FOR GETING HIGHT EFFICIENCY
	+C
	+C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	+C JRR: Initializing the polarimeter vector to zero
	+ HV = 0
	+ PHSPAC=1./223/PI11
	+ PHSP=1./25/PI2
	+C init decay mode JNPI
	+ AMP1=DCDMAS(IDFFIN(1,JNPI))
	+ AMP2=DCDMAS(IDFFIN(2,JNPI))
	+ AMP3=DCDMAS(IDFFIN(3,JNPI))
	+ AMP4=DCDMAS(IDFFIN(4,JNPI))
	+ IF (JNPI.EQ.1) THEN
	+ PREZ=0.7
	+ AMRX=0.782
	+ GAMRX=0.0084
	+ AMROP =1.2
	+ GAMROP=.46
	+ ELSE
	+ PREZ=0.0
	+ AMRX=1.4
	+ GAMRX=.6
	+ AMROP =AMRX
	+ GAMROP=GAMRX
	+
	+ ENDIF
	+! 07.06.96 here was an error in the type of variable.
	+ RRDUM=0.3
	+ CALL CHOICE(100+JNPI,RRDUM,ICHAN,PROB1,PROB2,PROB3,
	+ $ AMROP,GAMROP,AMRX,GAMRX,AMRB,GAMRB)
	+ PREZ=PROB1+PROB2
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+C
	+ CALL RANMAR(RRR,9)
	+C
	+* MASSES OF 4, 3 AND 2 PI SYSTEMS
	+C 3 PI WITH SAMPLING FOR RESONANCE
	+CAM
	+ RR1=RRR(6)
	+ AMS1=(AMP1+AMP2+AMP3+AMP4)**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+ ALP1=ATAN((AMS1-AMROP**2)/AMROP/GAMROP)
	+ ALP2=ATAN((AMS2-AMROP**2)/AMROP/GAMROP)
	+ ALP=ALP1+RR1*(ALP2-ALP1)
	+ AM4SQ =AMROP*2+AMROPGAMROP*TAN(ALP)
	+ AM4 =SQRT(AM4SQ)
	+ PHSPAC=PHSPAC*
	+ $ ((AM4SQ-AMROP2)2+(AMROPGAMROP)2)/(AMROPGAMROP)
	+ PHSPAC=PHSPAC*(ALP2-ALP1)
	+
	+C
	+ RR1=RRR(1)
	+ AMS1=(AMP2+AMP3+AMP4)**2
	+ AMS2=(AM4-AMP1)**2
	+ IF (RRR(9).GT.PREZ) THEN
	+ AM3SQ=AMS1+ RR1*(AMS2-AMS1)
	+ AM3 =SQRT(AM3SQ)
	+C --- this part of jacobian will be recovered later
	+ FF1=AMS2-AMS1
	+ ELSE
	+* PHASE SPACE WITH SAMPLING FOR OMEGA RESONANCE,
	+ ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	+ ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	+ ALP=ALP1+RR1*(ALP2-ALP1)
	+ AM3SQ =AMRX*2+AMRXGAMRX*TAN(ALP)
	+ AM3 =SQRT(AM3SQ)
	+C --- THIS PART OF THE JACOBIAN WILL BE RECOVERED LATER ---------------
	+ FF1=((AM3SQ-AMRX2)2+(AMRXGAMRX)2)/(AMRXGAMRX)
	+ FF1=FF1*(ALP2-ALP1)
	+ ENDIF
	+C MASS OF 2
	+ RR2=RRR(2)
	+ AMS1=(AMP3+AMP4)**2
	+ AMS2=(AM3-AMP2)**2
	+* FLAT PHASE SPACE;
	+ AM2SQ=AMS1+ RR2*(AMS2-AMS1)
	+ AM2 =SQRT(AM2SQ)
	+C --- this part of jacobian will be recovered later
	+ FF2=(AMS2-AMS1)
	+* 2 RESTFRAME, DEFINE PIZ AND PIPL
	+ ENQ1=(AM2SQ+AMP32-AMP42)/(2*AM2)
	+ ENQ2=(AM2SQ-AMP32+AMP42)/(2*AM2)
	+ PPI= ENQ12-AMP32
	+ PPPI=SQRT(ABS(ENQ12-AMP32))
	+ PHSPAC=PHSPAC(4PI)(2PPPI/AM2)
	+* PIZ momentum in 2 rest frame (PIZ is 3rd pi)
	+ CALL SPHERA(PPPI,PIZ)
	+ PIZ(4)=ENQ1
	+C PIPL momentum in 2 rest frame (PIPL is 4th pi)
	+ DO 30 I=1,3
	+ 30 PIPL(I)=-PIZ(I)
	+ PIPL(4)=ENQ2
	+* 3 REST FRAME, DEFINE PIM1
	+C PR momentum
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1./(2AM3)(AM32+AM22-AMP2**2)
	+ PR(3)= SQRT(ABS(PR(4)2-AM22))
	+ PPI = PR(4)2-AM22
	+C PIM1 momentum
	+ PIM1(1)=0
	+ PIM1(2)=0
	+ PIM1(4)=1./(2AM3)(AM32-AM22+AMP2**2)
	+ PIM1(3)=-PR(3)
	+C --- this part of jacobian will be recovered later
	+ FF3=(4PI)(2*PR(3)/AM3)
	+* OLD PIONS BOOSTED FROM 2 REST FRAME TO 3 REST FRAME
	+ EXE=(PR(4)+PR(3))/AM2
	+ CALL BOSTR3(EXE,PIZ,PIZ)
	+ CALL BOSTR3(EXE,PIPL,PIPL)
	+ RR3=RRR(3)
	+ RR4=RRR(4)
	+ THET =ACOS(-1.+2*RR3)
	+ PHI = 2PIRR4
	+ CALL ROTPOL(THET,PHI,PIPL)
	+ CALL ROTPOL(THET,PHI,PIM1)
	+ CALL ROTPOL(THET,PHI,PIZ)
	+ CALL ROTPOL(THET,PHI,PR)
	+C 4 rest frame, define PIM2
	+C PR momentum
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1./(2AM4)(AM42+AM32-AMP1**2)
	+ PR(3)= SQRT(ABS(PR(4)2-AM32))
	+ PPI = PR(4)2-AM32
	+C PIM2 momentum
	+ PIM2(1)=0
	+ PIM2(2)=0
	+ PIM2(4)=1./(2AM4)(AM42-AM32+AMP1**2)
	+ PIM2(3)=-PR(3)
	+C --- this part of jacobian will be recovered later
	+ FF4=(4PI)(2*PR(3)/AM4)
	+* OLD PIONS BOOSTED FROM 3 REST FRAME TO 4 REST FRAME
	+ EXE=(PR(4)+PR(3))/AM3
	+ CALL BOSTR3(EXE,PIZ,PIZ)
	+ CALL BOSTR3(EXE,PIPL,PIPL)
	+ CALL BOSTR3(EXE,PIM1,PIM1)
	+ RR3=RRR(7)
	+ RR4=RRR(8)
	+ THET =ACOS(-1.+2*RR3)
	+ PHI = 2PIRR4
	+ CALL ROTPOL(THET,PHI,PIPL)
	+ CALL ROTPOL(THET,PHI,PIM1)
	+ CALL ROTPOL(THET,PHI,PIM2)
	+ CALL ROTPOL(THET,PHI,PIZ)
	+ CALL ROTPOL(THET,PHI,PR)
	+C
	+* NOW TO THE TAU REST FRAME, DEFINE PAA AND NEUTRINO MOMENTA
	+* PAA MOMENTUM
	+ PAA(1)=0
	+ PAA(2)=0
	+ PAA(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AM4**2)
	+ PAA(3)= SQRT(ABS(PAA(4)2-AM42))
	+ PPI = PAA(4)2-AM42
	+ PHSPAC=PHSPAC(4PI)(2PAA(3)/AMTAU)
	+ PHSP=PHSP(4PI)(2PAA(3)/AMTAU)
	+* TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AM4**2)
	+ PN(3)=-PAA(3)
	+C ZBW 20.12.2002 bug fix
	+ IF(RRR(9).LE.0.5*PREZ) THEN
	+ DO 72 I=1,4
	+ X=PIM1(I)
	+ PIM1(I)=PIM2(I)
	+ 72 PIM2(I)=X
	+ ENDIF
	+C end of bug fix
	+C WE INCLUDE REMAINING PART OF THE JACOBIAN
	+C --- FLAT CHANNEL
	+ AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))2-(PIM1(3)+PIZ(3)+PIPL(3))2
	+ $ -(PIM1(2)+PIZ(2)+PIPL(2))2-(PIM1(1)+PIZ(1)+PIPL(1))2
	+ AMS2=(AM4-AMP2)**2
	+ AMS1=(AMP1+AMP3+AMP4)**2
	+ FF1=(AMS2-AMS1)
	+ AMS1=(AMP3+AMP4)**2
	+ AMS2=(SQRT(AM3SQ)-AMP1)**2
	+ FF2=AMS2-AMS1
	+ FF3=(4PI)(XLAM(AM22,AMP12,AM3SQ)/AM3SQ)
	+ FF4=(4PI)(XLAM(AM3SQ,AMP22,AM42)/AM4**2)
	+ UU=FF1FF2FF3*FF4
	+C --- FIRST CHANNEL
	+ AM3SQ=(PIM1(4)+PIZ(4)+PIPL(4))2-(PIM1(3)+PIZ(3)+PIPL(3))2
	+ $ -(PIM1(2)+PIZ(2)+PIPL(2))2-(PIM1(1)+PIZ(1)+PIPL(1))2
	+ AMS2=(AM4-AMP2)**2
	+ AMS1=(AMP1+AMP3+AMP4)**2
	+ ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	+ ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	+ FF1=((AM3SQ-AMRX2)2+(AMRXGAMRX)2)/(AMRXGAMRX)
	+ FF1=FF1*(ALP2-ALP1)
	+ AMS1=(AMP3+AMP4)**2
	+ AMS2=(SQRT(AM3SQ)-AMP1)**2
	+ FF2=AMS2-AMS1
	+ FF3=(4PI)(XLAM(AM22,AMP12,AM3SQ)/AM3SQ)
	+ FF4=(4PI)(XLAM(AM3SQ,AMP22,AM42)/AM4**2)
	+ FF=FF1FF2FF3*FF4
	+C --- SECOND CHANNEL
	+ AM3SQ=(PIM2(4)+PIZ(4)+PIPL(4))2-(PIM2(3)+PIZ(3)+PIPL(3))2
	+ $ -(PIM2(2)+PIZ(2)+PIPL(2))2-(PIM2(1)+PIZ(1)+PIPL(1))2
	+ AMS2=(AM4-AMP1)**2
	+ AMS1=(AMP2+AMP3+AMP4)**2
	+ ALP1=ATAN((AMS1-AMRX**2)/AMRX/GAMRX)
	+ ALP2=ATAN((AMS2-AMRX**2)/AMRX/GAMRX)
	+ GG1=((AM3SQ-AMRX2)2+(AMRXGAMRX)2)/(AMRXGAMRX)
	+ GG1=GG1*(ALP2-ALP1)
	+ AMS1=(AMP3+AMP4)**2
	+ AMS2=(SQRT(AM3SQ)-AMP2)**2
	+ GG2=AMS2-AMS1
	+ GG3=(4PI)(XLAM(AM22,AMP22,AM3SQ)/AM3SQ)
	+ GG4=(4PI)(XLAM(AM3SQ,AMP12,AM42)/AM4**2)
	+ GG=GG1GG2GG3*GG4
	+C --- JACOBIAN AVERAGED OVER THE TWO
	+ IF ( ( (FF+GG)UU+FFGG ).GT.0.0D0) THEN
	+ RR=FFGGUU/(0.5PREZ(FF+GG)UU+(1.0-PREZ)FF*GG)
	+ PHSPAC=PHSPAC*RR
	+ ELSE
	+ PHSPAC=0.0
	+ ENDIF
	+* MOMENTA OF THE TWO PI-MINUS ARE RANDOMLY SYMMETRISED
	+ IF (JNPI.EQ.1) THEN
	+ RR5= RRR(5)
	+ IF(RR5.LE.0.5) THEN
	+ DO 70 I=1,4
	+ X=PIM1(I)
	+ PIM1(I)=PIM2(I)
	+ 70 PIM2(I)=X
	+ ENDIF
	+ PHSPAC=PHSPAC/2.
	+ ELSE
	+C MOMENTA OF PI0-S ARE GENERATED UNIFORMLY ONLY IF PREZ=0.0
	+ RR5= RRR(5)
	+ IF(RR5.LE.0.5) THEN
	+ DO 71 I=1,4
	+ X=PIM1(I)
	+ PIM1(I)=PIM2(I)
	+ 71 PIM2(I)=X
	+ ENDIF
	+ PHSPAC=PHSPAC/6.
	+ ENDIF
	+* ALL PIONS BOOSTED FROM 4 REST FRAME TO TAU REST FRAME
	+* Z-AXIS ANTIPARALLEL TO NEUTRINO MOMENTUM
	+ EXE=(PAA(4)+PAA(3))/AM4
	+ CALL BOSTR3(EXE,PIZ,PIZ)
	+ CALL BOSTR3(EXE,PIPL,PIPL)
	+ CALL BOSTR3(EXE,PIM1,PIM1)
	+ CALL BOSTR3(EXE,PIM2,PIM2)
	+ CALL BOSTR3(EXE,PR,PR)
	+C PARTIAL WIDTH CONSISTS OF PHASE SPACE AND AMPLITUDE
	+C CHECK ON CONSISTENCY WITH DADNPI, THEN, CODE BREAKES UNIFORM PION
	+C DISTRIBUTION IN HADRONIC SYSTEM
	+ CALL DAM4PI(JNPI,PT,PN,PIM1,PIM2,PIZ,PIPL,AMPLIT,HV)
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+C PHASE SPACE CHECK
	+C DGAMT=PHSPAC
	+ DO 77 K=1,4
	+ PMULT(K,1) = PIM1(K)
	+ PMULT(K,2) = PIM2(K)
	+ PMULT(K,3) = PIZ (K)
	+ PMULT(K,4) = PIPL(K)
	+ 77 CONTINUE
	+ END
	+ SUBROUTINE DAM4PI(MNUM,PT,PN,PIM1,PIM2,PIM3,PIM4,AMPLIT,HV)
	+C ----------------------------------------------------------------------
	+* CALCULATES DIFFERENTIAL CROSS SECTION AND POLARIMETER VECTOR
	+* FOR TAU DECAY INTO 4 PI MODES
	+* ALL SPIN EFFECTS IN THE FULL DECAY CHAIN ARE TAKEN INTO ACCOUNT.
	+* CALCULATIONS DONE IN TAU REST FRAME WITH Z-AXIS ALONG NEUTRINO MOMENT
	+C MNUM DECAY MODE IDENTIFIER.
	+C
	+C called by : DPH4PI
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision HV(4),PT(4),PN(4),PIM1(4),
	+ * PIM2(4),PIM3(4),PIM4(4)
	+ double precision PIVEC(4),PIAKS(4),HVM(4)
	+ double complex HADCUR(4),FORM1,FORM2,FORM3,FORM4,FORM5
	+ EXTERNAL FORM1,FORM2,FORM3,FORM4,FORM5
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+C
	+ CALL CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
	+C
	+* CALCULATE PI-VECTORS: VECTOR AND AXIAL
	+ CALL CLVEC(HADCUR,PN,PIVEC)
	+ CALL CLAXI(HADCUR,PN,PIAKS)
	+ CALL CLNUT(HADCUR,BRAKM,HVM)
	+* SPIN INDEPENDENT PART OF DECAY DIFF-CROSS-SECT. IN TAU REST FRAME
	+ BRAK= (GV2+GA2)PT(4)PIVEC(4) +2.GVGAPT(4)PIAKS(4)
	+ & +2.(GV2-GA2)AMNUTAAMTAUBRAKM
	+ AMPLIT=(CCABIBGFERMI)2BRAK/2.
	+C POLARIMETER VECTOR IN TAU REST FRAME
	+ DO 90 I=1,3
	+ HV(I)=-(AMTAU((GV2+GA2)PIAKS(I)+2.GVGA*PIVEC(I)))
	+ & +(GV2-GA2)AMNUTAAMTAU*HVM(I)
	+C HV IS DEFINED FOR TAU- WITH GAMMA=B+HV*POL
	+ IF (BRAK.NE.0.0)
	+ &HV(I)=-HV(I)/BRAK
	+ 90 CONTINUE
	+ END
	+ SUBROUTINE DPH5PI(DGAMT,HV,PN,PAA,PMULT,JNPI)
	+C ----------------------------------------------------------------------
	+* IT SIMULATES 5pi DECAY IN TAU REST FRAME WITH
	+* Z-AXIS ALONG 5pi MOMENTUM
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+
	+
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ CHARACTER NAMES(NMODE)*31
	+ double precision HV(4),PT(4),PN(4),PAA(4),PMULT(4,9)
	+ double precision PR(4),PI1(4),PI2(4),PI3(4),PI4(4),PI5(4)
	+ double precision AMP1,AMP2,AMP3,AMP4,AMP5,ams1,ams2,amom,gamom
	+ double precision AM5SQ,AM4SQ,AM3SQ,AM2SQ,AM5,AM4,AM3
	+ double precision RRR(10)
	+ double precision gg1,gg2,gg3,ff1,ff2,ff3,ff4,alp,alp1,alp2
	+ double precision XM,AM,GAMMAB
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+ data fpi /93.3e-3/
	+c
	+ double complex BWIGN
	+C
	+ BWIGN(XM,AM,GAMMAB)=XM2/CMPLX(XM2-AM*2,GAMMABAM)
	+
	+C
	+ AMOM=.782
	+ GAMOM=0.0085
	+c
	+C 6 BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+C D3 P /2E/(2PI)3 (2PI)**4 DELTA4(SUM P)
	+ PHSPAC=1./229/PI14
	+c PHSPAC=1./25/PI2
	+C init 5pi decay mode (JNPI)
	+ AMP1=DCDMAS(IDFFIN(1,JNPI))
	+ AMP2=DCDMAS(IDFFIN(2,JNPI))
	+ AMP3=DCDMAS(IDFFIN(3,JNPI))
	+ AMP4=DCDMAS(IDFFIN(4,JNPI))
	+ AMP5=DCDMAS(IDFFIN(5,JNPI))
	+c
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+C
	+ CALL RANMAR(RRR,10)
	+C
	+c masses of 5, 4, 3 and 2 pi systems
	+c 3 pi with sampling for omega resonance
	+cam
	+c mass of 5 (12345)
	+ rr1=rrr(10)
	+ ams1=(amp1+amp2+amp3+amp4+amp5)**2
	+ ams2=(amtau-amnuta)**2
	+ am5sq=ams1+ rr1*(ams2-ams1)
	+ am5 =sqrt(am5sq)
	+ phspac=phspac*(ams2-ams1)
	+c
	+c mass of 4 (2345)
	+c flat phase space
	+ rr1=rrr(9)
	+ ams1=(amp2+amp3+amp4+amp5)**2
	+ ams2=(am5-amp1)**2
	+ am4sq=ams1+ rr1*(ams2-ams1)
	+ am4 =sqrt(am4sq)
	+ gg1=ams2-ams1
	+c
	+c mass of 3 (234)
	+C phase space with sampling for omega resonance
	+ rr1=rrr(1)
	+ ams1=(amp2+amp3+amp4)**2
	+ ams2=(am4-amp5)**2
	+ alp1=atan((ams1-amom**2)/amom/gamom)
	+ alp2=atan((ams2-amom**2)/amom/gamom)
	+ alp=alp1+rr1*(alp2-alp1)
	+ am3sq =amom*2+amomgamom*tan(alp)
	+ am3 =sqrt(am3sq)
	+c --- this part of the jacobian will be recovered later ---------------
	+ gg2=((am3sq-amom2)2+(amomgamom)2)/(amomgamom)
	+ gg2=gg2*(alp2-alp1)
	+c flat phase space;
	+C am3sq=ams1+ rr1*(ams2-ams1)
	+C am3 =sqrt(am3sq)
	+c --- this part of jacobian will be recovered later
	+C gg2=ams2-ams1
	+c
	+C mass of 2 (34)
	+ rr2=rrr(2)
	+ ams1=(amp3+amp4)**2
	+ ams2=(am3-amp2)**2
	+c flat phase space;
	+ am2sq=ams1+ rr2*(ams2-ams1)
	+ am2 =sqrt(am2sq)
	+c --- this part of jacobian will be recovered later
	+ gg3=ams2-ams1
	+c
	+c (34) restframe, define pi3 and pi4
	+ enq1=(am2sq+amp32-amp42)/(2*am2)
	+ enq2=(am2sq-amp32+amp42)/(2*am2)
	+ ppi= enq12-amp32
	+ pppi=sqrt(abs(enq12-amp32))
	+ ff1=(4pi)(2*pppi/am2)
	+c pi3 momentum in (34) rest frame
	+ call sphera(pppi,pi3)
	+ pi3(4)=enq1
	+c pi4 momentum in (34) rest frame
	+ do 30 i=1,3
	+ 30 pi4(i)=-pi3(i)
	+ pi4(4)=enq2
	+c
	+c (234) rest frame, define pi2
	+c pr momentum
	+ pr(1)=0
	+ pr(2)=0
	+ pr(4)=1./(2am3)(am32+am22-amp2**2)
	+ pr(3)= sqrt(abs(pr(4)2-am22))
	+ ppi = pr(4)2-am22
	+c pi2 momentum
	+ pi2(1)=0
	+ pi2(2)=0
	+ pi2(4)=1./(2am3)(am32-am22+amp2**2)
	+ pi2(3)=-pr(3)
	+c --- this part of jacobian will be recovered later
	+ ff2=(4pi)(2*pr(3)/am3)
	+c old pions boosted from 2 rest frame to 3 rest frame
	+ exe=(pr(4)+pr(3))/am2
	+ call bostr3(exe,pi3,pi3)
	+ call bostr3(exe,pi4,pi4)
	+ rr3=rrr(3)
	+ rr4=rrr(4)
	+ thet =acos(-1.+2*rr3)
	+ phi = 2pirr4
	+ call rotpol(thet,phi,pi2)
	+ call rotpol(thet,phi,pi3)
	+ call rotpol(thet,phi,pi4)
	+C
	+C (2345) rest frame, define pi5
	+c pr momentum
	+ pr(1)=0
	+ pr(2)=0
	+ pr(4)=1./(2am4)(am42+am32-amp5**2)
	+ pr(3)= sqrt(abs(pr(4)2-am32))
	+ ppi = pr(4)2-am32
	+c pi5 momentum
	+ pi5(1)=0
	+ pi5(2)=0
	+ pi5(4)=1./(2am4)(am42-am32+amp5**2)
	+ pi5(3)=-pr(3)
	+c --- this part of jacobian will be recovered later
	+ ff3=(4pi)(2*pr(3)/am4)
	+c old pions boosted from 3 rest frame to 4 rest frame
	+ exe=(pr(4)+pr(3))/am3
	+ call bostr3(exe,pi2,pi2)
	+ call bostr3(exe,pi3,pi3)
	+ call bostr3(exe,pi4,pi4)
	+ rr3=rrr(5)
	+ rr4=rrr(6)
	+ thet =acos(-1.+2*rr3)
	+ phi = 2pirr4
	+ call rotpol(thet,phi,pi2)
	+ call rotpol(thet,phi,pi3)
	+ call rotpol(thet,phi,pi4)
	+ call rotpol(thet,phi,pi5)
	+C
	+C (12345) rest frame, define pi1
	+c pr momentum
	+ pr(1)=0
	+ pr(2)=0
	+ pr(4)=1./(2am5)(am52+am42-amp1**2)
	+ pr(3)= sqrt(abs(pr(4)2-am42))
	+ ppi = pr(4)2-am42
	+c pi1 momentum
	+ pi1(1)=0
	+ pi1(2)=0
	+ pi1(4)=1./(2am5)(am52-am42+amp1**2)
	+ pi1(3)=-pr(3)
	+c --- this part of jacobian will be recovered later
	+ ff4=(4pi)(2*pr(3)/am5)
	+c old pions boosted from 4 rest frame to 5 rest frame
	+ exe=(pr(4)+pr(3))/am4
	+ call bostr3(exe,pi2,pi2)
	+ call bostr3(exe,pi3,pi3)
	+ call bostr3(exe,pi4,pi4)
	+ call bostr3(exe,pi5,pi5)
	+ rr3=rrr(7)
	+ rr4=rrr(8)
	+ thet =acos(-1.+2*rr3)
	+ phi = 2pirr4
	+ call rotpol(thet,phi,pi1)
	+ call rotpol(thet,phi,pi2)
	+ call rotpol(thet,phi,pi3)
	+ call rotpol(thet,phi,pi4)
	+ call rotpol(thet,phi,pi5)
	+c
	+* now to the tau rest frame, define paa and neutrino momenta
	+* paa momentum
	+ paa(1)=0
	+ paa(2)=0
	+c paa(4)=1./(2amtau)(amtau2-amnuta2+am5**2)
	+c paa(3)= sqrt(abs(paa(4)2-am52))
	+c ppi = paa(4)2-am52
	+ paa(4)=1./(2amtau)(amtau2-amnuta2+am5sq)
	+ paa(3)= sqrt(abs(paa(4)**2-am5sq))
	+ ppi = paa(4)**2-am5sq
	+ phspac=phspac(4pi)(2paa(3)/amtau)
	+* tau-neutrino momentum
	+ pn(1)=0
	+ pn(2)=0
	+ pn(4)=1./(2amtau)(amtau2+amnuta2-am5**2)
	+ pn(3)=-paa(3)
	+c
	+ phspac=phspac * gg1gg2gg3ff1ff2ff3ff4
	+c
	+C all pions boosted from 5 rest frame to tau rest frame
	+C z-axis antiparallel to neutrino momentum
	+ exe=(paa(4)+paa(3))/am5
	+ call bostr3(exe,pi1,pi1)
	+ call bostr3(exe,pi2,pi2)
	+ call bostr3(exe,pi3,pi3)
	+ call bostr3(exe,pi4,pi4)
	+ call bostr3(exe,pi5,pi5)
	+c
	+C partial width consists of phase space and amplitude
	+C AMPLITUDE (cf YS.Tsai Phys.Rev.D4,2821(1971)
	+C or F.Gilman SH.Rhie Phys.Rev.D31,1066(1985)
	+C
	+ PXQ=AMTAU*PAA(4)
	+ PXN=AMTAU*PN(4)
	+ QXN=PAA(4)PN(4)-PAA(1)PN(1)-PAA(2)PN(2)-PAA(3)PN(3)
	+ BRAK=2(GV2+GA2)(2PXQQXN+AM5SQ*PXN)
	+ & -6(GV2-GA2)AMTAUAMNUTAAM5SQ
	+ fompp = abs(bwign(am3,amom,gamom))**2
	+c normalisation factor (to some numerical undimensioned factor;
	+c cf R.Fischer et al ZPhys C3, 313 (1980))
	+ fnorm = 1/fpi**6
	+c AMPLIT=CCABIB*2GFERMI*2/2. BRAK * AM5SQ*SIGEE(AM5SQ,JNPI)
	+ AMPLIT=CCABIB*2GFERMI*2/2. BRAK
	+ amplit = amplit * fompp * fnorm
	+c phase space test
	+c amplit = amplit * fnorm
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+c ignore spin terms
	+ DO 40 I=1,3
	+ 40 HV(I)=0.
	+c
	+ do 77 k=1,4
	+ pmult(k,1)=pi1(k)
	+ pmult(k,2)=pi2(k)
	+ pmult(k,3)=pi3(k)
	+ pmult(k,4)=pi4(k)
	+ pmult(k,5)=pi5(k)
	+ 77 continue
	+ return
	+C missing: transposition of identical particles, statistical factors
	+C for identical matrices, polarimetric vector. Matrix element rather nai
	+C flat phase space in pion system + with breit wigner for omega
	+C anyway it is better than nothing, and code is improvable.
	+ end
	+ SUBROUTINE DPHSRK(DGAMT,HV,PN,PR,PMULT,INUM)
	+C ----------------------------------------------------------------------
	+C IT SIMULATES RHO DECAY IN TAU REST FRAME WITH
	+C Z-AXIS ALONG RHO MOMENTUM
	+C Rho decays to K Kbar
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision HV(4),PT(4),PN(4),PR(4),PKC(4),
	+ * PKZ(4),QQ(4),PMULT(4,9)
	+ double precision RR1(1)
	+ DATA PI /3.141592653589793238462643/
	+ DATA ICONT /0/
	+C
	+C THREE BODY PHASE SPACE NORMALISED AS IN BJORKEN-DRELL
	+ PHSPAC=1./211/PI5
	+C TAU MOMENTUM
	+ PT(1)=0.
	+ PT(2)=0.
	+ PT(3)=0.
	+ PT(4)=AMTAU
	+C MASS OF (REAL/VIRTUAL) RHO
	+ AMS1=(AMK+AMKZ)**2
	+ AMS2=(AMTAU-AMNUTA)**2
	+C FLAT PHASE SPACE
	+ CALL RANMAR(RR1,1)
	+ AMX2=AMS1+ RR1(1)*(AMS2-AMS1)
	+ AMX=SQRT(AMX2)
	+ PHSPAC=PHSPAC*(AMS2-AMS1)
	+C PHASE SPACE WITH SAMPLING FOR RHO RESONANCE
	+c ALP1=ATAN((AMS1-AMRO**2)/AMRO/GAMRO)
	+c ALP2=ATAN((AMS2-AMRO**2)/AMRO/GAMRO)
	+CAM
	+ 100 CONTINUE
	+c CALL RANMAR(RR1,1)
	+c ALP=ALP1+RR1(1)*(ALP2-ALP1)
	+c AMX2=AMRO*2+AMROGAMRO*TAN(ALP)
	+c AMX=SQRT(AMX2)
	+c IF(AMX.LT.(AMK+AMKZ)) GO TO 100
	+CAM
	+c PHSPAC=PHSPAC((AMX2-AMRO2)2+(AMROGAMRO)*2)/(AMROGAMRO)
	+c PHSPAC=PHSPAC*(ALP2-ALP1)
	+C
	+C TAU-NEUTRINO MOMENTUM
	+ PN(1)=0
	+ PN(2)=0
	+ PN(4)=1./(2AMTAU)(AMTAU2+AMNUTA2-AMX**2)
	+ PN(3)=-SQRT((PN(4)-AMNUTA)*(PN(4)+AMNUTA))
	+C RHO MOMENTUM
	+ PR(1)=0
	+ PR(2)=0
	+ PR(4)=1./(2AMTAU)(AMTAU2-AMNUTA2+AMX**2)
	+ PR(3)=-PN(3)
	+ PHSPAC=PHSPAC(4PI)(2PR(3)/AMTAU)
	+C
	+CAM
	+ ENQ1=(AMX2+AMK2-AMKZ2)/(2.*AMX)
	+ ENQ2=(AMX2-AMK2+AMKZ2)/(2.*AMX)
	+ PPPI=SQRT((ENQ1-AMK)*(ENQ1+AMK))
	+ PHSPAC=PHSPAC(4PI)(2PPPI/AMX)
	+C CHARGED PI MOMENTUM IN RHO REST FRAME
	+ CALL SPHERA(PPPI,PKC)
	+ PKC(4)=ENQ1
	+C NEUTRAL PI MOMENTUM IN RHO REST FRAME
	+ DO 20 I=1,3
	+20 PKZ(I)=-PKC(I)
	+ PKZ(4)=ENQ2
	+ EXE=(PR(4)+PR(3))/AMX
	+C PIONS BOOSTED FROM RHO REST FRAME TO TAU REST FRAME
	+ CALL BOSTR3(EXE,PKC,PKC)
	+ CALL BOSTR3(EXE,PKZ,PKZ)
	+ DO 30 I=1,4
	+ 30 QQ(I)=PKC(I)-PKZ(I)
	+C QQ transverse to PR
	+ PKSD =PR(4)PR(4)-PR(3)PR(3)-PR(2)PR(2)-PR(1)PR(1)
	+ QQPKS=PR(4)* QQ(4)-PR(3)* QQ(3)-PR(2)* QQ(2)-PR(1)* QQ(1)
	+ DO 31 I=1,4
	+31 QQ(I)=QQ(I)-PR(I)*QQPKS/PKSD
	+C AMPLITUDE
	+ PRODPQ=PT(4)*QQ(4)
	+ PRODNQ=PN(4)QQ(4)-PN(1)QQ(1)-PN(2)QQ(2)-PN(3)QQ(3)
	+ PRODPN=PT(4)*PN(4)
	+ QQ2= QQ(4)2-QQ(1)2-QQ(2)2-QQ(3)2
	+ BRAK=(GV2+GA2)(2PRODPQPRODNQ-PRODPNQQ2)
	+ & +(GV2-GA2)AMTAUAMNUTA*QQ2
	+ AMPLIT=(GFERMICCABIB)2BRAK2FPIRK(AMX)
	+ DGAMT=1/(2.AMTAU)AMPLIT*PHSPAC
	+ DO 40 I=1,3
	+ 40 HV(I)=2GVGAAMTAU(2PRODNQQQ(I)-QQ2*PN(I))/BRAK
	+ do 77 k=1,4
	+ pmult(k,1)=pkc(k)
	+ pmult(k,2)=pkz(k)
	+ 77 continue
	+ RETURN
	+ END
	+ double precision FUNCTION FPIRK(W)
	+C ----------------------------------------------------------
	+c square of pion form factor
	+C ----------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+c double complex FPIKMK
	+ double complex FPIKM
	+ FPIRK=ABS(FPIKM(W,AMK,AMKZ))**2
	+c FPIRK=ABS(FPIKMK(W,AMK,AMKZ))**2
	+ END
	+ double complex FUNCTION FPIKMK(W,XM1,XM2)
	+C **********************************************************
	+C Kaon form factor
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double complex BWIGM
	+ double precision XM1, XM2
	+ double precision ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
	+ SAVE PI,PIM,ROM,ROG,ROM1,ROG1,BETA1
	+ double complex BWIG
	+ EXTERNAL BWIG
	+ DATA INIT /0/
	+C
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0 ) THEN
	+ INIT=1
	+ PI=3.141592654
	+ PIM=.140
	+ ROM=0.773
	+ ROG=0.145
	+ ROM1=1.570
	+ ROG1=0.510
	+c BETA1=-0.111
	+ BETA1=-0.221
	+ ENDIF
	+C -----------------------------------------------
	+ S=W**2
	+ FPIKMK=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
	+ & /(1+BETA1)
	+ RETURN
	+ END
	+ SUBROUTINE RESLUX
	+C ****************
	+C INITIALIZE LUND COMMON
	+ IMPLICIT double precision (A-H,O-Z)
	+ PARAMETER (NMXHEP=2000)
	+ COMMON/HEPEVTX/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ SAVE /HEPEVTx/
	+ NHEP=0
	+ END
	+ SUBROUTINE DWRPH(KTO,PHX)
	+C
	+C -------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PHX(4)
	+ double precision QHOT(4)
	+C
	+ DO 9 K=1,4
	+ QHOT(K) =0.0
	+ 9 CONTINUE
	+C CASE OF TAU RADIATIVE DECAYS.
	+C FILLING OF THE LUND COMMON BLOCK.
	+ DO 1002 I=1,4
	+ 1002 QHOT(I)=PHX(I)
	+ IF (QHOT(4).GT.1.E-5) CALL DWLUPH(KTO,QHOT)
	+ RETURN
	+ END
	+ SUBROUTINE DWLUPH(KTO,PHOT)
	+C---------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C called by : DEXAY1,(DEKAY1,DEKAY2)
	+C
	+C used when radiative corrections in decays are generated
	+C---------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON /TAUPOS/ NP1,NP2
	+ double precision PHOT(4)
	+C
	+C check energy
	+ IF (PHOT(4).LE.0.0) RETURN
	+C
	+C position of decaying particle:
	+ IF((KTO.EQ. 1).OR.(KTO.EQ.11)) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+ KTOS=KTO
	+ IF(KTOS.GT.10) KTOS=KTOS-10
	+C boost and append photon (gamma is 22)
	+ CALL TRALO4(KTOS,PHOT,PHOT,AM)
	+ CALL FILHEP(0,1,22,NPS,NPS,0,0,PHOT,0.0D0,.TRUE.)
	+C
	+ RETURN
	+ END
	+
	+ SUBROUTINE DWLUEL(KTO,ISGN,PNU,PWB,PEL,PNE)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C
	+C called by : DEXAY,(DEKAY1,DEKAY2)
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON /TAUPOS/ NP1,NP2
	+ double precision PNU(4),PWB(4),PEL(4),PNE(4)
	+C
	+C position of decaying particle:
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C W boson (W+ is 24)
	+ CALL TRALO4(KTO,PWB,PWB,AM)
	+C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
	+C
	+C electron (e- is 11)
	+ CALL TRALO4(KTO,PEL,PEL,AM)
	+ CALL FILHEP(0,1,11*ISGN,NPS,NPS,0,0,PEL,AM,.FALSE.)
	+C
	+C anti electron neutrino (nu_e is 12)
	+ CALL TRALO4(KTO,PNE,PNE,AM)
	+ CALL FILHEP(0,1,-12*ISGN,NPS,NPS,0,0,PNE,AM,.TRUE.)
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLUMU(KTO,ISGN,PNU,PWB,PMU,PNM)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C
	+C called by : DEXAY,(DEKAY1,DEKAY2)
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON /TAUPOS/ NP1,NP2
	+ double precision PNU(4),PWB(4),PMU(4),PNM(4)
	+C
	+C position of decaying particle:
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C W boson (W+ is 24)
	+ CALL TRALO4(KTO,PWB,PWB,AM)
	+C CALL FILHEP(0,2,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
	+C
	+C muon (mu- is 13)
	+ CALL TRALO4(KTO,PMU,PMU,AM)
	+ CALL FILHEP(0,1,13*ISGN,NPS,NPS,0,0,PMU,AM,.FALSE.)
	+C
	+C anti muon neutrino (nu_mu is 14)
	+ CALL TRALO4(KTO,PNM,PNM,AM)
	+ CALL FILHEP(0,1,-14*ISGN,NPS,NPS,0,0,PNM,AM,.TRUE.)
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLUPI(KTO,ISGN,PPI,PNU)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C
	+C called by : DEXAY,(DEKAY1,DEKAY2)
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PNU(4),PPI(4)
	+ COMMON /TAUPOS/ NP1,NP2
	+C
	+C position of decaying particle:
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C charged pi meson (pi+ is 211)
	+ CALL TRALO4(KTO,PPI,PPI,AM)
	+ CALL FILHEP(0,1,-211*ISGN,NPS,NPS,0,0,PPI,AM,.TRUE.)
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLURO(KTO,ISGN,PNU,PRHO,PIC,PIZ)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C
	+C called by : DEXAY,(DEKAY1,DEKAY2)
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON /TAUPOS/ NP1,NP2
	+ double precision PNU(4),PRHO(4),PIC(4),PIZ(4)
	+C
	+C position of decaying particle:
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C charged rho meson (rho+ is 213)
	+ CALL TRALO4(KTO,PRHO,PRHO,AM)
	+ CALL FILHEP(0,2,-213*ISGN,NPS,NPS,0,0,PRHO,AM,.TRUE.)
	+C
	+C charged pi meson (pi+ is 211)
	+ CALL TRALO4(KTO,PIC,PIC,AM)
	+ CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIC,AM,.TRUE.)
	+C
	+C pi0 meson (pi0 is 111)
	+ CALL TRALO4(KTO,PIZ,PIZ,AM)
	+ CALL FILHEP(0,1,111,-2,-2,0,0,PIZ,AM,.TRUE.)
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLUAA(KTO,ISGN,PNU,PAA,PIM1,PIM2,PIPL,JAA)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C JAA = 1 (2) FOR A_1- DECAY TO PI+ 2PI- (PI- 2PI0)
	+C
	+C called by : DEXAY,(DEKAY1,DEKAY2)
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON /TAUPOS/ NP1,NP2
	+ double precision PNU(4),PAA(4),PIM1(4),PIM2(4),PIPL(4)
	+C
	+C position of decaying particle:
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C charged a_1 meson (a_1+ is 20213)
	+ CALL TRALO4(KTO,PAA,PAA,AM)
	+ CALL FILHEP(0,1,-20213*ISGN,NPS,NPS,0,0,PAA,AM,.TRUE.)
	+C
	+C two possible decays of the charged a1 meson
	+ IF(JAA.EQ.1) THEN
	+C
	+C A1 --> PI+ PI- PI- (or charged conjugate)
	+C
	+C pi minus (or c.c.) (pi+ is 211)
	+ CALL TRALO4(KTO,PIM2,PIM2,AM)
	+ CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PIM2,AM,.TRUE.)
	+C
	+C pi minus (or c.c.) (pi+ is 211)
	+ CALL TRALO4(KTO,PIM1,PIM1,AM)
	+ CALL FILHEP(0,1,-211*ISGN,-2,-2,0,0,PIM1,AM,.TRUE.)
	+C
	+C pi plus (or c.c.) (pi+ is 211)
	+ CALL TRALO4(KTO,PIPL,PIPL,AM)
	+ CALL FILHEP(0,1, 211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
	+C
	+ ELSE IF (JAA.EQ.2) THEN
	+C
	+C A1 --> PI- PI0 PI0 (or charged conjugate)
	+C
	+C pi zero (pi0 is 111)
	+ CALL TRALO4(KTO,PIM2,PIM2,AM)
	+ CALL FILHEP(0,1,111,-1,-1,0,0,PIM2,AM,.TRUE.)
	+C
	+C pi zero (pi0 is 111)
	+ CALL TRALO4(KTO,PIM1,PIM1,AM)
	+ CALL FILHEP(0,1,111,-2,-2,0,0,PIM1,AM,.TRUE.)
	+C
	+C pi minus (or c.c.) (pi+ is 211)
	+ CALL TRALO4(KTO,PIPL,PIPL,AM)
	+ CALL FILHEP(0,1,-211*ISGN,-3,-3,0,0,PIPL,AM,.TRUE.)
	+C
	+ ENDIF
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLUKK (KTO,ISGN,PKK,PNU)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PKK(4),PNU(4)
	+ COMMON /TAUPOS/ NP1,NP2
	+C
	+C position of decaying particle
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4 (KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C K meson (K+ is 321)
	+ CALL TRALO4 (KTO,PKK,PKK,AM)
	+ CALL FILHEP(0,1,-321*ISGN,NPS,NPS,0,0,PKK,AM,.TRUE.)
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLUKS(KTO,ISGN,PNU,PKS,PKK,PPI,JKST)
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / TAUKLE / BRA1,BRK0,BRK0B,BRKS
	+ double precision BRA1,BRK0,BRK0B,BRKS
	+ COMMON /TAUPOS/ NP1,NP2
	+ double precision XIO(1)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C JKST=10 (20) corresponds to K0B pi- (K- pi0) decay
	+C
	+C ----------------------------------------------------------------------
	+C
	+ double precision PNU(4),PKS(4),PKK(4),PPI(4)
	+C
	+C position of decaying particle
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C charged K* meson (K*+ is 323)
	+ CALL TRALO4(KTO,PKS,PKS,AM)
	+ CALL FILHEP(0,1,-323*ISGN,NPS,NPS,0,0,PKS,AM,.TRUE.)
	+C
	+C two possible decay modes of charged K*
	+ IF(JKST.EQ.10) THEN
	+C
	+C K*- --> pi- K0B (or charged conjugate)
	+C
	+C charged pi meson (pi+ is 211)
	+ CALL TRALO4(KTO,PPI,PPI,AM)
	+ CALL FILHEP(0,1,-211*ISGN,-1,-1,0,0,PPI,AM,.TRUE.)
	+C
	+ BRAN=BRK0B
	+ IF (ISGN.EQ.-1) BRAN=BRK0
	+C K0 --> K0_long (is 130) / K0_short (is 310) = 1/1
	+ CALL RANMAR(XIO,1)
	+ IF(XIO(1).GT.BRAN) THEN
	+ K0TYPE = 130
	+ ELSE
	+ K0TYPE = 310
	+ ENDIF
	+C
	+ CALL TRALO4(KTO,PKK,PKK,AM)
	+ CALL FILHEP(0,1,K0TYPE,-2,-2,0,0,PKK,AM,.TRUE.)
	+C
	+ ELSE IF(JKST.EQ.20) THEN
	+C
	+C K*- --> pi0 K-
	+C
	+C pi zero (pi0 is 111)
	+ CALL TRALO4(KTO,PPI,PPI,AM)
	+ CALL FILHEP(0,1,111,-1,-1,0,0,PPI,AM,.TRUE.)
	+C
	+C charged K meson (K+ is 321)
	+ CALL TRALO4(KTO,PKK,PKK,AM)
	+ CALL FILHEP(0,1,-321*ISGN,-2,-2,0,0,PKK,AM,.TRUE.)
	+C
	+ ENDIF
	+C
	+ RETURN
	+ END
	+ SUBROUTINE DWLNEW(KTO,ISGN,PNU,PWB,PNPI,MODE)
	+C ----------------------------------------------------------------------
	+C Lorentz transformation to CMsystem and
	+C Updating of HEPEVT record
	+C
	+C ISGN = 1/-1 for tau-/tau+
	+C
	+C called by : DEXAY,(DEKAY1,DEKAY2)
	+C ----------------------------------------------------------------------
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ PARAMETER (NMODE=15,NM1=0,NM2=1,NM3=8,NM4=2,NM5=1,NM6=3)
	+ COMMON / TAUDCD /IDFFIN(9,NMODE),MULPIK(NMODE)
	+ & ,NAMES
	+ COMMON /TAUPOS/ NP1,NP2
	+ CHARACTER NAMES(NMODE)*31
	+ double precision PNU(4),PWB(4),PNPI(4,9)
	+ double precision PPI(4)
	+C
	+ JNPI=MODE-7
	+C position of decaying particle
	+ IF(KTO.EQ. 1) THEN
	+ NPS=NP1
	+ ELSE
	+ NPS=NP2
	+ ENDIF
	+C
	+C tau neutrino (nu_tau is 16)
	+ CALL TRALO4(KTO,PNU,PNU,AM)
	+ CALL FILHEP(0,1,16*ISGN,NPS,NPS,0,0,PNU,AM,.TRUE.)
	+C
	+C W boson (W+ is 24)
	+ CALL TRALO4(KTO,PWB,PWB,AM)
	+ CALL FILHEP(0,1,-24*ISGN,NPS,NPS,0,0,PWB,AM,.TRUE.)
	+C
	+C multi pi mode JNPI
	+C
	+C get multiplicity of mode JNPI
	+ ND=MULPIK(JNPI)
	+ DO I=1,ND
	+cam KFPI=LUNPIK(IDFFIN(I,JNPI),-ISGN)
	+ KFPI=LUNPIK(IDFFIN(I,JNPI), ISGN)
	+C for charged conjugate case, change charged pions only
	+C IF(KFPI.NE.111)KFPI=KFPI*ISGN
	+ DO J=1,4
	+ PPI(J)=PNPI(J,I)
	+ END DO
	+ CALL TRALO4(KTO,PPI,PPI,AM)
	+ CALL FILHEP(0,1,KFPI,-I,-I,0,0,PPI,AM,.TRUE.)
	+ END DO
	+C
	+ RETURN
	+ END
	+ double precision FUNCTION AMAST(PP)
	+C ----------------------------------------------------------------------
	+C CALCULATES MASS OF PP (DOUBLE PRECISION)
	+C
	+C USED BY : RADKOR
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PP(4)
	+ AAA=PP(4)2-PP(3)2-PP(2)2-PP(1)2
	+C
	+ IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
	+ AMAST=AAA
	+ RETURN
	+ END
	+ double precision FUNCTION AMAS4(PP)
	+C ******************
	+C ----------------------------------------------------------------------
	+C CALCULATES MASS OF PP
	+C
	+C USED BY :
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PP(4)
	+ AAA=PP(4)2-PP(3)2-PP(2)2-PP(1)2
	+ IF(AAA.NE.0.0) AAA=AAA/SQRT(ABS(AAA))
	+ AMAS4=AAA
	+ RETURN
	+ END
	+ double precision FUNCTION ANGXY(X,Y)
	+C ----------------------------------------------------------------------
	+C
	+C USED BY : KORALZ RADKOR
	+C ----------------------------------------------------------------------
	+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	+ DATA PI /3.141592653589793238462643D0/
	+C
	+ IF(ABS(Y).LT.ABS(X)) THEN
	+ THE=ATAN(ABS(Y/X))
	+ IF(X.LE.0D0) THE=PI-THE
	+ ELSE
	+ THE=ACOS(X/SQRT(X2+Y2))
	+ ENDIF
	+ ANGXY=THE
	+ RETURN
	+ END
	+ double precision FUNCTION ANGFI(X,Y)
	+C ----------------------------------------------------------------------
	+* CALCULATES ANGLE IN (0,2*PI) RANGE OUT OF X-Y
	+C
	+C USED BY : KORALZ RADKOR
	+C ----------------------------------------------------------------------
	+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	+ DATA PI /3.141592653589793238462643D0/
	+C
	+ IF(ABS(Y).LT.ABS(X)) THEN
	+ THE=ATAN(ABS(Y/X))
	+ IF(X.LE.0D0) THE=PI-THE
	+ ELSE
	+ THE=ACOS(X/SQRT(X2+Y2))
	+ ENDIF
	+ IF(Y.LT.0D0) THE=2D0*PI-THE
	+ ANGFI=THE
	+ END
	+ SUBROUTINE ROTOD1(PH1,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C
	+C USED BY : KORALZ
	+C ----------------------------------------------------------------------
	+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	+ DIMENSION PVEC(4),QVEC(4),RVEC(4)
	+C
	+ PHI=PH1
	+ CS=COS(PHI)
	+ SN=SIN(PHI)
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ QVEC(1)=RVEC(1)
	+ QVEC(2)= CSRVEC(2)-SNRVEC(3)
	+ QVEC(3)= SNRVEC(2)+CSRVEC(3)
	+ QVEC(4)=RVEC(4)
	+ RETURN
	+ END
	+ SUBROUTINE ROTOD2(PH1,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C
	+C USED BY : KORALZ RADKOR
	+C ----------------------------------------------------------------------
	+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	+ DIMENSION PVEC(4),QVEC(4),RVEC(4)
	+C
	+ PHI=PH1
	+ CS=COS(PHI)
	+ SN=SIN(PHI)
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ QVEC(1)= CSRVEC(1)+SNRVEC(3)
	+ QVEC(2)=RVEC(2)
	+ QVEC(3)=-SNRVEC(1)+CSRVEC(3)
	+ QVEC(4)=RVEC(4)
	+ RETURN
	+ END
	+ SUBROUTINE ROTOD3(PH1,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C
	+C USED BY : KORALZ RADKOR
	+C ----------------------------------------------------------------------
	+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	+C
	+ DIMENSION PVEC(4),QVEC(4),RVEC(4)
	+ PHI=PH1
	+ CS=COS(PHI)
	+ SN=SIN(PHI)
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ QVEC(1)= CSRVEC(1)-SNRVEC(2)
	+ QVEC(2)= SNRVEC(1)+CSRVEC(2)
	+ QVEC(3)=RVEC(3)
	+ QVEC(4)=RVEC(4)
	+ END
	+ SUBROUTINE BOSTR3(EXE,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
	+C
	+C USED BY : TAUOLA KORALZ (?)
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PVEC(4),QVEC(4),RVEC(4)
	+C
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ RPL=RVEC(4)+RVEC(3)
	+ RMI=RVEC(4)-RVEC(3)
	+ QPL=RPL*EXE
	+ QMI=RMI/EXE
	+ QVEC(1)=RVEC(1)
	+ QVEC(2)=RVEC(2)
	+ QVEC(3)=(QPL-QMI)/2
	+ QVEC(4)=(QPL+QMI)/2
	+ END
	+ SUBROUTINE BOSTD3(EXE,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C BOOST ALONG Z AXIS, EXE=EXP(ETA), ETA= HIPERBOLIC VELOCITY.
	+C
	+C USED BY : KORALZ RADKOR
	+C ----------------------------------------------------------------------
	+ IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	+ DIMENSION PVEC(4),QVEC(4),RVEC(4)
	+C
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ RPL=RVEC(4)+RVEC(3)
	+ RMI=RVEC(4)-RVEC(3)
	+ QPL=RPL*EXE
	+ QMI=RMI/EXE
	+ QVEC(1)=RVEC(1)
	+ QVEC(2)=RVEC(2)
	+ QVEC(3)=(QPL-QMI)/2
	+ QVEC(4)=(QPL+QMI)/2
	+ RETURN
	+ END
	+ SUBROUTINE ROTOR1(PH1,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C
	+C called by :
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PVEC(4),QVEC(4),RVEC(4)
	+C
	+ PHI=PH1
	+ CS=COS(PHI)
	+ SN=SIN(PHI)
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ QVEC(1)=RVEC(1)
	+ QVEC(2)= CSRVEC(2)-SNRVEC(3)
	+ QVEC(3)= SNRVEC(2)+CSRVEC(3)
	+ QVEC(4)=RVEC(4)
	+ END
	+ SUBROUTINE ROTOR2(PH1,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C
	+C USED BY : TAUOLA
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision(A-H,O-Z)
	+ double precision PVEC(4),QVEC(4),RVEC(4)
	+C
	+ PHI=PH1
	+ CS=COS(PHI)
	+ SN=SIN(PHI)
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ QVEC(1)= CSRVEC(1)+SNRVEC(3)
	+ QVEC(2)=RVEC(2)
	+ QVEC(3)=-SNRVEC(1)+CSRVEC(3)
	+ QVEC(4)=RVEC(4)
	+ END
	+ SUBROUTINE ROTOR3(PHI,PVEC,QVEC)
	+C ----------------------------------------------------------------------
	+C
	+C USED BY : TAUOLA
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PVEC(4),QVEC(4),RVEC(4)
	+C
	+ CS=COS(PHI)
	+ SN=SIN(PHI)
	+ DO 10 I=1,4
	+ 10 RVEC(I)=PVEC(I)
	+ QVEC(1)= CSRVEC(1)-SNRVEC(2)
	+ QVEC(2)= SNRVEC(1)+CSRVEC(2)
	+ QVEC(3)=RVEC(3)
	+ QVEC(4)=RVEC(4)
	+ END
	+ SUBROUTINE SPHERD(R,X)
	+C ----------------------------------------------------------------------
	+C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
	+C DOUBLE PRECISON VERSION OF SPHERA
	+C ----------------------------------------------------------------------
	+ double precision R,X(4),PI,COSTH,SINTH
	+ double precision RRR(2)
	+ DATA PI /3.141592653589793238462643D0/
	+C
	+ CALL RANMAR(RRR,2)
	+ COSTH=-1+2*RRR(1)
	+ SINTH=SQRT(1 -COSTH**2)
	+ X(1)=RSINTHCOS(2PIRRR(2))
	+ X(2)=RSINTHSIN(2PIRRR(2))
	+ X(3)=R*COSTH
	+ RETURN
	+ END
	+ SUBROUTINE ROTPOX(THET,PHI,PP)
	+ IMPLICIT double precision (A-H,O-Z)
	+C ----------------------------------------------------------------------
	+C double precison version of ROTPOL
	+C ----------------------------------------------------------------------
	+ DIMENSION PP(4)
	+C
	+ CALL ROTOD2(THET,PP,PP)
	+ CALL ROTOD3( PHI,PP,PP)
	+ RETURN
	+ END
	+ SUBROUTINE SPHERA(R,X)
	+C ----------------------------------------------------------------------
	+C GENERATES UNIFORMLY THREE-VECTOR X ON SPHERE OF RADIUS R
	+C
	+C called by : DPHSxx,DADMPI,DADMKK
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision R,X(4)
	+ double precision RRR(2)
	+ DATA PI /3.141592653589793238462643/
	+C
	+ CALL RANMAR(RRR,2)
	+ COSTH=-1.+2.*RRR(1)
	+ SINTH=SQRT(1.-COSTH**2)
	+ X(1)=RSINTHCOS(2PIRRR(2))
	+ X(2)=RSINTHSIN(2PIRRR(2))
	+ X(3)=R*COSTH
	+ RETURN
	+ END
	+ SUBROUTINE ROTPOL(THET,PHI,PP)
	+C ----------------------------------------------------------------------
	+C
	+C called by : DADMAA,DPHSAA
	+C ----------------------------------------------------------------------
	+ IMPLICIT double precision (A-H,O-Z)
	+ double precision PP(4)
	+C
	+ CALL ROTOR2(THET,PP,PP)
	+ CALL ROTOR3( PHI,PP,PP)
	+ RETURN
	+ END
	+ SUBROUTINE RMARIN(IJKLIN,NTOTIN,NTOT2N)
	+ IMPLICIT NONE
	+ INTEGER IJKLIN,NTOTIN,NTOT2N
	+ RETURN
	+ END
	+ SUBROUTINE RMARUT(IJKLIN,NTOTIN,NTOT2N)
	+ IMPLICIT NONE
	+ INTEGER IJKLIN,NTOTIN,NTOT2N
	+ RETURN
	+ END
	+ SUBROUTINE RANMAR(RVEC,LENV)
	+ IMPLICIT NONE
	+ INTEGER LENV
	+ double precision RVEC
	+ DIMENSION RVEC(*)
	+ double precision PYR
	+ INTEGER IVEC
	+ DO 100 IVEC= 1, LENV
	+ RVEC(IVEC) = PYR(0)
	+ 100 CONTINUE
	+ RETURN
	+ END
	+ double precision FUNCTION DILOGT(X)
	+C *****************
	+ IMPLICIT double precision(A-H,O-Z)
	+CERN C304 VERSION 29/07/71 DILOG 59 C
	+ Z=-1.64493406684822
	+ IF(X .LT.-1.0) GO TO 1
	+ IF(X .LE. 0.5) GO TO 2
	+ IF(X .EQ. 1.0) GO TO 3
	+ IF(X .LE. 2.0) GO TO 4
	+ Z=3.2898681336964
	+ 1 T=1.0/X
	+ S=-0.5
	+ Z=Z-0.5* LOG(ABS(X))**2
	+ GO TO 5
	+ 2 T=X
	+ S=0.5
	+ Z=0.
	+ GO TO 5
	+ 3 DILOGT=1.64493406684822
	+ RETURN
	+ 4 T=1.0-X
	+ S=-0.5
	+ Z=1.64493406684822 - LOG(X)* LOG(ABS(T))
	+ 5 Y=2.66666666666666 *T+0.66666666666666
	+ B= 0.00000 00000 00001
	+ A=Y*B +0.00000 00000 00004
	+ B=Y*A-B+0.00000 00000 00011
	+ A=Y*B-A+0.00000 00000 00037
	+ B=Y*A-B+0.00000 00000 00121
	+ A=Y*B-A+0.00000 00000 00398
	+ B=Y*A-B+0.00000 00000 01312
	+ A=Y*B-A+0.00000 00000 04342
	+ B=Y*A-B+0.00000 00000 14437
	+ A=Y*B-A+0.00000 00000 48274
	+ B=Y*A-B+0.00000 00001 62421
	+ A=Y*B-A+0.00000 00005 50291
	+ B=Y*A-B+0.00000 00018 79117
	+ A=Y*B-A+0.00000 00064 74338
	+ B=Y*A-B+0.00000 00225 36705
	+ A=Y*B-A+0.00000 00793 87055
	+ B=Y*A-B+0.00000 02835 75385
	+ A=Y*B-A+0.00000 10299 04264
	+ B=Y*A-B+0.00000 38163 29463
	+ A=Y*B-A+0.00001 44963 00557
	+ B=Y*A-B+0.00005 68178 22718
	+ A=Y*B-A+0.00023 20021 96094
	+ B=Y*A-B+0.00100 16274 96164
	+ A=Y*B-A+0.00468 63619 59447
	+ B=Y*A-B+0.02487 93229 24228
	+ A=Y*B-A+0.16607 30329 27855
	+ A=Y*A-B+1.93506 43008 6996
	+ DILOGT=ST(A-B)+Z
	+ RETURN
	+C=======================================================================
	+C===================END OF CPC PART ====================================
	+C=======================================================================
	+ END
	Index: trunk/contrib/tauola/formf.f
	===================================================================
	--- trunk/contrib/tauola/formf.f (revision 0)
	+++ trunk/contrib/tauola/formf.f (revision 8889)
	@@ -0,0 +1,601 @@
	+ FUNCTION FORMOM(XMAA,XMOM)
	+ IMPLICIT double precision(A-H,O-Z)
	+C ==================================================================
	+C formfactorfor pi-pi0 gamma final state
	+C R. Decker, Z. Phys C36 (1987) 487.
	+C ==================================================================
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ COMMON /TESTA1/ KEYA1
	+ double complex BWIGN,FORMOM
	+ DATA ICONT /1/
	+* THIS INLINE FUNCT. CALCULATES THE SCALAR PART OF THE PROPAGATOR
	+ BWIGN(XM,AM,GAMMA)=1./CMPLX(XM2-AM2,GAMMA*AM)
	+* HADRON CURRENT
	+ FRO =0.266AMRO*2
	+ ELPHA=- 0.1
	+ AMROP = 1.7
	+ GAMROP= 0.26
	+ AMOM =0.782
	+ GAMOM =0.0085
	+ AROMEG= 1.0
	+ GCOUP=12.924
	+ GCOUP=GCOUP*AROMEG
	+ FQED =SQRT(4.0*3.1415926535/137.03604)
	+ FORMOM=FQEDFRO2/SQRT(2.0)GCOUP*2BWIGN(XMOM,AMOM,GAMOM)
	+ $ (BWIGN(XMAA,AMRO,GAMRO)+ELPHABWIGN(XMAA,AMROP,GAMROP))
	+ $ (BWIGN( 0.0D0,AMRO,GAMRO)+ELPHABWIGN( 0.0D0,AMROP,GAMROP))
	+ END
	+ FUNCTION FORM1(MNUM,QQ,S1,SDWA)
	+ IMPLICIT double precision(A-H,O-Z)
	+C ==================================================================
	+C formfactorfor F1 for 3 scalar final state
	+C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	+C H. Georgi, Weak interactions and modern particle theory,
	+C The Benjamin/Cummings Pub. Co., Inc. 1984.
	+C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	+C and erratum !!!!!!
	+C ==================================================================
	+C
	+ double complex FORM1,WIGNER,WIGFOR,FPIKM,BWIGM
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ WIGNER(A,B,C)= CMPLX(1.0,0.0D0)/CMPLX(A-B*2,BC)
	+ IF (MNUM.EQ.0) THEN
	+C ------------ 3 pi hadronic state (a1)
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ELSEIF (MNUM.EQ.1) THEN
	+C ------------ K- pi- K+
	+ FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMKZ)
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FORM1
	+ ELSEIF (MNUM.EQ.2) THEN
	+C ------------ K0 pi- K0B
	+ FORM1=BWIGM(S1,AMKST,GAMKST,AMPI,AMKZ)
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FORM1
	+ ELSEIF (MNUM.EQ.3) THEN
	+C ------------ K- K0 pi0
	+ FORM1=0.0D0
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM1=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FORM1
	+ ELSEIF (MNUM.EQ.4) THEN
	+C ------------ pi0 pi0 K-
	+ XM2=1.402
	+ GAM2=0.174
	+ FORM1=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
	+ FORM1=WIGFOR(QQ,XM2,GAM2)*FORM1
	+ ELSEIF (MNUM.EQ.5) THEN
	+C ------------ K- pi- pi+
	+ XM2=1.402
	+ GAM2=0.174
	+ FORM1=WIGFOR(QQ,XM2,GAM2)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ELSEIF (MNUM.EQ.6) THEN
	+ FORM1=0.0D0
	+ ELSEIF (MNUM.EQ.7) THEN
	+C -------------- eta pi- pi0 final state
	+ FORM1=0.0D0
	+ ENDIF
	+ END
	+ FUNCTION FORM2(MNUM,QQ,S1,SDWA)
	+ IMPLICIT double precision (A-H,O-Z)
	+C ==================================================================
	+C formfactorfor F2 for 3 scalar final state
	+C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	+C H. Georgi, Weak interactions and modern particle theory,
	+C The Benjamin/Cummings Pub. Co., Inc. 1984.
	+C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	+C and erratum !!!!!!
	+C ==================================================================
	+C
	+ double complex FORM2,WIGNER,WIGFOR,FPIKM,BWIGM
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ WIGNER(A,B,C)= CMPLX(1.0,0.0D0)/CMPLX(A-B*2,BC)
	+ IF (MNUM.EQ.0) THEN
	+C ------------ 3 pi hadronic state (a1)
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ELSEIF (MNUM.EQ.1) THEN
	+C ------------ K- pi- K+
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ELSEIF (MNUM.EQ.2) THEN
	+C ------------ K0 pi- K0B
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ELSEIF (MNUM.EQ.3) THEN
	+C ------------ K- K0 pi0
	+ GAMAX=GAMA1GFUN(QQ)/GFUN(AMA1*2)
	+ FORM2=AMA1*2WIGNER(QQ,AMA1,GAMAX)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ELSEIF (MNUM.EQ.4) THEN
	+C ------------ pi0 pi0 K-
	+ XM2=1.402
	+ GAM2=0.174
	+ FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
	+ FORM2=WIGFOR(QQ,XM2,GAM2)*FORM2
	+ ELSEIF (MNUM.EQ.5) THEN
	+C ------------ K- pi- pi+
	+ XM2=1.402
	+ GAM2=0.174
	+ FORM2=BWIGM(S1,AMKST,GAMKST,AMK,AMPIZ)
	+ FORM2=WIGFOR(QQ,XM2,GAM2)*FORM2
	+C
	+ ELSEIF (MNUM.EQ.6) THEN
	+ XM2=1.402
	+ GAM2=0.174
	+ FORM2=WIGFOR(QQ,XM2,GAM2)*FPIKM(SQRT(S1),AMPI,AMPI)
	+C
	+ ELSEIF (MNUM.EQ.7) THEN
	+C -------------- eta pi- pi0 final state
	+ FORM2=0.0D0
	+ ENDIF
	+C
	+ END
	+ double complex FUNCTION BWIGM(S,M,G,XM1,XM2)
	+ IMPLICIT double precision (A-H,O-Z)
	+C **********************************************************
	+C P-WAVE BREIT-WIGNER FOR RHO
	+C **********************************************************
	+ double precision S,M,G,XM1,XM2
	+ double precision PI,QS,QM,W,GS
	+ SAVE PI
	+ DATA INIT /0/
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0) THEN
	+ INIT=1
	+ PI=3.141592654
	+C ------- BREIT-WIGNER -----------------------
	+ ENDIF
	+ IF (S.GT.(XM1+XM2)**2) THEN
	+ QS=SQRT(ABS((S -(XM1+XM2)*2)(S -(XM1-XM2)**2)))/SQRT(S)
	+ QM=SQRT(ABS((M2-(XM1+XM2)2)(M2-(XM1-XM2)*2)))/M
	+ W=SQRT(S)
	+ GS=G(M/W)2(QS/QM)**3
	+ ELSE
	+ GS=0.0D0
	+ ENDIF
	+ BWIGM=M2/CMPLX(M2-S,-SQRT(S)*GS)
	+ RETURN
	+ END
	+ double complex FUNCTION FPIKM(W,XM1,XM2)
	+C **********************************************************
	+C PION FORM FACTOR
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double complex BWIGM
	+ double precision ROM,ROG,ROM1,ROG1,BETA1,PI,PIM,S,W
	+ SAVE PI,PIM,ROM,ROG,ROM1,ROG1,BETA1
	+ EXTERNAL BWIG
	+ DATA INIT /0/
	+C
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0 ) THEN
	+ INIT=1
	+ PI=3.141592654
	+ PIM=.140
	+ ROM=0.773
	+ ROG=0.145
	+ ROM1=1.370
	+ ROG1=0.510
	+ BETA1=-0.145
	+ ENDIF
	+C -----------------------------------------------
	+ S=W**2
	+ FPIKM=(BWIGM(S,ROM,ROG,XM1,XM2)+BETA1*BWIGM(S,ROM1,ROG1,XM1,XM2))
	+ & /(1+BETA1)
	+ RETURN
	+ END
	+ double complex FUNCTION FPIKMD(W,XM1,XM2)
	+C **********************************************************
	+C PION FORM FACTOR
	+C **********************************************************
	+ IMPLICIT double precision (A-H,O-Z)
	+ double complex BWIGM
	+ double precision ROM,ROG,ROM1,ROG1,PI,PIM,S,W
	+ SAVE PI,PIM,ROM,ROG,ROM1,ROG1,ROG2,ROM2,BETA,DELTA
	+ EXTERNAL BWIG
	+ DATA INIT /0/
	+C
	+C ------------ PARAMETERS --------------------
	+ IF (INIT.EQ.0 ) THEN
	+ INIT=1
	+ PI=3.141592654
	+ PIM=.140
	+ ROM=0.773
	+ ROG=0.145
	+ ROM1=1.500
	+ ROG1=0.220
	+ ROM2=1.750
	+ ROG2=0.120
	+ BETA=6.5
	+ DELTA=-26.0
	+ ENDIF
	+C -----------------------------------------------
	+ S=W**2
	+ FPIKMD=(DELTA*BWIGM(S,ROM,ROG,XM1,XM2)
	+ $ +BETA*BWIGM(S,ROM1,ROG1,XM1,XM2)
	+ $ + BWIGM(S,ROM2,ROG2,XM1,XM2))
	+ & /(1+BETA+DELTA)
	+ RETURN
	+ END
	+
	+ FUNCTION FORM3(MNUM,QQ,S1,SDWA)
	+C ==================================================================
	+C formfactorfor F3 for 3 scalar final state
	+C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	+C H. Georgi, Weak interactions and modern particle theory,
	+C The Benjamin/Cummings Pub. Co., Inc. 1984.
	+C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	+C and erratum !!!!!!
	+C ==================================================================
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ double complex FORM3
	+ IF (MNUM.EQ.6) THEN
	+ FORM3=CMPLX(0.0D0)
	+ ELSE
	+ FORM3=CMPLX(0.0D0)
	+ ENDIF
	+ FORM3=0
	+
	+ END
	+ FUNCTION FORM4(MNUM,QQ,S1,S2,S3)
	+C ==================================================================
	+C formfactorfor F4 for 3 scalar final state
	+C R. Decker, in preparation
	+C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	+C and erratum !!!!!!
	+C ==================================================================
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ double complex FORM4,WIGNER,FPIKM
	+ double precision M
	+ WIGNER(A,B,C)=CMPLX(1.0,0.0D0) /CMPLX(A-B*2,BC)
	+ IF (MNUM.EQ.0) THEN
	+C ------------ 3 pi hadronic state (a1)
	+ G1=5.8
	+ G2=6.08
	+ FPIP=0.02
	+ AMPIP=1.3
	+ GAMPIP=0.3
	+ S=QQ
	+ G=GAMPIP
	+ XM1=AMPIZ
	+ XM2=AMRO
	+ M =AMPIP
	+ W=SQRT(S)
	+ IF (S.GT.(XM1+XM2)**2) THEN
	+ QS=SQRT(ABS((S -(XM1+XM2)*2)(S -(XM1-XM2)**2)))/SQRT(S)
	+ QM=SQRT(ABS((M2-(XM1+XM2)2)(M2-(XM1-XM2)*2)))/M
	+ GS=G(M/W)2(QS/QM)**5
	+ ELSE
	+ GS=0.0D0
	+ ENDIF
	+ GAMX=GS*W/M
	+ FORM4=G1G2FPIP/AMRO4/AMPIP2
	+ $ AMPIP2WIGNER(QQ,AMPIP,GAMX)
	+ $ ( S1(S2-S3)*FPIKM(SQRT(S1),AMPIZ,AMPIZ)
	+ $ +S2(S1-S3)FPIKM(SQRT(S2),AMPIZ,AMPIZ) )
	+ ELSEIF (MNUM.EQ.1) THEN
	+C ------------ K- pi- K+
	+ G1=5.8
	+ G2=6.08
	+ FPIP=0.02
	+ AMPIP=1.3
	+ GAMPIP=0.3
	+ S=QQ
	+ G=GAMPIP
	+ XM1=AMPIZ
	+ XM2=AMRO
	+ M =AMPIP
	+ IF (S.GT.(XM1+XM2)**2) THEN
	+ QS=SQRT(ABS((S -(XM1+XM2)*2)(S -(XM1-XM2)**2)))/SQRT(S)
	+ QM=SQRT(ABS((M2-(XM1+XM2)2)(M2-(XM1-XM2)*2)))/M
	+ W=SQRT(S)
	+ GS=G(M/W)2(QS/QM)**5
	+ ELSE
	+ GS=0.0D0
	+ ENDIF
	+ GAMX=GS*W/M
	+ FORM4=G1G2FPIP/AMRO4/AMPIP2
	+ $ AMPIP2WIGNER(QQ,AMPIP,GAMX)
	+ $ ( S1(S2-S3)*FPIKM(SQRT(S1),AMPIZ,AMPIZ)
	+ $ +S2(S1-S3)FPIKM(SQRT(S2),AMPIZ,AMPIZ) )
	+ ELSE
	+ FORM4=CMPLX(0.0D0,0.0D0)
	+ ENDIF
	+C ---- this formfactor is switched off .. .
	+cam FORM4=CMPLX(0.0D0,0.0D0)
	+ END
	+ FUNCTION FORM5(MNUM,QQ,S1,S2)
	+C ==================================================================
	+C formfactorfor F5 for 3 scalar final state
	+C G. Kramer, W. Palmer, S. Pinsky, Phys. Rev. D30 (1984) 89.
	+C G. Kramer, W. Palmer Z. Phys. C25 (1984) 195.
	+C R. Decker, E. Mirkes, R. Sauer, Z. Was Karlsruhe preprint TTP92-25
	+C and erratum !!!!!!
	+C ==================================================================
	+C
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ double complex FORM5,WIGNER,FPIKM,FPIKMD,BWIGM
	+ WIGNER(A,B,C)=CMPLX(1.0,0.0D0)/CMPLX(A-B*2,BC)
	+ IF (MNUM.EQ.0) THEN
	+C ------------ 3 pi hadronic state (a1)
	+ FORM5=0.0D0
	+ ELSEIF (MNUM.EQ.1) THEN
	+C ------------ K- pi- K+
	+ ELPHA=-0.2
	+ FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
	+ $ *( FPIKM(SQRT(S2),AMPI,AMPI)
	+ $ +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
	+ ELSEIF (MNUM.EQ.2) THEN
	+C ------------ K0 pi- K0B
	+ ELPHA=-0.2
	+ FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)/(1+ELPHA)
	+ $ *( FPIKM(SQRT(S2),AMPI,AMPI)
	+ $ +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
	+ ELSEIF (MNUM.EQ.3) THEN
	+C ------------ K- K0 pi0
	+ FORM5=0.0D0
	+ ELSEIF (MNUM.EQ.4) THEN
	+C ------------ pi0 pi0 K-
	+ FORM5=0.0D0
	+ ELSEIF (MNUM.EQ.5) THEN
	+C ------------ K- pi- pi+
	+ ELPHA=-0.2
	+ FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMK)/(1+ELPHA)
	+ $ *( FPIKM(SQRT(S1),AMPI,AMPI)
	+ $ +ELPHA*BWIGM(S2,AMKST,GAMKST,AMPI,AMK))
	+ ELSEIF (MNUM.EQ.6) THEN
	+C ------------ pi- K0B pi0
	+ ELPHA=-0.2
	+ FORM5=BWIGM(QQ,AMKST,GAMKST,AMPI,AMKZ)/(1+ELPHA)
	+ $ *( FPIKM(SQRT(S2),AMPI,AMPI)
	+ $ +ELPHA*BWIGM(S1,AMKST,GAMKST,AMPI,AMK))
	+ ELSEIF (MNUM.EQ.7) THEN
	+C -------------- eta pi- pi0 final state
	+ FORM5=FPIKMD(SQRT(QQ),AMPI,AMPI)*FPIKM(SQRT(S1),AMPI,AMPI)
	+ ENDIF
	+C
	+ END
	+ SUBROUTINE CURR(MNUM,PIM1,PIM2,PIM3,PIM4,HADCUR)
	+C ==================================================================
	+C hadronic current for 4 pi final state
	+C R. Fisher, J. Wess and F. Wagner Z. Phys C3 (1980) 313
	+C R. Decker Z. Phys C36 (1987) 487.
	+C M. Gell-Mann, D. Sharp, W. Wagner Phys. Rev. Lett 8 (1962) 261.
	+C ==================================================================
	+
	+ IMPLICIT double precision (A-H,O-Z)
	+ COMMON / PARMAS / AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+C
	+ double precision AMTAU,AMNUTA,AMEL,AMNUE,AMMU,AMNUMU
	+ * ,AMPIZ,AMPI,AMRO,GAMRO,AMA1,GAMA1
	+ * ,AMK,AMKZ,AMKST,GAMKST
	+ COMMON / DECPAR / GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision GFERMI,GV,GA,CCABIB,SCABIB,GAMEL
	+ double precision PIM1(4),PIM2(4),PIM3(4),PIM4(4),PAA(4)
	+cam double complex HADCUR(4),FORM1,FORM2,FORM3,FPIKM
	+ double complex HADCUR(4),FORM1,FORM2,FORM3,WIGFOR
	+ double complex BWIGN
	+ double precision PA(4),PB(4)
	+ double precision AA(4,4),PP(4,4)
	+ DATA PI /3.141592653589793238462643/
	+ DATA FPI /93.3E-3/
	+ BWIGN(A,XM,XG)=1.0/CMPLX(A-XM*2,XMXG)
	+C
	+C --- masses and constants
	+cam rho-prim taken as in Dolinsky et al (PhysLett B174 (1986) 453)
	+cam (best fit to Argus data)
	+ G1=12.924
	+ G2=1475.98
	+ G =G1*G2
	+cam ELPHA=-.1
	+cam AMROP=1.7
	+cam GAMROP=0.26
	+ ELPHA= .02
	+ AMROP=1.250
	+ GAMROP=0.125
	+ AMOM=.782
	+ GAMOM=0.0085
	+cam ARFLAT=1.0
	+cam AROMEG=1.0
	+ ARFLAT=1.3
	+ AROMEG=2.0
	+C
	+ FRO=0.266AMRO*2
	+ COEF1=2.0SQRT(3.0)/FPI2ARFLAT
	+ COEF2=FROGAROMEG
	+C --- initialization of four vectors
	+ DO 7 K=1,4
	+ DO 8 L=1,4
	+ 8 AA(K,L)=0.0D0
	+ HADCUR(K)=CMPLX(0.0D0)
	+ PAA(K)=PIM1(K)+PIM2(K)+PIM3(K)+PIM4(K)
	+ PP(1,K)=PIM1(K)
	+ PP(2,K)=PIM2(K)
	+ PP(3,K)=PIM3(K)
	+ 7 PP(4,K)=PIM4(K)
	+C
	+ IF (MNUM.EQ.1) THEN
	+C ===================================================================
	+C pi- pi- p0 pi+ case ====
	+C ===================================================================
	+ QQ=PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2
	+C --- loop over thre contribution of the non-omega current
	+ DO 201 K=1,3
	+ SK=(PP(K,4)+PIM4(4))2-(PP(K,3)+PIM4(3))2
	+ $ -(PP(K,2)+PIM4(2))2-(PP(K,1)+PIM4(1))2
	+C -- definition of AA matrix
	+C -- cronecker delta
	+ DO 202 I=1,4
	+ DO 203 J=1,4
	+ 203 AA(I,J)=0.0D0
	+ 202 AA(I,I)=1.0
	+C ... and the rest ...
	+ DO 204 L=1,3
	+ IF (L.NE.K) THEN
	+ DENOM=(PAA(4)-PP(L,4))2-(PAA(3)-PP(L,3))2
	+ $ -(PAA(2)-PP(L,2))2-(PAA(1)-PP(L,1))2
	+ DO 205 I=1,4
	+ DO 205 J=1,4
	+ SIG= 1.0
	+ IF(J.NE.4) SIG=-SIG
	+ AA(I,J)=AA(I,J)
	+ $ -SIG(PAA(I)-2.0PP(L,I))*(PAA(J)-PP(L,J))/DENOM
	+ 205 CONTINUE
	+ ENDIF
	+ 204 CONTINUE
	+C --- lets add something to HADCURR
	+cam FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
	+C FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
	+ FORM1=WIGFOR(SK,AMRO,GAMRO)
	+C
	+ FIX=1.0
	+ IF (K.EQ.3) FIX=-2.0
	+ DO 206 I=1,4
	+ DO 206 J=1,4
	+ HADCUR(I)=
	+ $ HADCUR(I)+CMPLX(FIXCOEF1)FORM1AA(I,J)(PP(K,J)-PP(4,J))
	+ 206 CONTINUE
	+C --- end of the non omega current (3 possibilities)
	+ 201 CONTINUE
	+C
	+C
	+C --- there are two possibilities for omega current
	+C --- PA PB are corresponding first and second pi-s
	+ DO 301 KK=1,2
	+ DO 302 I=1,4
	+ PA(I)=PP(KK,I)
	+ PB(I)=PP(3-KK,I)
	+ 302 CONTINUE
	+C --- lorentz invariants
	+ QQA=0.0D0
	+ SS23=0.0D0
	+ SS24=0.0D0
	+ SS34=0.0D0
	+ QP1P2=0.0D0
	+ QP1P3=0.0D0
	+ QP1P4=0.0D0
	+ P1P2 =0.0D0
	+ P1P3 =0.0D0
	+ P1P4 =0.0D0
	+ DO 303 K=1,4
	+ SIGN=-1.0
	+ IF (K.EQ.4) SIGN= 1.0
	+ QQA=QQA+SIGN(PAA(K)-PA(K))*2
	+ SS23=SS23+SIGN(PB(K) +PIM3(K))*2
	+ SS24=SS24+SIGN(PB(K) +PIM4(K))*2
	+ SS34=SS34+SIGN(PIM3(K)+PIM4(K))*2
	+ QP1P2=QP1P2+SIGN(PAA(K)-PA(K))PB(K)
	+ QP1P3=QP1P3+SIGN(PAA(K)-PA(K))PIM3(K)
	+ QP1P4=QP1P4+SIGN(PAA(K)-PA(K))PIM4(K)
	+ P1P2=P1P2+SIGNPA(K)PB(K)
	+ P1P3=P1P3+SIGNPA(K)PIM3(K)
	+ P1P4=P1P4+SIGNPA(K)PIM4(K)
	+ 303 CONTINUE
	+C
	+ FORM2=COEF2(BWIGN(QQ,AMRO,GAMRO)+ELPHABWIGN(QQ,AMROP,GAMROP))
	+C FORM3=BWIGN(QQA,AMOM,GAMOM)*(BWIGN(SS23,AMRO,GAMRO)+
	+C $ BWIGN(SS24,AMRO,GAMRO)+BWIGN(SS34,AMRO,GAMRO))
	+ FORM3=BWIGN(QQA,AMOM,GAMOM)
	+C
	+ DO 304 K=1,4
	+ HADCUR(K)=HADCUR(K)+FORM2FORM3(
	+ $ PB (K)(QP1P3P1P4-QP1P4*P1P3)
	+ $ +PIM3(K)(QP1P4P1P2-QP1P2*P1P4)
	+ $ +PIM4(K)(QP1P2P1P3-QP1P3*P1P2) )
	+ 304 CONTINUE
	+ 301 CONTINUE
	+C
	+ ELSE
	+C ===================================================================
	+C pi0 pi0 p0 pi- case ====
	+C ===================================================================
	+ QQ=PAA(4)2-PAA(3)2-PAA(2)2-PAA(1)2
	+ DO 101 K=1,3
	+C --- loop over thre contribution of the non-omega current
	+ SK=(PP(K,4)+PIM4(4))2-(PP(K,3)+PIM4(3))2
	+ $ -(PP(K,2)+PIM4(2))2-(PP(K,1)+PIM4(1))2
	+C -- definition of AA matrix
	+C -- cronecker delta
	+ DO 102 I=1,4
	+ DO 103 J=1,4
	+ 103 AA(I,J)=0.0D0
	+ 102 AA(I,I)=1.0
	+C
	+C ... and the rest ...
	+ DO 104 L=1,3
	+ IF (L.NE.K) THEN
	+ DENOM=(PAA(4)-PP(L,4))2-(PAA(3)-PP(L,3))2
	+ $ -(PAA(2)-PP(L,2))2-(PAA(1)-PP(L,1))2
	+ DO 105 I=1,4
	+ DO 105 J=1,4
	+ SIG=1.0
	+ IF(J.NE.4) SIG=-SIG
	+ AA(I,J)=AA(I,J)
	+ $ -SIG(PAA(I)-2.0PP(L,I))*(PAA(J)-PP(L,J))/DENOM
	+ 105 CONTINUE
	+ ENDIF
	+ 104 CONTINUE
	+C --- lets add something to HADCURR
	+cam FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKM(SQRT(QQ),AMPI,AMPI)
	+C FORM1= FPIKM(SQRT(SK),AMPI,AMPI) *FPIKMD(SQRT(QQ),AMPI,AMPI)
	+ FORM1=WIGFOR(SK,AMRO,GAMRO)
	+ DO 106 I=1,4
	+ DO 106 J=1,4
	+ HADCUR(I)=
	+ $ HADCUR(I)+CMPLX(COEF1)FORM1AA(I,J)*(PP(K,J)-PP(4,J))
	+ 106 CONTINUE
	+C --- end of the non omega current (3 possibilities)
	+ 101 CONTINUE
	+ ENDIF
	+ END
	+ FUNCTION WIGFOR(S,XM,XGAM)
	+ IMPLICIT double precision (A-H,O-Z)
	+ double complex WIGFOR,WIGNOR
	+ WIGNOR=CMPLX(-XM*2,XMXGAM)
	+ WIGFOR=WIGNOR/CMPLX(S-XM*2,XMXGAM)
	+ END
	Index: trunk/contrib/tauola/tauola_dummy.f90
	===================================================================
	--- trunk/contrib/tauola/tauola_dummy.f90 (revision 0)
	+++ trunk/contrib/tauola/tauola_dummy.f90 (revision 8889)
	@@ -0,0 +1,92 @@
	+subroutine dekay (kto, hx)
	+ integer, intent(in) :: kto
	+ double precision, dimension(4), intent(in) :: hx
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine dekay
	+
	+subroutine dexay (kto, pol)
	+ integer, intent(in) :: kto
	+ double precision, dimension(4), intent(in) :: pol
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine dexay
	+
	+subroutine initdk (mode, keypol)
	+ integer, intent(in) :: mode, keypol
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine initdk
	+
	+subroutine inimas (mode, keypol)
	+ integer, intent(in) :: mode, keypol
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine inimas
	+
	+subroutine iniphx (xk00)
	+ double precision, intent(in) :: xk00
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine iniphx
	+
	+subroutine inietc (jakk1, jakk2, itd, ifpho)
	+ integer, intent(in) :: jakk1, jakk2, itd, ifpho
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine inietc
	+
	+subroutine phoini ()
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine phoini
	+
	+function wthiggs (ifpseudo, hh1, hh2)
	+ double precision, dimension(4), intent(in) :: hh1, hh2
	+ logical, intent(in) :: ifpseudo
	+ double precision :: wthiggs
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end function wthiggs
	+
	+subroutine taupi0 (mode, jak, ion)
	+ integer, intent(in) :: mode, jak
	+ integer, dimension(3), intent(in) :: ion
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine taupi0
	+
	+subroutine photos (id)
	+ integer, intent(in) :: id
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine photos
	+
	+subroutine ranmar (rvec, lenv)
	+ double precision, dimension(lenv) :: rvec
	+ integer, intent(in) :: lenv
	+ write (0, "(A)") "**************************************************************"
	+ write (0, "(A)") "* Error: TAUOLA has not been enabled, WHIZARD terminates *"
	+ write (0, "(A)") "**************************************************************"
	+ stop
	+end subroutine ranmar
	Index: trunk/contrib/stdhep/stdxwcm1.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwcm1.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwcm1.f (revision 8889)
	@@ -0,0 +1,46 @@
	+ subroutine stdxwcm1(ilbl,istream,lok)
	+
	+C...Purpose: to write begin/end run information in a standard format
	+C
	+C if ilbl = 100 write STDHEP begin run record
	+C if ilbl = 200 write STDHEP end run record
	+C
	+C lok = 0 if no problems were encountered
	+
	+ include "stdcm1.inc"
	+ include "stdcnt.inc"
	+ include "stdlun.inc"
	+ include "mcfio.inc"
	+
	+ integer ilbl,lok
	+ integer xdr_stdhep_cm1
	+ external xdr_stdhep_cm1
	+
	+ lok=0
	+ if(nevtlh.eq.0) nevtlh = nlhwrt
	+ if(ilbl.eq.100)then
	+ if(mcfio_block(istream, MCFIO_STDHEPBEG, xdr_stdhep_cm1)
	+ 1 .eq. -1) go to 800
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ elseif(ilbl.eq.200)then
	+ if(mcfio_block(istream, MCFIO_STDHEPEND, xdr_stdhep_cm1)
	+ 1 .eq. -1) go to 800
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ else
	+ lok = 3
	+ write (lnhout,701) ilbl
	+ endif
	+
	+ return
	+ 800 write (lnhout,801) ilbl
	+ lok=2
	+ stop
	+ 900 write (lnhout,901)
	+ lok=1
	+ stop
	+ 701 format(/5X,'STDXWCM1: called with improper label ',i4)
	+ 801 format(/5X,'STDXWCM1: error filling stdhep cm1 block for label '
	+ 1 ,i4)
	+ 901 format(/5X,'STDXWCM1: error writing stdhep cm1 block ')
	+ end
	+
	Index: trunk/contrib/stdhep/stdhep.inc
	===================================================================
	--- trunk/contrib/stdhep/stdhep.inc (revision 0)
	+++ trunk/contrib/stdhep/stdhep.inc (revision 8889)
	@@ -0,0 +1,46 @@
	+C -------------------------------------------------------------
	+C
	+ integer NMXHEP
	+ parameter (NMXHEP=4000)
	+ common/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	+ &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	+ integer NEVHEP,NHEP,ISTHEP,IDHEP,JMOHEP,JDAHEP
	+ double precision PHEP,VHEP
	+ save /HEPEVT/
	+C... NEVHEP - event number
	+C... NHEP - number of entries in this event
	+C... ISTHEP(..) - status code
	+C... IDHEP(..) - particle ID, P.D.G. standard
	+C... JMOHEP(1,..) - position of mother particle in list
	+C... JMOHEP(2,..) - position of second mother particle in list
	+C... JDAHEP(1,..) - position of first daughter in list
	+C... JDAHEP(2,..) - position of last daughter in list
	+C... PHEP(1,..) - x momentum in GeV/c
	+C... PHEP(2,..) - y momentum in GeV/c
	+C... PHEP(3,..) - z momentum in GeV/c
	+C... PHEP(4,..) - energy in GeV
	+C... PHEP(5,..) - mass in GeV/c**2
	+C... VHEP(1,..) - x vertex position in mm
	+C... VHEP(2,..) - y vertex position in mm
	+C... VHEP(3,..) - z vertex position in mm
	+C... VHEP(4,..) - production time in mm/c
	+C
	+C -------------------------------------------------------------
	+C
	+ common/hepev2/nmulti,jmulti(NMXHEP)
	+ integer nmulti,jmulti
	+ save /hepev2/
	+C... nmulti - number of interactions in the list
	+C... jmulti(..) - multiple interaction number
	+C
	+C -------------------------------------------------------------
	+ integer NMXMLT
	+ parameter (NMXMLT=16)
	+ common/hepev3/nevmulti(NMXMLT),itrkmulti(NMXMLT),mltstr(NMXMLT)
	+ integer nevmulti,itrkmulti,mltstr
	+ save /hepev3/
	+C... nevmulti(i) - event number of original interaction
	+C... itrkmulti(i) - first particle in the original interaction
	+C... mltstr(i) - stream this event is from
	+C
	+C -------------------------------------------------------------
	Index: trunk/contrib/stdhep/stdlun.h
	===================================================================
	--- trunk/contrib/stdhep/stdlun.h (revision 0)
	+++ trunk/contrib/stdhep/stdlun.h (revision 8889)
	@@ -0,0 +1,16 @@
	+/* StdHep I/O unit and stream information */
	+
	+#define LUN_ARRAY 16 /* I/O array size */
	+extern struct heplun {
	+ int lnhwrt; /* event output unit number */
	+ int lnhrd; /* event input unit number */
	+ int lnhout; /* line printer output unit number */
	+ int lnhdcy; /* decay file unit number */
	+ int lnhpdf; /* PDF file unit number */
	+ int lnhdmp; /* ascii dump file unit number */
	+ int lnhrdm[LUN_ARRAY]; /* unit number array for multiple I/O files */
	+} heplun_;
	+
	+extern struct stdstr {
	+ int ixdrstr[LUN_ARRAY]; /* array of xdr stream addresses */
	+} stdstr_;
	Index: trunk/contrib/stdhep/stdxwevtlh.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwevtlh.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwevtlh.f (revision 8889)
	@@ -0,0 +1,50 @@
	+ subroutine stdxwevtlh(ilbl,istream,lok)
	+
	+C...Purpose: to write an event from the standard common block.
	+C
	+C ilbl = 4 write HEPEVT and HEPEV4 common blocks
	+C ilbl = 5 write HEPEVT, HEPEV2, HEPEV3, and HEPEV4 common blocks
	+C lok = 0 if no problems were encountered
	+
	+ include "stdhep.inc"
	+ include "stdcnt.inc"
	+ include "stdlun.inc"
	+ include "mcfio.inc"
	+
	+ integer ilbl,lok,istream
	+ integer xdr_stdhep_4, xdr_stdhep_4_multi
	+ external xdr_stdhep_4, xdr_stdhep_4_multi
	+
	+ lok=0
	+ if(NHEP.LE.0)then
	+ write(lnhout,101) NEVHEP
	+ elseif(ilbl.eq.4)then
	+ call stdtcopy(1,istream,lok)
	+ if(lok.ne.0) go to 700
	+ if(mcfio_block(istream, MCFIO_STDHEP4, xdr_stdhep_4)
	+ 1 .eq. -1) go to 800
	+ call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ nstdwrt = nstdwrt + 1
	+ elseif(ilbl.eq.5)then
	+ if(mcfio_block(istream, MCFIO_STDHEP4M, xdr_stdhep_4_multi)
	+ 1 .eq. -1) go to 800
	+ call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ nstdwrt = nstdwrt + 1
	+ endif
	+ return
	+ 700 write (lnhout,701) NEVHEP
	+ lok = 4
	+ stop
	+ 800 write (lnhout,801) NEVHEP
	+ lok=2
	+ stop
	+ 900 write (lnhout,901) NEVHEP
	+ lok=1
	+ stop
	+ 101 format(/5X,'STDXWEVTLH: no particles to write in event',I8)
	+ 701 format(/5X,'STDXWEVTLH: error copying stdhep block for event ',I8)
	+ 801 format(/5X,'STDXWEVTLH: error filling stdhep block for event ',I8)
	+ 901 format(/5X,'STDXWEVTLH: error writing event ',I8)
	+ end
	Index: trunk/contrib/stdhep/stdtmp.h
	===================================================================
	--- trunk/contrib/stdhep/stdtmp.h (revision 0)
	+++ trunk/contrib/stdhep/stdtmp.h (revision 8889)
	@@ -0,0 +1,27 @@
	+/*
	+** Basic COMMON block from STDHEP: the temporary COMMON block
	+** This is a copy of the HEPEVT COMMON block
	+*/
	+/* note that to avoid alignment problems, structures and common blocks
	+ should be in the order: double precision, real, integer.
	+*/
	+extern struct stdtmp {
	+double phept[NMXHEP][5]; /* 4-Momentum, mass */
	+double vhept[NMXHEP][4]; /* Vertex information */
	+int nevhept; /* The event number */
	+int nhept; /* The number of entries in this event */
	+int isthept[NMXHEP]; /* The Particle id */
	+int idhept[NMXHEP]; /* The particle id */
	+int jmohept[NMXHEP][2]; /* The position of the mother particle */
	+int jdahept[NMXHEP][2]; /* Position of the first daughter... */
	+} stdtmp_;
	+
	+extern struct tmpev4 {
	+ double eventweightt; /* event weight */
	+ double alphaqedt; /* QED coupling alpha_em */
	+ double alphaqcdt; /* QCD coupling alpha_s */
	+ double scalet[10]; /* Scale Q of the event */
	+ double spint[NMXHEP][3]; /* spin information */
	+ int icolorflowt[NMXHEP][2]; /* (Anti-)Colour flow */
	+ int idrupt; /* ID, as given by LPRUP codes */
	+} tmpev4_;
	Index: trunk/contrib/stdhep/stdcm1.inc
	===================================================================
	--- trunk/contrib/stdhep/stdcm1.inc (revision 0)
	+++ trunk/contrib/stdhep/stdcm1.inc (revision 8889)
	@@ -0,0 +1,25 @@
	+c -------------------------------------------------------------
	+c
	+c stdecom - center-of-mass energy
	+c stdxsec - cross-section
	+c stdseed1 - random number seed
	+c stdseed2 - random number seed
	+c nevtreq - number of events to be generated
	+c nevtgen - number of events actually generated
	+c nevtwrt - number of events written to output file
	+c nevtlh - number of Les Houches events written to output file
	+c
	+c generatorname - name of Monte Carlo generator
	+c pdfname - name of PDF method used
	+c
	+ real stdecom,stdxsec
	+ double precision stdseed1,stdseed2
	+ integer nevtreq,nevtgen,nevtwrt,nevtlh
	+ character*20 generatorname, pdfname
	+ common /stdcm1/ stdecom,stdxsec,stdseed1,stdseed2,
	+ 1 nevtreq,nevtgen,nevtwrt,nevtlh
	+ common /stdcm2/ generatorname, pdfname
	+ save /stdcm1/
	+ save /stdcm2/
	+c
	+c -------------------------------------------------------------
	Index: trunk/contrib/stdhep/hepev4.inc
	===================================================================
	--- trunk/contrib/stdhep/hepev4.inc (revision 0)
	+++ trunk/contrib/stdhep/hepev4.inc (revision 8889)
	@@ -0,0 +1,53 @@
	+c -------------------------------------------------------------
	+c hepev4 holds generator level information
	+c
	+ double precision eventweightlh, scalelh
	+ double precision alphaqedlh, alphaqcdlh, spinlh
	+ integer icolorflowlh, idruplh
	+c
	+ common/hepev4/eventweightlh, alphaqedlh, alphaqcdlh, scalelh(10),
	+ 1 spinlh(3,NMXHEP), icolorflowlh(2,NMXHEP), idruplh
	+ save /hepev4/
	+
	+C idruplh : The identity of the current process,
	+C as given by the LPRUP codes.
	+C eventweightlh : The event weight:
	+C Equal to (total cross section)/(total generated)
	+C for the output of Pythia, Herwig, etc.
	+C alphaqedlh : QED coupling alpha_em.
	+C alphaqcdlh : QCD coupling alpha_s.
	+C scalelh(10) : Squared Scale Q of the event.
	+C......Defined for standard 2->1->2 or 2->2 process
	+C.......kinematics are p1 + p2 -> q1 + q2
	+C scalehl(1)= Q2 hard scale (used in PDF and couplings)
	+C scalehl(2)= Q2 scale of parton shower
	+C scalehl(3)= s-hat, invariant (p1+p2)**2
	+C scalehl(4)= t-hat, invariant (p1-q1)**2
	+C scalehl(5)= u-hat, invariant (p1-q2)**2
	+C scalehl(6)= squared transverse momentum of q1 (i.e., pt-hat**2)
	+C.......Additionally, for 2->3 processes, p1 + p2 -> q1 + q2 + q3
	+C scalehl(7)= squared transverse momentum of q2
	+C scalehl(8)= user defined, 0 by default
	+C scalehl(9)= user defined, 0 by default
	+C scalehl(10)= user defined, 0 by default
	+C spinlh(3,..) : spin information
	+C icolorflowlh(2,..) : (Anti-)Colour flow.
	+C
	+c -------------------------------------------------------------
	+
	+ double precision eventweightmulti, scalemulti
	+ double precision alphaqedmulti, alphaqcdmulti
	+ integer idrupmulti
	+
	+ common/hepev5/eventweightmulti(NMXMLT),alphaqedmulti(NMXMLT),
	+ 1 alphaqcdmulti(NMXMLT),scalemulti(10,NMXMLT),
	+ 2 idrupmulti(NMXMLT)
	+ save /hepev5/
	+
	+C idrupmulti(i) : identity of the original interaction
	+C eventweightmulti(i) : event weight of the original interaction
	+C alphaqedmulti : QED coupling alpha_em of the original interaction
	+C alphaqcdmulti : QCD coupling alpha_s of the original interaction
	+C scalemulti(10,i) : Scales of the original interaction
	+C
	+C -------------------------------------------------------------
	Index: trunk/contrib/stdhep/mcf_hepup_xdr.c
	===================================================================
	--- trunk/contrib/stdhep/mcf_hepup_xdr.c (revision 0)
	+++ trunk/contrib/stdhep/mcf_hepup_xdr.c (revision 8889)
	@@ -0,0 +1,194 @@
	+/*******************************************************************************
	+* *
	+* mcf_hepup_xdr.c -- XDR Utility routines for the Block Stdhep filters *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun, Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include <stdlib.h>
	+#include <time.h>
	+#include "mcfio_Dict.h"
	+#include "mcf_xdr.h"
	+#include "hepeup.h"
	+#include "heprup.h"
	+#include "stdver.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+bool_t xdr_hepeup_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the HEPEUP COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version. */
	+
	+ unsigned int nn, nn2, nn5;
	+ int *idat;
	+ double *dat;
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (*blockid != MCFIO_HEPEUP) {
	+ fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+
	+ nn = (unsigned int) hepeup_.nup; /* Number of elements in idup, istup, vtimup, spinup */
	+ nn2 = 2(unsigned int) hepeup_.nup; / Number of elements in mothup, icolup */
	+ nn5 = 5(unsigned int) hepeup_.nup; / Number of elements in pup */
	+
	+ /* Total length in bytes include blockid, ntot, version, as well
	+ as the common block entries */
	+ ntot = sizeof(int)(5 + 2nn + 2nn2) + sizeof(double)(4 + 2nn + nn5);
	+
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	+ xdr_int(xdrs, &(hepeup_.nup)) &&
	+ xdr_int(xdrs, &(hepeup_.idprup))) == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_HEPEUP) ) {
	+ fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+
	+ if ( xdr_double(xdrs, &(hepeup_.xwgtup) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(hepeup_.scalup) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(hepeup_.aqedup) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(hepeup_.aqcdup) ) == FALSE) return FALSE;
	+ idat = hepeup_.idup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nn, MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepeup_.istup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nn, MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) hepeup_.mothup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nn2, 2*MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) hepeup_.icolup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nn2, 2*MAXNUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) hepeup_.pup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nn5, 5*MAXNUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepeup_.vtimup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nn, MAXNUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepeup_.spinup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nn, MAXNUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ return TRUE;
	+}
	+
	+bool_t xdr_heprup_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the HEPRUP COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version. */
	+
	+ unsigned int nn, n2;
	+ int i;
	+ int *idat;
	+ char *vers;
	+ double *dat;
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (*blockid != MCFIO_HEPRUP) {
	+ fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+
	+ nn = (unsigned int) heprup_.nprup; /* Number of elements in xsecup, xerrup, xmaxup, lprup */
	+ n2 = (unsigned int) 2; /* Number of elements in idbmup, ebmup, pdfgup, pdfsup */
	+
	+ /* Total length in bytes include blockid, ntot, version, as well
	+ as the common block entries */
	+ ntot = sizeof(int)(5 + 3n2 + nn) + sizeof(double)(n2 + 3*nn);
	+
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	+ xdr_int(xdrs, &(heprup_.idwtup)) &&
	+ xdr_int(xdrs, &(heprup_.nprup))) == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_HEPRUP) ) {
	+ fprintf (stderr, "mcf_hepup_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ idat = heprup_.idbmup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &n2, 2, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) heprup_.ebmup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &n2, 2, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ idat = heprup_.pdfgup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &n2, 2, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = heprup_.pdfsup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &n2, 2, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) heprup_.xsecup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nn, MAXPUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) heprup_.xerrup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nn, MAXPUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) heprup_.xmaxup;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nn, MAXPUP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ idat = heprup_.lprup;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nn, MAXPUP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+
	+ return TRUE;
	+}
	+
	+
	Index: trunk/contrib/stdhep/mcf_Stdhep_xdr.c
	===================================================================
	--- trunk/contrib/stdhep/mcf_Stdhep_xdr.c (revision 0)
	+++ trunk/contrib/stdhep/mcf_Stdhep_xdr.c (revision 8889)
	@@ -0,0 +1,232 @@
	+/*******************************************************************************
	+* *
	+* mcf_Stdhep_xdr.c -- XDR Utility routines for the Block Stdhep filters *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun, Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include <stdlib.h>
	+#include <time.h>
	+#include "mcfio_Dict.h"
	+#include "mcf_xdr.h"
	+#include "stdhep.h"
	+#include "stdtmp.h"
	+#include "stdver.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+bool_t xdr_stdhep_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the HEPEVT temporary COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version. */
	+
	+ unsigned int nn, nn2, nn4, nn5, nnw, nnw2, nnw4, nnw5;
	+ int *idat;
	+ double *dat;
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (*blockid != MCFIO_STDHEP) {
	+ fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+
	+ nn = (unsigned int) stdtmp_.nhept; /* Number of elements in isthep or idhep */
	+ nn2 = 2(unsigned int) stdtmp_.nhept; / Number of elements in jmohep or jdahep */
	+ nn4 = 4(unsigned int) stdtmp_.nhept; / Number of elements in vhep */
	+ nn5 = 5(unsigned int) stdtmp_.nhept; / Number of elements in phep */
	+ nnw = (unsigned int) stdtmp_.nhept;
	+ nnw2 = 2 * nnw;
	+ nnw4 = 4 * nnw;
	+ nnw5 = 5 * nnw;
	+
	+ /* Total length in bytes include blockid, ntot, version, nevhept and nhept as well
	+ as the arrays remembering doubles are longer than ints. */
	+ ntot = 5sizeof(int) + sizeof(int)(2nn + 2nn2) + sizeof(double)(nn4 + nn5);
	+
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	+ xdr_int(xdrs, &(stdtmp_.nevhept)) &&
	+ xdr_int(xdrs, &(stdtmp_.nhept))) == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEP) ) {
	+ fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ idat = stdtmp_.isthept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = stdtmp_.idhept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) stdtmp_.jmohept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) stdtmp_.jdahept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) stdtmp_.phept;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw5, 5*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) stdtmp_.vhept;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ return TRUE;
	+}
	+
	+bool_t xdr_stdhep_multi_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the HEPEVT COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version.
	+ Also translate the HEPEV2 COMMON block from the STDHEP package to/from
	+ an XDR stream. HEPEV2 contains multiple interaction information */
	+
	+ unsigned int nn, nn2, nn4, nn5, nnw, nnw2, nnw4, nnw5, nmlt, nnmlt;
	+ int i;
	+ int *idat;
	+ char *vers;
	+ double *dat;
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (*blockid != MCFIO_STDHEPM) {
	+ fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ nn = sizeof(int) * hepevt_.nhep;
	+ nn2 = 2 * sizeof(int) * hepevt_.nhep;
	+ nn4 = 4 * sizeof(double) * hepevt_.nhep;
	+ nn5 = 5 * sizeof(double) * hepevt_.nhep;
	+ nmlt = sizeof(int) * hepev2_.nmulti;
	+ nnw = (unsigned int) hepevt_.nhep;
	+ nnw2 = 2 * nnw;
	+ nnw4 = 4 * nnw;
	+ nnw5 = 5 * nnw;
	+ nnmlt = (unsigned int) hepev2_.nmulti;
	+ ntot = 6 sizeof(int) + 3 * nn + 2 * nn2 + nn4 + nn5 + 3 * nmlt;
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	+ xdr_int(xdrs, &(hepevt_.nevhep)) &&
	+ xdr_int(xdrs, &(hepevt_.nhep))) == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEPM) ) {
	+ fprintf (stderr, "mcf_Stdhep_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ idat = hepevt_.isthep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepevt_.idhep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) hepevt_.jmohep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) hepevt_.jdahep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) hepevt_.phep;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw5, 5*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepevt_.vhep;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ /*
	+ ** V2.02 Upgrade : adding Multiple interactions.
	+ */
	+ vers = *version;
	+ if ((strcmp(vers,"1.05") == 0) && (xdrs->x_op == XDR_DECODE)) {
	+ hepev2_.nmulti = -1;
	+ return TRUE;
	+ }
	+ if ( xdr_int(xdrs, &(hepev2_.nmulti)) == FALSE) return FALSE;
	+ idat = hepev2_.jmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ /*
	+ ** V4.04 Upgrade : adding more Multiple interaction information
	+ */
	+ if (((strcmp(vers,"2.") > 0) \|\| (strcmp(vers,"3.") > 0))
	+ && (xdrs->x_op == XDR_DECODE)) {
	+ for (i = 0; i < NMXMLT; i++) {
	+ hepev3_.nevmulti[i] = 0;
	+ hepev3_.itrkmulti[i] = 0;
	+ hepev3_.mltstr[i] = 0;
	+ }
	+ return TRUE;
	+ }
	+ if (((strcmp(vers,"4.00") == 0) \|\| (strcmp(vers,"4.01") == 0) \|\|
	+ (strcmp(vers,"4.02") == 0) \|\| (strcmp(vers,"4.03") == 0) )
	+ && (xdrs->x_op == XDR_DECODE)) {
	+ for (i = 0; i < NMXMLT; i++) {
	+ hepev3_.nevmulti[i] = 0;
	+ hepev3_.itrkmulti[i] = 0;
	+ hepev3_.mltstr[i] = 0;
	+ }
	+ return TRUE;
	+ }
	+ idat = hepev3_.nevmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepev3_.itrkmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepev3_.mltstr;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ return TRUE;
	+}
	+
	+
	Index: trunk/contrib/stdhep/hepeup.h
	===================================================================
	--- trunk/contrib/stdhep/hepeup.h (revision 0)
	+++ trunk/contrib/stdhep/hepeup.h (revision 8889)
	@@ -0,0 +1,21 @@
	+/*
	+C...User process event common block.
	+*/
	+
	+#define MAXNUP 500
	+extern struct hepeup {
	+ int nup; /* number of particles */
	+ int idprup;
	+ double xwgtup;
	+ double scalup;
	+ double aqedup;
	+ double aqcdup;
	+ int idup[MAXNUP];
	+ int istup[MAXNUP];
	+ int mothup[MAXNUP][2];
	+ int icolup[MAXNUP][2];
	+ double pup[MAXNUP][5];
	+ double vtimup[MAXNUP];
	+ double spinup[MAXNUP];
	+} hepeup_;
	+
	Index: trunk/contrib/stdhep/stdzero.f
	===================================================================
	--- trunk/contrib/stdhep/stdzero.f (revision 0)
	+++ trunk/contrib/stdhep/stdzero.f (revision 8889)
	@@ -0,0 +1,50 @@
	+
	+ subroutine STDZERO
	+
	+C...Purpose: to zero the standard common block.
	+C
	+ include "stdhep.inc"
	+ include "hepev4.inc"
	+
	+ integer J,K
	+
	+C...set everything to zero
	+ NHEP = 0
	+ nmulti = 0
	+ do 120 J=1,NMXHEP
	+ ISTHEP(J)=0
	+ IDHEP(J)=0
	+ jmulti(J)=0
	+ do 100 K=1,2
	+ JMOHEP(K,J)=0
	+ JDAHEP(K,J)=0
	+ 100 icolorflowlh(K,J)=0
	+ do 105 K=1,5
	+ 105 PHEP(K,J)=0.
	+ do 110 K=1,4
	+ 110 VHEP(K,J)=0.
	+ do K=1,3
	+ spinlh(K,J) = 0.
	+ enddo
	+ 120 CONTINUE
	+ do j=1,NMXMLT
	+ nevmulti(j)=0
	+ itrkmulti(j)=0
	+ mltstr(j)=0
	+ eventweightmulti(j)=0.
	+ alphaqedmulti(j)=0.
	+ alphaqcdmulti(j)=0.
	+ do k=1,5
	+ scalemulti(k,j)=0.
	+ enddo
	+ idrupmulti(j)=0
	+ enddo
	+ eventweightlh = 0.
	+ alphaqedlh = 0.
	+ alphaqcdlh = 0.
	+ do j=1,5
	+ scalelh(j) = 0.
	+ enddo
	+ idruplh = 0
	+ return
	+ end
	Index: trunk/contrib/stdhep/stdver.inc
	===================================================================
	--- trunk/contrib/stdhep/stdver.inc (revision 0)
	+++ trunk/contrib/stdhep/stdver.inc (revision 8889)
	@@ -0,0 +1,10 @@
	+C -------------------------------------------------------------
	+C
	+ common/stdver/stdhep_ver,stdhep_date
	+ character*10 stdhep_ver
	+ character*20 stdhep_date
	+ save /stdver/
	+C... stdhep_ver - stdhep version number
	+C... stdhep_date - date of this stdhep version
	+C
	+C -------------------------------------------------------------
	Index: trunk/contrib/stdhep/stdlun.inc
	===================================================================
	--- trunk/contrib/stdhep/stdlun.inc (revision 0)
	+++ trunk/contrib/stdhep/stdlun.inc (revision 8889)
	@@ -0,0 +1,10 @@
	+C -------------------------------------------------------------
	+C
	+ integer lnhwrt,lnhrd,lnhout,lnhdcy,lnhpdf,lnhdmp,lnhrdm,ixdrstr
	+ character*80 qqufile ! use this to set the QQ user decay file
	+ common/heplun/lnhwrt,lnhrd,lnhout,lnhdcy,lnhpdf,lnhdmp,lnhrdm(16)
	+ common/stdstr/ixdrstr(16)
	+ common/stdfnm/qqufile
	+ save /heplun/,/stdstr/
	+C
	+C -------------------------------------------------------------
	Index: trunk/contrib/stdhep/stdtmp.inc
	===================================================================
	--- trunk/contrib/stdhep/stdtmp.inc (revision 0)
	+++ trunk/contrib/stdhep/stdtmp.inc (revision 8889)
	@@ -0,0 +1,54 @@
	+C -------------------------------------------------------------
	+C
	+C This is the temporary common block used to get events to and
	+C from xdr. It enables reading multiple stdhep input streams.
	+C
	+ common/stdtmp/ phept(5,NMXHEP),vhept(4,NMXHEP),
	+ 1 nevhept,nhept,isthept(NMXHEP),idhept(NMXHEP),
	+ & jmohept(2,NMXHEP),jdahept(2,NMXHEP)
	+ integer nevhept,nhept,isthept,idhept,jmohept,jdahept
	+ double precision phept,vhept
	+ save /stdtmp/
	+C... nevhept - event number
	+C... nhept - number of entries in this event
	+C... isthept(..) - status code
	+C... idhept(..) - particle ID, P.D.G. standard
	+C... jmohept(1,..) - position of mother particle in list
	+C... jmohept(2,..) - position of second mother particle in list
	+C... jdahept(1,..) - position of first daughter in list
	+C... jdahept(2,..) - position of last daughter in list
	+C... phept(1,..) - x momentum in GeV/c
	+C... phept(2,..) - y momentum in GeV/c
	+C... phept(3,..) - z momentum in GeV/c
	+C... phept(4,..) - energy in GeV
	+C... phept(5,..) - mass in GeV/c**2
	+C... vhept(1,..) - x vertex position in mm
	+C... vhept(2,..) - y vertex position in mm
	+C... vhept(3,..) - z vertex position in mm
	+C... vhept(4,..) - production time in mm/c
	+C
	+C -------------------------------------------------------------
	+c -------------------------------------------------------------
	+c hepev4 holds Les Houches information
	+c
	+ double precision eventweightt, scalet
	+ double precision alphaqedt, alphaqcdt, spint
	+ integer icolorflowt, idrupt
	+c
	+ common/tmpev4/eventweightt, alphaqedt, alphaqcdt, scalet(10),
	+ 1 spint(3,NMXHEP), icolorflowt(2,NMXHEP), idrupt
	+ save /tmpev4/
	+
	+C idrupt : The identity of the current process,
	+C as given by the LPRUP codes.
	+C eventweightt : The event weight:
	+C Equal to (total cross section)/(total generated)
	+C for the output of Pythia, Herwig, etc.
	+C scalet : Scale Q of the event.
	+C (fact. scale for PDF and energy scale for ISR and FSR)
	+C alphaqedt : QED coupling alpha_em.
	+C alphaqcdt : QCD coupling alpha_s.
	+C spint(3,..) : spin information
	+C icolorflowt(2,..) : (Anti-)Colour flow.
	+C
	+c -------------------------------------------------------------
	Index: trunk/contrib/stdhep/stdcnt.h
	===================================================================
	--- trunk/contrib/stdhep/stdcnt.h (revision 0)
	+++ trunk/contrib/stdhep/stdcnt.h (revision 8889)
	@@ -0,0 +1,9 @@
	+/*
	+ StdHep counting common block
	+*/
	+extern struct stdcnt {
	+ int nstdwrt; /* number of events written */
	+ int nstdrd; /* number of events read */
	+ int nlhwrt; /* number of Les Houches events written */
	+ int nlhrd; /* number of Les Houches events read */
	+} stdcnt_;
	Index: trunk/contrib/stdhep/heprup.h
	===================================================================
	--- trunk/contrib/stdhep/heprup.h (revision 0)
	+++ trunk/contrib/stdhep/heprup.h (revision 8889)
	@@ -0,0 +1,17 @@
	+/*
	+C...User process initialization commonblock.
	+*/
	+
	+#define MAXPUP 100
	+extern struct heprup {
	+ int idbmup[2];
	+ double ebmup[2];
	+ int pdfgup[2];
	+ int pdfsup[2];
	+ int idwtup;
	+ int nprup;
	+ double xsecup[MAXPUP];
	+ double xerrup[MAXPUP];
	+ double xmaxup[MAXPUP];
	+ int lprup[MAXPUP];
	+} heprup_;
	Index: trunk/contrib/stdhep/stdhd.h
	===================================================================
	--- trunk/contrib/stdhep/stdhd.h (revision 0)
	+++ trunk/contrib/stdhep/stdhd.h (revision 8889)
	@@ -0,0 +1,19 @@
	+/*
	+----------------------------------------------------------------
	+ This header collects the mcfio initial information
	+----------------------------------------------------------------
	+*/
	+
	+extern struct stdhd1 {
	+char date[255]; /* MCFIO_CREATIONDATE: creation date */
	+char title[255]; /* MCFIO_TITLE: title */
	+char comment[255]; /* MCFIO_COMMENT: comment */
	+} stdhd1_;
	+
	+extern struct stdhd2 {
	+int dlen; /* actual lenght of date */
	+int tlen; /* actual lenght of title */
	+int clen; /* actual lenght of comment */
	+int numblocks; /* MCFIO_NUMBLOCKS: number of blocks per event */
	+int blkids[50]; /* MCFIO_BLOCKIDS: list of block types */
	+} stdhd2_;
	Index: trunk/contrib/stdhep/stdxrd.f
	===================================================================
	--- trunk/contrib/stdhep/stdxrd.f (revision 0)
	+++ trunk/contrib/stdhep/stdxrd.f (revision 8889)
	@@ -0,0 +1,144 @@
	+ subroutine stdxrd(ilbl,istream,lok)
	+
	+C...Purpose: to read a buffer or an event from the standard common block.
	+C
	+C returns ilbl & lok
	+C
	+C ilbl = 1 - standard HEPEVT common block
	+C ilbl = 2 - standard HEPEVT common block and HEPEV2
	+C ilbl = 3 - stdevent struct
	+C ilbl = 4 - standard HEPEVT common block with Les Houches
	+C ilbl = 5 - standard HEPEVT common block with Les Houches
	+C and multiple collisions
	+C ilbl = 11 - HEPEUP common block
	+C ilbl = 12 - HEPRUP common block
	+C ilbl = 100 - STDHEP begin run record
	+C ilbl = 200 - STDHEP end run record
	+C
	+C lok = 0 if no problems were encountered
	+C
	+
	+ include "stdcnt.inc"
	+ include "stdlun.inc"
	+ include "stdhd.inc"
	+ include "mcfio.inc"
	+
	+ integer ilbl,lok,istream
	+ integer i
	+ integer xdr_stdhep, xdr_stdhep_multi, xdr_stdhep_cm1
	+ external xdr_stdhep, xdr_stdhep_multi, xdr_stdhep_cm1
	+ integer xdr_stdhep_cxx, xdr_stdhep_4, xdr_stdhep_4_multi
	+ external xdr_stdhep_cxx, xdr_stdhep_4, xdr_stdhep_4_multi
	+ integer xdr_hepeup, xdr_heprup
	+ external xdr_hepeup, xdr_heprup
	+
	+ logical lfirst
	+ data lfirst/.TRUE./
	+ save lfirst
	+
	+C...print version number if this is the first call
	+ if(lfirst)then
	+ call stdversn
	+ nstdrd = 0
	+ nlhrd = 0
	+ lfirst=.FALSE.
	+ endif
	+
	+ lok = 0
	+c...get the next xdr event
	+ if(mcfio_NextEvent(istream) .ne. MCFIO_RUNNING)then
	+ call mcfio_InfoStreamInt(istream,MCFIO_STATUS,istat)
	+ if(istat .eq. MCFIO_EOF) go to 800
	+ if(istat .eq. MCFIO_RUNNING) go to 700
	+ go to 900
	+ endif
	+c...what blocks are in this event?
	+ call mcfio_InfoEventInt(istream,MCFIO_NUMBLOCKS,numblocks)
	+ do i=1,numblocks
	+ call mcfio_InfoEventInt(istream,MCFIO_BLOCKIDS,blkids(i))
	+ if(blkids(i).eq.MCFIO_STDHEP)then
	+c...zero stdhep common
	+ call stdzero
	+c...fill stdhep common
	+ if(mcfio_block(istream,MCFIO_STDHEP,xdr_stdhep) .eq. -1)
	+ 1 go to 700
	+ ilbl = 1
	+ call stdtcopy(2,istream,lok)
	+ if(lok.eq.0) nstdrd = nstdrd + 1
	+ elseif(blkids(i).eq.MCFIO_STDHEPM)then
	+c...zero stdhep common
	+ call stdzero
	+c...fill stdhep common
	+ if(mcfio_block(istream,MCFIO_STDHEPM,xdr_stdhep_multi)
	+ 1 .eq. -1) go to 700
	+ ilbl = 2
	+ nstdrd = nstdrd + 1
	+ elseif(blkids(i).eq.MCFIO_STDHEP4)then
	+c...zero stdhep common
	+ call stdzero
	+c...fill stdhep common
	+ if(mcfio_block(istream,MCFIO_STDHEP4,xdr_stdhep_4) .eq. -1)
	+ 1 go to 700
	+ ilbl = 4
	+ call stdtcopy(2,istream,lok)
	+ if(lok.eq.0) nstdrd = nstdrd + 1
	+ elseif(blkids(i).eq.MCFIO_STDHEP4M)then
	+c...zero stdhep common
	+ call stdzero
	+c...fill stdhep common
	+ if(mcfio_block(istream,MCFIO_STDHEP4M,xdr_stdhep_4_multi)
	+ 1 .eq. -1) go to 700
	+ ilbl = 5
	+ nstdrd = nstdrd + 1
	+ elseif(blkids(i).eq.MCFIO_STDHEPCXX)then
	+c...zero stdhep common
	+ call stdzero
	+c...fill stdevent struct
	+c if(mcfio_block(istream,MCFIO_STDHEPCXX,xdr_stdhep_cxx)
	+c 1 .eq. -1) go to 700
	+ ilbl = 3
	+ write (lnhout,703)
	+c...fix stdhep common from stdevent
	+c call copy_stdevent
	+c nstdrd = nstdrd + 1
	+ elseif(blkids(i).eq.MCFIO_HEPEUP)then
	+c...Les Houches event - fill hepeup common
	+ if(mcfio_block(istream,MCFIO_HEPEUP,xdr_hepeup)
	+ 1 .eq. -1) go to 700
	+ ilbl = 11
	+ nlhrd = nlhrd + 1
	+ elseif(blkids(i).eq.MCFIO_HEPRUP)then
	+c...Les Houches event - fill heprup common
	+ if(mcfio_block(istream,MCFIO_HEPRUP,xdr_heprup)
	+ 1 .eq. -1) go to 700
	+ ilbl = 12
	+ nlhrd = nlhrd + 1
	+ elseif(blkids(i).eq.MCFIO_STDHEPBEG)then
	+c...begin run event - fill stdcm1 common
	+ if(mcfio_block(istream,MCFIO_STDHEPBEG,xdr_stdhep_cm1)
	+ 1 .eq. -1) go to 700
	+ ilbl = 100
	+ elseif(blkids(i).eq.MCFIO_STDHEPEND)then
	+c...end run event - fill stdcm1 common
	+ if(mcfio_block(istream,MCFIO_STDHEPEND,xdr_stdhep_cm1)
	+ 1 .eq. -1) go to 700
	+ ilbl = 200
	+ endif
	+ enddo
	+ return
	+
	+ 700 write (lnhout,701)
	+ lok=1
	+ return
	+ 800 write (lnhout,801)
	+ lok=1
	+ return
	+ 900 write (lnhout,901)
	+ lok=2
	+ stop
	+ 701 format(/5X,'STDXRD: unable to read xdr block')
	+ 703 format(/5X,'STDXRD: stdevent struct cannot be processed')
	+ 801 format(/5X,'STDXRD: end of file found')
	+ 901 format(/5X,'STDXRD: unrecognized status - stop')
	+ end
	+
	Index: trunk/contrib/stdhep/stdtcopy.f
	===================================================================
	--- trunk/contrib/stdhep/stdtcopy.f (revision 0)
	+++ trunk/contrib/stdhep/stdtcopy.f (revision 8889)
	@@ -0,0 +1,117 @@
	+ subroutine stdtcopy(idir,istr,lok)
	+
	+C...Purpose: to copy an event to/from the standard common block.
	+C
	+ implicit none
	+
	+ include "stdhep.inc"
	+ include "hepev4.inc"
	+ include "stdtmp.inc"
	+ include "stdlun.inc"
	+
	+ integer idir,lok,i,k,istr
	+
	+ lok=0
	+ if(idir.eq.1)then
	+c... copy from hepevt to stdtmp
	+ nhept = nhep
	+ nevhept = nevhep
	+ idrupt = idruplh
	+ eventweightt = eventweightlh
	+ alphaqedt = alphaqedlh
	+ alphaqcdt = alphaqcdlh
	+ do i=1,10
	+ scalet(i) = scalelh(i)
	+ enddo
	+ do i=1,nhep
	+ isthept(i) = isthep(i)
	+ idhept(i) = idhep(i)
	+ do k=1,2
	+ jmohept(k,i) = jmohep(k,i)
	+ jdahept(k,i) = jdahep(k,i)
	+ icolorflowt(k,i) = icolorflowlh(k,i)
	+ enddo
	+ do k=1,5
	+ phept(k,i) = phep(k,i)
	+ enddo
	+ do k=1,4
	+ vhept(k,i) = vhep(k,i)
	+ enddo
	+ do k=1,3
	+ spint(k,i) = spinlh(k,i)
	+ enddo
	+ enddo
	+ elseif(idir.eq.2)then
	+c... copy from stdtmp to hepevt
	+c... allow for multiple interactions
	+ if((nhep+nhept) .gt. NMXHEP) go to 900
	+ nevhep = nevhept
	+c... no multiple interaction option for hepev4 information
	+ idruplh = idrupt
	+ eventweightlh = eventweightt
	+ alphaqedlh = alphaqedt
	+ alphaqcdlh = alphaqcdt
	+ do i=1,10
	+ scalelh(i) = scalet(i)
	+ enddo
	+ do i=1,nhept
	+ isthep(i+nhep) = isthept(i)
	+ idhep(i+nhep) = idhept(i)
	+ do k=1,2
	+ jmohep(k,i+nhep) = jmohept(k,i)
	+ jdahep(k,i+nhep) = jdahept(k,i)
	+ icolorflowlh(k,i+nhep) = icolorflowt(k,i)
	+ enddo
	+ do k=1,5
	+ phep(k,i+nhep) = phept(k,i)
	+ enddo
	+ do k=1,4
	+ vhep(k,i+nhep) = vhept(k,i)
	+ enddo
	+ do k=1,3
	+ spinlh(k,i+nhep) = spint(k,i)
	+ enddo
	+ enddo
	+ nmulti = nmulti + 1
	+ if(nmulti.le.NMXMLT) then
	+ nevmulti(nmulti) = nevhept
	+ itrkmulti(nmulti) = nhep + 1
	+ mltstr(nmulti) = istr
	+ idrupmulti(nmulti) = idrupt
	+ eventweightmulti(nmulti) = eventweightt
	+ alphaqedmulti(nmulti) = alphaqedt
	+ alphaqcdmulti(nmulti) = alphaqcdt
	+ do i=1,10
	+ scalemulti(i,nmulti) = scalet(i)
	+ enddo
	+ else
	+ write(lnhout,902) nmulti,NMXMLT
	+ endif
	+C... adjust pointers for "multiple interaction" events
	+ do i=1,nhept
	+ jmulti(nhep+i) = nmulti
	+ do k=1,2
	+c... make sure 0 pointers remain 0
	+ if(jmohep(k,i+nhep).ne.0)
	+ 1 jmohep(k,i+nhep) = jmohep(k,i+nhep) + nhep
	+ if(jdahep(k,i+nhep).ne.0)
	+ 1 jdahep(k,i+nhep) = jdahep(k,i+nhep) + nhep
	+ if(icolorflowlh(k,i+nhep).ne.0)
	+ 1 icolorflowlh(k,i+nhep) = icolorflowlh(k,i+nhep) + nhep
	+ enddo
	+ enddo
	+ nhep = nhep + nhept
	+ else
	+ write (lnhout,801)
	+ endif
	+ return
	+ 900 continue
	+ write (lnhout,901) nevhept
	+ lok = 5
	+ return
	+ 801 format(/5X,'STDTCOPY: improper calling flag')
	+ 901 format(/5X,'STDTCOPY: event would overflow HEPEVT array size'/
	+ 1 5X,'STDTCOPY: event ',i8,' has been lost')
	+ 902 format(/5X,'STDTCOPY: ',i2,' multiple interactions in this event'/
	+ 1 5X,'STDTCOPY: only ',i2,'multiple interactions are allowed')
	+ end
	Index: trunk/contrib/stdhep/hepeup.inc
	===================================================================
	--- trunk/contrib/stdhep/hepeup.inc (revision 0)
	+++ trunk/contrib/stdhep/hepeup.inc (revision 8889)
	@@ -0,0 +1,33 @@
	+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)
	+
	+C
	+C Les Houches accord 2001
	+C
	+C NUP - number of particle entries in this event
	+C IDPRUP - ID of the process for this event
	+C (ID's are generator-specific)
	+C XWGTUP - event weight
	+C SCALUP - scale of the event in GeV, as used to calculate PDFs
	+C AQEDUP - QED coupling used for this event
	+C AQCDUP - QCD coupling used for this event
	+C IDUP - particle ID according to PDG convention
	+C ISTUP - status code:
	+C -1 incoming particle
	+C +1 outgoing final state particle
	+C -2 intermediate space like propagator
	+C +2 intermediate resonance, mass should be preserved
	+C +3 intermediate resonance for documentation only
	+C -9 incoming beam particles (generally not needed)
	+C MOTHUP - index of first and last mother
	+C ICOLUP - tag for color flow lines
	+C PUP - lab frame 4 momentum and mass in GeV
	+C VTIMUP - invariant lifetime
	+C SPINUP - cos of angle between spin-vector of particle and 3 momentum of decaying particle
	+C
	Index: trunk/contrib/stdhep/stdxwrt.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwrt.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwrt.f (revision 8889)
	@@ -0,0 +1,58 @@
	+ subroutine stdxwrt(ilbl,istream,lok)
	+
	+C...Purpose: to write a buffer or an event from the standard common block.
	+C
	+C if ilbl = 1 write HEPEVT common block
	+C ilbl = 2 write HEPEVT, HEPEV2, and HEPEV3 common blocks
	+C ilbl = 4 write HEPEVT and HEPEV4 common blocks
	+C ilbl = 5 write HEPEVT, HEPEV2, HEPEV3, and HEPEV4 common blocks
	+C ilbl = 11 write HEPEUP common block
	+C ilbl = 12 write HEPRUP common block
	+C ilbl = 100 write STDHEP begin run record
	+C ilbl = 200 write STDHEP end run record
	+C otherwise, don't do anything
	+C
	+C lok = 0 if no problems were encountered
	+
	+ include "stdcnt.inc"
	+ include "stdlun.inc"
	+
	+ integer ilbl,lok,istream
	+ logical lfirst
	+ data lfirst/.TRUE./
	+ save lfirst
	+
	+C...print version number if this is the first call
	+ if(lfirst)then
	+ call stdversn
	+ nstdwrt = 0
	+ nlhwrt = 0
	+ lfirst=.FALSE.
	+ endif
	+
	+ lok=0
	+ if(ilbl.eq.1 .or. ilbl.eq.2)then
	+C... the stdhep common block and maybe the multiple interaction common
	+ call stdxwevt(ilbl,istream,lok)
	+ elseif(ilbl.eq.4 .or. ilbl.eq.5)then
	+C... the stdhep common block and maybe the multiple interaction common
	+C... include HEPEV4
	+ call stdxwevtlh(ilbl,istream,lok)
	+ elseif(ilbl.eq.11 .or. ilbl.eq.12)then
	+C... the Les Houches common blocks
	+ call stdxwevtup(ilbl,istream,lok)
	+ elseif(ilbl.eq.100)then
	+ call stdxwcm1(ilbl,istream,lok)
	+ elseif(ilbl.eq.200)then
	+ call stdxwcm1(ilbl,istream,lok)
	+ else
	+ write(lnhout,902) ilbl
	+ endif
	+ return
	+ 900 write (lnhout,901)
	+ lok=1
	+ return
	+ 101 format(/5X,'STDXWRT: the output buffer is empty')
	+ 901 format(/5X,'STDXWRT: write error')
	+ 902 format(/5X,'STDXWRT: do not know what to do with record type',i5)
	+ end
	Index: trunk/contrib/stdhep/mcfio.inc
	===================================================================
	--- trunk/contrib/stdhep/mcfio.inc (revision 0)
	+++ trunk/contrib/stdhep/mcfio.inc (revision 8889)
	@@ -0,0 +1,154 @@
	+c
	+c Include file for mcfast i/o layer.
	+c
	+c Paul Lebrun, October 1994.
	+c
	+ integer MCFIO_VERSION
	+ integer MCFIO_STATUS
	+ integer MCFIO_RUNNING
	+ integer MCFIO_BOF
	+ integer MCFIO_EOF
	+ integer MCFIO_NUMBLOCKS
	+ integer MCFIO_READORWRITE
	+ integer MCFIO_READ
	+ integer MCFIO_WRITE
	+ integer MCFIO_DIRECTORSEQUENTIAL
	+ integer MCFIO_DIRECT
	+ integer MCFIO_SEQUENTIAL
	+ integer MCFIO_BLOCKIDS
	+ integer MCFIO_NUMWORDS
	+ integer MCFIO_EFFICIENCY
	+ integer MCFIO_NUMEVTS
	+ integer MCFIO_FILENUMBER
	+ integer MCFIO_MAXREC
	+ integer MCFIO_MINREC
	+ integer MCFIO_NUMRECORDS
	+ integer MCFIO_RECORDLENGTHS
	+ integer MCFIO_TITLE
	+ integer MCFIO_COMMENT
	+ integer MCFIO_CREATIONDATE
	+ integer MCFIO_CLOSINGDATE
	+ integer MCFIO_FILENAME
	+ integer MCFIO_DEVICENAME
	+ integer MCFIO_EVENTNUMBER
	+ integer MCFIO_STORENUMBER
	+ integer MCFIO_RUNNUMBER
	+ integer MCFIO_TRIGGERMASK
	+ integer MCFIO_NUMNTUPLES
	+ integer MCFIO_NTUPLESLIST
	+ PARAMETER (MCFIO_VERSION = 100)
	+ PARAMETER (MCFIO_STATUS = 101)
	+ PARAMETER (MCFIO_RUNNING = 102)
	+ PARAMETER (MCFIO_BOF = 103)
	+ PARAMETER (MCFIO_EOF = 104)
	+ PARAMETER (MCFIO_NUMBLOCKS = 501)
	+ PARAMETER (MCFIO_READORWRITE = 502)
	+ PARAMETER (MCFIO_READ = 1)
	+ PARAMETER (MCFIO_WRITE = 2)
	+ PARAMETER (MCFIO_DIRECTORSEQUENTIAL = 503)
	+ PARAMETER (MCFIO_DIRECT = 1)
	+ PARAMETER (MCFIO_SEQUENTIAL = 2)
	+ PARAMETER (MCFIO_BLOCKIDS = 504)
	+ PARAMETER (MCFIO_NUMWORDS = 505)
	+ PARAMETER (MCFIO_EFFICIENCY = 506)
	+ PARAMETER (MCFIO_NUMEVTS = 507)
	+ PARAMETER (MCFIO_FILENUMBER = 508)
	+ PARAMETER (MCFIO_MAXREC = 509)
	+ PARAMETER (MCFIO_MINREC = 510)
	+ PARAMETER (MCFIO_NUMRECORDS = 511)
	+ PARAMETER (MCFIO_RECORDLENGTHS = 512)
	+ PARAMETER (MCFIO_TITLE = 1001)
	+ PARAMETER (MCFIO_COMMENT = 1002)
	+ PARAMETER (MCFIO_CREATIONDATE = 1003)
	+ PARAMETER (MCFIO_CLOSINGDATE = 1013)
	+ PARAMETER (MCFIO_FILENAME = 1004)
	+ PARAMETER (MCFIO_DEVICENAME = 1005)
	+ PARAMETER (MCFIO_EVENTNUMBER = 2001)
	+ PARAMETER (MCFIO_STORENUMBER = 2002)
	+ PARAMETER (MCFIO_RUNNUMBER = 2003)
	+ PARAMETER (MCFIO_TRIGGERMASK = 2004)
	+ PARAMETER (MCFIO_NUMNTUPLES = 4001)
	+ PARAMETER (MCFIO_NTUPLESLIST = 4002)
	+
	+ integer mcfio_OpenReadDirect
	+ integer mcfio_OpenReadMapped
	+ integer mcfio_OpenWriteDirect
	+ integer mcfio_OpenReadSequential
	+ integer mcfio_OpenWriteSequential
	+ integer mcfio_NextEvent
	+ integer mcfio_SpecificEvent
	+ integer mcfio_NextSpecificEvent
	+ integer mcfio_Block
	+ integer mcfio_InfoNumStream
	+ integer mcfio_DeclareNtuple
	+ integer mcfio_EndDeclNtuples
	+ integer mcfio_Ntuple
	+ integer mcfio_NtupleMult
	+ integer mcfio_NtupleVar
	+ integer mcfio_NtupleSubVar
	+ integer mcfio_NtupleSubStruct
	+ integer mcfio_GetNtupleIds
	+ integer mcfio_GetNTupleUID
	+ integer mcfio_GetNTupleCategory
	+ integer mcfio_GetNTupleTitle
	+ integer mcfio_GetNTupleName
	+
	+ external mcfio_OpenReadDirect
	+ external mcfio_OpenReadMapped
	+ external mcfio_OpenWriteDirect
	+ external mcfio_OpenReadSequential
	+ external mcfio_OpenWriteSequential
	+ external mcfio_NextEvent
	+ external mcfio_SpecificEvent
	+ external mcfio_NextSpecificEvent
	+ external mcfio_Block
	+ external mcfio_InfoNumStream
	+ external mcfio_DeclareNtuple
	+ external mcfio_EndDeclNtuples
	+ external mcfio_Ntuple
	+ external mcfio_GetNtupleIds
	+ external mcfio_GetNTupleUID
	+ external mcfio_GetNTupleCategory
	+ external mcfio_GetNTupleTitle
	+ external mcfio_GetNTupleName
	+ external mcfio_NtupleMult
	+ external mcfio_NtupleVar
	+ external mcfio_NtupleSubVar
	+ external mcfio_NtupleSubStruct
	+C
	+C Block definition now. Start counting at 101 See also mcfioC_GetBlockNames
	+C
	+ integer MCFIO_STDHEP
	+ integer MCFIO_STDHEPM
	+ integer MCFIO_STDHEP4
	+ integer MCFIO_STDHEP4M
	+ integer MCFIO_STDHEPBEG
	+ integer MCFIO_STDHEPEND
	+ integer MCFIO_STDHEPCXX
	+ integer MCFIO_OFFTRACKARRAYS
	+ integer MCFIO_OFFTRACKSTRUCT
	+ integer MCFIO_TRACEARRAYS
	+ integer MCFIO_HEPEUP
	+ integer MCFIO_HEPRUP
	+ parameter ( MCFIO_STDHEP = 101 )
	+ parameter ( MCFIO_OFFTRACKARRAYS = 102 )
	+ parameter ( MCFIO_OFFTRACKSTRUCT = 103 )
	+ parameter ( MCFIO_TRACEARRAYS = 104 )
	+ parameter ( MCFIO_STDHEPM = 105 )
	+ parameter ( MCFIO_STDHEPBEG = 106 )
	+ parameter ( MCFIO_STDHEPEND = 107 )
	+ parameter ( MCFIO_STDHEPCXX = 108 )
	+ parameter ( MCFIO_STDHEP4 = 201 )
	+ parameter ( MCFIO_STDHEP4M = 202 )
	+ parameter ( MCFIO_HEPEUP = 203 )
	+ parameter ( MCFIO_HEPRUP = 204 )
	+c
	+c Some of these statements should be in the user code,
	+c uncommented.
	+c
	+c integer xdr_mcfast_track_offline
	+c external xdr_mcfast_track_offline
	+c integer xdr_mcfast_track_offlslow
	+c external xdr_mcfast_track_offlslow
	+c
	+c
	Index: trunk/contrib/stdhep/stdcnt.inc
	===================================================================
	--- trunk/contrib/stdhep/stdcnt.inc (revision 0)
	+++ trunk/contrib/stdhep/stdcnt.inc (revision 8889)
	@@ -0,0 +1,6 @@
	+C -------------------------------------------------------------
	+C
	+ integer nstdwrt,nstdrd,nlhwrt,nlhrd
	+ common /stdcnt/ nstdwrt,nstdrd,nlhwrt,nlhrd
	+ save /stdcnt/
	+C -------------------------------------------------------------
	Index: trunk/contrib/stdhep/Makefile.am
	===================================================================
	--- trunk/contrib/stdhep/Makefile.am (revision 0)
	+++ trunk/contrib/stdhep/Makefile.am (revision 8889)
	@@ -0,0 +1,109 @@
	+## Makefile.am -- Makefile for WHIZARD
	+##
	+## Process this file with automake to produce Makefile.in
	+##
	+########################################################################
	+#
	+# Copyright (C) 1999-2023 by
	+# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	+# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	+# Juergen Reuter <juergen.reuter@desy.de>
	+# with contributions from
	+# cf. main AUTHORS file
	+#
	+# WHIZARD is free software; you can redistribute it and/or modify it
	+# under the terms of the GNU General Public License as published by
	+# the Free Software Foundation; either version 2, or (at your option)
	+# any later version.
	+#
	+# WHIZARD is distributed in the hope that it will be useful, but
	+# WITHOUT ANY WARRANTY; without even the implied warranty of
	+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	+# GNU General Public License for more details.
	+#
	+# You should have received a copy of the GNU General Public License
	+# along with this program; if not, write to the Free Software
	+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	+#
	+########################################################################
	+
	+## The files in this directory end up in an auxiliary libtool library.
	+
	+noinst_LTLIBRARIES = libwo_stdhep.la
	+
	+libwo_stdhep_la_SOURCES = \
	+ mcf_hepev4_xdr.c \
	+ mcf_hepup_xdr.c \
	+ mcf_stdcm1_xdr.c \
	+ mcf_Stdhep_xdr.c \
	+ stdhep_mcfio.c \
	+ stdhep_internal_utils.c \
	+ stdtcopy.f \
	+ stdversn.f \
	+ stdxend.f \
	+ stdxrd.f \
	+ stdxrinit.f \
	+ stdxropen.f \
	+ stdxwcm1.f \
	+ stdxwevt.f \
	+ stdxwevtlh.f \
	+ stdxwevtup.f \
	+ stdxwinit.f \
	+ stdxwopen.f \
	+ stdxwrt.f \
	+ stdzero.f \
	+ hepev4.h \
	+ hepeup.h \
	+ heprup.h \
	+ stdcm1.h \
	+ stdcnt.h \
	+ stdhd.h \
	+ stdhep.h \
	+ stdhep_mcfio.h \
	+ stdlun.h \
	+ stdtmp.h \
	+ stdver.h \
	+ hepev4.inc \
	+ hepeup.inc \
	+ heprup.inc \
	+ mcfio.inc \
	+ stdcm1.inc \
	+ stdcnt.inc \
	+ stdhd.inc \
	+ stdhep.inc \
	+ stdlun.inc \
	+ stdtmp.inc \
	+ stdver.inc
	+
	+## The include files are not automatically found (by certain Fortran compilers)
	+## RPC flags need to be included if SunRPC is absent
	+AM_FCFLAGS = -I$(top_srcdir)/contrib/stdhep
	+AM_FFLAGS = -I$(top_srcdir)/contrib/stdhep
	+AM_CFLAGS = $(RPC_CFLAGS) -I$(top_srcdir)/contrib/mcfio
	+
	+########################################################################
	+## Default Fortran compiler options
	+
	+## Profiling
	+if FC_USE_PROFILING
	+AM_FCFLAGS += $(FCFLAGS_PROFILING)
	+endif
	+
	+## OpenMP
	+if FC_USE_OPENMP
	+AM_FCFLAGS += $(FCFLAGS_OPENMP)
	+endif
	+
	+########################################################################
	+## Non-standard cleanup tasks
	+
	+## Remove F90 module files
	+clean-local:
	+ -rm -f *.$(FC_MODULE_EXT)
	+if FC_SUBMODULES
	+ -rm -f *.smod
	+endif
	+
	+## Remove backup files
	+maintainer-clean-local:
	+ -rm -f *~
	Index: trunk/contrib/stdhep/stdxropen.f
	===================================================================
	--- trunk/contrib/stdhep/stdxropen.f (revision 0)
	+++ trunk/contrib/stdhep/stdxropen.f (revision 8889)
	@@ -0,0 +1,50 @@
	+ subroutine stdxropen(filename,ntries,istream,lok)
	+c
	+c initialize xdr reading
	+c
	+ implicit none
	+ include "mcfio.inc"
	+ include "stdlun.inc"
	+ include "stdhd.inc"
	+ integer istream,lok,ntries,i
	+ character() filename
	+
	+ logical lfirst
	+ data lfirst/.TRUE./
	+ save lfirst
	+c
	+c Initialization phase.
	+c
	+C...print version number if this is the first call
	+ if(lfirst)then
	+ call stdversn
	+ lfirst=.FALSE.
	+ endif
	+ lok = 0
	+ istream = mcfio_OpenReadDirect(filename)
	+ if (istream .eq. -1) go to 900
	+ call mcfio_InfoStreamChar(istream,MCFIO_CREATIONDATE,date,dlen)
	+ call mcfio_InfoStreamChar(istream,MCFIO_TITLE,title,tlen)
	+ call mcfio_InfoStreamChar(istream,MCFIO_COMMENT,comment,clen)
	+ call mcfio_InfoStreamInt(istream,MCFIO_NUMEVTS,ntries)
	+ call mcfio_InfoStreamInt(istream,MCFIO_NUMBLOCKS,numblocks)
	+ do i=1,numblocks
	+ call mcfio_InfoStreamInt(istream,MCFIO_BLOCKIDS,blkids(i))
	+ enddo
	+ write(lnhout,1001) istream,title(1:tlen),date(1:dlen),
	+ 1 comment(1:clen),ntries,numblocks
	+ return
	+
	+ 900 continue
	+ write(lnhout,1002)
	+ lok = -1
	+ stop
	+
	+1001 format(/' STDXROPEN: successfully opened input stream ',i5/
	+ 1 10x,'title: ',a60/
	+ 2 10x,'date: ',a60/
	+ 3 10x,a70/
	+ 4 20x,i10,' events'/
	+ 5 20x,i10,' blocks per event'/)
	+1002 format(' STDXROPEN: Cannot open input file, give up ')
	+ end
	Index: trunk/contrib/stdhep/heprup.inc
	===================================================================
	--- trunk/contrib/stdhep/heprup.inc (revision 0)
	+++ trunk/contrib/stdhep/heprup.inc (revision 8889)
	@@ -0,0 +1,40 @@
	+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)
	+
	+C
	+C Les Houches accord 2001
	+C
	+C MAXPUP - max. number of different processes to be interfaced at one time
	+C IDBMUP - ID of beam particles 1 and 2 according to the PDG convention
	+C EBMUP - energy in GeV of beam particles 1 and 2
	+C PDFGUP - author group for beam particles 1 and 2 according to PDFlib specifications
	+C PDFSUP - PDF set ID for beam particles 1 and 2 according to PDFlib specifications
	+C
	+C For e+e- or when the SHG defaults are to be used,
	+C set PDFGUP=-1 and PDFSUP=-1
	+C
	+C IDWTUP - master switch dictating how the event weights are interpreted
	+C NPRUP - number of different user subprocesses
	+C XSECUP - cross section for process in pb
	+C XERRUP - statistical error associated with XSECUP
	+C XMAXUP - maximum XWGTUP (in common block HEPEUP) for this process
	+C LPRUP - user process ID's for this run
	+C
	+C event control of
	+C IDWTUP selection mixing or XWGTUP output
	+C criteria unweighting input
	+C +1 XMAXUP SHG +weighted +1
	+C -1 XMAXUP SHG +/-weighted +/-1
	+C +2 XSECUP SHG +weighted +1
	+C -2 XSECUP SHG +/-weighted +/-1
	+C +3 user interface +1 +1
	+C -3 user interface +/-1 +/-1
	+C +4 user interface +weighted +weighted
	+C 14 user interface +/-weighted +/-weighted
	+C
	Index: trunk/contrib/stdhep/stdxrinit.f
	===================================================================
	--- trunk/contrib/stdhep/stdxrinit.f (revision 0)
	+++ trunk/contrib/stdhep/stdxrinit.f (revision 8889)
	@@ -0,0 +1,26 @@
	+ subroutine stdxrinit(filename,ntries,istream,lok)
	+c
	+c initialize xdr reading
	+c
	+ implicit none
	+ include "mcfio.inc"
	+ include "stdlun.inc"
	+ integer istream,lok,ntries
	+ character() filename
	+
	+ logical lfirst
	+ data lfirst/.TRUE./
	+ save lfirst
	+c
	+c Initialization phase.
	+c
	+C...print version number if this is the first call
	+ if(lfirst)then
	+ call stdversn
	+ lfirst=.FALSE.
	+ endif
	+ lok = 0
	+ call mcfio_init()
	+ call stdxropen(filename,ntries,istream,lok)
	+ return
	+ end
	Index: trunk/contrib/stdhep/stdxwevt.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwevt.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwevt.f (revision 8889)
	@@ -0,0 +1,48 @@
	+ subroutine stdxwevt(ilbl,istream,lok)
	+
	+C...Purpose: to write an event from the standard common block.
	+C
	+C lok = 0 if no problems were encountered
	+
	+ include "stdhep.inc"
	+ include "stdcnt.inc"
	+ include "stdlun.inc"
	+ include "mcfio.inc"
	+
	+ integer ilbl,lok,istream
	+ integer xdr_stdhep, xdr_stdhep_multi
	+ external xdr_stdhep, xdr_stdhep_multi
	+
	+ lok=0
	+ if(NHEP.LE.0)then
	+ write(lnhout,101) NEVHEP
	+ elseif(ilbl.eq.1)then
	+ call stdtcopy(1,istream,lok)
	+ if(lok.ne.0) go to 700
	+ if(mcfio_block(istream, MCFIO_STDHEP, xdr_stdhep)
	+ 1 .eq. -1) go to 800
	+ call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ nstdwrt = nstdwrt + 1
	+ elseif(ilbl.eq.2)then
	+ if(mcfio_block(istream, MCFIO_STDHEPM, xdr_stdhep_multi)
	+ 1 .eq. -1) go to 800
	+ call mcfio_SetEventInfo(istream, MCFIO_STORENUMBER, nevhep)
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ nstdwrt = nstdwrt + 1
	+ endif
	+ return
	+ 700 write (lnhout,701) NEVHEP
	+ lok = 4
	+ stop
	+ 800 write (lnhout,801) NEVHEP
	+ lok=2
	+ stop
	+ 900 write (lnhout,901) NEVHEP
	+ lok=1
	+ stop
	+ 101 format(/5X,'STDXWEVT: no particles to write in event',I8)
	+ 701 format(/5X,'STDXWEVT: error copying stdhep block for event ',I8)
	+ 801 format(/5X,'STDXWEVT: error filling stdhep block for event ',I8)
	+ 901 format(/5X,'STDXWEVT: error writing event ',I8)
	+ end
	Index: trunk/contrib/stdhep/stdhep.h
	===================================================================
	--- trunk/contrib/stdhep/stdhep.h (revision 0)
	+++ trunk/contrib/stdhep/stdhep.h (revision 8889)
	@@ -0,0 +1,49 @@
	+/*
	+** Basic COMMON block from STDHEP: the HEPEVT COMMON block
	+** See product StDhep
	+*/
	+/* note that to avoid alignment problems, structures and common blocks
	+ should be in the order: double precision, real, integer.
	+*/
	+#define NMXHEP 4000
	+#define NMXMLT 16
	+extern struct hepevt {
	+int nevhep; /* The event number */
	+int nhep; /* The number of entries in this event */
	+int isthep[NMXHEP]; /* The Particle id */
	+int idhep[NMXHEP]; /* The particle id */
	+int jmohep[NMXHEP][2]; /* The position of the mother particle */
	+int jdahep[NMXHEP][2]; /* Position of the first daughter... */
	+double phep[NMXHEP][5]; /* 4-Momentum, mass */
	+double vhep[NMXHEP][4]; /* Vertex information */
	+} hepevt_;
	+extern struct hepev2 {
	+int nmulti; /* number of interactions in the list */
	+int jmulti[NMXHEP]; /* multiple interaction number */
	+} hepev2_;
	+extern struct hepev3 {
	+int nevmulti[NMXMLT]; /* event number of original interaction */
	+int itrkmulti[NMXMLT]; /* first particle in the original interaction */
	+int mltstr[NMXMLT]; /* stream this event is from */
	+} hepev3_;
	+
	+/* prototypes */
	+#if defined(c_plusplus) \|\| defined(__cplusplus)
	+extern "C" {
	+#endif
	+
	+void hepnam_(int particleID, char name, int length_of_name);
	+int hepchg_(int *particleID);
	+float stdchg_(int *particleID);
	+void stdspin_(int index, int jspin);
	+void stdcquarks_(int index, int quark1, int quark2, int quark3,
	+ int ang_mom, int jspin, int radial, int kqx);
	+void stdquarks_(int index, int quark1, int quark2, int quark3,
	+ int ang_mom, int jspin, int radial, int kqx);
	+
	+#if defined(c_plusplus) \|\| defined(__cplusplus)
	+}
	+#endif
	+
	+void StdHepZero();
	+int StdHepTempCopy(int idir, int istr);
	Index: trunk/contrib/stdhep/stdhd.inc
	===================================================================
	--- trunk/contrib/stdhep/stdhd.inc (revision 0)
	+++ trunk/contrib/stdhep/stdhd.inc (revision 8889)
	@@ -0,0 +1,23 @@
	+c -------------------------------------------------------------
	+c This header collects the mcfio initial information
	+c
	+c date - MCFIO_CREATIONDATE: creation date
	+c title - MCFIO_TITLE: title
	+c comment - MCFIO_COMMENT: comment
	+c dlen - actual lenght of date
	+c tlen - actual lenght of title
	+c clen - actual lenght of comment
	+c numblocks - MCFIO_NUMBLOCKS: number of blocks per event
	+c blkids - MCFIO_BLOCKIDS: list of block types
	+c
	+c use: write(*,1001) title(1:tlen),date(1:dlen),comment(1:clen)
	+c 1001 format(10x,'title: ',a60/10x,'date: ',a60/10x,a70)
	+c
	+ character*255 date, title, comment
	+ integer dlen, tlen, clen, numblocks, blkids
	+ common /stdhd1/ date, title, comment
	+ common /stdhd2/ dlen, tlen, clen, numblocks, blkids(50)
	+ save /stdhd1/
	+ save /stdhd2/
	+c
	+c -------------------------------------------------------------
	Index: trunk/contrib/stdhep/mcf_hepev4_xdr.c
	===================================================================
	--- trunk/contrib/stdhep/mcf_hepev4_xdr.c (revision 0)
	+++ trunk/contrib/stdhep/mcf_hepev4_xdr.c (revision 8889)
	@@ -0,0 +1,271 @@
	+/*******************************************************************************
	+* *
	+* mcf_hepev4_xdr.c -- XDR Utility routines for the Block Stdhep filters *
	+* hepevt and hepev4 (and optionally hepev2 and hepev3) *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun, Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include <stdlib.h>
	+#include <time.h>
	+#include "mcfio_Dict.h"
	+#include "mcf_xdr.h"
	+#include "stdhep.h"
	+#include "hepev4.h"
	+#include "stdtmp.h"
	+#include "stdver.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+bool_t xdr_stdhep_4_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the HEPEVT temporary COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version. */
	+
	+ unsigned int nn, nn2, nn3, nn4, nn5, nnw, nnw2, nnw3, nnw4, nnw5;
	+ int *idat;
	+ double *dat;
	+ unsigned int n5 = 5; /* for scale */
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (*blockid != MCFIO_STDHEP4) {
	+ fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+
	+ nn = (unsigned int) stdtmp_.nhept; /* Number of elements in isthep or idhep */
	+ nn2 = 2(unsigned int) stdtmp_.nhept; / Number of elements in jmohep or jdahep */
	+ nn3 = 3(unsigned int) stdtmp_.nhept; / Number of elements in spinlh */
	+ nn4 = 4(unsigned int) stdtmp_.nhept; / Number of elements in vhep */
	+ nn5 = 5(unsigned int) stdtmp_.nhept; / Number of elements in phep */
	+ nnw = (unsigned int) stdtmp_.nhept;
	+ nnw2 = 2 * nnw;
	+ nnw3 = 3 * nnw;
	+ nnw4 = 4 * nnw;
	+ nnw5 = 5 * nnw;
	+
	+ /* Total length in bytes include blockid, ntot, version, nevhept and nhept as well
	+ as the arrays remembering doubles are longer than ints. */
	+ ntot = 5sizeof(int) + sizeof(int)(2nn + 2*nn2)
	+ + sizeof(double)*(nn4 + nn5)
	+ + (8 + nn3)sizeof(double) + (1 + nn2)sizeof(int);
	+
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	+ xdr_int(xdrs, &(stdtmp_.nevhept)) &&
	+ xdr_int(xdrs, &(stdtmp_.nhept))) == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEP4) ) {
	+ fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ idat = stdtmp_.isthept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int),
	+ (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = stdtmp_.idhept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int),
	+ (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) stdtmp_.jmohept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int),
	+ (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) stdtmp_.jdahept;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int),
	+ (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) stdtmp_.phept;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw5, 5*NMXHEP, sizeof(double),
	+ (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) stdtmp_.vhept;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ /* valid for stdhep 5.01 and later */
	+ if ( xdr_double(xdrs, &(tmpev4_.eventweightt) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(tmpev4_.alphaqedt) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(tmpev4_.alphaqcdt) ) == FALSE) return FALSE;
	+ dat = (double *) tmpev4_.scalet;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &n5, 10, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) tmpev4_.spint;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw3, 3*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ idat = (int *) tmpev4_.icolorflowt;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ if ( xdr_int(xdrs, &(tmpev4_.idrupt) ) == FALSE) return FALSE;
	+ return TRUE;
	+}
	+
	+bool_t xdr_stdhep_4_multi_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the HEPEVT COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version.
	+ Also translate the HEPEV2 COMMON block from the STDHEP package to/from
	+ an XDR stream. HEPEV2 contains multiple interaction information */
	+
	+ unsigned int nn, nn2, nn3, nn4, nn5, nnw, nnw2, nnw3, nnw4, nnw5;
	+ unsigned int nmlt, nnmlt, nmltd, nnmlt5;
	+ int i;
	+ int *idat;
	+ char *vers;
	+ double *dat;
	+ unsigned int n5 = 10; /* for scale */
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (*blockid != MCFIO_STDHEP4M) {
	+ fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ nn = sizeof(int) * hepevt_.nhep;
	+ nn2 = 2 * sizeof(int) * hepevt_.nhep;
	+ nn3 = 3 * sizeof(double) * hepevt_.nhep;
	+ nn4 = 4 * sizeof(double) * hepevt_.nhep;
	+ nn5 = 10 * sizeof(double) * hepevt_.nhep;
	+ nmlt = sizeof(int) * hepev2_.nmulti;
	+ nmltd = sizeof(double) * hepev2_.nmulti;
	+ nnw = (unsigned int) hepevt_.nhep;
	+ nnw2 = 2 * nnw;
	+ nnw3 = 3 * nnw;
	+ nnw4 = 4 * nnw;
	+ nnw5 = 5 * nnw;
	+ nnmlt = (unsigned int) hepev2_.nmulti;
	+ nnmlt5 = 5 * nnmlt;
	+ ntot = 6 sizeof(int) + 3 * nn + 2 * nn2 + nn4 + nn5 + 3 * nmlt
	+ + nn3 + 8 * sizeof(double) + nn2 + sizeof(int)
	+ + 8 * nmltd + nmlt;
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) &&
	+ xdr_int(xdrs, &(hepevt_.nevhep)) &&
	+ xdr_int(xdrs, &(hepevt_.nhep))) == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) && ( *blockid != MCFIO_STDHEP4M) ) {
	+ fprintf (stderr, "mcf_hepev4_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ idat = hepevt_.isthep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepevt_.idhep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) hepevt_.jmohep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = (int *) hepevt_.jdahep;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ dat = (double *) hepevt_.phep;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw5, 5*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepevt_.vhep;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw4, 4*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ /*
	+ ** V2.02 Upgrade : adding Multiple interactions.
	+ */
	+ if ( xdr_int(xdrs, &(hepev2_.nmulti)) == FALSE) return FALSE;
	+ idat = hepev2_.jmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw, NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ /*
	+ ** V4.04 Upgrade : adding more Multiple interaction information
	+ */
	+ idat = hepev3_.nevmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepev3_.itrkmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ idat = hepev3_.mltstr;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ /* valid for stdhep 5.01 and later */
	+ if ( xdr_double(xdrs, &(hepev4_.eventweightlh) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(hepev4_.alphaqedlh) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(hepev4_.alphaqcdlh) ) == FALSE) return FALSE;
	+ dat = (double *) hepev4_.scalelh;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &n5, 10, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepev4_.spinlh;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnw3, 3*NMXHEP, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ idat = (int *) hepev4_.icolorflowlh;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnw2, 2*NMXHEP, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ if ( xdr_int(xdrs, &(hepev4_.idruplh) ) == FALSE) return FALSE;
	+ dat = (double *) hepev5_.eventweightmulti;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnmlt, NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepev5_.alphaqedmulti;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnmlt, NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepev5_.alphaqcdmulti;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnmlt, NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ dat = (double *) hepev5_.scalemulti;
	+ if ( xdr_array(xdrs, (char **) &dat,
	+ &nnmlt5, 10*NMXMLT, sizeof(double), (xdrproc_t)xdr_double) == FALSE) return FALSE;
	+ idat = hepev5_.idrupmulti;
	+ if ( xdr_array(xdrs, (char **) &idat,
	+ &nnmlt, NMXMLT, sizeof(int), (xdrproc_t)xdr_int) == FALSE) return FALSE;
	+ return TRUE;
	+}
	+
	+
	Index: trunk/contrib/stdhep/mcf_stdcm1_xdr.c
	===================================================================
	--- trunk/contrib/stdhep/mcf_stdcm1_xdr.c (revision 0)
	+++ trunk/contrib/stdhep/mcf_stdcm1_xdr.c (revision 8889)
	@@ -0,0 +1,148 @@
	+/*******************************************************************************
	+* *
	+* mcf_stdcm1_xdr.c -- XDR Utility routines for the Block stdcm1 filters *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun, Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include <stdlib.h>
	+#include <time.h>
	+#include "mcfio_Dict.h"
	+#include "mcf_xdr.h"
	+#include "stdcm1.h"
	+#include "stdver.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+struct stdcm1 stdcm1_;
	+struct stdcm2 stdcm2_;
	+
	+bool_t xdr_stdhep_cm1_(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+
	+{
	+/* Translate the STDCM1 COMMON block from the STDHEP package to/from
	+ an XDR stream. Note that we do not allocate memory, because we fill
	+ directly the COMMON. Also, mcfio will allocate the space for the
	+ string version. */
	+
	+ unsigned int nn, nn1, nn2;
	+ int *idat;
	+ double *dat;
	+ char *vers;
	+ char *cdat;
	+
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ if (( blockid != MCFIO_STDHEPEND)&&( blockid != MCFIO_STDHEPBEG)) {
	+ fprintf (stderr, "mcf_Stdhep_cm1_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ nn = sizeof(int) * stdcm1_.nevtreq;
	+ nn1 = sizeof(float) * stdcm1_.nevtreq;
	+ nn2 = sizeof(double) * stdcm1_.nevtreq;
	+ ntot = 3 sizeof(int) + 3 * nn + 2 * nn1 + 2 * nn2
	+ + 2 * sizeof(char) * ( MCF_XDR_STDCM2_LENGTH + 1 );
	+ if (xdrs->x_op == XDR_MCFIOCODE) return TRUE;
	+ strncpy(version[0],stdver_.stdhep_ver, 4);
	+ }
	+
	+ if ( (xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH) )
	+ == FALSE) return FALSE;
	+
	+ if ((xdrs->x_op == XDR_DECODE) &&
	+ (( blockid != MCFIO_STDHEPEND)&&( blockid != MCFIO_STDHEPBEG))) {
	+ fprintf (stderr, "mcf_Stdhep_cm1_xdr: Inconsistent Blockid %d \n ",
	+ (*blockid));
	+ return FALSE;
	+ }
	+ if ( xdr_int(xdrs, &(stdcm1_.nevtreq) ) == FALSE) return FALSE;
	+ if ( xdr_int(xdrs, &(stdcm1_.nevtgen) ) == FALSE) return FALSE;
	+ if ( xdr_int(xdrs, &(stdcm1_.nevtwrt) ) == FALSE) return FALSE;
	+ if ( xdr_float(xdrs, &(stdcm1_.stdecom) ) == FALSE) return FALSE;
	+ if ( xdr_float(xdrs, &(stdcm1_.stdxsec) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(stdcm1_.stdseed1) ) == FALSE) return FALSE;
	+ if ( xdr_double(xdrs, &(stdcm1_.stdseed2) ) == FALSE) return FALSE;
	+ /*
	+ ** V5.01 Upgrade : adding stdcm2
	+ */
	+ vers = *version;
	+ if (((strcmp(vers,"1.") == 0) \|\| (strcmp(vers,"2.") == 0) \|\|
	+ (strcmp(vers,"3.") == 0) \|\| (strcmp(vers,"4.") == 0) \|\|
	+ (strcmp(vers,"5.00") == 0) ) && (xdrs->x_op == XDR_DECODE)) {
	+ strncpy(stdcm2_.generatorname, " ", MCF_XDR_STDCM2_LENGTH);
	+ strncpy(stdcm2_.pdfname, " ", MCF_XDR_STDCM2_LENGTH);
	+ return TRUE;
	+ }
	+/*
	+ allocate memory and deal with encoding and decoding separately
	+*/
	+ cdat = malloc(MCF_XDR_STDCM2_LENGTH+1);
	+ if( (xdrs->x_op == XDR_DECODE) ) {
	+ strncpy(stdcm2_.generatorname, " ", MCF_XDR_STDCM2_LENGTH);
	+ strncpy(stdcm2_.pdfname, " ", MCF_XDR_STDCM2_LENGTH);
	+ cdat = NULL;
	+ if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	+ strncpy(stdcm2_.generatorname,cdat,MCF_XDR_STDCM2_LENGTH);
	+ cdat = NULL;
	+ if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	+ strncpy(stdcm2_.pdfname,cdat,MCF_XDR_STDCM2_LENGTH);
	+ } else {
	+ strncpy(cdat, stdcm2_.generatorname, MCF_XDR_STDCM2_LENGTH);
	+ /* some compilers do not properly append the null terminator */
	+ cdat[MCF_XDR_STDCM2_LENGTH]='\0';
	+ if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	+ strncpy(cdat, stdcm2_.pdfname, MCF_XDR_STDCM2_LENGTH);
	+ cdat[MCF_XDR_STDCM2_LENGTH]='\0';
	+ if ( xdr_string(xdrs, &cdat, MCF_XDR_STDCM2_LENGTH+1 ) == FALSE) return FALSE;
	+ }
	+ free(cdat);
	+
	+ /*
	+ ** V5.02 Upgrade : add nevtlh to stdcm1
	+ ** note that we cannot get here unless the version is 5.00 or greater
	+ */
	+ if (((strcmp(vers,"5.00") == 0) \|\| (strcmp(vers,"5.01") == 0))
	+ && (xdrs->x_op == XDR_DECODE)) {
	+ stdcm1_.nevtlh = 0;
	+ return TRUE;
	+ }
	+ if ( xdr_int(xdrs, &(stdcm1_.nevtlh) ) == FALSE) return FALSE;
	+
	+ return TRUE;
	+}
	+
	Index: trunk/contrib/stdhep/stdxwopen.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwopen.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwopen.f (revision 8889)
	@@ -0,0 +1,53 @@
	+ subroutine stdxwopen(filename,gtitle,ntries,istream,lok)
	+c
	+c initialize xdr tape writing
	+c WARNING: this routine cannot be used if you want to write anything
	+c besides stdhep records
	+c
	+ implicit none
	+ include "mcfio.inc"
	+ include "stdlun.inc"
	+ include "stdhd.inc"
	+ integer istream,lok,ntries
	+ character () filename
	+ character () gtitle
	+ character (10), target :: commnt = "No comment"
	+ character (10), pointer :: comm => null()
	+
	+ logical lfirst
	+ data lfirst/.TRUE./
	+ save lfirst
	+
	+C...print version number if this is the first call
	+ if(lfirst)then
	+ call stdversn
	+ lfirst=.FALSE.
	+ endif
	+c
	+c Initialization phase.
	+c
	+ comm => commnt
	+ lok = 0
	+ title = gtitle
	+ numblocks = 8
	+ blkids(1) = MCFIO_STDHEP
	+ blkids(2) = MCFIO_STDHEPM
	+ blkids(3) = MCFIO_STDHEPBEG
	+ blkids(4) = MCFIO_STDHEPEND
	+ blkids(5) = MCFIO_STDHEP4
	+ blkids(6) = MCFIO_STDHEP4M
	+ blkids(7) = MCFIO_HEPEUP
	+ blkids(8) = MCFIO_HEPRUP
	+ istream = mcfio_OpenWriteDirect(filename, title, comm,
	+ & ntries, blkids, numblocks)
	+ if (istream .eq. -1) then
	+ write(lnhout,1002)
	+ lok = -1
	+ stop
	+ end if
	+ write(lnhout,1001)
	+
	+ return
	+1001 format(' STDXWOPEN WARNING: I/O is initialized for stdhep only')
	+1002 format(' STDXWOPEN: Cannot open output file, give up ')
	+ end
	Index: trunk/contrib/stdhep/stdxwinit.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwinit.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwinit.f (revision 8889)
	@@ -0,0 +1,28 @@
	+ subroutine stdxwinit(filename,title,ntries,istream,lok)
	+c
	+c initialize xdr tape writing
	+c WARNING: this routine cannot be used if you want to write anything
	+c besides stdhep records
	+c
	+ implicit none
	+ include "mcfio.inc"
	+ include "stdlun.inc"
	+ integer istream,lok,ntries
	+ character () filename
	+ character () title
	+
	+ logical lfirst
	+ data lfirst/.TRUE./
	+
	+C...print version number if this is the first call
	+ if(lfirst)then
	+ call stdversn
	+ lfirst=.FALSE.
	+ endif
	+c
	+c Initialization phase.
	+c
	+ call mcfio_init()
	+ call stdxwopen(filename,title,ntries,istream,lok)
	+ return
	+ end
	Index: trunk/contrib/stdhep/hepev4.h
	===================================================================
	--- trunk/contrib/stdhep/hepev4.h (revision 0)
	+++ trunk/contrib/stdhep/hepev4.h (revision 8889)
	@@ -0,0 +1,21 @@
	+/* Hepev4 holds Les Houches information */
	+/* note that to avoid alignment problems, structures and common blocks
	+ should be in the order: double precision, real, integer.
	+*/
	+extern struct hepev4 {
	+ double eventweightlh; /* event weight */
	+ double alphaqedlh; /* QED coupling alpha_em */
	+ double alphaqcdlh; /* QCD coupling alpha_s */
	+ double scalelh[10]; /* Scale Q of the event */
	+ double spinlh[NMXHEP][3]; /* spin information */
	+ int icolorflowlh[NMXHEP][2]; /* (Anti-)Colour flow */
	+ int idruplh; /* ID, as given by LPRUP codes */
	+} hepev4_;
	+
	+extern struct hepev5 {
	+ double eventweightmulti[NMXMLT]; /* original event weight */
	+ double alphaqedmulti[NMXMLT]; /* original QED coupling alpha_em */
	+ double alphaqcdmulti[NMXMLT]; /* original QCD coupling alpha_s */
	+ double scalemulti[NMXMLT][10]; /* original Scale Q of the event */
	+ int idrupmulti[NMXMLT]; /* original ID, as given by LPRUP codes */
	+} hepev5_;
	Index: trunk/contrib/stdhep/stdcm1.h
	===================================================================
	--- trunk/contrib/stdhep/stdcm1.h (revision 0)
	+++ trunk/contrib/stdhep/stdcm1.h (revision 8889)
	@@ -0,0 +1,19 @@
	+/*
	+** STDHEP begin/end run COMMON block
	+** See product StDhep
	+*/
	+extern struct stdcm1 {
	+float stdecom; /* STDECOM - center-of-mass energy */
	+float stdxsec; /* STDXSEC - cross-section */
	+double stdseed1; /* STDSEED1 - random number seed */
	+double stdseed2; /* STDSEED2 - random number seed */
	+int nevtreq; /* NEVTREQ - number of events to be generated */
	+int nevtgen; /* NEVTGEN - number of events actually generated */
	+int nevtwrt; /* NEVTWRT - number of events written to output file */
	+int nevtlh; /* NEVTLH - number of Les Houches events written to output file */
	+} stdcm1_;
	+
	+extern struct stdcm2 {
	+char generatorname[20]; /* name of Monte Carlo generator */
	+char pdfname[20]; /* name of PDF method used */
	+} stdcm2_;
	Index: trunk/contrib/stdhep/stdxwevtup.f
	===================================================================
	--- trunk/contrib/stdhep/stdxwevtup.f (revision 0)
	+++ trunk/contrib/stdhep/stdxwevtup.f (revision 8889)
	@@ -0,0 +1,54 @@
	+ subroutine stdxwevtup(ilbl,istream,lok)
	+
	+C...Purpose: to write an event from the standard common block.
	+C
	+C ilbl = 11 write HEPEUP common block
	+C ilbl = 12 write HEPRUP common block
	+C lok = 0 if no problems were encountered
	+
	+ include "hepeup.inc"
	+ include "heprup.inc"
	+ include "stdcnt.inc"
	+ include "stdlun.inc"
	+ include "mcfio.inc"
	+
	+ integer ilbl,lok,istream
	+ integer xdr_hepeup, xdr_heprup
	+ external xdr_hepeup, xdr_heprup
	+
	+ lok=0
	+
	+ if(ilbl.eq.11)then
	+ if(nup.le.0)then
	+ write(lnhout,101)
	+C... negative units seem to be a problem for nagfor
	+C write(lnhout,101) nup
	+ else
	+ if(mcfio_block(istream, MCFIO_HEPEUP, xdr_hepeup)
	+ 1 .eq. -1) go to 700
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ nlhwrt = nlhwrt + 1
	+ endif
	+ elseif(ilbl.eq.12)then
	+ if(mcfio_block(istream, MCFIO_HEPRUP, xdr_heprup)
	+ 1 .eq. -1) go to 800
	+ if(mcfio_NextEvent(istream) .eq. -1) go to 900
	+ nlhwrt = nlhwrt + 1
	+ endif
	+
	+ return
	+
	+ 700 write (lnhout,701)
	+ lok=2
	+ stop
	+ 800 write (lnhout,801)
	+ lok=2
	+ stop
	+ 900 write (lnhout,901)
	+ lok=1
	+ stop
	+ 101 format(/5X,'stdxwevtup: no particles to write for HEPEUP block')
	+ 701 format(/5X,'stdxwevtup: error filling Les Houches HEPEUP block ')
	+ 801 format(/5X,'stdxwevtup: error filling Les Houches HEPRUP block ')
	+ 901 format(/5X,'stdxwevtup: error writing Les Houches event ')
	+ end
	Index: trunk/contrib/stdhep/stdhep_internal_utils.c
	===================================================================
	--- trunk/contrib/stdhep/stdhep_internal_utils.c (revision 0)
	+++ trunk/contrib/stdhep/stdhep_internal_utils.c (revision 8889)
	@@ -0,0 +1,208 @@
	+/*******************************************************************************
	+* *
	+* stdhep_internal_utils.c -- C version of stdhep internal utility routines *
	+* *
	+* Copyright (c) 1995 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <stdlib.h>
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+/*
	+* StdHep definitions and include files
	+*/
	+#include "stdhep.h"
	+#include "hepev4.h"
	+#include "stdtmp.h"
	+#include "hepeup.h"
	+
	+struct stdtmp stdtmp_;
	+struct tmpev4 tmpev4_;
	+
	+/* Purpose: copy an event to/from the standard common block */
	+int StdHepTempCopy(int idir, int istr)
	+{
	+ int nh, i, k;
	+ if (idir == 1) { /* copy from hepevt to stdtmp */
	+ stdtmp_.nevhept = hepevt_.nevhep;
	+ stdtmp_.nhept = hepevt_.nhep;
	+ tmpev4_.eventweightt = hepev4_.eventweightlh;
	+ tmpev4_.alphaqedt = hepev4_.alphaqedlh;
	+ tmpev4_.alphaqcdt = hepev4_.alphaqcdlh;
	+ for (i = 0; i < 10; i++) {
	+ tmpev4_.scalet[i] = hepev4_.scalelh[i];
	+ }
	+ tmpev4_.idrupt = hepev4_.idruplh;
	+ for (i = 0; i < hepevt_.nhep; i++) {
	+ stdtmp_.isthept[i] = hepevt_.isthep[i];
	+ stdtmp_.idhept[i] = hepevt_.idhep[i];
	+ for (k = 0; k < 2; k++) {
	+ stdtmp_.jmohept[i][k] = hepevt_.jmohep[i][k];
	+ stdtmp_.jdahept[i][k] = hepevt_.jdahep[i][k];
	+ tmpev4_.icolorflowt[i][k] = hepev4_.icolorflowlh[i][k];
	+ }
	+ for (k = 0; k < 5; k++)
	+ stdtmp_.phept[i][k] = hepevt_.phep[i][k];
	+ for (k = 0; k < 4; k++)
	+ stdtmp_.vhept[i][k] = hepevt_.vhep[i][k];
	+ for (k = 0; k < 3; k++)
	+ tmpev4_.spint[i][k] = hepev4_.spinlh[i][k];
	+ }
	+ } else if (idir == 2) { /* copy from stdtmp to hepevt */
	+ if (hepevt_.nhep + stdtmp_.nhept > NMXHEP) {
	+ fprintf(stderr,
	+ " StdHepTempCopy: event would overflow HEPEVT array size\n");
	+ fprintf(stderr," StdHepTempCopy: event %d has been lost\n",
	+ stdtmp_.nevhept);
	+ return 5;
	+ }
	+ hepevt_.nevhep = stdtmp_.nevhept;
	+ nh = hepevt_.nhep;
	+ hepev4_.eventweightlh = tmpev4_.eventweightt;
	+ hepev4_.alphaqedlh = tmpev4_.alphaqedt;
	+ hepev4_.alphaqcdlh = tmpev4_.alphaqcdt;
	+ for (i = 0; i < 10; i++) {
	+ hepev4_.scalelh[i] = tmpev4_.scalet[i];
	+ }
	+ hepev4_.idruplh = tmpev4_.idrupt;
	+ for (i = 0; i < stdtmp_.nhept; i++) {
	+ hepevt_.isthep[nh+i] = stdtmp_.isthept[i];
	+ hepevt_.idhep[nh+i] = stdtmp_.idhept[i];
	+ for (k = 0; k < 2; k++) {
	+ hepevt_.jmohep[nh+i][k] = stdtmp_.jmohept[i][k];
	+ hepevt_.jdahep[nh+i][k] = stdtmp_.jdahept[i][k];
	+ hepev4_.icolorflowlh[nh+i][k] = tmpev4_.icolorflowt[i][k];
	+ }
	+ for (k = 0; k < 5; k++)
	+ hepevt_.phep[nh+i][k] = stdtmp_.phept[i][k];
	+ for (k = 0; k < 4; k++)
	+ hepevt_.vhep[nh+i][k] = stdtmp_.vhept[i][k];
	+ for (k = 0; k < 3; k++)
	+ hepev4_.spinlh[nh+i][k] = tmpev4_.spint[i][k];
	+ }
	+ hepev2_.nmulti += 1;
	+ if (hepev2_.nmulti <= NMXMLT ) {
	+ hepev3_.nevmulti[hepev2_.nmulti] = stdtmp_.nevhept;
	+ hepev3_.itrkmulti[hepev2_.nmulti] = stdtmp_.nhept + 1;
	+ hepev3_.mltstr[hepev2_.nmulti] = istr;
	+ hepev5_.eventweightmulti[i] = tmpev4_.eventweightt;
	+ hepev5_.alphaqedmulti[i] = tmpev4_.alphaqedt;
	+ hepev5_.alphaqcdmulti[i] = tmpev4_.alphaqcdt;
	+ for( k = 0; k < 10; ++k) {
	+ hepev5_.scalemulti[i][k] = tmpev4_.scalet[k];
	+ }
	+ hepev5_.idrupmulti[i] = tmpev4_.idrupt;
	+ } else {
	+ fprintf(stderr," StdHepTempCopy: %d multiple interactions in this event\n",
	+ hepev2_.nmulti );
	+ fprintf(stderr," StdHepTempCopy: only %d multiple interactions are allowed\n",
	+ NMXMLT );
	+ }
	+ for (i = 0; i < stdtmp_.nhept; i++) {
	+ hepev2_.jmulti[nh+i] = hepev2_.nmulti;
	+ for (k = 0; k < 2; k++) {
	+ if (hepevt_.jmohep[nh+i][k] != 0) {
	+ hepevt_.jmohep[nh+i][k] += hepevt_.nhep;
	+ }
	+ if (hepevt_.jdahep[nh+i][k] != 0) {
	+ hepevt_.jdahep[nh+i][k] += hepevt_.nhep;
	+ }
	+ if (hepev4_.icolorflowlh[nh+i][k] != 0) {
	+ hepev4_.icolorflowlh[nh+i][k] += hepevt_.nhep;
	+ }
	+ }
	+ }
	+ hepevt_.nhep += stdtmp_.nhept;
	+ } else {
	+ fprintf(stderr," StdHepTempCopy: improper calling flag\n");
	+ }
	+ return 0;
	+}
	+
	+void StdHepZero(void)
	+{
	+ int i, k;
	+ hepevt_.nhep = 0;
	+ hepev2_.nmulti = 0;
	+ for (i = 0; i < NMXHEP; i++) {
	+ hepevt_.isthep[i] = 0;
	+ hepevt_.idhep[i] = 0;
	+ hepev2_.jmulti[i] = 0;
	+ for (k = 0; k < 2; k++) {
	+ hepevt_.jmohep[i][k] = 0;
	+ hepevt_.jdahep[i][k] = 0;
	+ hepev4_.icolorflowlh[i][k] = 0;
	+ }
	+ for (k = 0; k < 5; k++)
	+ hepevt_.phep[i][k] = 0.;
	+ for (k = 0; k < 4; k++)
	+ hepevt_.vhep[i][k] = 0.;
	+ for (k = 0; k < 3; k++)
	+ hepev4_.spinlh[i][k] = 0.;
	+ }
	+ for (i = 0; i < NMXMLT; i++) {
	+ hepev3_.nevmulti[i] = 0;
	+ hepev3_.itrkmulti[i] = 0;
	+ hepev3_.mltstr[i] = 0;
	+ hepev5_.eventweightmulti[i] = 0.;
	+ hepev5_.alphaqedmulti[i] = 0.;
	+ hepev5_.alphaqcdmulti[i] = 0.;
	+ for( k = 0; k < 10; ++k) {
	+ hepev5_.scalemulti[i][k] = 0.;
	+ }
	+ hepev5_.idrupmulti[i] = 0;
	+ }
	+ hepev4_.eventweightlh = 0.;
	+ hepev4_.alphaqedlh = 0.;
	+ hepev4_.alphaqcdlh = 0.;
	+ for (i = 0; i < 10; i++) {
	+ hepev4_.scalelh[i] = 0.;
	+ }
	+ hepev4_.idruplh = 0;
	+}
	+
	+void StdHepZeroHEPEUP(void)
	+{
	+ int i, k;
	+ hepeup_.nup;
	+ hepeup_.idprup;
	+ hepeup_.xwgtup;
	+ hepeup_.scalup;
	+ hepeup_.aqedup;
	+ hepeup_.aqcdup;
	+ for (i = 0; i < MAXNUP; ++i) {
	+ hepeup_.idup[i];
	+ hepeup_.istup[i];
	+ for (k = 0; k < 2; ++k) {
	+ hepeup_.mothup[i][k];
	+ hepeup_.icolup[i][k];
	+ }
	+ for (k = 0; k < 5; ++k) {
	+ hepeup_.pup[i][k];
	+ }
	+ hepeup_.vtimup[i];
	+ hepeup_.spinup[i];
	+ }
	+}
	Index: trunk/contrib/stdhep/stdhep_mcfio.c
	===================================================================
	--- trunk/contrib/stdhep/stdhep_mcfio.c (revision 0)
	+++ trunk/contrib/stdhep/stdhep_mcfio.c (revision 8889)
	@@ -0,0 +1,540 @@
	+/*******************************************************************************
	+* *
	+* stdhep_mcfio.c -- C version of mcfio interface routines *
	+* *
	+* Copyright (c) 1995 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <stdlib.h>
	+#include <rpc/types.h>
	+#include <rpc/xdr.h>
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+/*
	+* mcfio/StdHep definitions and include files
	+*/
	+#include "mcf_xdr.h"
	+#include "mcfio_Dict.h"
	+#include "mcfio_Direct.h"
	+#include "mcfio_Util1.h"
	+#include "mcfio_Block.h"
	+#include "stdhep.h"
	+#include "hepev4.h"
	+#include "hepeup.h"
	+#include "heprup.h"
	+#include "stdhd.h"
	+#include "stdcnt.h"
	+#include "stdlun.h"
	+#include "stdhep_mcfio.h"
	+
	+struct hepevt hepevt_;
	+struct hepev2 hepev2_;
	+struct hepev3 hepev3_;
	+struct hepev4 hepev4_;
	+struct hepev5 hepev5_;
	+struct hepeup hepeup_;
	+struct heprup heprup_;
	+struct stdcnt stdcnt_;
	+struct heplun heplun_;
	+struct stdstr stdstr_;
	+struct stdhd1 stdhd1_;
	+struct stdhd2 stdhd2_;
	+
	+extern int xdr_stdhep_();
	+extern int xdr_stdhep_multi_();
	+extern int xdr_stdhep_4_();
	+extern int xdr_stdhep_4_multi_();
	+extern int xdr_stdhep_cm1_();
	+extern int xdr_hepeup_();
	+extern int xdr_heprup_();
	+
	+int StdHepXdrReadInit(char *filename, int ntries, int ist)
	+{
	+ int ierr;
	+
	+ mcfioC_Init();
	+ ierr = StdHepXdrReadOpen(filename, ntries, ist);
	+ return ierr;
	+}
	+int StdHepXdrReadOpen(char *filename, int ntries, int ist)
	+{
	+ int istream, iblk;
	+ int numblocks, blkids[50];
	+
	+ istream = mcfioC_OpenReadDirect(filename);
	+ stdstr_.ixdrstr[ist] = istream;
	+ if (istream == -1) {
	+ fprintf(stderr," StdHepXdrReadOpen: cannot open output file \n");
	+ return -1;
	+ }
	+ mcfioC_InfoStreamChar(istream, MCFIO_CREATIONDATE, stdhd1_.date, &stdhd2_.dlen);
	+ mcfioC_InfoStreamChar(istream, MCFIO_TITLE, stdhd1_.title, &stdhd2_.tlen);
	+ mcfioC_InfoStreamChar(istream, MCFIO_COMMENT, stdhd1_.comment, &stdhd2_.clen);
	+ mcfioC_InfoStreamInt(istream, MCFIO_NUMEVTS, &ntries);
	+ mcfioC_InfoStreamInt(istream, MCFIO_NUMBLOCKS, &numblocks);
	+ mcfioC_InfoStreamInt(istream, MCFIO_BLOCKIDS, blkids);
	+
	+ stdhd2_.numblocks = numblocks;
	+ for ( iblk=0; iblk < numblocks; ++iblk ) {
	+ stdhd2_.blkids[iblk] = blkids[iblk];
	+ }
	+
	+ stdcnt_.nstdrd = 0;
	+ stdcnt_.nlhrd = 0;
	+ fprintf(stdout,
	+ " StdHepXdrReadOpen: successfully opened input stream %d\n",istream);
	+ fprintf(stdout," title: %s\n",stdhd1_.title);
	+ fprintf(stdout," date: %s\n",stdhd1_.date);
	+ fprintf(stdout," %d events\n",ntries);
	+ fprintf(stdout," %d blocks per event\n",stdhd2_.numblocks);
	+ return 0;
	+}
	+int StdHepXdrRead(int *ilbl, int ist)
	+{
	+/* Purpose: to read a buffer or an event from the standard common block.
	+C
	+C returns ilbl
	+C
	+C ilbl = 1 - standard HEPEVT common block
	+C ilbl = 2 - standard HEPEVT common block and HEPEV2
	+C ilbl = 3 - stdevent struct
	+C ilbl = 4 - standard HEPEVT common block with Les Houches
	+C ilbl = 5 - standard HEPEVT common block with Les Houches
	+C and multiple collisions
	+C ilbl = 11 - HEPEUP common block
	+C ilbl = 12 - HEPRUP common block
	+C ilbl = 100 - STDHEP begin run record
	+C ilbl = 200 - STDHEP end run record
	+C */
	+
	+ int istat;
	+ int i, numblocks, blkids[50];
	+
	+ int istream = stdstr_.ixdrstr[ist];
	+ if(mcfioC_NextEvent(istream) != MCFIO_RUNNING) {
	+ mcfioC_InfoStreamInt(istream, MCFIO_STATUS, &istat);
	+ if(istat == MCFIO_EOF) {
	+ fprintf(stderr," StdHepXdrRead: end of file found\n");
	+ return 1;
	+ }
	+ else {
	+ fprintf(stderr," StdHepXdrRead: unrecognized status - stop\n");
	+ return 2;
	+ }
	+ }
	+ mcfioC_InfoStreamInt(istream, MCFIO_NUMBLOCKS, &numblocks);
	+ mcfioC_InfoStreamInt(istream, MCFIO_BLOCKIDS, blkids);
	+
	+ for (i = 0; i < numblocks; i++) {
	+ if (blkids[i] == MCFIO_STDHEP) {
	+ StdHepZero();
	+ if (mcfioC_Block(istream,MCFIO_STDHEP,xdr_stdhep_) != -1) {
	+ *ilbl = 1;
	+ if (StdHepTempCopy(2,istream) == 0)
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_STDHEPM) {
	+ StdHepZero();
	+ if (mcfioC_Block(istream,MCFIO_STDHEPM,xdr_stdhep_multi_) != -1) {
	+ *ilbl = 2;
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_STDHEP4) {
	+ StdHepZero();
	+ if (mcfioC_Block(istream,MCFIO_STDHEP4,xdr_stdhep_4_) != -1) {
	+ *ilbl = 4;
	+ if (StdHepTempCopy(2,istream) == 0)
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_STDHEP4M) {
	+ StdHepZero();
	+ if (mcfioC_Block(istream,MCFIO_STDHEP4M,xdr_stdhep_4_multi_) != -1) {
	+ *ilbl = 5;
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_STDHEPBEG) {
	+ if (mcfioC_Block(istream,MCFIO_STDHEPBEG,xdr_stdhep_cm1_) != -1) {
	+ *ilbl = 100;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_STDHEPEND) {
	+ if (mcfioC_Block(istream,MCFIO_STDHEPEND,xdr_stdhep_cm1_) != -1) {
	+ *ilbl = 200;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_HEPEUP) {
	+ if (mcfioC_Block(istream,MCFIO_HEPEUP,xdr_hepeup_) != -1) {
	+ *ilbl = 11;
	+ stdcnt_.nlhrd = stdcnt_.nlhrd + 1;
	+ return 0;
	+ }
	+ }
	+ else if (blkids[i] == MCFIO_HEPRUP) {
	+ if (mcfioC_Block(istream,MCFIO_HEPRUP,xdr_heprup_) != -1) {
	+ *ilbl = 12;
	+ stdcnt_.nlhrd = stdcnt_.nlhrd + 1;
	+ return 0;
	+ }
	+ }
	+ }
	+ return 1;
	+}
	+int StdHepXdrReadMulti(int *ilbl, int ist)
	+{
	+/* Purpose: to read a buffer or an event from the standard common block
	+ this routine handles multiple input streams
	+C
	+C return ilbl
	+C
	+C ilbl = 1 - standard HEPEVT common block
	+C ilbl = 2 - standard HEPEVT common block and HEPEV2
	+C ilbl = 100 - STDHEP begin run record
	+C ilbl = 200 - STDHEP end run record
	+C */
	+
	+ int istat;
	+ int i, numblocks, blkids[50];
	+
	+ int istream = stdstr_.ixdrstr[ist];
	+ if(mcfioC_NextEvent(istream) != MCFIO_RUNNING) {
	+ mcfioC_InfoStreamInt(istream, MCFIO_STATUS, &istat);
	+ if(istat == MCFIO_EOF) {
	+ fprintf(stderr," StdHepXdrReadMulti: end of file found\n");
	+ return 1;
	+ }
	+ else {
	+ fprintf(stderr,
	+ " StdHepXdrReadMulti: unrecognized status - stop\n");
	+ return 2;
	+ }
	+ }
	+ mcfioC_InfoStreamInt(istream, MCFIO_NUMBLOCKS, &numblocks);
	+ mcfioC_InfoStreamInt(istream, MCFIO_BLOCKIDS, blkids);
	+ for (i = 0; i < numblocks; i++) {
	+ if (blkids[i] == MCFIO_STDHEP) {
	+ if (mcfioC_Block(istream,MCFIO_STDHEP,xdr_stdhep_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrReadMulti: unable to read xdr block\n");
	+ return 1;
	+ }
	+ *ilbl = 1;
	+ if (StdHepTempCopy(2,istream) == 0)
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ }
	+ else if (blkids[i] == MCFIO_STDHEPM) {
	+ fprintf(stderr,
	+ " StdHepXdrRead: multiple interaction event - HEPEVT is zeroed\n");
	+ StdHepZero();
	+ if (mcfioC_Block(istream,MCFIO_STDHEPM,xdr_stdhep_multi_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrReadMulti: unable to read xdr block\n");
	+ return 1;
	+ }
	+ *ilbl = 2;
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ }
	+ else if (blkids[i] == MCFIO_STDHEP4) {
	+ if (mcfioC_Block(istream,MCFIO_STDHEP4,xdr_stdhep_4_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrReadMulti: unable to read xdr block\n");
	+ return 1;
	+ }
	+ *ilbl = 4;
	+ if (StdHepTempCopy(2,istream) == 0)
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ }
	+ else if (blkids[i] == MCFIO_STDHEP4M) {
	+ fprintf(stderr,
	+ " StdHepXdrRead: multiple interaction event - HEPEVT is zeroed\n");
	+ StdHepZero();
	+ if (mcfioC_Block(istream,MCFIO_STDHEP4M,xdr_stdhep_4_multi_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrReadMulti: unable to read xdr block\n");
	+ return 1;
	+ }
	+ *ilbl = 5;
	+ stdcnt_.nstdrd = stdcnt_.nstdrd + 1;
	+ }
	+ }
	+ return 0;
	+}
	+int StdHepXdrWriteInit(char filename, char title, int ntries, int ist)
	+{
	+ int ierr;
	+
	+ mcfioC_Init();
	+ ierr = StdHepXdrWriteOpen(filename, title, ntries, ist);
	+ return ierr;
	+}
	+int StdHepXdrWriteOpen(char filename, char title, int ntries, int ist)
	+{
	+ int istream, iblk;
	+ int numblocks = 8;
	+ int blkids[50];
	+ char *comment = '\0';
	+
	+ blkids[0] = MCFIO_STDHEP;
	+ blkids[1] = MCFIO_STDHEPM;
	+ blkids[2] = MCFIO_STDHEPBEG;
	+ blkids[3] = MCFIO_STDHEPEND;
	+ blkids[4] = MCFIO_STDHEP4;
	+ blkids[5] = MCFIO_STDHEP4M;
	+ blkids[6] = MCFIO_HEPEUP;
	+ blkids[7] = MCFIO_HEPRUP;
	+
	+ strncpy(stdhd1_.title,title,255);
	+ stdhd2_.numblocks = numblocks;
	+ for ( iblk=0; iblk < numblocks; ++iblk ) {
	+ stdhd2_.blkids[iblk] = blkids[iblk];
	+ }
	+
	+ istream = mcfioC_OpenWriteDirect(filename, title, comment,
	+ ntries, blkids, numblocks);
	+ stdstr_.ixdrstr[ist] = istream;
	+ if (istream == -1) {
	+ fprintf(stderr," StdHepXdrWriteOpen: cannot open output file \n");
	+ return -1;
	+ }
	+ fprintf(stdout," StdHepXdrWriteOpen: I/O initialized for StdHep only\n");
	+ return 0;
	+}
	+int StdHepXdrWrite(int ilbl, int ist)
	+{
	+ int iret = 0;
	+
	+ if ((ilbl == 1) \|\| (ilbl == 2))
	+ iret = StdHepXdrWriteEvent(ilbl, ist);
	+ else if ((ilbl == 4) \|\| (ilbl == 5))
	+ iret = StdHepXdrWriteEventLH(ilbl, ist);
	+ else if (ilbl == 11)
	+ iret = StdHepXdrWriteEventEUP(ilbl, ist);
	+ else if (ilbl == 12)
	+ iret = StdHepXdrWriteEventRUP(ilbl, ist);
	+ else if ((ilbl == 100) \|\| (ilbl == 200))
	+ iret = StdHepXdrWriteCM(ilbl, ist);
	+ else
	+ fprintf(stderr,
	+ " StdHepXdrWrite: don't know what to do with record type %d\n", ilbl);
	+ return iret;
	+}
	+int StdHepXdrWriteCM(int ilbl, int ist)
	+{
	+ int istream = stdstr_.ixdrstr[ist];
	+ if (ilbl == 100) {
	+ if (mcfioC_Block(istream, MCFIO_STDHEPBEG, xdr_stdhep_cm1_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteCM: error filling stdhep cm1 common block\n");
	+ return 2;
	+ }
	+ }
	+ else if (ilbl == 200) {
	+ if (mcfioC_Block(istream, MCFIO_STDHEPEND, xdr_stdhep_cm1_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteCM: error filling stdhep cm1 common block\n");
	+ return 2;
	+ }
	+ }
	+ else {
	+ fprintf(stderr,
	+ " StdHepXdrWriteCM: called with improper label %d\n",ilbl);
	+ return 3;
	+ }
	+ if (mcfioC_NextEvent(istream) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteCM: error writing stdhep cm1 xdr block\n");
	+ return 1;
	+ }
	+ return 0;
	+}
	+int StdHepXdrWriteEvent(int ilbl, int ist)
	+{
	+ int istream = stdstr_.ixdrstr[ist];
	+ if ((ilbl != 1) && (ilbl != 2)) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEvent: called with illegal label %d\n",
	+ ilbl);
	+ return 3;
	+ }
	+ else if (hepevt_.nhep <= 0) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEvent: event %d is empty\n", hepevt_.nevhep);
	+ return 0;
	+ }
	+ else if (ilbl == 1) {
	+ if (StdHepTempCopy(1,istream) != 0) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEvent: copy failed - event not written\n");
	+ return 4;
	+ }
	+ if (mcfioC_Block(istream, MCFIO_STDHEP, xdr_stdhep_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEvent: error filling stdhep block for event %d\n",
	+ hepevt_.nevhep);
	+ return 2;
	+ }
	+ mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	+ }
	+ else if (ilbl == 2) {
	+ if (mcfioC_Block(istream, MCFIO_STDHEPM, xdr_stdhep_multi_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEvent: error filling stdhep block for event %d\n",
	+ hepevt_.nevhep);
	+ return 2;
	+ }
	+ mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	+ }
	+ if (mcfioC_NextEvent(istream) == -1) {
	+ fprintf(stderr," StdHepXdrWriteCM: error writing event %d\n",
	+ hepevt_.nevhep);
	+ return 1;
	+ }
	+ stdcnt_.nstdwrt = stdcnt_.nstdwrt + 1;
	+ return 0;
	+}
	+int StdHepXdrWriteEventLH(int ilbl, int ist)
	+{
	+ int istream = stdstr_.ixdrstr[ist];
	+ if ((ilbl != 4) && (ilbl != 5)) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventLH: called with illegal label %d\n",
	+ ilbl);
	+ return 3;
	+ }
	+ else if (hepevt_.nhep <= 0) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventLH: event %d is empty\n", hepevt_.nevhep);
	+ return 0;
	+ }
	+ else if (ilbl == 4) {
	+ if (StdHepTempCopy(1,istream) != 0) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventLH: copy failed - event not written\n");
	+ return 4;
	+ }
	+ if (mcfioC_Block(istream, MCFIO_STDHEP4, xdr_stdhep_4_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventLH: error filling stdhep block for event %d\n",
	+ hepevt_.nevhep);
	+ return 2;
	+ }
	+ mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	+ }
	+ else if (ilbl == 5) {
	+ if (mcfioC_Block(istream, MCFIO_STDHEP4M, xdr_stdhep_4_multi_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventLH: error filling stdhep block for event %d\n",
	+ hepevt_.nevhep);
	+ return 2;
	+ }
	+ mcfioC_SetEventInfo(istream, MCFIO_STORENUMBER, &hepevt_.nevhep);
	+ }
	+ if (mcfioC_NextEvent(istream) == -1) {
	+ fprintf(stderr," StdHepXdrWriteLH: error writing event %d\n",
	+ hepevt_.nevhep);
	+ return 1;
	+ }
	+ stdcnt_.nstdwrt = stdcnt_.nstdwrt + 1;
	+ return 0;
	+}
	+int StdHepXdrWriteEventEUP(int ilbl, int ist)
	+{
	+ int istream = stdstr_.ixdrstr[ist];
	+ if ( ilbl != 11 ) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventEUP: called with illegal label %d\n",
	+ ilbl);
	+ return 3;
	+ }
	+ else if (hepeup_.nup <= 0) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventEUP: event is empty\n");
	+ return 0;
	+ }
	+ else if (ilbl == 11) {
	+ if (mcfioC_Block(istream, MCFIO_HEPEUP, xdr_hepeup_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventEUP: error filling stdhep block for event\n");
	+ return 2;
	+ }
	+ }
	+ if (mcfioC_NextEvent(istream) == -1) {
	+ fprintf(stderr," StdHepXdrWriteEUP: error writing event\n");
	+ return 1;
	+ }
	+ stdcnt_.nlhwrt = stdcnt_.nlhwrt + 1;
	+ return 0;
	+}
	+int StdHepXdrWriteEventRUP(int ilbl, int ist)
	+{
	+ int istream = stdstr_.ixdrstr[ist];
	+ if ( ilbl != 12 ) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventRUP: called with illegal label %d\n",
	+ ilbl);
	+ return 3;
	+ }
	+ else if (ilbl == 12) {
	+ if (mcfioC_Block(istream, MCFIO_HEPRUP, xdr_heprup_) == -1) {
	+ fprintf(stderr,
	+ " StdHepXdrWriteEventRUP: error filling stdhep block for event\n");
	+ return 2;
	+ }
	+ }
	+ if (mcfioC_NextEvent(istream) == -1) {
	+ fprintf(stderr," StdHepXdrWriteRUP: error writing event\n");
	+ return 1;
	+ }
	+ stdcnt_.nlhwrt = stdcnt_.nlhwrt + 1;
	+ return 0;
	+}
	+void StdHepXdrEnd(int ist)
	+{
	+ int inum, ieff;
	+
	+ int istream = stdstr_.ixdrstr[ist];
	+ mcfioC_InfoStreamInt(istream, MCFIO_NUMWORDS, &inum);
	+ mcfioC_InfoStreamInt(istream, MCFIO_EFFICIENCY, &ieff);
	+ mcfioC_Close(istream);
	+ fprintf(stdout,
	+ " StdHepXdrEnd: %d words i/o with %d efficiency\n",inum,ieff);
	+}
	+void StdHepPrintHeader( )
	+{
	+ fprintf(stdout," StdHep MCFio header information:\n");
	+ fprintf(stdout," title: %s\n",stdhd1_.title);
	+ fprintf(stdout," date: %s\n",stdhd1_.date);
	+ fprintf(stdout," %s\n",stdhd1_.comment);
	+ fprintf(stdout," %d blocks per event\n",stdhd2_.numblocks);
	+}
	Index: trunk/contrib/stdhep/stdhep_mcfio.h
	===================================================================
	--- trunk/contrib/stdhep/stdhep_mcfio.h (revision 0)
	+++ trunk/contrib/stdhep/stdhep_mcfio.h (revision 8889)
	@@ -0,0 +1,53 @@
	+#ifndef STDHEP_MCFIO_H
	+#define STDHEP_MCFIO_H
	+
	+/*******************************************************************************
	+* *
	+* stdhep_mcfio.h -- header for C version of mcfio interface routines *
	+* *
	+* Copyright (c) 1995 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Lynn Garren *
	+* *
	+* *
	+*******************************************************************************/
	+
	+/* prototypes */
	+#if defined(c_plusplus) \|\| defined(__cplusplus)
	+extern "C" {
	+#endif
	+
	+
	+int StdHepXdrReadInit(char *filename, int ntries, int ist);
	+int StdHepXdrReadOpen(char *filename, int ntries, int ist);
	+int StdHepXdrRead(int *ilbl, int ist);
	+int StdHepXdrReadMulti(int *ilbl, int ist);
	+int StdHepXdrWriteInit(char filename, char title, int ntries, int ist);
	+int StdHepXdrWriteOpen(char filename, char title, int ntries, int ist);
	+int StdHepXdrWrite(int ilbl, int ist);
	+int StdHepXdrWriteCM(int ilbl, int ist);
	+int StdHepXdrWriteEvent(int ilbl, int ist);
	+int StdHepXdrWriteEventLH(int ilbl, int ist);
	+int StdHepXdrWriteEventEUP(int ilbl, int ist);
	+int StdHepXdrWriteEventRUP(int ilbl, int ist);
	+void StdHepXdrEnd(int ist);
	+void StdHepPrintHeader( );
	+
	+#if defined(c_plusplus) \|\| defined(__cplusplus)
	+}
	+#endif
	+
	+#endif /* STDHEP_MCFIO_H */
	Index: trunk/contrib/stdhep/stdversn.f
	===================================================================
	--- trunk/contrib/stdhep/stdversn.f (revision 0)
	+++ trunk/contrib/stdhep/stdversn.f (revision 8889)
	@@ -0,0 +1,22 @@
	+ subroutine stdversn
	+C
	+C...print STDHEP version number
	+C
	+ include "stdver.inc"
	+ include "stdlun.inc"
	+ logical lfirst
	+ data lfirst/.TRUE./
	+ save lfirst
	+
	+ if(lfirst)then
	+ lfirst = .FALSE.
	+ stdhep_ver = '5.06.01'
	+ stdhep_date = 'November 20, 2007'
	+ write(lnhout,1001) stdhep_ver,stdhep_date
	+ endif
	+1001 format(//
	+ 1 10X,'********************************************************'/
	+ 2 10X,'* STDHEP version ',a7,' - ',a20,' *'/
	+ 3 10X,'********************************************************'//)
	+ return
	+ end
	Index: trunk/contrib/stdhep/stdver.h
	===================================================================
	--- trunk/contrib/stdhep/stdver.h (revision 0)
	+++ trunk/contrib/stdhep/stdver.h (revision 8889)
	@@ -0,0 +1,5 @@
	+/* stdhep version common block */
	+extern struct stdver {
	+char stdhep_ver[10]; /* stdhep version numver */
	+char stdhep_date[20]; /* date of this stdhep version */
	+} stdver_;
	Index: trunk/contrib/stdhep/stdxend.f
	===================================================================
	--- trunk/contrib/stdhep/stdxend.f (revision 0)
	+++ trunk/contrib/stdhep/stdxend.f (revision 8889)
	@@ -0,0 +1,16 @@
	+ subroutine stdxend(istream)
	+c
	+c end xdr tape writing
	+c
	+ implicit none
	+ include "mcfio.inc"
	+ include "stdlun.inc"
	+ integer istream,ieff,inum
	+c
	+ call mcfio_InfoStreamInt(istream, MCFIO_NUMWORDS, inum)
	+ call mcfio_InfoStreamInt(istream, MCFIO_EFFICIENCY, ieff)
	+ call mcfio_close(istream)
	+ write(lnhout,1001) inum,ieff
	+ return
	+1001 format(/10x,'STDXEND: ',i10,' words i/o with ',i8,' efficiency ')
	+ end
	Index: trunk/contrib/Makefile.am
	===================================================================
	--- trunk/contrib/Makefile.am (revision 0)
	+++ trunk/contrib/Makefile.am (revision 8889)
	@@ -0,0 +1,30 @@
	+## Makefile.am -- Makefile for WHIZARD data files
	+##
	+## Process this file with automake to produce Makefile.in
	+#
	+# Copyright (C) 1999-2023 by
	+# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	+# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	+# Juergen Reuter <juergen.reuter@desy.de>
	+# with contributions from
	+# cf. main AUTHORS file
	+#
	+# WHIZARD is free software; you can redistribute it and/or modify it
	+# under the terms of the GNU General Public License as published by
	+# the Free Software Foundation; either version 2, or (at your option)
	+# any later version.
	+#
	+# WHIZARD is distributed in the hope that it will be useful, but
	+# WITHOUT ANY WARRANTY; without even the implied warranty of
	+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	+# GNU General Public License for more details.
	+#
	+# You should have received a copy of the GNU General Public License
	+# along with this program; if not, write to the Free Software
	+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	+#
	+########################################################################
	+
	+## Subdirectories to configure
	+SUBDIRS = \
	+ mcfio stdhep pythia6 tauola
	Index: trunk/contrib/mcfio/mcf_ntuBldDbinc.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_ntuBldDbinc.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_ntuBldDbinc.h (revision 8889)
	@@ -0,0 +1,21 @@
	+/*
	+ * dbin.h
	+ *
	+ * C++ utility routines for the dbin package: see dbin.lex
	+ *
	+ * N.B. The Strings class from the CLHEP library is used.
	+ *
	+ * Torre Wenaus 04/01/1994
	+ *
	+ * Modifications:
	+ * 8/21/95 T. Wenaus Mod history started
	+ * 8/21/95 TW Strings class removed from dbin generated code.
	+ * 8/22/95 TW Strings class removed from dbinc.cc
	+ *
	+ * November 1995: some clean up to be able to run this code and
	+ * standard dbin simulateneously..
	+ * Make some routine & variable static, and change the name of routine
	+ * called from the outside, following the Nirvana/mcfio conventions.
	+ *
	+ */
	+void mcf_ntubldRead(char* fname);
	Index: trunk/contrib/mcfio/mcfio_UserDictionary.h
	===================================================================
	--- trunk/contrib/mcfio/mcfio_UserDictionary.h (revision 0)
	+++ trunk/contrib/mcfio/mcfio_UserDictionary.h (revision 8889)
	@@ -0,0 +1,25 @@
	+/*
	+** A small container to hold a set of user block declaration
	+**
	+* Written by Paul Lebrun, Aug 2001
	+*/
	+
	+typedef struct _aUserBlockDecl {
	+ int blkNum;
	+ char *title;
	+} aUserBlockDecl;
	+
	+typedef struct _allMCFIO_UserBlockDecl {
	+ int num;
	+ int numPreAlloc;
	+ aUserBlockDecl **decls;
	+}allMCFIO_UserBlockDecl ;
	+
	+extern allMCFIO_UserBlockDecl *AllMCFIO_UserBlockDecl;
	+
	+/*
	+** Internally used in mcfio. Return NULL if not on the list,
	+** otherwise return the point to the relevant title block.
	+*/
	+char *mcfioC_UserBlockDescript(int blkNum);
	+void mcfioC_DefineUserBlock(int blkN, char *descr);
	Index: trunk/contrib/mcfio/mcfio_Direct.c
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Direct.c (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Direct.c (revision 8889)
	@@ -0,0 +1,1029 @@
	+/*******************************************************************************
	+* *
	+* mcfio_Direct.c -- Utility routines for the McFast Monte-Carlo *
	+* Direct Access I/O core routines *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <sys/stat.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#include <stdlib.h>
	+#include <unistd.h>
	+#include <time.h>
	+#include <sys/mman.h>
	+#include <fcntl.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcfio_Dict.h"
	+#include "mcfio_Util1.h"
	+#include "mcfio_Direct.h"
	+#include "mcf_NTuIOFiles.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcfio_Sequential.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+#ifndef MAP_FILE
	+#define MAP_FILE 0
	+#endif
	+
	+extern nTuDDL **NTuDDLList;
	+extern int NumOfNTuples;
	+
	+
	+/* Static routine used in this module */
	+
	+static int mcfioC_gofornextevent(mcfStream *str);
	+static int mcfioC_nextspecevt(mcfStream *str, int inum, int istore,
	+ int irun, int itrig);
	+static int openReadDirect(char*filename, int mode);
	+
	+
	+int mcfioC_OpenReadDirect(char *filename)
	+{
	+/*
	+** Routine to open and read the header file for a Direct access Stream,
	+** Standard Unix I/O
	+*/
	+ return openReadDirect(filename, MCFIO_DIRECT);
	+}
	+
	+int mcfioC_OpenReadMapped(char *filename)
	+{
	+/*
	+** Routine to open and read the header file for a Direct access Stream,
	+** Standard Unix I/O
	+*/
	+ return openReadDirect(filename, MCFIO_MEMMAPPED);
	+}
	+
	+static int openReadDirect(char *filename, int mode)
	+/*
	+** Routine to open and read the header file for a Direct access Stream.
	+*/
	+{
	+ int i, j, jstr, idtmp, ntot, ll1, jdRef, oldNumOfNTuples;
	+ int iff;
	+ u_int p1, p2;
	+ FILE *ff;
	+ mcfStream *str;
	+ nTuDDL ddl, ddlRef;
	+ struct stat statbuf;
	+ char *srcFile;
	+
	+
	+ if (McfStreamPtrList == NULL) mcfioC_Init();
	+
	+ if (McfNumOfStreamActive >= MCF_STREAM_NUM_MAX) {
	+ fprintf(stderr,
	+ " mcfio_OpenReadDirect: Too many streams opened simultaneously.\n");
	+ return -1;
	+ }
	+ jstr = -1; i=0;
	+ while ((jstr == -1) && (i<MCF_STREAM_NUM_MAX)) {
	+ if (McfStreamPtrList[i] == NULL) jstr=i;
	+ i++;
	+ }
	+ if(jstr == -1) {
	+ fprintf(stderr,
	+ " mcfio_OpenReadDirect: Internal error, please report \n");
	+ return -1;
	+ }
	+ if ((filename == NULL) \|\| (strlen(filename) > 255)) {
	+ fprintf(stderr,
	+ " mcfio_OpenReadDirect: You must give a valid UNIX filename.\n");
	+ return -1;
	+ }
	+ /*
	+ ** Now we can try to open this file....
	+ */
	+ if (mode == MCFIO_DIRECT) {
	+ ff = fopen(filename, "r");
	+ if (ff == NULL) {
	+ fprintf(stderr,
	+ " mcfio_OpenReadDirect: Problem opening file %s, message \n", filename);
	+ perror ("mcfio_OpenReadDirect");
	+ return -1;
	+ }
	+ } else {
	+ /*
	+ ** Using memory mapped i/o
	+ */
	+ iff = open(filename, O_RDONLY);
	+ if (iff < 0) {
	+ fprintf(stderr,
	+ " mcfio_OpenReadMapped: Problem opening file %s, message \n", filename);
	+ perror ("mcfio_OpenReadMapped");
	+ return -1;
	+ }
	+ }
	+ McfStreamPtrList[jstr] = (mcfStream *) malloc(sizeof(mcfStream));
	+ str = McfStreamPtrList[jstr];
	+ str->xdr = (XDR *) malloc(sizeof(XDR));
	+ str->id = jstr+1;
	+ str->row = MCFIO_READ;
	+ str->dos = mode;
	+ str->numWordsC = 0;
	+ str->numWordsT = 0;
	+ ll1 = strlen(filename) + 1;
	+ str->filename = (char ) malloc(sizeof(char) ll1);
	+ strcpy(str->filename,filename);
	+ if (mode == MCFIO_DIRECT) {
	+ str->filePtr = ff;
	+ xdrstdio_create(str->xdr, ff, XDR_DECODE);
	+ str->fileDescr = 0;
	+ str->fileAddr = NULL;
	+ str->fileLen = 0;
	+ } else {
	+ /*
	+ ** Use memory mapped I/O
	+ */
	+ if (fstat(iff, &statbuf) < 0) {
	+ fprintf (stderr,
	+ " mcfio_OpenReadMapped: Problem getting file length for %s \n", filename);
	+ perror ("mcfio_OpenReadMapped");
	+ return -1;
	+ }
	+ if ((srcFile =
	+ mmap(0, statbuf.st_size, PROT_READ, MAP_FILE \| MAP_SHARED, iff, 0 ))
	+ == (caddr_t) -1) {
	+ fprintf (stderr,
	+ " mcfio_OpenReadMapped: Problem with memory mapping for %s \n", filename);
	+ perror ("mcfio_OpenReadMapped");
	+ return -1;
	+ }
	+ str->filePtr = (FILE *) NULL;
	+ str->fileDescr = iff;
	+ str->fileAddr = srcFile;
	+ str->fileLen = (size_t) statbuf.st_size;
	+ xdrmem_create(str->xdr, srcFile, statbuf.st_size, XDR_DECODE);
	+ }
	+ str->device = NULL;
	+ str->vsn = NULL;
	+ str->filenumber = -1;
	+ str->minlrec = -1;
	+ str->maxlrec = -1;
	+ str->shead = NULL;
	+ str->ehead = NULL;
	+ str->table = NULL;
	+ str->buffer = NULL;
	+ str->buffer2 = NULL;
	+ p1 = xdr_getpos(str->xdr);
	+ str->firstPos = p1;
	+ str->status = MCFIO_BOF;
	+ str->fhead = NULL;
	+ oldNumOfNTuples = NumOfNTuples;
	+ if (xdr_mcfast_fileheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->fhead), str->id) == FALSE) {
	+ fprintf (stderr,
	+ "mcfio_OpenReadDirect: Unable to decode fileheader \n");
	+ mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	+ mcfioC_Close(jstr+1);
	+ return -1;
	+ }
	+ if (idtmp != FILEHEADER) {
	+ fprintf (stderr,
	+ "mcfio_OpenReadDirect: First Structure not the header \n");
	+
	+ fprintf (stderr,
	+ " : Further accesses probably suspicious \n");
	+ mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	+ mcfioC_Close(jstr+1);
	+ return -1;
	+ }
	+ p2 = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ /*
	+ ** Check if new these Ntuple template are not reference, if so,
	+ ** set the reference pointer accordingly, conversely, recompute the
	+ ** offsets and length if requested. We also fill the sequential
	+ ** id number for the descriptors. Note: those are trivial for
	+ ** input streams, but we still fill them for consitency.
	+ */
	+ for (i=0; i<str->fhead->nNTuples; i++) {
	+ ddl = mcf_GetNTuByPtrID((oldNumOfNTuples+i+1));
	+ if (ddl == NULL) continue;
	+ ddl->streamId = (jstr+1);
	+ ddl->seqNTuId = (i+1);
	+ if (ddl->descrNtu == NULL) {
	+ for (j=0, jdRef=1; j<i; j++, jdRef++) {
	+ if (jdRef == ddl->referenceId) {
	+ ddlRef = mcf_GetNTuByPtrID((oldNumOfNTuples+j+1));
	+ /*
	+ ** back up in the linked list if need be, until we
	+ ** a fully documented descriptor.
	+ */
	+ while (ddlRef->descrNtu == NULL) ddlRef = ddlRef->reference;
	+ ddl->reference = ddlRef;
	+ break;
	+ }
	+ }
	+ } else {
	+ if (McfNTuPleSaveDecoding == TRUE) {
	+ mcf_ComputeNTuOffsets(ddl);
	+ mcf_ComputeNTuLengths(ddl);
	+ }
	+ }
	+ }
	+ str->currentPos = p2;
	+ str->fhead->firstTable = p2;
	+ /* presumably correct , assume standard direct acces file config. */
	+ str->numWordsT += ((p2-p1)/4);
	+ str->status = MCFIO_RUNNING;
	+ str->table = (mcfxdrEventTable *) malloc(sizeof(mcfxdrEventTable));
	+ str->table->nextLocator = -1;
	+ str->table->dim = str->fhead->dimTable;
	+ str->table->numevts = 0;
	+ str->table->previousnumevts = 0;
	+ str->table->evtnums = NULL;
	+ str->table->storenums = NULL;
	+ str->table->runnums = NULL;
	+ str->table->trigMasks = NULL;
	+ str->table->ptrEvents = NULL;
	+ str->ehead = (mcfxdrEventHeader *) malloc(sizeof(mcfxdrEventHeader));
	+ str->ehead->dimBlocks = str->fhead->nBlocks;
	+ str->ehead->blockIds = NULL;
	+ str->ehead->ptrBlocks = NULL;
	+ str->ehead->dimNTuples = str->fhead->nNTuples;
	+ str->ehead->nTupleIds = NULL;
	+ str->ehead->ptrNTuples = NULL;
	+ McfNumOfStreamActive++;
	+ return (jstr+1);
	+}
	+
	+int mcfioC_OpenWriteDirect(char filename, char title, char *comment,
	+ int numevts_pred, int *blkIds, u_int nBlocks)
	+
	+/*
	+** Routine to open and write the header file for a Direct access Stream.
	+*/
	+{
	+ int i, jstr, idtmp, ntot;
	+ u_int p1, p2;
	+ FILE *ff;
	+ mcfStream *str;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: We will first initialize by calling mcfio_Init.\n");
	+ mcfioC_Init();
	+ }
	+ if (McfNumOfStreamActive >= MCF_STREAM_NUM_MAX) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: Too many streams opened simultaneously.\n");
	+ return -1;
	+ }
	+ jstr = -1; i=0;
	+ while ((jstr == -1) && (i<MCF_STREAM_NUM_MAX)) {
	+ if (McfStreamPtrList[i] == NULL) jstr=i;
	+ i++;
	+ }
	+ if(jstr == -1) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: Internal error, please report \n");
	+ return -1;
	+ }
	+ if ((filename == NULL) \|\| (strlen(filename) > 255)) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: You must give a valid UNIX filename.\n");
	+ return -1;
	+ }
	+ if ((title != NULL) && (strlen(title) > 255)) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: Title is too long\n");
	+ return -1;
	+ }
	+
	+ if ((comment != NULL) && (strlen(comment) > 255)) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: comment is too long\n");
	+ return -1;
	+ }
	+
	+ /*
	+ ** Now we can try to open this file....
	+ */
	+ ff = fopen(filename, "w");
	+ if (ff == NULL) {
	+ fprintf(stderr,
	+ " mcfio_OpenWriteDirect: Problem opening file %s, message \n", filename);
	+ perror ("mcfio_OpenWriteDirect");
	+ return -1;
	+ }
	+ McfStreamPtrList[jstr] = (mcfStream *) malloc(sizeof(mcfStream));
	+ str = McfStreamPtrList[jstr];
	+ str->xdr = (XDR *) malloc(sizeof(XDR));
	+ str->id = jstr+1;
	+ str->row = MCFIO_WRITE;
	+ str->dos = MCFIO_DIRECT;
	+ str->numWordsC = 0;
	+ str->numWordsT = 0;
	+ str->filename = (char ) malloc(sizeof(char) ( strlen(filename) +1) );
	+ strcpy(str->filename,filename);
	+ str->filePtr = ff;
	+ str->device = NULL;
	+ str->vsn = NULL;
	+ str->filenumber = -1;
	+ str->minlrec = -1;
	+ str->maxlrec = -1;
	+ str->shead = NULL;
	+ str->ehead = NULL;
	+ str->table = NULL;
	+ str->buffer = NULL;
	+ str->buffer2 = NULL;
	+ xdrstdio_create(str->xdr, ff, XDR_ENCODE);
	+ p1 = xdr_getpos(str->xdr);
	+ str->firstPos = p1;
	+ str->currentPos = p1;
	+ str->status = MCFIO_BOF;
	+ str->fhead = (mcfxdrFileHeader *) malloc(sizeof(mcfxdrFileHeader));
	+ /*
	+ ** Fill the file header, additional info will be written on tape
	+ */
	+ if (title == NULL) strcpy(str->fhead->title,"No Title given");
	+ else strcpy(str->fhead->title,title);
	+
	+ if (comment == NULL) strcpy(str->fhead->comment,"No comment");
	+ else strcpy(str->fhead->comment, comment);
	+ str->fhead->numevts_expect = numevts_pred;
	+ str->fhead->numevts = 0;
	+ /*
	+ ** Futur expansion : make this a tunable parameter.
	+ */
	+ str->fhead->dimTable = MCF_DEFAULT_TABLE_SIZE;
	+ str->fhead->firstTable = -1;
	+ str->fhead->nBlocks = nBlocks;
	+ if (nBlocks > 0) {
	+ str->fhead->blockIds = (int ) malloc(sizeof(int) nBlocks);
	+ str->fhead->blockNames = (char*) malloc(sizeof(char ) * nBlocks);
	+ } else {
	+ str->fhead->blockIds = NULL;
	+ str->fhead->blockNames = NULL;
	+ }
	+ for (i=0; i<nBlocks; i++) {
	+ str->fhead->blockIds[i] = blkIds[i];
	+ str->fhead->blockNames[i] =
	+ (char ) malloc(sizeof(char) (MCF_XDR_B_TITLE_LENGTH + 1));
	+ mcfioC_GetBlockName(blkIds[i], str->fhead->blockNames[i]);
	+ }
	+ str->fhead->nNTuples = 0; /* Will be filled later */
	+ if (mcfioC_Wrtfhead(str, INITIATE) == FALSE){
	+ mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	+ fclose(ff);
	+ return -1;
	+ }
	+ str->table = (mcfxdrEventTable *) malloc(sizeof(mcfxdrEventTable));
	+ str->table->numevts=-1;
	+ str->table->nextLocator = -1;
	+ str->table->evtnums = (int ) malloc(sizeof(int) str->fhead->dimTable);
	+ str->table->storenums = (int ) malloc(sizeof(int) str->fhead->dimTable);
	+ str->table->runnums = (int ) malloc(sizeof(int) str->fhead->dimTable);
	+ str->table->trigMasks = (int ) malloc(sizeof(int) str->fhead->dimTable);
	+ str->table->ptrEvents =
	+ (u_int ) malloc(sizeof(int) str->fhead->dimTable);
	+ /*
	+ ** Write the first dummy table
	+ */
	+ if (mcfioC_Wrttable(str, INITIATE) == FALSE) return -1;
	+ str->ehead = (mcfxdrEventHeader *) malloc(sizeof(mcfxdrEventHeader));
	+ str->ehead->dimBlocks = str->fhead->nBlocks;
	+ str->ehead->nBlocks = 0;
	+ str->ehead->dimNTuples = 0;
	+ str->ehead->nNTuples = 0;
	+ str->ehead->evtnum = 0;
	+ str->ehead->previousevtnum = 0;
	+ str->ehead->storenum = 0;
	+ str->ehead->runnum = 0;
	+ str->ehead->trigMask = 0;
	+ str->ehead->nTupleIds = NULL;
	+ str->ehead->ptrNTuples = NULL;
	+ if (nBlocks > 0) {
	+ str->ehead->blockIds =
	+ (int ) malloc(sizeof(int) str->fhead->nBlocks);
	+ str->ehead->ptrBlocks =
	+ (u_int ) malloc(sizeof(int) str->fhead->nBlocks);
	+ } else {
	+ str->ehead->blockIds = NULL;
	+ str->ehead->ptrBlocks = NULL;
	+ }
	+ /*
	+ ** Write the first dummy event header
	+ */
	+ if (mcfioC_WrtEvt(str, INITIATE) == FALSE) return -1;
	+ str->ehead->evtnum = 0;
	+ str->status = MCFIO_RUNNING;
	+ McfNumOfStreamActive++;
	+ return (jstr+1);
	+
	+}
	+
	+int mcfioC_NextEvent(int stream)
	+/*
	+** The Core routine for getting or setting the next event d.s. from/to
	+** a stream.
	+**
	+*/
	+{
	+ int i, jstr, idtmp, ntot, nn1;
	+ u_int p_evt, p1, p2, *p_ptr;
	+ mcfStream *str;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: You must first initialize by calling mcfio_Init.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str->dos == MCFIO_SEQUENTIAL) return mcfioC_NextEventSequential(stream);
	+ if (str->row == MCFIO_READ) {
	+ /*
	+ ** Read the next event, hunt for either an event or a table of event
	+ ** if event table not available.
	+ */
	+ if ((str->table == NULL) \|\|
	+ ((str->table != NULL)&& (str->table->evtnums == NULL))) {
	+ idtmp = mcfioC_gofornextevent(str);
	+ if (idtmp != EVENTTABLE) {
	+ if (str->table !=NULL)
	+ mcfioC_Free_EventTable(&(str->table));
	+ if (idtmp == NOTHING) return -1;
	+ p_evt = str->currentPos;
	+ } else {
	+ if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: XDR Error decoding the EventTable \n");
	+ return -1;
	+ }
	+ p2 = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((p2-str->currentPos)/4);
	+ str->currentPos = p2;
	+ str->table->ievt = 0;
	+ /*
	+ ** If table empty, cal this routine recursively to get
	+ ** the next event
	+ */
	+ if (str->table->numevts <= 0) {
	+ if (str->table->nextLocator == -1)
	+ mcfioC_Free_EventTable(&(str->table));
	+ return mcfioC_NextEvent(str->id);
	+ }
	+ p_evt = str->table->ptrEvents[0];
	+ }
	+ } else {
	+ if (str->table->ievt < str->table->numevts) {
	+ p_evt = str->table->ptrEvents[str->table->ievt];
	+ } else {
	+ /*
	+ ** decode the next table, if valid. If not, scrap the
	+ ** existing table and call next event recursively.
	+ */
	+ if (str->table->nextLocator == -2) {
	+ /*
	+ ** Stream is at EOF
	+ */
	+ str->status = MCFIO_EOF;
	+ return MCFIO_EOF;
	+ } else if (str->table->nextLocator == -1) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: Corrupted Event Table \n");
	+ return -1;
	+ }
	+ if (xdr_setpos(str->xdr, str->table->nextLocator) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: Error Repositioning stream \n");
	+ return -1;
	+ }
	+ if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: XDR Error decoding the EventTable \n");
	+ return -1;
	+ }
	+ p2 = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((p2-str->currentPos)/4);
	+ str->currentPos = p2;
	+ str->table->ievt = 0;
	+ p_evt = str->table->ptrEvents[0];
	+ }
	+ }
	+ /*
	+ ** we should be pointing to a good event header here.
	+ */
	+ if (xdr_setpos(str->xdr, p_evt) == FALSE) return -1;
	+ if( xdr_mcfast_eventheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return -1;
	+ str->currentPos = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((str->currentPos - p_evt)/4);
	+ if (str->table != NULL) str->table->ievt ++;
	+ return MCFIO_RUNNING;
	+ } else {
	+ /*
	+ ** Writing Code here.
	+ */
	+ str->table->numevts++;
	+ str->fhead->numevts++;
	+ if (str->ehead->previousevtnum == str->ehead->evtnum) str->ehead->evtnum++;
	+ /*
	+ ** Write the current event header, normal case. First Flush the current
	+ ** event, then initiate the next one event. Note that wrtevt will
	+ ** reposition the stream after rewriting the event header, if FLUSH.
	+ ** e.g. ready to initiate either a new table or a new event.
	+ */
	+ if (mcfioC_WrtEvt(str, FLUSH) == FALSE) return -1;
	+ str->ehead->previousevtnum = str->ehead->evtnum;
	+ if (str->table->numevts == (str->fhead->dimTable - 1)) {
	+ /*
	+ ** The Event table is now full. Flush it. Then initiate a new table.
	+ */
	+ str->table->nextLocator = xdr_getpos(str->xdr);
	+ if (mcfioC_Wrttable(str, FLUSH) == FALSE) return -1;
	+ if (mcfioC_Wrttable(str, INITIATE) == FALSE) return -1;
	+ }
	+ str->ehead->nBlocks = 0;
	+ str->ehead->nNTuples = 0;
	+ nn1 = str->ehead->evtnum;
	+ if (mcfioC_WrtEvt(str, INITIATE) == FALSE) return -1;
	+ str->ehead->evtnum = nn1;
	+ return MCFIO_RUNNING;
	+ }
	+}
	+
	+int mcfioC_SpecificEvent(int stream, int ievt,
	+ int istore, int irun, int itrig)
	+{
	+ int i, jstr, idtmp, ntot, ok, nn1;
	+ u_int p_evt, p1, p2, *p_ptr;
	+ mcfStream *str;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_SpecificEvent: You must first initialize by calling mcfio_Init.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_SpecificEvent: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if ((str->row != MCFIO_READ) \|\| (str->dos == MCFIO_SEQUENTIAL)) {
	+ fprintf(stderr,
	+" mcfio_SpecificEvent: Only valid for INPUT, DIRECT ACCESS \
	+ or Memory Mapped \n");
	+ return -1;
	+ }
	+ if (xdr_setpos(str->xdr, str->fhead->firstTable) == FALSE ) {
	+ fprintf(stderr,
	+ " mcfio_SpecificEvent: Could not reposition Direct Access Stream %d \n",
	+ (jstr+1)) ;
	+ return -1;
	+ }
	+ str->currentPos = str->fhead->firstTable;
	+
	+ ok = mcfioC_nextspecevt(str, ievt, istore, irun, itrig);
	+ if (ok == FALSE) {
	+ mcfioC_RewindDirect(jstr);
	+ if (xdr_setpos(str->xdr, str->fhead->firstTable) == FALSE ) {
	+ fprintf(stderr,
	+ " mcfio_SpecificEvent: Could not reposition Direct Access Stream %d \n",
	+ (jstr+1)) ;
	+ return -1;
	+ }
	+ str->currentPos = str->fhead->firstTable;
	+ ok = mcfioC_nextspecevt(str, ievt, istore, irun, itrig);
	+ }
	+ if (ok == FALSE) return -1;
	+ return ok;
	+
	+}
	+int mcfioC_NextSpecificEvent(int stream, int ievt,
	+ int istore, int irun, int itrig)
	+{
	+ int i, jstr, idtmp, ntot, ok, nn1;
	+ u_int p_evt, p1, p2, *p_ptr;
	+ mcfStream *str;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NextSpecific: You must first initialize by calling mcfio_Init.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NextSpecific: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if ((str->row != MCFIO_READ) \|\| (str->dos == MCFIO_SEQUENTIAL)) {
	+ fprintf(stderr,
	+ " mcfio_NextSpecificEvent: Only valid for INPUT, DIRECT ACCESS\
	+ or memory mapped I/O \n");
	+ return -1;
	+ }
	+ ok = mcfioC_nextspecevt(str, ievt, istore, irun, itrig);
	+ if (ok == FALSE) return -1;
	+ return ok;
	+
	+}
	+
	+
	+void mcfioC_CloseDirect(int jstr)
	+/*
	+** Close a direct access stream, Standard I/O or Memory Mapped
	+**
	+*/
	+{
	+ int i, idtmp, ntot;
	+ u_int p1, p2, *p_ptr;
	+ FILE *ff;
	+ mcfStream *str;
	+ nTuDDL *ddl;
	+
	+ str = McfStreamPtrList[jstr];
	+ if (str->row == MCFIO_WRITE) {
	+ /*
	+ ** Flush the event header, and the last table header.
	+ */
	+ if (str->status == MCFIO_RUNNING) {
	+ str->table->numevts++;
	+ str->ehead->evtnum++;
	+ if (mcfioC_WrtEvt(str, FLUSH) == FALSE) return;
	+ str->table->nextLocator = -2;
	+ str->table->numevts--; /* Decrement, the table is incomplete at
	+ this point */
	+ if (mcfioC_Wrttable(str, FLUSH) == FALSE) return;
	+ if (mcfioC_Wrtfhead(str, FLUSH) == FALSE) return;
	+ }
	+ }
	+ xdr_destroy(str->xdr);
	+ if (str->dos == MCFIO_DIRECT) {
	+ fclose(str->filePtr);
	+ } else {
	+ /*
	+ ** Memory mapped I/O, one has to unmapped..
	+ */
	+ munmap((caddr_t) str->fileAddr, str->fileLen);
	+ close(str->fileDescr);
	+ }
	+ /*
	+ ** One must declare the Ntuples obsolete for this stream.
	+ ** Do not release the memory, just flag these Ntuple with an obsolete
	+ ** stream
	+ */
	+ for (i=0; i<NumOfNTuples; i++) {
	+ ddl = mcf_GetNTuByPtrID((i+1));
	+ if ((ddl != NULL) && (ddl->streamId == (jstr+1)))
	+ ddl->streamId = -1;
	+ }
	+}
	+
	+void mcfioC_RewindDirect(int jstr)
	+/*
	+** Rewind a direct access stream, open for Read only
	+**
	+*/
	+{
	+ mcfStream *str;
	+
	+ str = McfStreamPtrList[jstr];
	+ if (xdr_setpos(str->xdr, str->fhead->firstTable) == FALSE )
	+ fprintf(stderr,
	+ " mcfio_Rewind: Could not reposition Direct Access Stream %d \n",
	+ (jstr+1)) ;
	+ str->currentPos = str->fhead->firstTable;
	+ if (str->table != NULL) {
	+ str->table->nextLocator = str->fhead->firstTable;
	+ str->table->numevts = 0;
	+ str->table->previousnumevts = 0;
	+ }
	+ if (str->ehead != NULL) {
	+ str->ehead->evtnum = 0;
	+ str->ehead->previousevtnum = 0;
	+ }
	+ return;
	+}
	+
	+int mcfioC_Wrtfhead(mcfStream *str, int mode)
	+/*
	+** Write the file header.
	+** IF Mode = INITIATE, write the dummy information, at the current location.
	+** IF mode = Flush, rewite all the information, this time with the
	+** correct number of events.
	+**
	+*/
	+{
	+ int idtmp, ntot;
	+ u_int p1, p0;
	+ int k;
	+ time_t clock;
	+
	+ idtmp = FILEHEADER;
	+ if (mode == FLUSH) {
	+ time(&clock);
	+ strcpy(str->fhead->closingDate, ctime(&clock));
	+ if(xdr_setpos(str->xdr,str->firstPos) == FALSE) return FALSE;
	+ if (xdr_mcfast_fileheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->fhead), str->id) == FALSE) {
	+ fprintf (stderr,
	+ "mcfio_OpenCloseDirect: Unable to reencode file head \n");
	+ return FALSE;
	+ }
	+ /*
	+ ** The version of MCFIO is still at this point v2.0
	+ */
	+ } else if (mode == INITIATE) {
	+ /* Put the current date/time in a string */
	+ time(&clock);
	+ strcpy(str->fhead->date, ctime(&clock));
	+ /*
	+ ** We obviously do not have the closing times stamp yet (Causality)
	+ ** So we put ?, however, we have to put the right number of them,
	+ ** the we do not screw up the XDR pointers..
	+ */
	+ for (k=0; k<strlen(ctime(&clock)); k++) str->fhead->closingDate[k] = '?';
	+ str->fhead->closingDate[strlen(ctime(&clock))] = '\0';
	+ p0 = str->currentPos;
	+ if (xdr_mcfast_fileheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->fhead), str->id) == FALSE) {
	+ fprintf (stderr,
	+ "mcfio_OpenWriteDirect: Unable to encode fileheader \n");
	+ return FALSE;
	+ }
	+ p1 = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((p1-p0)/4);
	+ str->currentPos = p1;
	+ return TRUE;
	+ } else {
	+ fprintf(stderr," mcfioC_Wrtfhead: Internal error, lost mode \n");
	+ return FALSE;
	+ }
	+ return TRUE;
	+}
	+
	+
	+int mcfioC_WrtEvt(mcfStream *str, int mode)
	+/*
	+** Write an event header, and update the table. Presumably, we have room
	+** in this table to do so.
	+** IF Mode = INITIATE, write the dummy event header, at the current location.
	+** Do not fill the element table.
	+** If mode = FLUSH write the real event header and also
	+** fill the Table elements.
	+**
	+*/
	+{
	+ int i, idtmp, ntot;
	+ u_int p1, p0;
	+
	+ idtmp = EVENTHEADER;
	+ if (mode == FLUSH) {
	+ str->table->evtnums[str->table->numevts] = str->ehead->evtnum;
	+ str->table->storenums[str->table->numevts] = str->ehead->storenum;
	+ str->table->runnums[str->table->numevts] = str->ehead->runnum;
	+ str->table->trigMasks[str->table->numevts] = str->ehead->trigMask;
	+ str->table->ptrEvents[str->table->numevts] = str->evtPos;
	+ p0 = str->currentPos;
	+ if(xdr_setpos(str->xdr,str->evtPos) == FALSE) return FALSE;
	+ p1 = str->evtPos;
	+ if(xdr_mcfast_eventheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return FALSE;
	+ str->currentPos = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((str->currentPos-p1)/4);
	+ if(xdr_setpos(str->xdr,p0) == FALSE) return FALSE;
	+ str->currentPos = p0;
	+ str->ehead->nBlocks = 0;
	+ str->ehead->nNTuples = 0;
	+ return TRUE;
	+ } else if (mode == INITIATE) {
	+ str->ehead->nBlocks = 0; /do not initialize nNTuples, already done /
	+ str->ehead->evtnum = -1;
	+ str->evtPos = xdr_getpos(str->xdr);
	+
	+ if(xdr_mcfast_eventheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return FALSE;
	+ str->currentPos = xdr_getpos(str->xdr);
	+ return TRUE;
	+ } else {
	+ fprintf(stderr," mcfioC_WrtEvt: Internal error, lost mode \n");
	+ return FALSE;
	+ }
	+}
	+
	+int mcfioC_Wrttable(mcfStream *str, int mode)
	+/*
	+** Write an event table.
	+** IF Mode = INITIATE, write the dummy event table, at the current location.
	+** Do not fill the element table.
	+** If mode = FLUSH write the real event header and also
	+** fill the Table elements.
	+**
	+*/
	+{
	+ int idtmp, ntot;
	+ u_int p1, p0;
	+
	+ idtmp = EVENTTABLE;
	+ str->table->dim = str->fhead->dimTable;
	+ if (mode == FLUSH) {
	+ p0 = str->currentPos;
	+ if(xdr_setpos(str->xdr,str->tablePos) == FALSE) return FALSE;
	+ p1 = str->tablePos;
	+ str->table->numevts++;
	+ if(xdr_mcfast_eventtable(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->table)) == FALSE) return FALSE;
	+ str->currentPos = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((str->currentPos-p1)/4);
	+ if(xdr_setpos(str->xdr,p0) == FALSE) return FALSE;
	+ str->currentPos = p0;
	+ str->tablePos = -1;
	+ str->table->nextLocator = -1;
	+ str->table->numevts=-1;
	+ return TRUE;
	+ } else if (mode == INITIATE) {
	+ str->tablePos = xdr_getpos(str->xdr);
	+ str->table->nextLocator = -1;
	+ if(xdr_mcfast_eventtable(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->table)) == FALSE) return FALSE;
	+ str->currentPos = xdr_getpos(str->xdr);
	+ return TRUE;
	+ } else {
	+ fprintf(stderr," mcfioC_Wrttable: Internal error, lost mode \n");
	+ return FALSE;
	+ }
	+}
	+
	+static int mcfioC_gofornextevent(mcfStream *str)
	+/*
	+** Move in the direct access file to the next event or event table,
	+** whatever comes first. The XDR current position is set to the beginning
	+** of the event header or event table, if search sucessfull.
	+** We position the stream to the last Block or Ntuple defined in
	+** the current event.
	+*/
	+{
	+ u_int p1, p2;
	+ int id, ntot, go;
	+
	+ go = TRUE;
	+
	+ while (go == TRUE) {
	+ p1 = xdr_getpos(str->xdr);
	+ if (xdr_mcfast_headerBlock(str->xdr, &id, &ntot, McfGenericVersion)
	+ == FALSE) return NOTHING;
	+ if ((id == EVENTTABLE) \|\| (id == EVENTHEADER)) {
	+ str->currentPos = p1;
	+ if(xdr_setpos(str->xdr, p1) == FALSE) return NOTHING;
	+ return id;
	+ }
	+ }
	+ return NOTHING; /* This statement is to make the compiler happy */
	+}
	+
	+static int mcfioC_nextspecevt(mcfStream *str, int inum, int istore,
	+ int irun, int itrig)
	+/*
	+** For Input, Direct access streams, hunt for a psecific event
	+**
	+*/
	+{
	+ int i, jstr, j, idtmp, ntot, found;
	+ u_int p_evt, p1, p2, *p_ptr;
	+
	+ if ((str->table == NULL) \|\|
	+ ((str->table != NULL)&& (str->table->evtnums == NULL))) {
	+ idtmp = mcfioC_gofornextevent(str);
	+ if (idtmp != EVENTTABLE) {
	+ fprintf(stderr,
	+ " mcfio_SpecificEvent: No event table on stream %d \n", str->id);
	+ return FALSE;
	+ } else {
	+ if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_SpecificEvent: XDR Error decoding the EventTable \n");
	+ return FALSE;
	+ }
	+ p2 = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((p2-str->currentPos)/4);
	+ str->currentPos = p2;
	+ str->table->ievt = 0;
	+ /*
	+ ** If table empty, cal this routine recursively to get
	+ ** the next event
	+ */
	+ str->table->ievt = 0;
	+ }
	+ }
	+ found = FALSE;
	+ while (found == FALSE){
	+ j = str->table->ievt;
	+ if (str->table->ievt < str->table->numevts) {
	+ if (((inum == 0)
	+ \|\| ( inum != 0 && (str->table->evtnums[j] == inum))) &&
	+ (((istore == 0)
	+ \|\| (istore != 0) && (str->table->storenums[j] == istore))) &&
	+ (((irun == 0)
	+ \|\| (irun != 0) && (str->table->runnums[j] == irun))) &&
	+ (((itrig == 0)
	+ \|\| (itrig != 0) && (str->table->trigMasks[j] == itrig))))
	+ found = TRUE;
	+ p_evt = str->table->ptrEvents[str->table->ievt];
	+ str->table->ievt++;
	+ } else {
	+ /*
	+ ** decode the next table, if valid. If not, scrap the
	+ ** existing table and call next event recursively.
	+ */
	+ if (str->table->nextLocator == -2) {
	+ /*
	+ ** Stream is at EOF
	+ */
	+ str->status = MCFIO_EOF;
	+
	+ return FALSE;
	+
	+ } else if (str->table->nextLocator == -1) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: Next EventTable corrupted, abandoning search \n");
	+ return FALSE;
	+ }
	+ if (xdr_setpos(str->xdr, str->table->nextLocator)
	+ == FALSE) { fprintf(stderr,
	+ " mcfio_NextEvent: XDR Error repositioning to the next EventTable \n");
	+ return FALSE;
	+ } else {
	+ if( xdr_mcfast_eventtable(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->table)) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NextEvent: XDR Error decoding the EventTable \n");
	+ return FALSE;
	+ }
	+ }
	+ p2 = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((p2-str->currentPos)/4);
	+ str->currentPos = p2;
	+ str->table->ievt = 0;
	+ p_evt = str->table->ptrEvents[0];
	+ }
	+ }
	+ if (found == FALSE) return FALSE;
	+ /*
	+ ** we should be pointing to a good event header here.
	+ */
	+ if (xdr_setpos(str->xdr, p_evt) == FALSE) return FALSE;
	+ if( xdr_mcfast_eventheader(str->xdr, &idtmp,
	+ &ntot, McfGenericVersion, &(str->ehead)) == FALSE) return FALSE;
	+ str->currentPos = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((str->currentPos - p_evt)/4);
	+ return MCFIO_RUNNING;
	+
	+}
	Index: trunk/contrib/mcfio/mcf_ntubld_db.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_ntubld_db.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_ntubld_db.h (revision 8889)
	@@ -0,0 +1,59 @@
	+#ifndef _mcf_tmp_INC
	+#define _mcf_tmp_INC
	+
	+
	+/*** template line_title ***/
	+
	+typedef struct _line_title_s {
	+ char line[80]; /* */
	+} line_title_s;
	+static const int n_el_line_title=1;
	+extern struct line_title_c {
	+ int n_obj_line_title;
	+ int idmline_title;
	+ line_title_s line_title[500];
	+} line_title_c_;
	+static int *n_obj_line_title = &(line_title_c_.n_obj_line_title);
	+static line_title_s *line_title = &line_title_c_.line_title[0];
	+
	+/*** template header ***/
	+
	+typedef struct _header_s {
	+ char title[80]; /* */
	+ char version[80]; /* */
	+ char namemaxindex[80]; /* */
	+ int maxmult; /* */
	+ int orgstyle; /* */
	+ int nvar; /* */
	+} header_s;
	+static const int n_el_header=6;
	+extern struct header_c {
	+ int n_obj_header;
	+ int idmheader;
	+ header_s header[1];
	+} header_c_;
	+static int *n_obj_header = &(header_c_.n_obj_header);
	+static header_s *header = &header_c_.header[0];
	+
	+/*** template variable ***/
	+
	+typedef struct _variable_s {
	+ char name[80]; /* */
	+ char description[80]; /* */
	+ int type; /* */
	+ char isfixedsize[80]; /* */
	+ int numdim; /* */
	+ int dimensions[5]; /* */
	+} variable_s;
	+static const int n_el_variable=10;
	+extern struct variable_c {
	+ int n_obj_variable;
	+ int idmvariable;
	+ variable_s variable[100];
	+} variable_c_;
	+static int *n_obj_variable = &(variable_c_.n_obj_variable);
	+static variable_s *variable = &variable_c_.variable[0];
	+
	+#endif
	+
	+void mcf_ntubldInit();
	Index: trunk/contrib/mcfio/mcf_xdr.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_xdr.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_xdr.h (revision 8889)
	@@ -0,0 +1,185 @@
	+/*******************************************************************************
	+* *
	+* mcf_xdr.h -- Include file for mcfast Xdr layer. Specifies the headers *
	+* ( Block, event, table and files) * *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warrenty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+*******************************************************************************/
	+#define MCF_XDR_F_TITLE_LENGTH 255
	+#define MCF_XDR_B_TITLE_LENGTH 80
	+#define MCF_XDR_MAXLREC 32000
	+#define MCF_XDR_MINLREC 512
	+#define MCF_XDR_VERSION "v0.0"
	+#define MCF_STREAM_NUM_MAX 20
	+#define MCF_DEFAULT_TABLE_SIZE 100
	+#define MCF_XDR_VERSION_LENGTH 4
	+#define MCF_XDR_STDCM2_LENGTH 20
	+#define XDR_MCFIOCODE 1025 /* Private code to be passed to the encoding
	+ filter to estimate the length prior to encode
	+ in memory */
	+
	+typedef enum _mcfxdrBlockType {
	+ GENERIC, FILEHEADER, EVENTTABLE, SEQUENTIALHEADER,
	+ EVENTHEADER, NOTHING
	+} mcfxdrBlockType;
	+
	+
	+typedef struct _mcfxdrGeneric{
	+ int id; /* Identifier for this item = FILEHEADER */
	+ int length; /* The length of data body, byte count, excluding
	+ the id and version, and this word */
	+ char version[MCF_XDR_VERSION_LENGTH+1];
	+ /* The version of this particular block */
	+ int data; / The data block */
	+} mcfxdrGeneric;
	+
	+typedef struct _mcfxdrFileHeader{
	+ int id; /* Identifier for this item = FILEHEADER */
	+ int length; /* The length of data body, byte count, excluding
	+ the id and version, and this word */
	+ char version[MCF_XDR_VERSION_LENGTH+1];
	+ /* The version of this particular block */
	+ char title[MCF_XDR_F_TITLE_LENGTH+1];
	+ /* The title length */
	+ char comment[MCF_XDR_F_TITLE_LENGTH+1]; /* The comment ..*/
	+ char date[30];
	+ char closingDate[30];
	+ unsigned int numevts_expect; /* The number of event expected */
	+ unsigned int numevts; /* The number of evts really written on tape */
	+ unsigned int firstTable; /* The XDR locator for the first table */
	+ unsigned int dimTable; /* The number of events listed in the fixed-sized
	+ event table */
	+ unsigned int nBlocks;
	+ /* The maximum number of Block types in the file
	+ ( excluding File headers and Event Tables) */
	+ int blockIds; / The list of Block identifiers */
	+
	+ char *blockNames; / The list of names ( Titles) for these blocks */
	+ unsigned int nNTuples;
	+ /* The maximum number of Ntuples defined for this
	+ stream */
	+
	+} mcfxdrFileHeader;
	+
	+typedef struct _mcfxdrEventTable{
	+ int id; /* Identifier for this item = EVENTTABLE */
	+ int length; /* The length of data body, byte count, excluding
	+ the id and version, and this word */
	+ char version[MCF_XDR_VERSION_LENGTH+1];
	+ /* The version of this particular block */
	+ int nextLocator; /The Locator for the next Event Table. /
	+ int previousnumevts; /* The size of the previous Table */
	+ int numevts; /* The number of events in this chunk */
	+ unsigned int dim; /* The dimension of the arrays listed below */
	+ unsigned int ievt; /* The current index in the list */
	+ int evtnums; / The List of event numbers, within a store */
	+ int storenums; / The list of Store number within a Run */
	+ int runnums; / The list of run numbers */
	+ int trigMasks; / The list of user-defined Trigger masks */
	+ unsigned int *ptrEvents;
	+ /* The list of XDR pointers for these events */
	+} mcfxdrEventTable;
	+
	+typedef struct _mcfxdrSequentialHeader{
	+ int id; /* Identifier for this item = SEQUENTIALHEADER */
	+ int length; /* The length of data body, byte count, excluding
	+ the id and version, and this word */
	+ char version[MCF_XDR_VERSION_LENGTH+1];
	+ /* The version of this particular block */
	+ unsigned int nRecords; /* The number of records (including this one)
	+ in the logical event */
	+} mcfxdrSequentialHeader;
	+
	+typedef struct _mcfxdrEventHeader{
	+ int id; /* Identifier for this item = CHUNKHEADER */
	+ int length; /* The length of data body, byte count, excluding
	+ the id and version, and this word */
	+ char version[MCF_XDR_VERSION_LENGTH+1];
	+ /* The version of this particular block */
	+ int previousevtnum; /* The previous event number */
	+ int evtnum; /* The event numbers, within a store */
	+ int storenum; /* The Store number within a Run */
	+ int runnum; /* The Run numbers */
	+ int trigMask; /* The Trigger masks */
	+ unsigned int nBlocks; /* The number of Blocks */
	+ unsigned int dimBlocks; /* The dimension of the two following arrays */
	+ int blockIds; / The list of Block identifiers */
	+ unsigned int *ptrBlocks;
	+ /* The list of XDR pointers for these blocks */
	+ unsigned int nNTuples;
	+ /* The number of Ntuples defined for this event */
	+
	+ unsigned int dimNTuples; /* The dimension of the two following arrays */
	+ int nTupleIds; / The list of Ntuple identifiers, pointing to the
	+ global list array */
	+ unsigned int *ptrNTuples;
	+ /* The list of XDR pointers for these NTuples */
	+
	+} mcfxdrEventHeader;
	+
	+typedef struct _mcfStream{
	+ int id; /* Id of the Stream */
	+ int row; /* Read or Write */
	+ int dos; /* Direct, Memory Mapped I/O or Sequential */
	+ int status; /* The Stream status, either at BOF, RUNNING, EOF
	+ or simply declared, and needs to be opened
	+ (NTuple usage) */
	+ int numWordsC; /* The number of words read or written, Content */
	+ int numWordsT; /* The number of words read or written, Total */
	+ mcfxdrFileHeader fhead; / The File header */
	+ mcfxdrEventHeader ehead; / The current Event Header */
	+ unsigned int currentPos; /* The XDR current position */
	+ unsigned int evtPos; /* The XDR position for the begingin of evt */
	+ unsigned int tablePos; /* The XDR position for the table */
	+ unsigned int firstPos; /* The XDR position just before file header */
	+ XDR xdr; / The XDR stream */
	+ char filename; / Filename */
	+ FILE filePtr; / The file pointer */
	+ int fileDescr; /* File descriptor if Memory Mapped */
	+ char fileAddr; / Address in virtual memory if Memory Mapped */
	+ size_t fileLen; /* The file length */
	+ mcfxdrEventTable table; / The event table */
	+ char device; / The device name, if any */
	+ char vsn; / The Visual S. number, e.g., the tape label */
	+ int filenumber; /* The sequential file number, if any */
	+ int minlrec; /* The minimum record length for this stream */
	+ int maxlrec; /* The maximum record length for this stream */
	+ int bufferSize; /* The current size of the primary buffer */
	+ mcfxdrSequentialHeader shead; / The Sequential header */
	+ char buffer; / A pointer to a generic data buffer, to get the
	+ data from tape and then decode it */
	+ char buffer2; / A secondary buffer, to hold the event
	+ as the event grows */
	+} mcfStream;
	+
	+extern mcfStream **McfStreamPtrList;
	+extern char **McfGenericVersion;
	+extern unsigned int McfNumOfStreamActive;
	+extern bool_t McfNTuPleSaveDecoding;
	+
	+bool_t xdr_mcfast_generic(XDR xdrs, int blockid,
	+ int ntot, char* version, char** data);
	+bool_t xdr_mcfast_headerBlock(XDR xdrs, int blockid,
	+ int ntot, char* version);
	+bool_t xdr_mcfast_fileheader(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrFileHeader **mcf,
	+ int streamId);
	+bool_t xdr_mcfast_eventtable(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrEventTable **mcf);
	+bool_t xdr_mcfast_seqheader(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrSequentialHeader **mcf);
	+bool_t xdr_mcfast_eventheader(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrEventHeader **mcf);
	Index: trunk/contrib/mcfio/Makefile.am
	===================================================================
	--- trunk/contrib/mcfio/Makefile.am (revision 0)
	+++ trunk/contrib/mcfio/Makefile.am (revision 8889)
	@@ -0,0 +1,93 @@
	+## Makefile.am -- Makefile for WHIZARD
	+##
	+## Process this file with automake to produce Makefile.in
	+##
	+########################################################################
	+#
	+# Copyright (C) 1999-2023 by
	+# Wolfgang Kilian <kilian@physik.uni-siegen.de>
	+# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	+# Juergen Reuter <juergen.reuter@desy.de>
	+# with contributions from
	+# cf. main AUTHORS file
	+#
	+# WHIZARD is free software; you can redistribute it and/or modify it
	+# under the terms of the GNU General Public License as published by
	+# the Free Software Foundation; either version 2, or (at your option)
	+# any later version.
	+#
	+# WHIZARD is distributed in the hope that it will be useful, but
	+# WITHOUT ANY WARRANTY; without even the implied warranty of
	+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	+# GNU General Public License for more details.
	+#
	+# You should have received a copy of the GNU General Public License
	+# along with this program; if not, write to the Free Software
	+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	+#
	+########################################################################
	+
	+## The files in this directory end up in an auxiliary libtool library.
	+AM_FCFLAGS =
	+AM_FFLAGS =
	+AM_CFLAGS = $(RPC_CFLAGS)
	+
	+noinst_LTLIBRARIES = libwo_mcfio.la
	+
	+libwo_mcfio_la_SOURCES = \
	+ mcfio_FPrintDictionary.f \
	+ mcfio_Util1.h \
	+ mcfio_Util1.c \
	+ mcf_ntuBldDbinc.h \
	+ mcf_ntuBldDbinc.c \
	+ mcf_NTuIOUtils.h \
	+ mcf_NTuIOUtils.c \
	+ mcf_NTuIOFiles.h \
	+ mcf_NTuIOFiles.c \
	+ mcfio_UserDictionary.h \
	+ mcfio_UserDictionary.c \
	+ mcf_evt_xdr.c \
	+ mcfio_FBinding.c \
	+ mcfio_Direct.h \
	+ mcfio_Direct.c \
	+ mcfio_SeqDummy.c \
	+ mcfio_Block.c \
	+ mcf_ntubldInit.c \
	+ mcf_nTupleDescript.h \
	+ mcf_ntubld_db.h \
	+ mcf_xdr.h \
	+ mcf_xdr_Ntuple.h \
	+ mcfio_Block.h \
	+ mcfio_Dict.h \
	+ mcfio_Sequential.h
	+
	+SUFFIXES: .lo .$(FC_MODULE_EXT)
	+
	+########################################################################
	+## Default Fortran compiler options
	+
	+## Profiling
	+if FC_USE_PROFILING
	+AM_FCFLAGS += $(FCFLAGS_PROFILING)
	+AM_FFLAGS += $(FCFLAGS_PROFILING)
	+endif
	+
	+## OpenMP
	+if FC_USE_OPENMP
	+AM_FCFLAGS += $(FCFLAGS_OPENMP)
	+AM_FFLAGS += $(FCFLAGS_OPENMP)
	+endif
	+
	+########################################################################
	+## Non-standard cleanup tasks
	+
	+## Remove F90 module files
	+clean-local:
	+ -rm -f *.$(FC_MODULE_EXT)
	+if FC_SUBMODULES
	+ -rm -f *.smod
	+endif
	+
	+## Remove backup files
	+maintainer-clean-local:
	+ -rm -f *~
	Index: trunk/contrib/mcfio/mcfio_Sequential.h
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Sequential.h (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Sequential.h (revision 8889)
	@@ -0,0 +1,15 @@
	+/*******************************************************************************
	+* *
	+* mc_Sequential.h -- Include file for mcfast Sequential i/o layer. *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+*******************************************************************************/
	+int mcfioC_OpenReadSequential(char device, char label, int filenumber);
	+int mcfioC_OpenWriteSequential(char device, char label, char *title,
	+ char *comment, int numevts_pred,
	+ int *blkIds, unsigned int nBlocks);
	+int mcfioC_NextEventSequential(int stream);
	+void mcfioC_CloseSequentialFile(int stream);
	+void mcfioC_CloseSequentialTape(int stream);
	Index: trunk/contrib/mcfio/mcfio_Direct.h
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Direct.h (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Direct.h (revision 8889)
	@@ -0,0 +1,24 @@
	+/*******************************************************************************
	+* *
	+* mcfio_Direct.h -- Include file for mcfast Direct i/o layer. *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+*******************************************************************************/
	+#define INITIATE 3
	+#define FLUSH 4
	+int mcfioC_OpenReadDirect(char *filename);
	+int mcfioC_OpenReadMapped(char *filename);
	+int mcfioC_OpenWriteDirect(char filename, char title, char *comment,
	+ int numevts_pred, int *blkIds, u_int nBlocks);
	+int mcfioC_NextEvent(int stream);
	+int mcfioC_SpecificEvent(int stream, int ievt,
	+ int istore, int irun, int itrig);
	+int mcfioC_NextSpecificEvent(int stream, int ievt,
	+ int istore, int irun, int itrig);
	+void mcfioC_CloseDirect(int jstr);
	+void mcfioC_RewindDirect(int jstr);
	+int mcfioC_WrtEvt(mcfStream *str, int mode);
	+int mcfioC_Wrttable(mcfStream *str, int mode);
	+int mcfioC_Wrtfhead(mcfStream *str, int mode);
	Index: trunk/contrib/mcfio/mcfio_FBinding.c
	===================================================================
	--- trunk/contrib/mcfio/mcfio_FBinding.c (revision 0)
	+++ trunk/contrib/mcfio/mcfio_FBinding.c (revision 8889)
	@@ -0,0 +1,428 @@
	+/*******************************************************************************
	+* *
	+* mcfio_FBinding.c -- Utility routines for the McFast Monte-Carlo *
	+* Fortran Application Interface. *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun *
	+* The mallocNCopyMcfio and CleanFortranString have been borrowed from the *
	+* Nirvana project. *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <limits.h>
	+#include <stdlib.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcfio_Dict.h"
	+#include "mcfio_Util1.h"
	+#include "mcfio_UserDictionary.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcf_NTuIOFiles.h"
	+#include "mcfio_Direct.h"
	+#include "mcfio_Sequential.h"
	+#include "mcfio_Block.h"
	+
	+char mallocNCopyMcfio(char string, int length);
	+static void cleanFortranString(char *string, int length);
	+
	+void mcfio_init_(void)
	+{
	+ mcfioC_Init();
	+}
	+
	+void mcfio_rewind_(int *stream)
	+{
	+ mcfioC_Rewind(*stream);
	+}
	+
	+void mcfio_close_(int *stream)
	+{
	+ mcfioC_Close(*stream);
	+}
	+
	+void mcfio_closesequentialfile_(int *stream)
	+{
	+ mcfioC_CloseSequentialFile(*stream);
	+}
	+
	+void mcfio_closesequentialtape_(int *stream)
	+{
	+ mcfioC_CloseSequentialTape(*stream);
	+}
	+
	+void mcfio_printdictionary_(void)
	+{
	+ mcfioC_PrintDictionary();
	+}
	+
	+unsigned int mcfio_infonumstream_(int istreams, int nmax)
	+{
	+ return mcfioC_InfoNumStream(istreams, (unsigned int) *nmax);
	+}
	+
	+void mcfio_infostreamint_(int stream, int key, int *values)
	+{
	+ mcfioC_InfoStreamInt(stream, key, values);
	+}
	+
	+void mcfio_infostreamchar_(int stream, int key,
	+ char answer, int lret, int length)
	+{
	+ char *aString;
	+ int ll1;
	+ /* Rely on the fact that the maximum char. length is probably FILENAME_MAX
	+ for information content, that is, 1024 on IRIX and other systems */
	+ aString = (char ) malloc((FILENAME_MAX + 1) sizeof(char));
	+ mcfioC_InfoStreamChar(stream, key, aString, lret);
	+ ll1 = *lret;
	+ if (ll1 > length) ll1 = length;
	+ strncpy(answer, aString, ll1);
	+ free(aString);
	+}
	+
	+void mcfio_infoeventint_(int Event, int key, int *values)
	+{
	+ mcfioC_InfoEventInt(Event, key, values);
	+}
	+
	+void mcfio_infoeventchar_(int Event, int key, char *answer,
	+ int *lret, int length)
	+{
	+ char *aString;
	+ int ll1;
	+
	+ aString = (char ) malloc(sizeof(char) (FILENAME_MAX + 1));
	+ mcfioC_InfoEventChar(Event, key, aString, lret);
	+ ll1 = *lret;
	+ if (ll1 > length) ll1 = length;
	+ strncpy(answer, aString, ll1);
	+ free(aString);
	+}
	+
	+void mcfio_seteventinfo_(int Event, int key, int *values)
	+{
	+ mcfioC_SetEventInfo(Event, key, values);
	+}
	+
	+void mcfio_infoblockchar_(int Event, int blkId,
	+ int key, char answer, int *lret, int length)
	+{
	+ char *aString;
	+
	+ int ll1;
	+
	+ aString = (char ) malloc(sizeof(char) (FILENAME_MAX + 1));
	+ mcfioC_InfoBlockChar(Event, blkId, *key, aString, lret);
	+ ll1 = *lret;
	+ if (ll1 > length) ll1 = length;
	+ strncpy(answer, aString, ll1);
	+ free(aString);
	+}
	+
	+void mcfio_getblockname_(int blkId, char answer, int length)
	+{
	+ char *aString;
	+
	+ aString = (char ) malloc(sizeof(char) (FILENAME_MAX + 1));
	+ mcfioC_GetBlockName(*blkId, aString);
	+ strncpy(answer, aString, length);
	+ free(aString);
	+}
	+
	+void mcfio_defineuserblock_(int blkId, char name,
	+ bool_t xdr_filter, int *current_size, int length)
	+{
	+ char *aString;
	+
	+ aString = mallocNCopyMcfio(name, length);
	+ mcfioC_DefineUserBlock(*blkId, aString);
	+ /* Original version which does not match mcfio_UserDictionary.c */
	+ /* mcfioC_DefineUserBlock(blkId, aString, xdr_filter, current_size); /
	+ free(aString);
	+}
	+
	+int mcfio_declarentuple_(int uid, chartitle, char *category,
	+ int stream, char filename, int la, int lb, int lc)
	+{
	+ char aString, bString, *cString;
	+ int iret;
	+
	+ aString = mallocNCopyMcfio(title, la);
	+ bString = mallocNCopyMcfio(category, lb);
	+ cString = mallocNCopyMcfio(filename, lc);
	+ iret = mcfioC_DeclareNtuple(uid, aString, bString, stream, cString);
	+ free(aString); free(bString); free(cString);
	+ return iret;
	+}
	+
	+int mcfio_enddeclntuples_(int *stream)
	+{
	+ return mcfioC_EndDeclNTuples(*stream);
	+}
	+
	+
	+int mcfio_getntupleids_(int stream, int ids, int *max)
	+{
	+ return mcfioC_GetNTupleIds(stream, ids, max);
	+}
	+
	+int mcfio_getntupleuid_(int stream, int id)
	+{
	+ return mcfioC_GetNTupleUID(stream, id);
	+}
	+
	+int mcfio_getntuplecategory_(int stream, int id, char *category, int ll)
	+{
	+ int iret, lret;
	+ char *aString;
	+ mcfioC_GetNTupleCategory(stream, id, &aString);
	+ lret = strlen(aString);
	+ if (ll > lret) strcpy(category, aString);
	+ else strncpy(category, aString, (ll-1));
	+ return lret;
	+}
	+
	+int mcfio_getntupletitle_(int stream, int id, char *title, int ll)
	+{
	+ int iret, lret;
	+ char *aString;
	+ mcfioC_GetNTupleTitle(stream, id, &aString);
	+ lret = strlen(aString);
	+ if (ll > lret) strcpy(title, aString);
	+ else strncpy(title, aString, (ll-1));
	+ return lret;
	+}
	+
	+int mcfio_getntuplename_(int stream, int id, char *name, int ll)
	+{
	+ int iret, lret;
	+ char *aString;
	+ mcfioC_GetNTupleName(stream, id, &aString);
	+ lret = strlen(aString);
	+ if (ll > lret) strcpy(name, aString);
	+ else strncpy(name, aString, (ll-1));
	+ return lret;
	+}
	+
	+int mcfio_openreaddirect_(char *filename, int length)
	+{
	+ char *aString;
	+ int iret;
	+
	+ aString = mallocNCopyMcfio(filename, length);
	+ iret = mcfioC_OpenReadDirect(aString);
	+ if (aString != NULL) free(aString);
	+ return iret;
	+}
	+
	+int mcfio_openreadmapped_(char *filename, int length)
	+{
	+ char *aString;
	+ int iret;
	+
	+ aString = mallocNCopyMcfio(filename, length);
	+ iret = mcfioC_OpenReadMapped(aString);
	+ if (aString != NULL) free(aString);
	+ return iret;
	+}
	+
	+int mcfio_openreadsequential_(char device, char vsn,
	+ int *filenumber, int l1, int l2)
	+{
	+ char aString, bString;
	+ int iret;
	+
	+ aString = mallocNCopyMcfio(device, l1);
	+ bString = mallocNCopyMcfio(vsn,l2);
	+ iret = mcfioC_OpenReadSequential(aString, bString, *filenumber);
	+ if (aString != NULL) free(aString);
	+ if (bString != NULL) free(bString);
	+ return iret;
	+}
	+
	+void mcfio_setforsavedecoding_(int *value)
	+{
	+ mcfioC_SetForSaveDecoding(*value);
	+}
	+
	+int mcfio_openwritedirect_(char filename, char title, char *comment,
	+ int numevts_pred, int blkIds, int *nBlocks,
	+ int ll1, int ll2, int ll3)
	+{
	+ char aString, bString, *cString;
	+ int iret;
	+
	+ aString = mallocNCopyMcfio(filename, ll1);
	+ bString = mallocNCopyMcfio(title, ll2);
	+ cString = mallocNCopyMcfio(comment, ll3);
	+ iret = mcfioC_OpenWriteDirect(aString, bString, cString,
	+ numevts_pred, blkIds, (unsigned int) nBlocks);
	+ if (aString != NULL) free(aString);
	+ if (bString != NULL) free(bString);
	+ if (cString != NULL) free(cString);
	+ return iret;
	+}
	+
	+int mcfio_openwritesequential_(char device, char vsn, char *title,
	+ char comment, int numevts_pred, int *blkIds,
	+ int *nBlocks, int ll1, int ll2, int ll3, int ll4)
	+{
	+ char aString, bString, cString, dString;
	+ int iret;
	+
	+ aString = mallocNCopyMcfio(device, ll1);
	+ bString = mallocNCopyMcfio(vsn, ll2);
	+ cString = mallocNCopyMcfio(title, ll3);
	+ dString = mallocNCopyMcfio(comment, ll4);
	+ iret = mcfioC_OpenWriteSequential(aString, bString, cString, dString,
	+ numevts_pred, blkIds, (unsigned int) nBlocks);
	+ if (aString != NULL) free(aString);
	+ if (bString != NULL) free(bString);
	+ if (cString != NULL) free(cString);
	+ if (dString != NULL) free(dString);
	+ return iret;
	+}
	+
	+int mcfio_nextevent_(int *stream)
	+{
	+ return mcfioC_NextEvent(*stream);
	+}
	+
	+int mcfio_specificevent_(int stream, int ievt,
	+ int istore, int irun, int *itrig)
	+{
	+ return mcfioC_SpecificEvent(stream, ievt, istore, irun, *itrig);
	+}
	+
	+int mcfio_nextspecificevent_(int stream,int ievt,
	+ int istore, int irun, int *itrig)
	+{
	+ return mcfioC_NextSpecificEvent(*stream,
	+ ievt, istore, irun, itrig);
	+}
	+
	+int mcfio_block_(int stream, int blkid,
	+ bool_t xdr_filtercode(XDR xdrs, int blockid, int ntot, char *version))
	+{
	+ return mcfioC_Block(stream, blkid, xdr_filtercode);
	+}
	+
	+int mcfio_ntuple_(int stream, int ntupleid, char *version, int ll)
	+{
	+/*
	+** Note we do not copy the string this time, as we are interested in the
	+** address, not the content
	+*/
	+ return mcfioC_NTuple(stream, ntupleid, version);
	+}
	+
	+
	+int mcfio_ntuplemult_(int stream, int ntupleid, char *version, int ll)
	+{
	+ return mcfioC_NTupleMult(stream, ntupleid, version);
	+}
	+
	+int mcfio_ntuplevar_(int stream, int ntupleid, int *ivar,
	+ char *version, int ll)
	+{
	+ int ivarF;
	+ ivarF = (*ivar) -1;
	+ return mcfioC_NTupleVar(stream, ntupleid, ivarF, version);
	+}
	+
	+int mcfio_ntuplesubvar_(int stream, int ntupleid,
	+ int ivar, int multIndex, char *version, int ll)
	+{
	+ int ivarF, multIndexF;
	+ ivarF = (*ivar) -1;
	+ multIndexF = (*multIndex) -1;
	+ return mcfioC_NTupleSubVar(stream, ntupleid,
	+ ivarF, multIndexF, version);
	+}
	+
	+int mcfio_ntuplesubstruct_(int stream, int ntupleid,
	+ int multIndex, char version, int ll)
	+{
	+ int multIndexF;
	+ multIndexF = (*multIndex) -1;
	+ return mcfioC_NTupleSubStruct(stream, ntupleid,
	+ multIndexF, version);
	+}
	+
	+
	+char mallocNCopyMcfio(char string, int length)
	+{
	+ char *str;
	+
	+ if (string == NULL) return NULL;
	+ if (length < 0) {
	+ fprintf(stderr,
	+ "hs: Error. Character argument has negative length, setting to null\n");
	+ length = 0;
	+ }
	+ str = malloc(length + 1);
	+ if (length > 0)
	+ strncpy(str, string, length);
	+ str[length] = '\0';
	+ /* printf(" string = /%s/, length: %d (before)\n", str, strlen(str)); */
	+ cleanFortranString(str, length);
	+ /* printf(" string = /%s/, length: %d (cleaned)\n", str, strlen(str)); */
	+ return str;
	+}
	+
	+
	+/*
	+** clean junk out of fortran strings that might not have been
	+** fully initialized or have trailing blanks. Assumes enough
	+** room to append a null at the end of the string.
	+**
	+** This cleanFortranString continues after detecting a junk character and
	+** includes a few more valid characters than other cleanFortranString's.
	+*/
	+static void cleanFortranString(char *string, int length)
	+{
	+ static char validChars[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
	+abcdefghijklmnopqrstuvwxyz1234567890/~!@#$%^&*()_+=-`\"\'?><,.\\[]{}:; \t";
	+ char inPtr, outPtr;
	+ int i;
	+
	+ /* remove junk characters */
	+ inPtr = outPtr = string;
	+ for (i=1; i<=length; i++) {
	+ if (strchr(validChars, *inPtr))
	+ outPtr++ = inPtr++;
	+ else
	+ inPtr++;
	+ }
	+
	+ /* remove trailing spaces */
	+ for (outPtr--; outPtr>=string; outPtr--)
	+ if (outPtr != ' ' && outPtr != '\0')
	+ break;
	+
	+ /* add a null to terminate the string */
	+ ++outPtr;
	+ *outPtr = '\0';
	+}
	+
	+
	Index: trunk/contrib/mcfio/mcf_nTupleDescript.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_nTupleDescript.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_nTupleDescript.h (revision 8889)
	@@ -0,0 +1,86 @@
	+/*******************************************************************************
	+* *
	+* mcf_nTupleDescript.h -- Include file for mcfast generalized nTuple *
	+* descriptors. This is a genric structres that can hold info about *
	+* specficic instances of a generalized nTuple. *
	+* *
	+* P. Lebrun, September 1995. *
	+* *
	+*******************************************************************************/
	+/*
	+** Information concerning a generic variable within an Ntuple
	+*/
	+enum varTypes {BYTE_NTU, CHARACTER_NTU, INTEGER2_NTU, LOGICAL_NTU,
	+ INTEGER_NTU, REAL_NTU,
	+ DBL_PRECISION_NTU, COMPLEX_NTU, DBL_COMPLEX_NTU, POINTER_NTU};
	+
	+enum orgStyles {PARALLEL_ARRAY_NTU, DATA_STRUCT_NTU};
	+
	+#define N_VAR_TYPES 10
	+#define MAX_VAR_NAME 31
	+#define MAX_NTU_TITLE 80
	+#define MAX_VAR_DESCRIP 1023
	+#define MAX_VAR_DIMENSIONS 4
	+#define NUM_START_VARIABLES 10
	+#define NTU_MAX_TITLE_LENGTH 80
	+#define NTU_MAX_CATEGORY_LENGTH 255
	+#define NTU_MAX_CATEGORY_DEPTH 40
	+#define NTU_START_LIST_SIZE 20
	+
	+typedef struct {
	+ char nameBlank; /* flag indicating that the variable does not exist. */
	+ char name; / Mnemonic name of the variable. */
	+ char description;/ description for the variable */
	+ int type; /* Variable type (int, ...) see above enum varTypes */
	+ char isFixedSize; /* Variable is or is not indexed by nTuple multiplicity*/
	+ int numDim; /* The variable dimensions, not counting mult. one */
	+ int dimensions[MAX_VAR_DIMENSIONS+1];
	+ /* Variable dims, not counting the multiplicity one*/
	+ size_t lengthW; /* Used in XDR filtering, length in words */
	+ size_t lengthB; /* Used in XDR filtering, length in byte */
	+ long offset; /* The variable virtual address for a given instance */
	+ u_int offsetXDR; /* The variable relative address within the struct. */
	+} varGenNtuple;
	+
	+typedef struct {
	+ int numVariables; /* The total number of variables in the structure */
	+ int numAvailable; /* The number of available var. in var. array */
	+ char nameIndex[32]; /* The name for the Ntuple single index */
	+ int maxMultiplicity; /* The maximum multiplicity for any instances */
	+ char title; / Title for the structure */
	+ char description; / Description of this structure. */
	+ char version[8]; /* The version string */
	+ int orgStyle; /* The organization of the indexed variables */
	+ void address; / Virtual address of a particular instance */
	+ long multOffset; /* Offset for the multiplicity offset */
	+ u_int multXDROffset; /* Adress for the multiplicity offset */
	+ long fenceOffset; /* Offset for the fence */
	+ u_int fenceXDROffset; /* XDR offset for the fence */
	+ long subOffset; / Offset for the sub structures */
	+ u_int subXDROffset; / XDR offset for the sub structures */
	+ varGenNtuple *variables; / The variable descriptions */
	+ int varOrdering; / Ordering of the variables for the dbin, .h.. file*/
	+ int firstIndexed; /* Once ordered, the first indexed for indexed part */
	+} descrGenNtuple;
	+
	+/*
	+** A Data structure to hold a DDL, without MOTIF widget, to be used in
	+** stand alone mode in mcfio.
	+*/
	+
	+typedef struct nTuDDLRec {
	+ int id; /* The id of the NTuple, as returned to the user */
	+ int seqNTuId; /* The sequential number for this particular stream */
	+ int uid; /* The user Id, Unique (within a Category) id */
	+ char *category;
	+ char *title;
	+ char dbinFileName; / dbin filename, not guarantted to be there. */
	+ int streamId; /* The stream on which this ddl is assigned to */
	+ int referenceId;
	+ struct nTuDDLRec *reference;
	+ /* the reference in case a similar ddl has already
	+ been installed in the running image. */
	+
	+ descrGenNtuple descrNtu; / The Ntuple Descriptor */
	+} nTuDDL;
	+
	Index: trunk/contrib/mcfio/mcf_evt_xdr.c
	===================================================================
	--- trunk/contrib/mcfio/mcf_evt_xdr.c (revision 0)
	+++ trunk/contrib/mcfio/mcf_evt_xdr.c (revision 8889)
	@@ -0,0 +1,1602 @@
	+/*******************************************************************************
	+* *
	+* mcf_evt_xdr.c -- XDR Utility routines for the McFast Monte-Carlo *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include <stdlib.h>
	+#include <time.h>
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcf_xdr_Ntuple.h"
	+#include "mcf_NTuIOFiles.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcfio_Util1.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+
	+static bool_t xdr_mcfast_NTuDDL(XDR xdrs, char version, nTuDDL *ddl);
	+static bool_t xdr_mcfast_descrNTU(XDR xdrs, char version,
	+ descrGenNtuple *dNTu);
	+static bool_t xdr_mcfast_varDescrNTU(XDR xdrs, char version,
	+ varGenNtuple *var);
	+
	+extern nTuDDL **NTuDDLList;
	+extern int NumOfNTuples;
	+
	+bool_t xdr_mcfast_generic(XDR xdrs, int blockid,
	+ int ntot, char* version, char** data)
	+{
	+/* Translate a Generic mcfFast block. This module will allocate memory
	+ for the data. */
	+
	+ unsigned int nn;
	+
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ nn = strlen(*data);
	+ *ntot = 12+nn;
	+ strcpy(*version, "0.00");
	+ } else if (xdrs->x_op == XDR_FREE) {
	+ free(*data);
	+ return 1;
	+ }
	+
	+ if (( xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	+ == FALSE) return FALSE;
	+ nn = *ntot - 12;
	+ if (xdrs->x_op == XDR_DECODE) *data = NULL;
	+ return (xdr_string(xdrs, data, nn));
	+}
	+
	+
	+bool_t xdr_mcfast_headerBlock(XDR xdrs, int blockid,
	+ int ntot, char* version)
	+{
	+/* Translate a Generic mcfFast block. This module will allocate memory
	+ for the data. */
	+
	+ unsigned int nn;
	+
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ printf ("xdr_mcfast_headerBlock: Internal error \n");
	+ return FALSE;
	+ }
	+
	+ return ( xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH));
	+}
	+bool_t xdr_mcfast_fileheader(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrFileHeader **mcf,
	+ int streamId)
	+{
	+/* Translate a mcf FileHeader block. This subroutine will allocate
	+ the memory needed if the stream is DECODE */
	+
	+ int i;
	+ unsigned int nn, oldNumOfNTuples;
	+ char **ctmp;
	+ char atmp, btmp, *dtmp;
	+ int *itmp;
	+ bool_t ok;
	+ mcfxdrFileHeader *mcftmp;
	+ nTuDDL *ddl;
	+ float fv;
	+
	+
	+ mcftmp = *mcf;
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ ntot = sizeof(mcfxdrFileHeader) - sizeof(int ) - sizeof(char **)
	+ + 2 * sizeof(int) * mcftmp->nBlocks
	+ - sizeof(char) * MCF_XDR_F_TITLE_LENGTH
	+ + sizeof(char) * strlen(mcftmp->title) +
	+ + sizeof(char) * strlen(mcftmp->comment) ;
	+ for (i=0, ctmp = mcftmp->blockNames;
	+ i< mcftmp->nBlocks; i++, ctmp++) ntot += strlen(ctmp);
	+ strcpy(*version, "2.01");
	+ } else if (xdrs->x_op == XDR_FREE) {
	+ mcfioC_Free_FileHeader(mcf);
	+ return 1;
	+ } else if((xdrs->x_op == XDR_DECODE) && (*mcf == NULL)) {
	+ mcftmp = (mcfxdrFileHeader *) malloc(sizeof(mcfxdrFileHeader));
	+ *mcf = mcftmp;
	+ }
	+
	+
	+
	+ if (( xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	+ == FALSE) return FALSE;
	+
	+ /*
	+ ** Code valid for version 1.00
	+ */
	+ if (strcmp(*version, "1.00") == 0) {
	+ atmp = &(mcftmp->title[0]);
	+ btmp = &(mcftmp->comment[0]);
	+ dtmp = &(mcftmp->date[0]);
	+
	+ if ((xdr_string(xdrs, &atmp, MCF_XDR_F_TITLE_LENGTH) &&
	+ xdr_string(xdrs,&btmp, MCF_XDR_F_TITLE_LENGTH) &&
	+ xdr_string(xdrs,&dtmp, 30)) == FALSE) return FALSE;
	+
	+ if ((xdr_u_int(xdrs,&(mcftmp->numevts_expect)) &&
	+ xdr_u_int(xdrs,&(mcftmp->numevts)) &&
	+ xdr_u_int(xdrs,&(mcftmp->firstTable)) &&
	+ xdr_u_int(xdrs,&(mcftmp->dimTable)) &&
	+ xdr_u_int(xdrs,&(mcftmp->nBlocks))) == FALSE) return FALSE;
	+ if(xdrs->x_op == XDR_DECODE) {
	+ mcftmp->blockIds = (int ) malloc(sizeof(int) mcftmp->nBlocks);
	+ mcftmp->blockNames =
	+ (char*) malloc(sizeof(char ) * mcftmp->nBlocks);
	+ for (i=0; i<mcftmp->nBlocks; i++)
	+ mcftmp->blockNames[i] =
	+ (char ) malloc(sizeof(char) (MCF_XDR_B_TITLE_LENGTH +1));
	+ }
	+ itmp = mcftmp->blockIds;
	+ if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->nBlocks;
	+ if (xdr_array(xdrs, (char **) &itmp, &nn,
	+ mcftmp->nBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ for (i=0; i<mcftmp->nBlocks; i++) {
	+ if (xdr_string(xdrs, &(mcftmp->blockNames[i]),
	+ MCF_XDR_B_TITLE_LENGTH) == FALSE) return FALSE;
	+ }
	+ mcftmp->nNTuples = 0;
	+ } else if (strncmp(*version, "2.",2) == 0){
	+ sscanf(*version, "%f", &fv);
	+ /*
	+ ** Code valid for version 2.xx, adding the NTuples
	+ */
	+ atmp = &(mcftmp->title[0]);
	+ btmp = &(mcftmp->comment[0]);
	+ dtmp = &(mcftmp->date[0]);
	+
	+ if ((xdr_string(xdrs, &atmp, MCF_XDR_F_TITLE_LENGTH) &&
	+ xdr_string(xdrs,&btmp, MCF_XDR_F_TITLE_LENGTH) &&
	+ xdr_string(xdrs,&dtmp, 30)) == FALSE) return FALSE;
	+
	+ if (fv == 2.) strcpy(mcftmp->closingDate, mcftmp->date);
	+ else {
	+ atmp = &(mcftmp->closingDate[0]);
	+ if (xdr_string(xdrs, &atmp, 30) == FALSE) return FALSE;
	+ }
	+ if ((xdr_u_int(xdrs,&(mcftmp->numevts_expect)) &&
	+ xdr_u_int(xdrs,&(mcftmp->numevts)) &&
	+ xdr_u_int(xdrs,&(mcftmp->firstTable)) &&
	+ xdr_u_int(xdrs,&(mcftmp->dimTable)) &&
	+ xdr_u_int(xdrs,&(mcftmp->nBlocks)) &&
	+ xdr_u_int(xdrs,&(mcftmp->nNTuples))) == FALSE) return FALSE;
	+ if((xdrs->x_op == XDR_DECODE) && (mcftmp->nBlocks > 0)) {
	+ mcftmp->blockIds = (int ) malloc(sizeof(int) mcftmp->nBlocks);
	+ mcftmp->blockNames =
	+ (char*) malloc(sizeof(char ) * mcftmp->nBlocks);
	+ for (i=0; i<mcftmp->nBlocks; i++)
	+ mcftmp->blockNames[i] =
	+ (char ) malloc(sizeof(char) (MCF_XDR_B_TITLE_LENGTH +1));
	+ }
	+ itmp = mcftmp->blockIds;
	+ if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->nBlocks;
	+ if (mcftmp->nBlocks > 0) {
	+ if (xdr_array(xdrs, (char **) &itmp, &nn,
	+ mcftmp->nBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ for (i=0; i<mcftmp->nBlocks; i++) {
	+ if (xdr_string(xdrs, &(mcftmp->blockNames[i]),
	+ MCF_XDR_B_TITLE_LENGTH) == FALSE) return FALSE;
	+ }
	+ } else {
	+ mcftmp->blockNames = NULL;
	+ mcftmp->blockIds = NULL;
	+ }
	+ /*
	+ ** Now take care of the Ntuples
	+ */
	+ if((xdrs->x_op == XDR_DECODE) && (mcftmp->nNTuples > 0)) {
	+ oldNumOfNTuples = NumOfNTuples;
	+ for (i=0; i<mcftmp->nNTuples; i++) {
	+ ddl = (nTuDDL * ) malloc(sizeof(nTuDDL));
	+ AddNTuDDLtoList(ddl);
	+ if (xdr_mcfast_NTuDDL(xdrs, *version, ddl) == FALSE)
	+ return FALSE;
	+ }
	+ } else if ((xdrs->x_op == XDR_ENCODE) && (mcftmp->nNTuples > 0)) {
	+ for (i=0; i<NumOfNTuples; i++) {
	+ ddl =mcf_GetNTuByPtrID(i+1);
	+ if ((ddl->streamId == streamId) &&
	+ (xdr_mcfast_NTuDDL(xdrs, *version, ddl) == FALSE))
	+ return FALSE;
	+ }
	+ }
	+
	+ } else return FALSE; /* Other Futur version encoded here. */
	+ return TRUE;
	+
	+}
	+
	+bool_t xdr_mcfast_eventtable(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrEventTable **mcf)
	+{
	+/* Translate a mcf EventTable block. This subroutine will allocate
	+ the memory needed if the stream is DECODE */
	+
	+ int i, *idat;
	+ unsigned int nn, nnold, *uidat;
	+ char **ctmp;
	+ mcfxdrEventTable *mcftmp;
	+
	+
	+ mcftmp = *mcf;
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ ntot = sizeof(mcfxdrEventTable) + 4 sizeof(int)* mcftmp->dim
	+ + sizeof(unsigned int)* mcftmp->dim - 2 * sizeof(int)
	+ - 4 * sizeof(int ) - sizeof(u_int );
	+ strcpy(*version, "1.00");
	+ } else if (xdrs->x_op == XDR_FREE) {
	+ mcfioC_Free_EventTable(mcf);
	+ return 1;
	+ } else if((xdrs->x_op == XDR_DECODE) && ( mcftmp == NULL)) {
	+ mcftmp = (mcfxdrEventTable *) malloc(sizeof(mcfxdrEventTable));
	+ *mcf = mcftmp;
	+ }
	+
	+
	+
	+ if (( xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	+ == FALSE) return FALSE;
	+
	+ /*
	+ ** Code valid for version 1.00
	+ */
	+ if (strcmp(*version, "1.00") == 0) {
	+
	+ if((xdrs->x_op == XDR_DECODE) && (mcftmp->evtnums != NULL))
	+ nnold = mcftmp->previousnumevts;
	+ else nnold = 0;
	+ idat = &mcftmp->nextLocator;
	+ uidat = (u_int *) &mcftmp->numevts;
	+ if ((xdr_int(xdrs,idat) && xdr_u_int(xdrs,uidat )) == FALSE)
	+ return FALSE;
	+ if(xdrs->x_op == XDR_DECODE) {
	+ if ((mcftmp->evtnums == NULL) \|\| (mcftmp->numevts > nnold)) {
	+ if (mcftmp->evtnums != NULL) {
	+ /*
	+ ** I don't trust realloc.. just alloc again..
	+ */
	+ free(mcftmp->evtnums); free(mcftmp->storenums);
	+ free(mcftmp->runnums); free(mcftmp->trigMasks);
	+ free(mcftmp->ptrEvents);
	+ }
	+ mcftmp->evtnums = (int ) malloc(sizeof(int) mcftmp->dim);
	+ mcftmp->storenums = (int ) malloc(sizeof(int) mcftmp->dim);
	+ mcftmp->runnums = (int ) malloc(sizeof(int) mcftmp->dim);
	+ mcftmp->trigMasks = (int ) malloc(sizeof(int) mcftmp->dim);
	+ mcftmp->ptrEvents =
	+ (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dim);
	+ mcftmp->previousnumevts = mcftmp->dim;
	+ }
	+ }
	+ if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dim;
	+ idat = mcftmp->evtnums;
	+ if (xdr_array(xdrs, (char **) &idat, &nn,
	+ mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ idat = mcftmp->storenums;
	+ if (xdr_array(xdrs, (char **) &idat, &nn,
	+ mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ idat = mcftmp->runnums;
	+ if (xdr_array(xdrs, (char **) &idat, &nn,
	+ mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ idat = mcftmp->trigMasks;
	+ if (xdr_array(xdrs, (char **) &idat, &nn,
	+ mcftmp->dim, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ uidat = mcftmp->ptrEvents;
	+ if (xdr_array(xdrs, (char **) &uidat, &nn,
	+ mcftmp->dim, sizeof(int), (xdrproc_t)xdr_u_int) == FALSE)
	+ return FALSE;
	+ } else return FALSE; /* Future version encoded here. */
	+ return TRUE;
	+
	+}
	+
	+bool_t xdr_mcfast_seqheader(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrSequentialHeader **mcf)
	+{
	+/* Translate a mcf EventTable block. This subroutine will allocate
	+ the memory needed if the stream is DECODE */
	+
	+ int i;
	+ unsigned int nn;
	+ char **ctmp;
	+ mcfxdrSequentialHeader *mcftmp;
	+
	+
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ mcftmp = *mcf;
	+ *ntot = sizeof(mcfxdrSequentialHeader);
	+ strcpy(*version, "1.00");
	+ } else if (xdrs->x_op == XDR_FREE) {
	+ mcfioC_Free_SeqHeader(mcf);
	+ return 1;
	+ } else if(xdrs->x_op == XDR_DECODE) {
	+ if (*mcf == NULL) {
	+ mcftmp = (mcfxdrSequentialHeader *)
	+ malloc(sizeof(mcfxdrSequentialHeader));
	+ *mcf = mcftmp;
	+ } else mcftmp = *mcf;
	+
	+ }
	+
	+
	+
	+/* if (( xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	+ == FALSE) return FALSE;
	+*/
	+ if (xdr_int(xdrs,blockid) == FALSE) return FALSE;
	+ if (xdr_int(xdrs,ntot) == FALSE) return FALSE;
	+ if (xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH)
	+ == FALSE) return FALSE;
	+ /*
	+ ** Code valid for version 1.00
	+ */
	+ if (strcmp(*version, "1.00") == 0) {
	+
	+ if (xdr_u_int(xdrs,&(mcftmp->nRecords)) == FALSE) return FALSE;
	+ } else return FALSE; /* Futur version encoded here. */
	+ return TRUE;
	+
	+}
	+
	+bool_t xdr_mcfast_eventheader(XDR xdrs, int blockid,
	+ int ntot, char* version, mcfxdrEventHeader **mcf)
	+{
	+/* Translate a mcf Event header block. This subroutine will allocate
	+ the memory needed if the stream is DECODE */
	+
	+ int i, *itmp;
	+ unsigned int nn, nnold, nNTuOld, *uitmp;
	+ char **ctmp;
	+ mcfxdrEventHeader *mcftmp;
	+
	+
	+ mcftmp = *mcf;
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ *ntot = sizeof(mcfxdrEventHeader)
	+ + sizeof(unsigned int)* mcftmp->nBlocks
	+ + sizeof(int ) * mcftmp->nBlocks
	+ - sizeof(int ) - sizeof(u_int ) ;
	+ strcpy(*version, "2.00");
	+ } else if (xdrs->x_op == XDR_FREE) {
	+ mcfioC_Free_EventHeader(mcf);
	+ return 1;
	+ } else if((xdrs->x_op == XDR_DECODE) && (mcftmp == NULL)) {
	+ mcftmp =
	+ (mcfxdrEventHeader *) malloc(sizeof(mcfxdrEventHeader));
	+ *mcf = mcftmp;
	+ mcftmp->blockIds = NULL;
	+ mcftmp->ptrBlocks = NULL;
	+ }
	+
	+
	+
	+ if (( xdr_int(xdrs, blockid) &&
	+ xdr_int(xdrs, ntot) &&
	+ xdr_string(xdrs, version, MCF_XDR_VERSION_LENGTH))
	+ == FALSE) return FALSE;
	+
	+ /*
	+ ** Code valid for version 1.00
	+ */
	+ if (strcmp(*version, "1.00") == 0) {
	+ if((xdrs->x_op == XDR_DECODE) && (mcftmp->blockIds != NULL))
	+ nnold = mcftmp->dimBlocks;
	+ else nnold = 0;
	+ if ((xdr_int(xdrs,&(mcftmp->evtnum)) &&
	+ xdr_int(xdrs,&(mcftmp->storenum)) &&
	+ xdr_int(xdrs,&(mcftmp->runnum)) &&
	+ xdr_int(xdrs,&(mcftmp->trigMask)) &&
	+ xdr_u_int(xdrs,&(mcftmp->nBlocks)) &&
	+ xdr_u_int(xdrs,&(mcftmp->dimBlocks))) == FALSE) return FALSE;
	+ if(xdrs->x_op == XDR_DECODE) {
	+ if ((mcftmp->blockIds == NULL) \|\| (mcftmp->dimBlocks > nnold)) {
	+ if (mcftmp->blockIds != NULL) {
	+ /*
	+ ** I don't trust realloc.. just alloc again..
	+ */
	+ free(mcftmp->blockIds); free(mcftmp->ptrBlocks);
	+ }
	+ mcftmp->blockIds =
	+ (int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	+ mcftmp->ptrBlocks =
	+ (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	+ }
	+ }
	+ if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dimBlocks;
	+ itmp = mcftmp->blockIds;
	+ if (xdr_array(xdrs, (char **) &itmp, &nn,
	+ mcftmp->dimBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ uitmp = mcftmp->ptrBlocks;
	+ if (xdr_array(xdrs, (char **) &uitmp, &nn,
	+ mcftmp->dimBlocks, sizeof(u_int), (xdrproc_t)xdr_u_int) == FALSE)
	+ return FALSE;
	+ } else if (strcmp(*version, "2.00") == 0) {
	+ if (xdrs->x_op == XDR_DECODE) {
	+ nnold = 0;
	+ if (mcftmp->blockIds != NULL) nnold = mcftmp->dimBlocks;
	+ nNTuOld = 0;
	+ if (mcftmp->nTupleIds != NULL) nNTuOld = mcftmp->dimNTuples;
	+ }
	+ if ((xdr_int(xdrs,&(mcftmp->evtnum)) &&
	+ xdr_int(xdrs,&(mcftmp->storenum)) &&
	+ xdr_int(xdrs,&(mcftmp->runnum)) &&
	+ xdr_int(xdrs,&(mcftmp->trigMask)) &&
	+ xdr_u_int(xdrs,&(mcftmp->nBlocks)) &&
	+ xdr_u_int(xdrs,&(mcftmp->dimBlocks)) &&
	+ xdr_u_int(xdrs,&(mcftmp->nNTuples)) &&
	+ xdr_u_int(xdrs,&(mcftmp->dimNTuples))) == FALSE) return FALSE;
	+ if(xdrs->x_op == XDR_DECODE) {
	+ if ((mcftmp->blockIds == NULL) \|\| (mcftmp->dimBlocks > nnold)) {
	+ if (mcftmp->blockIds != NULL) {
	+ free(mcftmp->blockIds);
	+ free(mcftmp->ptrBlocks);
	+ }
	+ mcftmp->blockIds =
	+ (int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	+ mcftmp->ptrBlocks =
	+ (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dimBlocks);
	+ }
	+ if ((mcftmp->nTupleIds == NULL) \|\| (mcftmp->dimNTuples > nNTuOld)) {
	+ if (mcftmp->nTupleIds != NULL) {
	+ free(mcftmp->nTupleIds);
	+ free(mcftmp->ptrNTuples);
	+ }
	+ mcftmp->nTupleIds =
	+ (int ) malloc(sizeof(unsigned int) mcftmp->dimNTuples);
	+ mcftmp->ptrNTuples =
	+ (unsigned int ) malloc(sizeof(unsigned int) mcftmp->dimNTuples);
	+ }
	+ }
	+ if (mcftmp->dimBlocks > 0) {
	+ if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dimBlocks;
	+ itmp = mcftmp->blockIds;
	+ if (xdr_array(xdrs, (char **) &itmp, &nn,
	+ mcftmp->dimBlocks, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ uitmp = mcftmp->ptrBlocks;
	+ if (xdr_array(xdrs, (char **) &uitmp, &nn,
	+ mcftmp->dimBlocks, sizeof(u_int), (xdrproc_t)xdr_u_int) == FALSE)
	+ return FALSE;
	+ }
	+ if (mcftmp->dimNTuples > 0) {
	+ if (xdrs->x_op == XDR_ENCODE) nn = mcftmp->dimNTuples;
	+ itmp = mcftmp->nTupleIds;
	+ if (xdr_array(xdrs, (char **) &itmp, &nn,
	+ mcftmp->dimNTuples, sizeof(int), (xdrproc_t)xdr_int) == FALSE)
	+ return FALSE;
	+ uitmp = mcftmp->ptrNTuples;
	+ if (xdr_array(xdrs, (char **) &uitmp, &nn,
	+ mcftmp->dimNTuples, sizeof(u_int), (xdrproc_t)xdr_u_int) == FALSE)
	+ return FALSE;
	+ }
	+ } else
	+ return FALSE; /* Futur version encoded here. */
	+ return TRUE;
	+
	+}
	+
	+static bool_t xdr_mcfast_NTuDDL(XDR xdrs, char version, nTuDDL *ddl)
	+{
	+ int i, nc_title, nc_category, idRef;
	+ descrGenNtuple *dNTu;
	+
	+
	+ /*
	+ ** This is the first version, let us not get too compilcated..
	+ */
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ nc_title = strlen(ddl->title);
	+ nc_category = strlen(ddl->category);
	+ idRef = -1;
	+ /*
	+ ** Cross reference is only valid within the same stream.
	+ */
	+ if ((ddl->reference != NULL) &&
	+ (ddl->streamId == ddl->reference->streamId )) {
	+ /*
	+ ** compute the rerefence token. This is the sequential
	+ ** number of the reference Ntuple for this stream.
	+ */
	+ for (i=0, idRef=0; i<NumOfNTuples; i++) {
	+ if (NTuDDLList[i]->streamId == ddl->reference->streamId)
	+ idRef++;
	+ if (NTuDDLList[i]->id == ddl->reference->id) break;
	+ }
	+ }
	+ }
	+ if (xdr_int(xdrs, &nc_title) == FALSE) return FALSE;
	+ if (xdr_int(xdrs, &nc_category) == FALSE) return FALSE;
	+ if (xdr_int(xdrs, &idRef) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_DECODE) {
	+ ddl->title = (char ) malloc(sizeof(char) (nc_title +1));
	+ ddl->category = (char ) malloc(sizeof(char) (nc_category +1));
	+ ddl->dbinFileName = NULL;
	+ ddl->streamId = -1;
	+ }
	+ if (xdr_int(xdrs,&(ddl->uid)) == FALSE) return FALSE;
	+ if (xdr_string(xdrs, &(ddl->title), nc_title) == FALSE) return FALSE;
	+ if (xdr_string(xdrs, &(ddl->category),
	+ nc_category) == FALSE) return FALSE;
	+ if (idRef == -1) {
	+ if (xdrs->x_op == XDR_DECODE)
	+ ddl->descrNtu = (descrGenNtuple *) malloc (sizeof(descrGenNtuple));
	+ if (ddl->descrNtu == NULL) dNTu = ddl->reference->descrNtu;
	+ else dNTu = ddl->descrNtu;
	+ if (xdr_mcfast_descrNTU(xdrs, version, dNTu) == FALSE)
	+ return FALSE;
	+ if (xdrs->x_op == XDR_DECODE) ddl->reference = NULL;
	+ } else {
	+ if (xdrs->x_op == XDR_DECODE) {
	+ ddl->descrNtu = NULL;
	+ ddl->referenceId = idRef;
	+ /* we will set the reference pointer in mcfio_Direct */
	+ }
	+ }
	+ return TRUE;
	+
	+}
	+
	+static bool_t xdr_mcfast_descrNTU(XDR xdrs, char version,
	+ descrGenNtuple *dNTu)
	+{
	+ int i, nc_desc, nc_title;
	+ u_int nn;
	+ char *tc;
	+ /*
	+ ** This is the first version, let us not get too compilcated..
	+ */
	+
	+ if (xdr_int(xdrs,&(dNTu->numVariables)) == FALSE) return FALSE;
	+ dNTu->numAvailable = dNTu->numVariables;
	+ if (xdr_int(xdrs,&(dNTu->maxMultiplicity)) == FALSE) return FALSE;
	+ if (xdr_int(xdrs,&(dNTu->orgStyle)) == FALSE)return FALSE;
	+ if (xdr_int(xdrs,&(dNTu->firstIndexed)) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_ENCODE) nc_title = strlen(dNTu->title);
	+ if (xdr_int(xdrs, &nc_title) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_ENCODE) nc_desc = strlen(dNTu->description);
	+ if (xdr_int(xdrs, &nc_desc) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_DECODE) {
	+ dNTu->title = (char ) malloc(sizeof(char) (nc_title+1));
	+ dNTu->subXDROffset = NULL;
	+ dNTu->description = (char ) malloc(sizeof(char) (nc_desc+1));
	+ dNTu->varOrdering = (int ) malloc(sizeof(int) dNTu->numVariables);
	+ for (i=0; i<dNTu->numVariables; i++) dNTu->varOrdering[i] = i;
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ dNTu->subXDROffset = NULL;
	+ dNTu->subOffset = NULL;
	+ } else {
	+ dNTu->subOffset =
	+ (long ) malloc(sizeof(long) dNTu->maxMultiplicity);
	+ dNTu->subXDROffset =
	+ (u_int ) malloc(sizeof(long) dNTu->maxMultiplicity);
	+ }
	+ dNTu->variables =
	+ (varGenNtuple *) malloc(sizeof(varGenNtuple ) * dNTu->numVariables);
	+ for (i=0; i<dNTu->numVariables; i++)
	+ dNTu->variables[i] = (varGenNtuple *) malloc(sizeof(varGenNtuple));
	+ }
	+ tc = dNTu->nameIndex;
	+ if (xdr_string(xdrs, &tc, 31) == FALSE) return FALSE;
	+ if (xdr_string(xdrs,
	+ (char **) &(dNTu->title), nc_title) == FALSE) return FALSE;
	+ if (xdr_string(xdrs,
	+ &(dNTu->description), nc_desc) == FALSE) return FALSE;
	+ tc = dNTu->version;
	+ if (xdr_string(xdrs, &tc, 7) == FALSE) return FALSE;
	+ if (xdr_long(xdrs, &(dNTu->multOffset)) == FALSE) return FALSE;
	+ if (xdr_long(xdrs, &(dNTu->fenceOffset)) == FALSE) return FALSE;
	+ nn = dNTu->maxMultiplicity;
	+ if (dNTu->orgStyle != PARALLEL_ARRAY_NTU) {
	+ if (xdr_array(xdrs,
	+ (char **) &(dNTu->subOffset), &nn, nn, sizeof(long), (xdrproc_t)xdr_long) == FALSE)
	+ return FALSE;
	+ }
	+ for (i=0; i<dNTu->numVariables; i++)
	+ if (xdr_mcfast_varDescrNTU(xdrs, version, dNTu->variables[i]) == FALSE)
	+ return FALSE;
	+ return TRUE;
	+}
	+static bool_t xdr_mcfast_varDescrNTU(XDR xdrs, char version,
	+ varGenNtuple *var)
	+{
	+ int i, nc_name, nc_desc, *pdim;
	+ u_int nn;
	+
	+
	+
	+ if (xdrs->x_op == XDR_ENCODE) nc_name = strlen(var->name);
	+ if (xdr_int(xdrs, &nc_name) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ if (var->description == NULL) nc_desc = 0;
	+ else nc_desc = strlen(var->description);
	+ }
	+ if (xdr_int(xdrs, &nc_desc) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_DECODE) {
	+ var->name = (char ) malloc(sizeof(char) (nc_name+1));
	+ if (nc_desc>0)
	+ var->description = (char ) malloc(sizeof(char) (nc_desc+1));
	+ else var->description = NULL;
	+ var->nameBlank = FALSE;
	+ }
	+
	+ if (xdr_string(xdrs, &(var->name), nc_name) == FALSE) return FALSE;
	+ if (nc_desc > 0)
	+ if (xdr_string(xdrs, &(var->description), nc_desc) == FALSE)
	+ return FALSE;
	+ if (xdr_int(xdrs,&(var->type)) == FALSE) return FALSE;
	+ if (xdr_char(xdrs,&(var->isFixedSize)) == FALSE) return FALSE;
	+ if (xdr_int(xdrs,&(var->numDim)) == FALSE) return FALSE;
	+ nn = var->numDim;
	+ pdim = var->dimensions;
	+ if ((nn > 0) && (xdr_array(xdrs,
	+ (char **) &pdim, &nn, nn, sizeof(int), (xdrproc_t)xdr_int)) == FALSE)
	+ return FALSE;
	+ if (xdrs->x_op == XDR_ENCODE) nn = (u_int) var->lengthB;
	+ if (xdr_u_int(xdrs,&(nn)) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_DECODE) var->lengthB = (size_t) nn;
	+ if (xdrs->x_op == XDR_ENCODE) nn = (u_int) var->lengthW;
	+ if (xdr_u_int(xdrs,&(nn)) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_DECODE) var->lengthW = (size_t) nn;
	+ if (xdr_long(xdrs,&(var->offset)) == FALSE) return FALSE;
	+ return TRUE;
	+}
	+/*
	+** Generalized NTuple XDR filter
	+*/
	+bool_t xdr_mcfast_NTuple(XDR xdrs, descrGenNtuple dNTu,
	+ int pnTot, int nTupleId, char version)
	+{
	+ int i, j, id, nm, lastFixed;
	+ u_int nn;
	+ char vv, cDat, *start;
	+ int *pnMult;
	+ void *pnFence;
	+ int *ipnFence;
	+ void end, pt;
	+ bool_t ok;
	+/*
	+** Upon write, check that the version token is identical to the one stored
	+** in the ddl.
	+*/
	+ start = version;
	+ if(dNTu->firstIndexed == -1) lastFixed = dNTu->numVariables;
	+ else lastFixed = dNTu->firstIndexed;
	+ if ((xdrs->x_op == XDR_ENCODE) \|\| (xdrs->x_op == XDR_MCFIOCODE)) {
	+ nn = strlen(dNTu->version);
	+ if (strncmp(version, dNTu->version, (size_t) nn ) != 0) {
	+ fprintf (stderr, "mcfio_NTuple: version mismatch! \n\
	+ Version used in the Event loop = %s\n\
	+ ... in the DDl template = %s\n", version,dNTu->version);
	+ return FALSE;
	+ }
	+ id = nTupleId;
	+/*
	+** Compute the total length
	+*/
	+ cDat = start; cDat += dNTu->multOffset;
	+ pnMult = (int *) cDat;
	+ nm = *pnMult;
	+ for (i=0, nn=0; i<lastFixed; i++)
	+ nn += dNTu->variables[i]->lengthB;
	+ if(dNTu->firstIndexed != -1)
	+ for(i=dNTu->firstIndexed; i<dNTu->numVariables; i++)
	+ nn += (dNTu->variables[i]->lengthB * nm);
	+ *pnTot = 6 + nn/4;
	+ }
	+ if (xdr_int(xdrs, &id) == FALSE) return FALSE;
	+ if (xdr_int(xdrs, pnTot) == FALSE) return FALSE;
	+ if (xdrs->x_op == XDR_ENCODE) {
	+ vv = dNTu->version;
	+ if (xdr_string(xdrs, &vv, 11) == FALSE) return FALSE;
	+ } else if (xdrs->x_op == XDR_DECODE) {
	+ if (xdr_string(xdrs, &version, 11) == FALSE) return FALSE;
	+ if (strcmp(version, dNTu->version) != 0) {
	+ fprintf (stderr, "mcfio_NTuple: version mismatch! \n\
	+ Version used in the Event loop = %s\n\
	+ ... in the DDl template = %s\n", version,dNTu->version);
	+ return FALSE;
	+ }
	+ if (id != nTupleId) {
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected NTuple identifier % instead of %d\n", id, nTupleId);
	+ return FALSE;
	+ }
	+ }
	+
	+ cDat = start; cDat += dNTu->multOffset;
	+ pnMult = (int *) cDat;
	+ if (xdr_int(xdrs, pnMult) == FALSE) return FALSE;
	+ /*
	+ ** Close the fence now, we will check it upon DECODE at the end
	+ */
	+ cDat = start; cDat += dNTu->fenceOffset;
	+ pnFence = (void *) cDat;
	+ if (xdrs->x_op == XDR_ENCODE) memcpy(pnFence, pnTot, sizeof(int));
	+ if (xdr_int(xdrs, (int *) pnFence) == FALSE) return FALSE;
	+ nm = *pnMult;
	+ for (i=0; i<lastFixed; i++) {
	+ if (dNTu->variables[i]->lengthW == 1) {
	+ cDat = start; cDat += dNTu->variables[i]->offset;
	+ pt = (void *) cDat;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_char(xdrs, (char *) pt);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_short(xdrs, (short *) pt);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_int(xdrs, (int *) pt);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_float(xdrs, (float *) pt);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_double(xdrs, (double *) pt);
	+ break;
	+ case COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_long(xdrs, (long *) pt);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ }
	+ else if (dNTu->variables[i]->lengthW > 0) {
	+ cDat = start; cDat += dNTu->variables[i]->offset;
	+ pt = (void *) cDat;
	+ nn = dNTu->variables[i]->lengthW;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ if (ok == FALSE) return FALSE;
	+ }
	+ }
	+ if (dNTu->firstIndexed != -1) {
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	+ cDat = start; cDat += dNTu->variables[i]->offset;
	+ pt = (void *) cDat;
	+ nn = nm * dNTu->variables[i]->lengthW;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ vv = (char *) pt;
	+ ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ if (ok == FALSE) return FALSE;
	+ }
	+ } else { /dump the substructures one a time /
	+ for (j=0; j<nm; j++) {
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	+ cDat = start;
	+ cDat += (dNTu->subOffset[j] + dNTu->variables[i]->offset);
	+ pt = (void *) cDat;
	+ if (dNTu->variables[i]->lengthW == 1) {
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_char(xdrs, (char *) pt);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_short(xdrs, (short *) pt);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_int(xdrs, (int *) pt);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_float(xdrs, (float *) pt);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_double(xdrs, (double *) pt);
	+ break;
	+ case COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_long(xdrs, (long *) pt);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ }
	+ else if (dNTu->variables[i]->lengthW > 0) {
	+ nn = dNTu->variables[i]->lengthW;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ if (ok == FALSE) return FALSE;
	+ }
	+ } /end of i loop /
	+ } /end of j loop /
	+ } /* End of orgStyle clause */
	+ } /* End of firstIndexed clause */
	+ /*
	+ ** Check the fence..
	+ */
	+ ipnFence = (int *) pnFence;
	+ if ((xdrs->x_op == XDR_DECODE) && (ipnFence != pnTot)) {
	+ fprintf (stderr, "mcfio_NTuple: Suspected Data Overwrite! \n\
	+ Fence content found on the input stream is = %d\n\
	+ ... while we expect %d\n", ipnFence, pnTot);
	+ return FALSE;
	+ }
	+ return TRUE;
	+}
	+
	+/*
	+** Generalized NTuple XDR filter, for DECODE only, used exclusively
	+** to establish the relative XDR pointers.
	+*/
	+bool_t xdr_mcfast_NTupleXDRPtr(XDR xdrs, descrGenNtuple dNTu,
	+ int pnTot, int nTupleId, char version)
	+{
	+ int i, j, id, nm, lastFixed;
	+ u_int nn, startXDR;
	+ char vv, cDat;
	+ int pnMult, pnFence;
	+ void start, end, *pt;
	+ bool_t ok;
	+
	+ /*
	+ ** Allocate memory for supointer array if need be.
	+ */
	+ if(dNTu->firstIndexed == -1) lastFixed = dNTu->numVariables;
	+ else lastFixed = dNTu->firstIndexed;
	+
	+ if (dNTu->subXDROffset != NULL) free(dNTu->subXDROffset);
	+ dNTu->subXDROffset =
	+ (u_int ) malloc (sizeof(u_int) dNTu->maxMultiplicity);
	+ start = (void *) version;
	+ startXDR = xdr_getpos(xdrs);
	+ if (xdr_int(xdrs, &id) == FALSE) return FALSE;
	+ if (xdr_int(xdrs, pnTot) == FALSE) return FALSE;
	+
	+ if (xdr_string(xdrs, &version, 11) == FALSE) return FALSE;
	+ if (id != nTupleId) {
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected NTuple identifier % instead of %d\n", id, nTupleId);
	+ return FALSE;
	+ }
	+ cDat = start; cDat += dNTu->multOffset;
	+ pnMult = (int *) cDat;
	+ dNTu->multXDROffset = xdr_getpos(xdrs) - startXDR;
	+ if (xdr_int(xdrs, pnMult) == FALSE) return FALSE;
	+ /*
	+ ** Close the fence now, we will check it upon DECODE at the end
	+ */
	+ cDat = start; cDat += dNTu->fenceOffset;
	+ pnFence = (int *) cDat;
	+ dNTu->fenceXDROffset = xdr_getpos(xdrs) - startXDR;
	+ if (xdr_int(xdrs, (int *) pnFence) == FALSE) return FALSE;
	+ nm = *pnMult;
	+ for (i=0; i<lastFixed; i++) {
	+ dNTu->variables[i]->offsetXDR = 0;
	+ if (dNTu->variables[i]->lengthW == 1) {
	+ cDat = start; cDat += dNTu->variables[i]->offset;
	+ pt = (void *) cDat;
	+ dNTu->variables[i]->offsetXDR = xdr_getpos(xdrs) - startXDR;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_char(xdrs, (char *) pt);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_short(xdrs, (short *) pt);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_int(xdrs, (int *) pt);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_float(xdrs, (float *) pt);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_double(xdrs, (double *) pt);
	+ break;
	+ case COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_long(xdrs, (long *) pt);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ }
	+ else if (dNTu->variables[i]->lengthW > 0) {
	+ cDat = start; cDat += dNTu->variables[i]->offset;
	+ pt = (void *) cDat;
	+ nn = dNTu->variables[i]->lengthW;
	+ dNTu->variables[i]->offsetXDR = xdr_getpos(xdrs) - startXDR;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ if (ok == FALSE) return FALSE;
	+ }
	+ }
	+ if (dNTu->firstIndexed != -1) {
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	+ cDat =start; cDat += dNTu->variables[i]->offset;
	+ pt = (void *) cDat;
	+ nn = nm * dNTu->variables[i]->lengthW;
	+ dNTu->variables[i]->offsetXDR = xdr_getpos(xdrs) - startXDR;
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ vv = (char *) pt;
	+ ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ if (ok == FALSE) return FALSE;
	+ }
	+ } else { /dump the substructure one a time /
	+ for (j=0; j<nm; j++) {
	+ dNTu->subXDROffset[j] = xdr_getpos(xdrs) - startXDR;
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	+ cDat = start;
	+ cDat += (dNTu->subOffset[j] + dNTu->variables[i]->offset);
	+ pt = (void *) cDat;
	+ if (j == 0) dNTu->variables[i]->offsetXDR = 0;
	+ if (dNTu->variables[i]->lengthW == 1) {
	+ if (j == 0) dNTu->variables[i]->offsetXDR =
	+ xdr_getpos(xdrs) - startXDR- dNTu->subXDROffset[j];
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_char(xdrs, (char *) pt);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_short(xdrs, (short *) pt);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_int(xdrs, (int *) pt);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_float(xdrs, (float *) pt);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_double(xdrs, (double *) pt);
	+ break;
	+ case COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_long(xdrs, (long *) pt);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ }
	+ else if (dNTu->variables[i]->lengthW > 0) {
	+ nn = dNTu->variables[i]->lengthW;
	+ if (j == 0) dNTu->variables[i]->offsetXDR =
	+ xdr_getpos(xdrs) - startXDR - dNTu->subXDROffset[0];
	+ switch (dNTu->variables[i]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_bytes(xdrs, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(xdrs,
	+ (char **) &pt, &nn, nn, sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ fprintf (stderr, "mcfio_NTuple: internal error! \n\
	+ Unexpected variables type %d on NTuple \n",
	+ dNTu->variables[i]->type, nTupleId);
	+ break;
	+ }
	+ if (ok == FALSE) return FALSE;
	+ }
	+ } /end of i loop /
	+ } /end of j loop /
	+ } /* End of orgStyle clause */
	+ } /* End of firstIndexed clause */
	+ /*
	+ ** Check the fence..
	+ */
	+ if (pnFence != pnTot) {
	+ fprintf (stderr, "mcfio_NTuple: Suspected Data Overwrite! \n\
	+ Fence content found on the input stream is = %d\n\
	+ ... while we expect %d\n", pnFence, pnTot);
	+ return FALSE;
	+ }
	+ return TRUE;
	+}
	+/*
	+** Generalized NTuple XDR filter, used for Decode only.
	+** Simply decode the multiplicty value. No checks whatsoever!
	+*/
	+bool_t xdr_mcfast_NTupleMult(mcfStream str, descrGenNtuple dNTu,
	+ char* version)
	+{
	+ char *cDat;
	+
	+ cDat = version;
	+ cDat += dNTu->multOffset;
	+ xdr_setpos(str->xdr, (str->currentPos + dNTu->multXDROffset) );
	+ return (xdr_int(str->xdr, ((int *) cDat)));
	+}
	+
	+/*
	+** Generalized NTuple XDR filter, used for Decode only.
	+** Simply decode one variable (scalar) or array value. No checks whatsoever!
	+** Not applicable if the structure organization style is VAX FORTRAN d/s
	+** and the index corresponds to an indexed variable.
	+*/
	+bool_t xdr_mcfast_NTupleVar(mcfStream str, descrGenNtuple dNTu,
	+ int ivar, char* version)
	+{
	+ char *cDat;
	+ u_int nn;
	+ void *pt;
	+ int ivarP;
	+
	+ ivarP = ivar;
	+ while (dNTu->variables[ivarP]->lengthW == 0) ivarP--;
	+ cDat = version;
	+ cDat += dNTu->variables[ivarP]->offset;
	+ pt = (void *) cDat;
	+ xdr_setpos(str->xdr,
	+ (str->currentPos + dNTu->variables[ivarP]->offsetXDR));
	+ if ((dNTu->variables[ivarP]->lengthW == 1) &&
	+ (ivarP < dNTu->firstIndexed)) {
	+ switch (dNTu->variables[ivarP]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ return xdr_char(str->xdr, (char *) pt);
	+ case INTEGER2_NTU:
	+ return xdr_short(str->xdr, (short *) pt);
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ return xdr_int(str->xdr, (int *) pt);
	+ case REAL_NTU:
	+ return xdr_float(str->xdr, (float *) pt);
	+ case DBL_PRECISION_NTU:
	+ return xdr_double(str->xdr, (double *) pt);
	+ case COMPLEX_NTU:
	+ nn =2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn, sizeof(float), (xdrproc_t)xdr_float);
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn, sizeof(double), (xdrproc_t)xdr_double);
	+ case POINTER_NTU:
	+ return xdr_long(str->xdr, (long *) pt);
	+ default :
	+ return FALSE;
	+ }
	+ } else {
	+ nn = dNTu->variables[ivarP]->lengthW;
	+ switch (dNTu->variables[ivarP]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ return xdr_bytes(str->xdr, (char **) &pt, &nn, nn);
	+ case INTEGER2_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(short), (xdrproc_t)xdr_short);
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(int), (xdrproc_t)xdr_int);
	+ case REAL_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ case DBL_PRECISION_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ case POINTER_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(long), (xdrproc_t)xdr_long);
	+ default :
	+ return FALSE;
	+ }
	+ }
	+}
	+/*
	+** Generalized NTuple XDR filter, used for Decode only.
	+** Simply decode one variable (scalar) or array value. No checks whatsoever!
	+** Not applicable if the structure organization style is parallel array
	+** or the index corresponds to a fixed size variable.
	+*/
	+bool_t xdr_mcfast_NTupleSubVar(mcfStream str, descrGenNtuple dNTu,
	+ int ivar, int multIndex, char* version)
	+{
	+ char *cDat;
	+ u_int nn;
	+ void *pt;
	+ int ivarP;
	+
	+ ivarP = ivar;
	+ while (dNTu->variables[ivarP]->lengthW == 0) ivarP--;
	+ cDat = version;
	+ cDat += dNTu->subOffset[multIndex];
	+ cDat += dNTu->variables[ivarP]->offset;
	+ pt = (void *) cDat;
	+ xdr_setpos(str->xdr,
	+ (str->currentPos + dNTu->subXDROffset[multIndex] +
	+ dNTu->variables[ivarP]->offsetXDR));
	+ if (dNTu->variables[ivarP]->lengthW == 1) {
	+ switch (dNTu->variables[ivarP]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ return xdr_char(str->xdr, (char *) pt);
	+ case INTEGER2_NTU:
	+ return xdr_short(str->xdr, (short *) pt);
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ return xdr_int(str->xdr, (int *) pt);
	+ case REAL_NTU:
	+ return xdr_float(str->xdr, (float *) pt);
	+ case DBL_PRECISION_NTU:
	+ return xdr_double(str->xdr, (double *) pt);
	+ case COMPLEX_NTU:
	+ nn =2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ case POINTER_NTU:
	+ return xdr_long(str->xdr, (long *) pt);
	+ default :
	+ return FALSE;
	+ }
	+ } else {
	+ nn = dNTu->variables[ivarP]->lengthW;
	+ switch (dNTu->variables[ivarP]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ return xdr_bytes(str->xdr, (char **) &pt, &nn, nn);
	+ case INTEGER2_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(short), (xdrproc_t)xdr_short);
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(int), (xdrproc_t)xdr_int);
	+ case REAL_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ case DBL_PRECISION_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ case POINTER_NTU:
	+ return xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(long), (xdrproc_t)xdr_long);
	+ default :
	+ return FALSE;
	+ }
	+ }
	+}
	+/*
	+** Generalized NTuple XDR filter, used for Decode only.
	+** Simply decode a sub-structure given a value for the multiplicity index.
	+** Not applicable if the structure organization style is parallel array.
	+** No check whatsover!
	+*/
	+bool_t xdr_mcfast_NTupleSubStruct(mcfStream str, descrGenNtuple dNTu,
	+ int multIndex, char* version)
	+{
	+ char *cDat;
	+ u_int nn;
	+ void *pt;
	+ int iv;
	+ bool_t ok;
	+
	+ xdr_setpos(str->xdr,
	+ (str->currentPos + dNTu->subXDROffset[multIndex]));
	+ for (iv=dNTu->firstIndexed; iv<dNTu->numVariables; iv++) {
	+ cDat = version;
	+ cDat +=
	+ dNTu->subOffset[multIndex] + dNTu->variables[iv]->offset;
	+ pt = (void *) cDat;
	+ if (dNTu->variables[iv]->lengthW == 1) {
	+ switch (dNTu->variables[iv]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_char(str->xdr, (char *) pt);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_short(str->xdr, (short *) pt);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_int(str->xdr, (int *) pt);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_float(str->xdr, (float *) pt);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_double(str->xdr, (double *) pt);
	+ break;
	+ case COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn =2;
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_long(str->xdr, (long *) pt);
	+ default :
	+ return FALSE;
	+ }
	+ } else if (dNTu->variables[iv]->lengthW > 1){
	+ nn = dNTu->variables[iv]->lengthW;
	+ switch (dNTu->variables[iv]->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ ok = xdr_bytes(str->xdr, (char **) &pt, &nn, nn);
	+ break;
	+ case INTEGER2_NTU:
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(short), (xdrproc_t)xdr_short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(int), (xdrproc_t)xdr_int);
	+ break;
	+ case REAL_NTU:
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(float), (xdrproc_t)xdr_float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ nn = nn*2;
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(double), (xdrproc_t)xdr_double);
	+ break;
	+ case POINTER_NTU:
	+ ok = xdr_array(str->xdr,
	+ (char **) &pt, &nn, nn,
	+ sizeof(long), (xdrproc_t)xdr_long);
	+ break;
	+ default :
	+ return FALSE;
	+ }
	+ }
	+ }
	+ return TRUE;
	+}
	Index: trunk/contrib/mcfio/mcf_ntubldInit.c
	===================================================================
	--- trunk/contrib/mcfio/mcf_ntubldInit.c (revision 0)
	+++ trunk/contrib/mcfio/mcf_ntubldInit.c (revision 8889)
	@@ -0,0 +1,31 @@
	+/* Database default init routine */
	+/*** Generated automatically using the dbin tool. */
	+/*** Not to be modified by user. */
	+#include "mcf_ntubld_db.h"
	+void mcf_ntubldInit() {
	+
	+/*** template line_title ***/
	+/* char line " " */
	+/* end template */
	+*n_obj_line_title=0;
	+
	+/*** template header ***/
	+/* char title */
	+/* char version */
	+/* char nameMaxIndex */
	+/* int maxMult */
	+/* int orgStyle */
	+/* int nVar */
	+/* end template */
	+*n_obj_header=0;
	+
	+/*** template variable ***/
	+/* char name */
	+/* char description */
	+/* int type */
	+/* char isFixedSize */
	+/* int numDim */
	+/* int dimensions(5) */
	+/* end template */
	+*n_obj_variable=0;
	+}
	Index: trunk/contrib/mcfio/mcf_NTuIOUtils.c
	===================================================================
	--- trunk/contrib/mcfio/mcf_NTuIOUtils.c (revision 0)
	+++ trunk/contrib/mcfio/mcf_NTuIOUtils.c (revision 8889)
	@@ -0,0 +1,292 @@
	+/*******************************************************************************
	+* *
	+* mcf_NTuIOUtils.c -- Utilities to manipulate files within the MCFIO Gen. *
	+* Ntuple schema *
	+* *
	+* P. Lebrun, September 1995. *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <stdlib.h>
	+#include <sys/param.h>
	+#include <limits.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcfio_Dict.h"
	+#include "mcf_NTuIOFiles.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcf_ntubld_db.h"
	+#ifndef False
	+#define False 0
	+#endif
	+#ifndef True
	+#define True 1
	+#endif
	+
	+extern nTuDDL **NTuDDLList;
	+extern int NumOfNTuples;
	+
	+nTuDDL *mcf_GetNTuByPtrID(int id)
	+{
	+ int **ip;
	+
	+ if ( (id < 1) \|\| (id > NumOfNTuples)) return NULL;
	+ ip = (int **) NTuDDLList;
	+ ip += (id-1);
	+ return (nTuDDL ) ip;
	+}
	+
	+nTuDDL *mcf_GetNTuByStreamID(int stream, int id)
	+{
	+ int i, num;
	+ nTuDDL *ddl;
	+
	+ for (i=0, num=0; i<NumOfNTuples; i++) {
	+ ddl = NTuDDLList[i];
	+ if ((ddl->streamId == stream) && (ddl->seqNTuId == id)) return ddl;
	+ }
	+ return NULL;
	+}
	+int mcf_NTuId(int uid, char *category)
	+/*
	+ uid Unique User id
	+ category Category name, must be an exact match
	+
	+ Returns: Macfio_Ntuple id, or -1 if no items matched, or if
	+ Category is illegal..
	+*/
	+{
	+ int i, j, **ip;
	+ nTuDDL *item;
	+ char *cat;
	+
	+ if (!mcf_CheckValidCat(category, FALSE)) return -1;
	+ ip = (int **) NTuDDLList;
	+ cat = mcf_ValidStr(category, NTU_MAX_CATEGORY_LENGTH, "category");
	+ for (i=0; i< NumOfNTuples; i++, ip++) {
	+ item = (nTuDDL ) ip;
	+ if (item->uid == uid) { /* Look first at uid, if match, */
	+ /* Confirm with Category */
	+ if ((category == NULL) && (item->category == NULL))
	+ return (item->id);
	+ if (strcmp(category, item->category) == 0)
	+ return (item->id);
	+ j = strspn(category, " ");
	+ if (strcmp((category+j), item->category) == 0)
	+ return (item->id);
	+ }
	+ }
	+ return -1;
	+}
	+
	+int mcfioC_GetNTupleIds(int stream, int *ids, int max)
	+{
	+ int i, num;
	+ nTuDDL *ddl;
	+
	+ for (i=0, num=0; i<NumOfNTuples; i++) {
	+ ddl = NTuDDLList[i];
	+ if (ddl->streamId == stream) {
	+ if (num < max ) ids[num] = ddl->id;
	+ num++;
	+ }
	+ }
	+ return num;
	+}
	+
	+int mcfioC_GetNTupleUID(int stream, int id)
	+{
	+ nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	+ return ddl->uid;
	+}
	+
	+void mcfioC_GetNTupleCategory(int stream, int id, char **answer)
	+{
	+ nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	+ *answer = ddl->category;
	+}
	+
	+void mcfioC_GetNTupleTitle(int stream, int id, char **answer)
	+{
	+ nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	+ *answer = ddl->title;
	+}
	+
	+void mcfioC_GetNTupleName(int stream, int id, char **answer)
	+{
	+ nTuDDL *ddl = mcf_GetNTuByStreamID(stream, id);
	+ if (ddl->reference == NULL)
	+ *answer = ddl->descrNtu->title;
	+ else *answer = ddl->reference->descrNtu->title;
	+}
	+
	+/*
	+** Copy utility routine for a General Ntuple Variable descriptor d/s
	+** It is the responsability of the usr to allocate memory for the
	+** structure where data will be copied to.
	+*/
	+void CopyVarGenNtuple(varGenNtuple vFrom, varGenNtuple vTo)
	+{
	+ char string, tc, *tc2;
	+ int i, ll;
	+
	+ if ((vTo == NULL) \|\| (vFrom == NULL)) return;
	+ vTo->nameBlank = vFrom->nameBlank;
	+ if (vTo->name != NULL) {
	+ free(vTo->name);
	+ vTo->name = NULL;
	+ }
	+ if (vFrom->name != NULL) {
	+ ll = (1 + strlen(vFrom->name));
	+ vTo->name =
	+ (char ) malloc(sizeof(char) ll);
	+ strcpy(vTo->name, vFrom->name);
	+ }
	+ if (vTo->description != NULL) {
	+ free(vTo->description);
	+ vTo->description = NULL;
	+ }
	+ if (vFrom->description != NULL) {
	+ vTo->description =
	+ (char ) malloc(sizeof(char) (1 + strlen(vFrom->description)));
	+ strcpy(vTo->description, vFrom->description);
	+ }
	+ vTo->type = vFrom->type;
	+ vTo->isFixedSize = vFrom->isFixedSize;
	+ vTo->numDim = vFrom->numDim;
	+ if (vFrom->numDim > 0) {
	+ for (i=0; i<vFrom->numDim; i++)
	+ vTo->dimensions[i] = vFrom->dimensions[i];
	+ }
	+ vTo->offset = vFrom->offset;
	+ vTo->offsetXDR = vFrom->offsetXDR;
	+}
	+/*
	+** insert this ddl into the Global List, expand the list if need be.
	+** Also increment the number of NTuples defined (don't do it twice!).
	+*/
	+void AddNTuDDLtoList(nTuDDL *ddl)
	+{
	+ int i, **ipo;
	+
	+ NumOfNTuples++;
	+ ddl->id = NumOfNTuples;
	+ /*
	+ ** insert this ddl into the Global List, expand the list if need be
	+ */
	+ if( (NumOfNTuples - (NumOfNTuples/NTU_START_LIST_SIZE)*NTU_START_LIST_SIZE)
	+ == 1 && (NumOfNTuples != 1)) {
	+ ipo = (int **) NTuDDLList;
	+ NTuDDLList = (nTuDDL *) malloc(sizeof(int )*
	+ ((NumOfNTuples/NTU_START_LIST_SIZE + 1)*NTU_START_LIST_SIZE));
	+ memcpy(NTuDDLList, ipo, (sizeof(int )(NumOfNTuples-1)));
	+ free (ipo);
	+ }
	+ NTuDDLList[NumOfNTuples-1] = ddl;
	+
	+}
	+/*
	+** Free the memory for a Ntuple Data Descrp. Lang (DDL).
	+*/
	+void DestroyNTuDDL(nTuDDL *ddl)
	+{
	+ int i;
	+ if (ddl->title != NULL) free(ddl->title);
	+ if (ddl->category != NULL) free(ddl->category);
	+ if (ddl->dbinFileName != NULL) free(ddl->dbinFileName);
	+ DestroyGenNtuple(ddl->descrNtu);
	+ free(ddl);
	+}
	+/*
	+** Free the memory for a Description NTuple
	+** Note : the pointer to adrresses are lost, the user will have to give
	+** them to this application back..
	+*/
	+void DestroyGenNtuple(descrGenNtuple *dNTu)
	+{
	+ int i;
	+
	+ if (dNTu == NULL) return;
	+ if (dNTu->title != NULL) free(dNTu->title);
	+ if (dNTu->description != NULL) free(dNTu->description);
	+ if (dNTu->varOrdering != NULL) free(dNTu->varOrdering);
	+ if (dNTu->subOffset != NULL) free(dNTu->subOffset);
	+ if (dNTu->subXDROffset != NULL) free(dNTu->subXDROffset);
	+ for (i=0; i<dNTu->numAvailable; i++)
	+ DestroyVarGenNtuple(dNTu->variables[i]);
	+ free(dNTu->variables);
	+ free(dNTu);
	+}
	+
	+
	+void DestroyVarGenNtuple(varGenNtuple *var)
	+{
	+
	+ if (var == NULL) return;
	+ if (var->name != NULL) free(var->name);
	+ if (var->description != NULL) free(var->description);
	+ free(var);
	+}
	+/*
	+ * ValidStr - Validate strings supplied by user
	+ *
	+ * returns: pointer to valid same or new truncated string
	+ *
	+ * Note: copy string returned, if needed, before calling ValidStr again
	+ */
	+char mcf_ValidStr(char string, int max_length, char *strKind)
	+{
	+ static char str[NTU_MAX_CATEGORY_LENGTH+1]; /* make longest string */
	+ static char str1[1] = "";
	+
	+ if (string == NULL)
	+ return str1; /* return empty string */
	+ if (strlen(string) <= max_length)
	+ return string; /* return pointer to same string */
	+ fprintf(stderr,
	+ "Mcfio_Ntuple: Error. Specified %s string is too long, truncating\n ->%s\n",
	+ strKind, string);
	+ memset(str, 0, NTU_MAX_CATEGORY_LENGTH+1);
	+ return strncpy(str, string, max_length); /* return ptr to trunc. string */
	+}
	+/*
	+** Based on the HistoScope Check Category
	+*/
	+int mcf_CheckValidCat(char *category, int dotDotDot)
	+{
	+ static char validChars[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ\
	+abcdefghijklmnopqrstuvwxyz1234567890/~!@#$%^&*()_+=-`\"\'\t?><,. ";
	+ char strDots, error = NULL;
	+ int len;
	+
	+ if (category == NULL)
	+ return 1;
	+ len = strlen(category);
	+ strDots = strstr(category, "...");
	+ if (len >= NTU_MAX_CATEGORY_LENGTH)
	+ error = "is too long";
	+ else if (strspn(category, validChars) != len)
	+ error = "contains invalid characters";
	+ else if (strstr(category, "//") != NULL)
	+ error = "contains \"//\"";
	+ else if (category[0] == '/')
	+ error = "contains leading slash";
	+ else if (category[len-1] == '/')
	+ error = "contains trailing slash";
	+ else if ((dotDotDot == 0 && strDots != NULL)
	+ \|\| (dotDotDot != 0 && strDots != NULL && strDots != category + len-3))
	+ error = "contains invalid \"...\"";
	+
	+ if (error != NULL) {
	+ fprintf(stderr, "Error in declared category %s: %s\n",
	+ error, category);
	+ return 0;
	+ } else {
	+ return (strDots == NULL ? 1 : -1);
	+ }
	+}
	+
	Index: trunk/contrib/mcfio/mcfio_Dict.h
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Dict.h (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Dict.h (revision 8889)
	@@ -0,0 +1,57 @@
	+/*******************************************************************************
	+* *
	+* mcfio_dict.h -- Dictionary for Key words used in Info routines. *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+*******************************************************************************/
	+#define MCFIO_VERSION 100
	+#define MCFIO_STATUS 101
	+#define MCFIO_RUNNING 102
	+#define MCFIO_BOF 103
	+#define MCFIO_EOF 104
	+#define MCFIO_NUMBLOCKS 501
	+#define MCFIO_READORWRITE 502
	+#define MCFIO_READ 1
	+#define MCFIO_WRITE 2
	+#define MCFIO_DIRECTORSEQUENTIAL 503
	+#define MCFIO_DIRECT 1
	+#define MCFIO_SEQUENTIAL 2
	+#define MCFIO_MEMMAPPED 3
	+#define MCFIO_BLOCKIDS 504
	+#define MCFIO_NUMWORDS 505
	+#define MCFIO_EFFICIENCY 506
	+#define MCFIO_NUMEVTS 507
	+#define MCFIO_FILENUMBER 508
	+#define MCFIO_MAXREC 509
	+#define MCFIO_MINREC 510
	+#define MCFIO_NUMRECORDS 511
	+#define MCFIO_RECORDLENGTHS 512
	+#define MCFIO_TITLE 1001
	+#define MCFIO_COMMENT 1002
	+#define MCFIO_CREATIONDATE 1003
	+#define MCFIO_CLOSINGDATE 1013
	+#define MCFIO_FILENAME 1004
	+#define MCFIO_DEVICENAME 1005
	+#define MCFIO_EVENTNUMBER 2001
	+#define MCFIO_STORENUMBER 2002
	+#define MCFIO_RUNNUMBER 2003
	+#define MCFIO_TRIGGERMASK 2004
	+#define MCFIO_NUMNTUPLES 4001
	+#define MCFIO_NTUPLESLIST 4002
	+/*
	+** Block definition now. Start counting at 101 See also mcfioC_GetBlockNames
	+*/
	+#define MCFIO_STDHEP 101
	+#define MCFIO_OFFTRACKARRAYS 102
	+#define MCFIO_OFFTRACKSTRUCT 103
	+#define MCFIO_TRACEARRAYS 104
	+#define MCFIO_STDHEPM 105
	+#define MCFIO_STDHEPBEG 106
	+#define MCFIO_STDHEPEND 107
	+#define MCFIO_STDHEPCXX 108
	+#define MCFIO_STDHEP4 201
	+#define MCFIO_STDHEP4M 202
	+#define MCFIO_HEPEUP 203
	+#define MCFIO_HEPRUP 204
	Index: trunk/contrib/mcfio/mcf_NTuIOFiles.c
	===================================================================
	--- trunk/contrib/mcfio/mcf_NTuIOFiles.c (revision 0)
	+++ trunk/contrib/mcfio/mcf_NTuIOFiles.c (revision 8889)
	@@ -0,0 +1,968 @@
	+/*******************************************************************************
	+* *
	+* mcf_NTuIOFiles.c -- Utilities to manipulate files within the MCFIO Gen. *
	+* Ntuple schema *
	+* *
	+* P. Lebrun, September 1995. *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <unistd.h>
	+#include <string.h>
	+#include <stdlib.h>
	+#include <ctype.h>
	+#include <sys/param.h>
	+#include <limits.h>
	+#include <time.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#ifdef _HPUX_SOURCE
	+#include <unistd.h>
	+#endif
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcfio_Dict.h"
	+#include "mcfio_Direct.h"
	+#include "mcfio_Util1.h"
	+#include "mcf_ntuBldDbinc.h"
	+#include "mcf_NTuIOFiles.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcf_ntubld_db.h"
	+#ifndef False
	+#define False 0
	+#endif
	+#ifndef True
	+#define True 1
	+#endif
	+
	+extern char *VarTypesNamesF77[N_VAR_TYPES];
	+extern char *VarTypesNamesC[N_VAR_TYPES];
	+
	+extern struct line_title_c line_title_c_;
	+extern struct header_c header_c_;
	+extern struct variable_c variable_c_;
	+
	+/*
	+** Ntuple identifiers list, initialized here and in mcfio_Util1
	+*/
	+nTuDDL **NTuDDLList = NULL;
	+int NumOfNTuples = 0;
	+bool_t McfNTuPleSaveDecoding = True;
	+
	+static char makeStructName(char title, int orgStyle);
	+static size_t nDatVariable(varGenNtuple *varTmp);
	+static size_t sizeVariable(varGenNtuple *varTmp);
	+static char mcf_copyNtrim(char fromString);
	+
	+int mcfioC_DeclareNtuple(int uid, char title, char category,
	+ int stream, char *filename)
	+{
	+ nTuDDL ddl, ddlRef;
	+ int i, l, j, jstr, dejaVu, id, ip, ipo, **ipt;
	+
	+
	+ if ((stream < 1) \|\| (stream > MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,
	+ " mcfio_NtupleDDLRead: Illegal MCFIO stream number.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_DeclareNtuple: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+
	+ if (McfStreamPtrList[jstr]->row != MCFIO_WRITE) {
	+ fprintf(stderr,
	+ " mcfio_DeclareNtuple: You must declare an Ntuple for an Output Stream\n");
	+ return -1;
	+ }
	+
	+ if (!mcf_CheckValidCat(category, False)) return 0;
	+
	+ /* Check that this item characterized by uid/Category has not already been
	+ created. If so, do not create a new one. If associated to the same
	+ stream, flag this as an error. */
	+
	+ id = mcf_NTuId(uid, category);
	+ if (id != -1) {
	+ ddl = mcf_GetNTuByPtrID(id);
	+ if (ddl->streamId == stream) {
	+ fprintf(stderr,
	+ "Mcfio Declare Ntuple: An item with this uid/Category already exists.\n");
	+ fprintf(stderr, " uid = %d, Category = %s, ", uid, category);
	+ fprintf(stderr, "Ntuple not created.\n");
	+ return -1;
	+ }
	+ }
	+ /*
	+ ** May be this dbin template has already been digested. If so, refer
	+ ** to it, to avoid re-computing all the offsets.
	+ */
	+ ip = (int **) NTuDDLList;
	+ for (i=0, dejaVu=False; i< NumOfNTuples; i++, ip++) {
	+ ddlRef = (nTuDDL ) ip;
	+ if ((ddlRef->dbinFileName != NULL) &&
	+ (strcmp(filename, ddlRef->dbinFileName) == 0)) {
	+ dejaVu = True;
	+ /* Create a holder for this Ntuple Description */
	+ ddl = (nTuDDL * ) malloc(sizeof(nTuDDL));
	+ /*
	+ ** back up in the linked list if need be, until we
	+ ** a fully documented descriptor.
	+ */
	+ while (ddlRef->descrNtu == NULL) ddlRef = ddlRef->reference;
	+ ddl->reference = ddlRef;
	+ ddl->descrNtu = NULL;
	+ ddl->dbinFileName = NULL;
	+ break;
	+ }
	+ }
	+ if (dejaVu == False) {
	+ ddl = mcf_GetFileNTuDDL(filename);
	+ if (ddl == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NtupleDDLRead: Error reading %s\n", filename );
	+ return -1;
	+ }
	+ ddl->reference = NULL;
	+ }
	+ ddl->title = mcf_copyNtrim(mcf_ValidStr(title, NTU_MAX_TITLE_LENGTH,
	+ "title"));
	+ if (category == NULL)
	+ ddl->category =
	+ mcf_copyNtrim(mcf_ValidStr(category, NTU_MAX_CATEGORY_LENGTH,
	+ "category"));
	+ else {
	+ ddl->category = mcf_copyNtrim(category);
	+ }
	+ AddNTuDDLtoList(ddl);
	+/*
	+** Now we compute the offssets.
	+*/
	+ if (dejaVu == False) {
	+ mcf_ComputeNTuOffsets(ddl);
	+/*
	+** Now we compute the lengths..
	+*/
	+ mcf_ComputeNTuLengths(ddl);
	+ }
	+ ddl->uid = uid;
	+ ddl->streamId = stream;
	+ /*
	+ ** Set the sequential id for this particular stream
	+ */
	+ for (i=0, j=0; i<NumOfNTuples; i++)
	+ if (NTuDDLList[i]->streamId == ddl->streamId) j++;
	+ ddl->seqNTuId = j;
	+ (McfStreamPtrList[jstr]->fhead->nNTuples)++;
	+ return ddl->seqNTuId;
	+}
	+
	+int mcfioC_EndDeclNTuples(int stream)
	+/*
	+** Routine to end theNtuple delcaration and rewrite the beginning of the
	+** file.
	+*/
	+{
	+ int i, j, jstr, idtmp, ntot;
	+ u_int p1, p2;
	+ FILE *ff;
	+ mcfStream *str;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_EndDeclNtuple: No stream open, No inialization.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_EndDeclNtuple: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str->row != MCFIO_WRITE) {
	+ fprintf(stderr,
	+ " mcfio_EndDeclNtuple: This routine is not applicable to Input streams...\n");
	+ return -1;
	+ }
	+ if (str->fhead->nNTuples < 1) {
	+ fprintf(stderr,
	+ " mcfio_EndDeclNtuple: No Ntuple declared for this stream...\n");
	+ return 0;
	+ }
	+ /*
	+ ** Now we can try toto complete the file header. As it is now bigger,
	+ ** and it is the first structure written, it is easier to start over.
	+ ** Destroy the XDR stream, close the file, and reopen it.
	+ */
	+ xdr_destroy(str->xdr);
	+ fclose(str->filePtr);
	+ remove(str->filename);
	+ ff = fopen(str->filename, "w");
	+ if (ff == NULL) {
	+ fprintf(stderr,
	+ " mcfio_EndDeclNtuple: Problem re-opening file %s, message \n",
	+ str->filename);
	+ return -1;
	+ }
	+ xdrstdio_create(str->xdr, ff, XDR_ENCODE);
	+ p1 = xdr_getpos(str->xdr);
	+ str->firstPos = p1;
	+ str->currentPos = p1;
	+ /*
	+ ** In the file header, we do not store the NTuple Ids, as they are
	+ ** not necessarily valid in an other context, where we have different
	+ ** streams/NTuples combinations. The SeqNTuId are trivial,
	+ ** within a stream, at the file header (1,2,3,..)
	+ ** But, of course, we must provide an array for the event header..
	+ */
	+ str->ehead->dimNTuples = str->fhead->nNTuples;
	+ str->ehead->nNTuples = 0;
	+ str->ehead->nTupleIds =
	+ (int ) malloc(sizeof(int) str->fhead->nNTuples);
	+
	+ str->ehead->ptrNTuples =
	+ (u_int ) malloc(sizeof(u_int) str->fhead->nNTuples);
	+ for (i=0; i<str->ehead->dimNTuples; i++) str->ehead->ptrNTuples[i]=0;
	+
	+ str->status = MCFIO_BOF;
	+ if (mcfioC_Wrtfhead(str, INITIATE) == FALSE){
	+ mcfioC_FreeStream(&McfStreamPtrList[jstr]);
	+ fclose(ff);
	+ return -1;
	+ }
	+ /*
	+ ** Write the first dummy table
	+ */
	+ if (mcfioC_Wrttable(str, INITIATE) == FALSE) return -1;
	+ /*
	+ ** Write the first dummy event header
	+ */
	+ if (mcfioC_WrtEvt(str, INITIATE) == FALSE) return -1;
	+ str->ehead->evtnum = 0;
	+ str->status = MCFIO_RUNNING;
	+ return (str->fhead->nNTuples);
	+}
	+
	+nTuDDL mcf_GetFileNTuDDL(charfilename)
	+{
	+ nTuDDL *ddl;
	+ int i, l, j;
	+ char text, tc;
	+ varGenNtuple *varTmp;
	+ descrGenNtuple *dNTu;
	+
	+ /* Create a holder for this Ntuple Description */
	+ ddl = (nTuDDL * ) malloc(sizeof(nTuDDL));
	+ ddl->dbinFileName = (char ) malloc(sizeof(char) (strlen(filename) +1));
	+ strcpy(ddl->dbinFileName, filename);
	+ ddl->descrNtu = (descrGenNtuple *) malloc(sizeof(descrGenNtuple));
	+ dNTu = ddl->descrNtu;
	+
	+ header_c_.n_obj_header = 0;
	+ line_title_c_.n_obj_line_title = 0;
	+ mcf_ntubldRead(filename);
	+ if ((line_title_c_.n_obj_line_title < 1) \|\|
	+ (header_c_.n_obj_header != 1)) {
	+ fprintf(stderr,
	+ " This file was not created by the ntuBuild aplication!");
	+ return NULL;
	+ }
	+ if (strcmp(line_title_c_.line_title[0].line,
	+ "ntuBuild Database, v1.0") != 0) {
	+ fprintf(stderr,
	+ " This file was not created by a wrong version of ntuBuild!");
	+ return NULL;
	+ }
	+ /*
	+ ** There are 80 character per lines in dbin..
	+ */
	+ text = (char *)
	+ malloc(sizeof(char) * 80 * (line_title_c_.n_obj_line_title -1));
	+ for (i=1, tc=text; i<line_title_c_.n_obj_line_title; i++) {
	+ strcpy(tc, line_title_c_.line_title[i].line);
	+ tc += strlen(line_title_c_.line_title[i].line);
	+ *tc = '\n'; tc++;
	+ }
	+ *tc = '\0';
	+ dNTu->description = text;
	+
	+ l = strlen(header_c_.header[0].title);
	+ dNTu->title = (char ) malloc(sizeof(char) (l+1));
	+ strcpy(dNTu->title, header_c_.header[0].title);
	+
	+ strcpy(dNTu->version, header_c_.header[0].version);
	+
	+ strcpy(dNTu->nameIndex, header_c_.header[0].namemaxindex);
	+
	+ dNTu->maxMultiplicity = header_c_.header[0].maxmult;
	+
	+ dNTu->orgStyle = header_c_.header[0].orgstyle;
	+ dNTu->numVariables = header_c_.header[0].nvar;
	+ dNTu->numAvailable = dNTu->numVariables;
	+ dNTu->variables =
	+ (varGenNtuple *) malloc(sizeof(varGenNtuple ) * dNTu->numVariables);
	+ /*
	+ ** Now the variables
	+ */
	+ for (i=0; i<variable_c_.n_obj_variable; i++) {
	+ dNTu->variables[i] =
	+ (varGenNtuple *) malloc(sizeof(varGenNtuple));
	+ varTmp = dNTu->variables[i];
	+ varTmp->nameBlank = False;
	+ varTmp->name = (char *)
	+ malloc(sizeof(char) * (strlen(variable_c_.variable[i].name) + 1));
	+ strcpy(varTmp->name, variable_c_.variable[i].name);
	+
	+ if ((strlen(variable_c_.variable[i].description) > 1) \|\|
	+ variable_c_.variable[i].description[0] != ' ') {
	+ varTmp->description = (char ) malloc(sizeof(char)
	+ (strlen(variable_c_.variable[i].description) + 1));
	+ strcpy(varTmp->description, variable_c_.variable[i].description);
	+ } else varTmp->description = NULL;
	+ varTmp->type = variable_c_.variable[i].type;
	+ varTmp->isFixedSize = True;
	+ if (strncmp(variable_c_.variable[i].isfixedsize,"Yes",3))
	+ varTmp->isFixedSize = False;
	+ varTmp->numDim = variable_c_.variable[i].numdim;
	+ if (varTmp->numDim > 0)
	+ for (j=0; j< varTmp->numDim; j++)
	+ varTmp->dimensions[j] = variable_c_.variable[i].dimensions[j];
	+
	+ }
	+ /*
	+ ** Set the ordering. Trivial in this case, it has been ordered in
	+ ** the save routine.
	+ */
	+ dNTu->varOrdering = (int ) malloc(sizeof(int) dNTu->numAvailable);
	+ for (i=0; i<dNTu->numVariables; i++)
	+ dNTu->varOrdering[i] = i;
	+ dNTu->subOffset = NULL;
	+ dNTu->subXDROffset = NULL;
	+ return ddl;
	+
	+}
	+
	+/*
	+** Compute the offsets by writing a simple program, stand alone, that uses
	+** the d/s
	+*/
	+void mcf_ComputeNTuOffsets(nTuDDL *ddl)
	+{
	+ char tmpName[128], tc, tc1, *nameCom;
	+ int i, j, l, fd, firstIndexed, nDat;
	+ char filenameInclude[128], filenameProgram[128], filenameExec[128];
	+ char filenameData[128], nameMaxIndex[32];
	+ char line[256];
	+ void **ptrBegVar;
	+ varGenNtuple *varTmp;
	+ descrGenNtuple *dNTu;
	+ FILE *Ffp;
	+
	+ dNTu =ddl->descrNtu;
	+ for (i=0; i< dNTu->numVariables; i++) {
	+ varTmp = dNTu->variables[i];
	+ varTmp->offset = 0;
	+ }
	+
	+ memset(tmpName, 0, 127);
	+ tc = tmpName;
	+ sprintf(tc, "tmp_%s_XXXXXX", ddl->descrNtu->title);
	+/* this is a kludge - we create a temporary file, close it, and use the name */
	+ fd = mkstemp(tmpName);
	+ if ( fd < 0 ) {
	+ fprintf(stderr,
	+ " Can not compose a tempoary name in mcf_ComputeOffsets!");
	+ return;
	+ }
	+ tc1 = tc;
	+ close(fd);
	+ sprintf(filenameInclude, "%s.h", tc1);
	+ sprintf(filenameProgram, "%s.c", tc1);
	+ sprintf(filenameData, "%s.dat", tc1);
	+ strcpy(filenameExec, tc1);
	+ mcf_ComposeDoth(ddl->descrNtu, filenameInclude);
	+/*
	+** Compose a little moronic program that establishes the addresses of all
	+** variables. There might be a better way, though.. However, this ought to be
	+** safe.
	+*/
	+ Ffp = fopen( filenameProgram, "w");
	+ fprintf(Ffp, "#include <stdio.h>\n");
	+ fprintf(Ffp, "#include \"%s\"\n",filenameInclude);
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU)
	+ fprintf(Ffp, "#define NUM_VAR %d\n", (dNTu->numVariables+3));
	+ else
	+ fprintf(Ffp, "#define NUM_VAR %d\n",
	+ (dNTu->numVariables + 3 + dNTu->maxMultiplicity) );
	+
	+ nameCom = makeStructName(dNTu->title, dNTu->orgStyle);
	+
	+ fprintf(Ffp, "%s_struct tmpStruct; \n", nameCom);
	+ fprintf(Ffp, "main(int argc, char **argv)\n");
	+ fprintf(Ffp, "{\n");
	+ fprintf(Ffp, " void *ptrBegVar[NUM_VAR];\n");
	+ fprintf(Ffp, " FILE *Ffp;\n");
	+ fprintf(Ffp, " int i;\n");
	+ fprintf(Ffp, "\n");
	+ fprintf(Ffp, " ptrBegVar[0] = (void *) &tmpStruct.version[0];\n");
	+ fprintf(Ffp,
	+ " ptrBegVar[1] = (void *) &tmpStruct.%s;\n",dNTu->nameIndex);
	+ for(i=0, firstIndexed=-1; i<dNTu->numVariables; i++) {
	+ if (dNTu->variables[i]->isFixedSize == False) {
	+ firstIndexed = i; break;
	+ }
	+ }
	+ dNTu->firstIndexed = firstIndexed;
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ for(i=0; i<dNTu->numVariables; i++) {
	+ varTmp = dNTu->variables[i];
	+ /*
	+ ** Assume that all the variables are properly
	+ ** defined at this stage (e..g, coming from a valid DDL dbin file)
	+ ** and in order
	+ */
	+ tc = line;
	+ if ((varTmp->numDim == 0) && (varTmp->isFixedSize == True))
	+ sprintf(tc,
	+ " ptrBegVar[%d] = (void *) &tmpStruct.%s%n",
	+ (i+2), varTmp->name, &l);
	+ else
	+ sprintf(tc,
	+ " ptrBegVar[%d] = (void *) tmpStruct.%s%n",
	+ (i+2), varTmp->name, &l);
	+ tc+=l;
	+ fprintf(Ffp, "%s;\n", line);
	+ }
	+ fprintf(Ffp,
	+ " ptrBegVar[%d] = (void *) tmpStruct.fence;\n",dNTu->numVariables+2);
	+ } else {
	+ for(i=0; i<dNTu->numVariables; i++) {
	+ varTmp = dNTu->variables[i];
	+ tc = line;
	+ if (varTmp->isFixedSize == True) {
	+ if (varTmp->numDim == 0)
	+ sprintf(tc,
	+ " ptrBegVar[%d] = (void *) &tmpStruct.%s%n",
	+ (i+2), varTmp->name, &l);
	+ else
	+ sprintf(tc,
	+ " ptrBegVar[%d] = (void *) tmpStruct.%s%n",
	+ (i+2), varTmp->name, &l);
	+ } else {
	+ if (varTmp->numDim == 0)
	+ sprintf(tc,
	+ " ptrBegVar[%d] = (void *) &tmpStruct.var[0].%s%n",
	+ (i+2), varTmp->name, &l);
	+ else
	+ sprintf(tc,
	+ " ptrBegVar[%d] = (void *) tmpStruct.var[0].%s%n",
	+ (i+2), varTmp->name, &l);
	+ }
	+ fprintf(Ffp, "%s;\n", line);
	+ }
	+ tc1 = dNTu->nameIndex;
	+ strcpy(nameMaxIndex, tc1);
	+ l = strlen(tc1);
	+ if (l > 26) {
	+ strncpy(nameMaxIndex, tc1, 26);
	+ sprintf(&nameMaxIndex[26],"_max");
	+ } else
	+ sprintf(nameMaxIndex, "%s_max", tc1);
	+ fprintf(Ffp," for (i=0; i<%s; i++) \n", nameMaxIndex);
	+ tc = line;
	+ if (firstIndexed != -1) {
	+ varTmp = dNTu->variables[firstIndexed];
	+ sprintf(tc,
	+ " ptrBegVar[i+%d] = (void *) &tmpStruct.var[i].%s%n",
	+ (2+dNTu->numVariables), varTmp->name, &l); tc+=l;
	+ if (varTmp->numDim > 0) for (j=0; j<varTmp->numDim; j++, tc+=l)
	+ sprintf(tc, "[0]%n", &l);
	+ fprintf(Ffp, "%s;\n", line);
	+ }
	+ fprintf(Ffp,
	+ " ptrBegVar[%d] = (void *) tmpStruct.fence;\n",
	+ dNTu->numVariables+2+dNTu->maxMultiplicity);
	+ }
	+ fprintf(Ffp, " ");
	+ fprintf(Ffp," Ffp = fopen(\"%s\",\"w\");\n",filenameData);
	+ fprintf(Ffp," fwrite((void ) ptrBegVar, sizeof(void ),\
	+(size_t) NUM_VAR, Ffp);\n");
	+ fprintf(Ffp," fclose(Ffp);\n");
	+ fprintf(Ffp,"}\n");
	+ fclose(Ffp);
	+ free(nameCom);
	+ /*
	+ ** Now compile, link and load this exec, read the result
	+ */
	+ sprintf(line,"rm -f %s", filenameExec);
	+ system(line);
	+#ifdef _HPUX_SOURCE
	+ sprintf(line,"cc -Aa -D_HPUX_SOURCE -o %s %s",
	+ filenameExec, filenameProgram);
	+#else
	+ sprintf(line,"cc -o %s %s", filenameExec, filenameProgram);
	+#endif
	+ system(line);
	+ sprintf(line,"./%s", filenameExec);
	+ system(line);
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) nDat = dNTu->numVariables+3;
	+ else nDat = dNTu->numVariables+3+dNTu->maxMultiplicity;
	+ if (firstIndexed == -1) nDat = dNTu->numVariables+3;
	+ ptrBegVar = (void *) malloc (sizeof(void ) * (nDat));
	+ Ffp = fopen(filenameData, "r");
	+ fread((void ) ptrBegVar, sizeof(void ), (size_t) nDat, Ffp);
	+ fclose(Ffp);
	+ /*
	+ ** remove garbage files..
	+ */
	+ remove(filenameData); remove(filenameProgram); remove(filenameExec);
	+ remove(filenameInclude);
	+ /*
	+ ** Convert these addresses to offsets
	+ */
	+ dNTu->multOffset = ((long) ptrBegVar[1] - (long) ptrBegVar[0]);
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ dNTu->fenceOffset =
	+ ((long) ptrBegVar[dNTu->numVariables+2] - (long) ptrBegVar[0]);
	+ for (i=0; i< dNTu->numVariables; i++)
	+ dNTu->variables[i]->offset =
	+ ((long) ptrBegVar[i+2] - (long) ptrBegVar[0]);
	+ } else {
	+ for (i=0; i< dNTu->numVariables; i++) {
	+ varTmp = dNTu->variables[i];
	+ if (varTmp->isFixedSize)
	+ varTmp->offset =
	+ ((long) ptrBegVar[i+2] - (long) ptrBegVar[0]);
	+ else
	+ varTmp->offset =
	+ ((long) ptrBegVar[i+2] - (long)ptrBegVar[firstIndexed+2]);
	+ }
	+ if (dNTu->subOffset != NULL) free(dNTu->subOffset);
	+ dNTu->subOffset =
	+ (long ) malloc(sizeof(long) dNTu->maxMultiplicity);
	+ if (firstIndexed != -1) {
	+ for (i=0; i<dNTu->maxMultiplicity; i++)
	+ dNTu->subOffset[i] =
	+ ((long) ptrBegVar[i+2+dNTu->numVariables] -
	+ (long) ptrBegVar[0]);
	+ }
	+ dNTu->fenceOffset =
	+ ((long) ptrBegVar[dNTu->numVariables+2+dNTu->maxMultiplicity]
	+ - (long) ptrBegVar[0]);
	+ }
	+ free(ptrBegVar);
	+}
	+
	+/*
	+** Compute the lengths for the XDR Array statements. It is assumed that the
	+** NTUple descriptor is sorted, no blank variables.
	+*/
	+void mcf_ComputeNTuLengths(nTuDDL *ddl)
	+{
	+ int i, j, lastTmp, sameType;
	+ size_t nDat, sizeItem;
	+ varGenNtuple var1, var2;
	+ descrGenNtuple *dNTu;
	+
	+ dNTu =ddl->descrNtu;
	+ if (dNTu->firstIndexed != -1) lastTmp = dNTu->firstIndexed;
	+ else lastTmp = dNTu->numVariables;
	+ /*
	+ ** fixed size first..
	+ */
	+ for (i=0; i<lastTmp; i++)
	+ dNTu->variables[i]->lengthW = nDatVariable(dNTu->variables[i]);
	+/*
	+** This, in principle, is the optimized version, where we collaps single
	+** fields of the same type into an array. However, this is machine
	+** dependant.
	+*/
	+ for (i=0; i<lastTmp; i++) {
	+ var1 = dNTu->variables[i];
	+ if (var1->lengthW != 0) {
	+ nDat = nDatVariable(var1);
	+ j=i+1;
	+ sizeItem = sizeVariable(var1);
	+ sameType = True;
	+ while ((j<lastTmp) && (sameType)) {
	+ var2 = dNTu->variables[j];
	+ if (var2->type != var1->type) sameType = False;
	+ if (sameType && ((( var2->offset -
	+ var1->offset)/sizeItem) ==
	+ nDat)) {
	+ nDat += nDatVariable(var2);
	+ var2->lengthW = 0; j++;
	+ }
	+ }
	+ var1->lengthW = nDat;
	+ var1->lengthB = nDat*sizeItem;
	+ }
	+ }
	+ /*
	+ ** The variable size, similar code. This fill is very simple if the
	+ ** if the organisation is parallel arrays, as we can not implmenent
	+ ** compaction
	+ */
	+ if (dNTu->firstIndexed == -1) return;
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	+ dNTu->variables[i]->lengthW
	+ = nDatVariable(dNTu->variables[i]);
	+ dNTu->variables[i]->lengthB = dNTu->variables[i]->lengthW
	+ * sizeVariable(dNTu->variables[i]);
	+ }
	+ } else {
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++)
	+ dNTu->variables[i]->lengthW = nDatVariable(dNTu->variables[i]);
	+ for (i=dNTu->firstIndexed; i<dNTu->numVariables; i++) {
	+ var1 = dNTu->variables[i];
	+ if (var1->lengthW != 0) {
	+ nDat = nDatVariable(var1);
	+ j=i+1;
	+ sizeItem = sizeVariable(var1);
	+ sameType = True;
	+ while ((j<dNTu->numVariables) && (sameType)) {
	+ var2 = dNTu->variables[j];
	+ if (var2->type != var1->type) sameType = False;
	+ if (sameType && (((var2->offset -
	+ var1->offset)/sizeItem) ==
	+ nDat)) {
	+ nDat += nDatVariable(var2);
	+ var2->lengthW = 0; j++;
	+ }
	+ }
	+ var1->lengthW = nDat;
	+ var1->lengthB = nDat*sizeItem;
	+ }
	+ }
	+ }
	+
	+}
	+/*
	+** Compute, in size_t units (bytes, I hope) the length of a particular
	+** variable. Only the fixed size part, we will have to multiplity
	+** by the multiplicty in the XDR filter.
	+*/
	+
	+static size_t nDatVariable(varGenNtuple *var)
	+{
	+ size_t n;
	+ int i;
	+
	+ n=1;
	+ for (i=0; i<var->numDim; i++) n = n * var->dimensions[i];
	+ return n;
	+}
	+static size_t sizeVariable(varGenNtuple *var)
	+{
	+ size_t n;
	+
	+ switch (var->type) {
	+ case BYTE_NTU: case CHARACTER_NTU:
	+ n = sizeof(char);
	+ break;
	+ case INTEGER2_NTU:
	+ n = sizeof(short);
	+ break;
	+ case LOGICAL_NTU: case INTEGER_NTU:
	+ n = sizeof(int);
	+ break;
	+ case REAL_NTU:
	+ n = sizeof(float);
	+ break;
	+ case DBL_PRECISION_NTU:
	+ n = sizeof(double);
	+ break;
	+ case COMPLEX_NTU:
	+ n = 2 * sizeof(float);
	+ break;
	+ case DBL_COMPLEX_NTU:
	+ n = 2 * sizeof(double);
	+ break;
	+ case POINTER_NTU:
	+ n = sizeof(void *);
	+ break;
	+ default :
	+ fprintf(stderr, " mcf_ComputNTuLength, internal error \n");
	+ n = 0;
	+ break;
	+ }
	+ return n;
	+}
	+
	+/*
	+** Compose the .h file. Called from NTuBldMenu and this file. The structure
	+** is assumed valid.
	+*/
	+void mcf_ComposeDoth(descrGenNtuple dNTu, char filename)
	+{
	+ char nameCom, line[FILENAME_MAX+500], tmp, version, text, tc, tc2;
	+ char nameMaxIndex[32], nameTmpIndex[32];
	+ char nullDescr[4], *descrTmp;
	+ int i, j, l, kmode, nc, ncTot, nl, iv;
	+ time_t clock;
	+ FILE *Ffp;
	+ varGenNtuple *var;
	+
	+ nameCom = makeStructName(dNTu->title, dNTu->orgStyle);
	+ strcpy(nullDescr, "? ");
	+ strcpy(line, filename);
	+ tc = strchr(line, '.');
	+ if (tc == NULL) {
	+ l = strlen(filename);
	+ tc = line; tc+=l;
	+ }
	+ strcpy(tc,".h");
	+ Ffp = fopen(line, "w");
	+ fprintf(Ffp,"/* ntuBuild\n");
	+ time(&clock);
	+ tmp = line; sprintf(tmp,"** Creation Date : %n", &l); tmp += l;
	+ strncpy(tmp,ctime(&clock), 24); tmp += 24; tmp='\n'; tmp++; tmp = '\0';
	+ fprintf(Ffp,line);
	+ fprintf(Ffp,"** User Comments\n");
	+ text = dNTu->description;
	+ tc = text;
	+ if (*tc == '\0')
	+ fprintf(Ffp,"** no user comments\n");
	+ else {
	+ ncTot = strlen(tc); nc =0;
	+ while (nc < ncTot) {
	+ tc2 = strchr(tc,'\n');
	+ nl = (int) (tc2-tc)/sizeof(char);
	+ if ((tc2 == NULL) \|\| (nl > 75)) nl = 75;
	+ strncpy(line, tc, nl); line[nl] = '\0';
	+ fprintf (Ffp,"** %s\n", line);
	+ tc += nl; nc += nl;
	+ if (*tc == '\n') {
	+ tc++;
	+ nc++;
	+ }
	+ }
	+ }
	+ fprintf(Ffp,"*/ \n");
	+ version = dNTu->version;
	+ text = dNTu->nameIndex;
	+ strcpy(nameTmpIndex, text);
	+ l = strlen(text);
	+ if (l > 26) {
	+ strncpy(nameMaxIndex, text, 26);
	+ sprintf(&nameMaxIndex[26],"_max");
	+ } else
	+ sprintf(nameMaxIndex, "%s_max", text);
	+ fprintf(Ffp,"#define %s %d\n", nameMaxIndex, dNTu->maxMultiplicity);
	+ if (dNTu->orgStyle == PARALLEL_ARRAY_NTU) {
	+ fprintf(Ffp, "typedef struct _%s_struct {\n", nameCom);
	+ /*
	+ ** The first 64 bits contain the version token, as a char[8] string
	+ ** floowed by the multiplicty variable, followed by an integer pad
	+ */
	+ fprintf(Ffp," char version[8]; /* Version token */\n");
	+ fprintf(Ffp,
	+ " int %s; /* Generalized Ntuple Multiplicity value */ \n",
	+ nameTmpIndex);
	+ fprintf(Ffp,
	+ " int padding; /* Padding for 64 bit architecture */ \n");
	+ for (iv=0; iv< dNTu->numVariables; iv++) {
	+ for (j=0; j<dNTu->numAvailable; j++)
	+ if (dNTu->varOrdering[j] == iv) i = j;
	+ var = dNTu->variables[i];
	+ kmode = 0; if (var->isFixedSize != True) kmode = 1;
	+ if (var->description == NULL) descrTmp = nullDescr;
	+ else descrTmp = var->description;
	+ tc = line;
	+ if ((var->type != COMPLEX_NTU) &&
	+ (var->type != DBL_COMPLEX_NTU)) {
	+ sprintf(tc," %s %n", VarTypesNamesC[var->type], &l);
	+ tc +=l;
	+ if ((var->numDim == 0) && (kmode ==0))
	+ sprintf(tc," %s; /* %s */",
	+ var->name, descrTmp);
	+ else if (var->numDim == 0) {
	+ sprintf(tc," %s[%s]; /* %s */",
	+ var->name, nameMaxIndex, descrTmp);
	+ } else {
	+ sprintf(tc," %s%n",var->name, &l); tc+=l;
	+ if (kmode == 1) {
	+ sprintf(tc, "[%s]%n", nameMaxIndex, &l);
	+ tc +=l;
	+ }
	+ for (j=var->numDim-1; j>-1; j--, tc+=l)
	+ sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	+
	+ sprintf (tc,"; /* %s */", descrTmp);
	+ }
	+ } else { /* got to convert to float or dbl */
	+ if (var->type == COMPLEX_NTU)
	+ sprintf(tc," float %n", &l);
	+
	+ else if (var->type == DBL_COMPLEX_NTU)
	+ sprintf(tc," double %n", &l);
	+
	+ tc +=l;
	+ if ((var->numDim == 0) && (kmode ==0))
	+ sprintf(tc," %s[2]; /* %s */", var->name, descrTmp);
	+ else if (var->numDim == 0) {
	+ sprintf(tc," %s[%s][2]; /* %s */",
	+ var->name, nameMaxIndex, descrTmp);
	+ } else {
	+ sprintf(tc," %s%n",var->name, &l); tc+=l;
	+ if (kmode == 1) {
	+ sprintf(tc, "[%s]%n", nameMaxIndex, &l);
	+ tc +=l;
	+ }
	+ for (j=var->numDim-1; j>-1; j--, tc+=l)
	+ sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	+ sprintf (tc,"[2]; /* %s */", descrTmp);
	+ }
	+ }
	+ fprintf(Ffp,"%s\n", line);
	+ }
	+ fprintf(Ffp," int fence[2]; \n");
	+ fprintf(Ffp,"} %s_struct; \n", nameCom);
	+ }else {
	+ /*
	+ ** The other type of organisation, using structure
	+ */
	+ fprintf(Ffp, "typedef struct _%s_v_struct{\n", nameCom);
	+ for (iv=0; iv< dNTu->numVariables; iv++) {
	+ for (j=0; j<dNTu->numAvailable; j++)
	+ if (dNTu->varOrdering[j] == iv) i = j;
	+ var = dNTu->variables[i];
	+ if (var->isFixedSize == False) {
	+ tc = line;
	+ if (var->type == COMPLEX_NTU)
	+ sprintf(tc," float %n", &l);
	+ else if (var->type == DBL_COMPLEX_NTU)
	+ sprintf(tc," double %n", &l);
	+ else
	+ sprintf(tc," %s %n", VarTypesNamesC[var->type], &l);
	+ tc +=l;
	+ sprintf(tc," %s%n",var->name, &l); tc+=l;
	+ if (var->numDim != 0) {
	+ for (j=var->numDim-1; j>-1; j--, tc+=l)
	+ sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	+ }
	+ if ((var->type == COMPLEX_NTU) \|\|
	+ (var->type == DBL_COMPLEX_NTU)) {
	+ sprintf (tc,"[2]%n",&l);
	+ tc += l;
	+ }
	+ if (var->description == NULL) descrTmp = nullDescr;
	+ else descrTmp = var->description;
	+ sprintf(tc,"; /* %s */%n", descrTmp, &l); tc += l;
	+ fprintf(Ffp,"%s\n", line);
	+ }
	+ }
	+ fprintf(Ffp,"} %s_v_struct; \n", nameCom);
	+ fprintf(Ffp,"/* ----- */ \n", line);
	+ /*
	+ ** the mother structure now
	+ */
	+ fprintf(Ffp, "typedef struct _%s_struct{\n", nameCom);
	+ fprintf(Ffp," char version[8]; /* Version token */\n");
	+ fprintf(Ffp,
	+ " int %s; /* Generalized Ntuple Multiplicity value */ \n",
	+ nameTmpIndex);
	+ fprintf(Ffp,
	+ " int padding; /* Padding for 64 bit architecture */ \n");
	+ for (iv=0; iv< dNTu->numVariables; iv++) {
	+ for (j=0; j<dNTu->numAvailable; j++)
	+ if (dNTu->varOrdering[j] == iv) i = j;
	+ var = dNTu->variables[i];
	+ if (var->isFixedSize == True) {
	+ tc = line;
	+ if (var->type == COMPLEX_NTU)
	+ sprintf(tc," float %n", &l);
	+ else if (var->type == DBL_COMPLEX_NTU)
	+ sprintf(tc," double %n", &l);
	+ else
	+ sprintf(tc," %s %n", VarTypesNamesC[var->type], &l);
	+ tc +=l;
	+ sprintf(tc," %s%n",var->name, &l); tc+=l;
	+ if (var->numDim != 0) {
	+ for (j=var->numDim-1; j>-1; j--, tc+=l)
	+ sprintf(tc,"[%d]%n", var->dimensions[j], &l);
	+ }
	+ if ((var->type == COMPLEX_NTU) \|\|
	+ (var->type == DBL_COMPLEX_NTU)) {
	+ sprintf (tc,"[2]%n",&l);
	+ tc += l;
	+ }
	+ if (var->description == NULL) descrTmp = nullDescr;
	+ else descrTmp = var->description;
	+ sprintf(tc,"; /* %s */%n", descrTmp, &l); tc += l;
	+ fprintf(Ffp,"%s\n", line);
	+ }
	+ }
	+ fprintf(Ffp,
	+ " %s_v_struct var[%s]; /* The array of substructures */\n",
	+ nameCom, nameMaxIndex);
	+ fprintf(Ffp," int fence[2]; \n");
	+ fprintf(Ffp,"} %s_struct; \n", nameCom);
	+ }
	+ free(nameCom);
	+ fclose(Ffp);
	+
	+}
	+
	+void mcfioC_SetForSaveDecoding(int val)
	+{
	+ if(val != 0) McfNTuPleSaveDecoding = True;
	+ else McfNTuPleSaveDecoding = False;
	+}
	+
	+static char makeStructName(char title, int orgStyle)
	+{
	+ char *out;
	+ int i, l, nMax;
	+
	+ l = strlen(title);
	+ if (orgStyle == PARALLEL_ARRAY_NTU) nMax = 23;
	+ else nMax = 21;
	+ if (l > nMax) l = nMax;
	+ out = (char ) malloc(sizeof(char) (l+1));
	+ strncpy(out, title, l); out[l]='\0';
	+ for (i=0; i<l; i++) if (out[i] == ' ') out[i] = '_';
	+ return out;
	+}
	+/*
	+** CopyNtrim - Copy "fromString" to a malloc'd new string,
	+** trimming off leading and trailing spaces & tabs.
	+** The newly malloc'd string is returned.
	+** If fromString is NULL, NULL is returned.
	+*/
	+static char mcf_copyNtrim(char fromString)
	+{
	+ char c, toString;
	+ int len, i;
	+
	+ if (fromString == NULL)
	+ return NULL;
	+ toString = (char *) malloc(strlen(fromString)+1);
	+
	+ /* Find the first non-white character */
	+ for (c=fromString; c == ' ' \|\| c == '\t'; c++);
	+
	+ /* Copy the remainder of fromString to toString */
	+ strcpy(toString, c);
	+
	+ /* Remove trailing spaces and tabs by converting to nulls */
	+ len = strlen(toString);
	+ if (len == 0) /* special case for empty strings */
	+ return toString;
	+ for (i = len-1; i >= 0; --i) {
	+ if (isspace(toString[i]))
	+ toString[i] = '\0';
	+ else
	+ break;
	+ }
	+ return toString;
	+}
	+
	+
	+
	Index: trunk/contrib/mcfio/mcfio_Block.c
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Block.c (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Block.c (revision 8889)
	@@ -0,0 +1,486 @@
	+/*******************************************************************************
	+* *
	+* mcfio_Block.c -- Utility routines for the McFast Monte-Carlo *
	+* The routine to encode/decode a block *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#include <stdlib.h>
	+#include <time.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcf_xdr_Ntuple.h"
	+#include "mcfio_Dict.h"
	+#include "mcfio_Util1.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcfio_Direct.h"
	+#include "mcfio_Block.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+int mcfioC_Block(int stream, int blkid,
	+ bool_t xdr_filtercode(XDR xdrs, int blockid, int ntot, char *version))
	+/*
	+** Routine to decode or encode a particular Block. Return 1 if O.K,
	+** -1 if a problem or unknow block.
	+**
	+** Adding Ntuple instances ... October 1995.
	+*/
	+{
	+ int i, j, jstr, idtmp, ntot, nbuff;
	+ bool_t ok;
	+ u_int p1;
	+ mcfStream *str;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_Block: You must first initialize by calling mcfio_Init.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_Block: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if ((str->row == MCFIO_WRITE) &&
	+ (str->fhead->nBlocks == str->ehead->nBlocks)) {
	+ fprintf(stderr,
	+ " mcfio_Block: Maximum number of Blocks reached for stream %d ...\n", stream);
	+ fprintf(stderr,
	+ " Please upgrade the declaration mcfio_Open statement \n");
	+ return -1;
	+ }
	+
	+ if (str->row == MCFIO_READ) {
	+ for(i=0, j=-1; i<str->ehead->nBlocks; i++) {
	+ if (str->ehead->blockIds[i] == blkid) j = i;
	+ }
	+ if (j == -1) {
	+ fprintf(stderr,
	+ " mcfio_Block: Unable to find block i.d. %d in Stream %d \n", blkid, stream);
	+ return -1;
	+ }
	+ if (xdr_setpos(str->xdr,str->ehead->ptrBlocks[j]) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_Block: Unable to position stream at block %d \n", blkid);
	+ return -1;
	+ }
	+ str->currentPos = str->ehead->ptrBlocks[j];
	+ } else if (str->row == MCFIO_WRITE) {
	+ idtmp = blkid;
	+ /*
	+ ** if to Sequential media, one first has to make sure we have
	+ ** enough room in the buffer.
	+ */
	+ if (str->dos == MCFIO_SEQUENTIAL) {
	+ str->xdr->x_op = XDR_MCFIOCODE;
	+ ok = xdr_filtercode(str->xdr, &idtmp, &ntot, McfGenericVersion);
	+ str->xdr->x_op = XDR_ENCODE;
	+ if ((str->currentPos + 4*(ntot + 1)) > str->bufferSize) {
	+ /*
	+ ** Once again, I don't trust realloc, got to copy to the second
	+ ** buffer.
	+ */
	+ nbuff = 1 +
	+ (((4*(ntot + 1)) + (str->currentPos - str->firstPos))/
	+ str->maxlrec);
	+ str->buffer2 =
	+ (char ) malloc (sizeof(char) (str->maxlrec *nbuff));
	+ memcpy(str->buffer2, str->buffer,
	+ (str->currentPos - str->firstPos));
	+ free(str->buffer);
	+ str->buffer = str->buffer2;
	+ str->buffer2 = NULL;
	+ str->bufferSize = str->maxlrec * nbuff;
	+ xdrmem_create(str->xdr, str->buffer, str->bufferSize, XDR_ENCODE);
	+ if (xdr_setpos(str->xdr, str->currentPos) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_Block:\n\
	+ Unable to position stream %d at block %d after realocation.\n", stream, blkid);
	+ return -1;
	+ }
	+ }
	+ }
	+ }
	+ p1 = str->currentPos;
	+ ok = xdr_filtercode(str->xdr, &idtmp, &ntot, McfGenericVersion);
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_Block: Unable to encode or decode block I.D. %d \n", blkid);
	+ j = str->ehead->nBlocks;
	+ if (xdr_setpos(str->xdr,p1) == FALSE)
	+ fprintf(stderr,
	+ " mcfio_Block: Unable to position stream at block %d \n", blkid);
	+ return -1;
	+ }
	+ if(blkid != idtmp) {
	+ fprintf(stderr,
	+ " mcfio_Block: Unexpected I.D = %d found instead of I.D. %d \n",
	+ idtmp, blkid);
	+ return -1;
	+ }
	+ if (str->row == MCFIO_WRITE) {
	+ str->ehead->blockIds[str->ehead->nBlocks] = blkid;
	+ str->ehead->ptrBlocks[str->ehead->nBlocks] = p1;
	+ str->ehead->nBlocks++;
	+ }
	+ str->currentPos = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((str->currentPos-p1)/4);
	+ return 1;
	+
	+}
	+int mcfioC_NTuple(int stream, int nTupleId, char * version)
	+{
	+ int i, j, jstr, idtmp, ntot, nbuff;
	+ bool_t ok;
	+ u_int p1;
	+ mcfStream *str;
	+ nTuDDL *ddl;
	+ descrGenNtuple *dNTu;
	+
	+ if (McfStreamPtrList == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: You must first initialize by calling mcfio_Init.\n");
	+ return -1;
	+ }
	+ jstr = stream-1;
	+ if (McfStreamPtrList[jstr] == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: First, declare the stream by calling mcfio_Open...\n");
	+ return -1;
	+ }
	+
	+ ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	+ if (ddl == NULL) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Illegal or inexistant NTuple Id %d for stream %d \n",
	+ nTupleId, stream);
	+ return -1;
	+ }
	+ if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	+ else dNTu = ddl->reference->descrNtu;
	+ str = McfStreamPtrList[jstr];
	+ if ((str->row == MCFIO_WRITE) &&
	+ (str->fhead->nNTuples == str->ehead->nNTuples)) {
	+ fprintf(stderr,
	+" mcfio_NTuple: Maximum number of NTuples reached for stream %d ...\n", stream);
	+ fprintf(stderr,
	+ " Please upgrade the Ntuple declarations statements. \n");
	+ return -1;
	+ }
	+
	+ if (str->row == MCFIO_READ) {
	+ for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	+ if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	+ }
	+ if (j == -1) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to find NTuple i.d. %d in Stream %d \n",
	+ nTupleId, stream);
	+ return -1;
	+ }
	+ if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ str->currentPos = str->ehead->ptrNTuples[j];
	+ } else if (str->row == MCFIO_WRITE) {
	+ /*
	+ ** if to Sequential media, one first has to make sure we have
	+ ** enough room in the buffer.
	+ */
	+ if (str->dos == MCFIO_SEQUENTIAL) {
	+ str->xdr->x_op = XDR_MCFIOCODE;
	+ ok = xdr_mcfast_NTuple(str->xdr, dNTu, &ntot,
	+ ddl->seqNTuId, version);
	+ str->xdr->x_op = XDR_ENCODE;
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ "mcfio_NTuple: can not Encode or Decode Ntuple id % on Seq. Stream %d ",
	+ nTupleId, stream);
	+ return -1;
	+ }
	+ if ((str->currentPos + 4*(ntot + 1)) > str->bufferSize) {
	+ /*
	+ ** Once again, I don't trust realloc, got to copy to the second
	+ ** buffer.
	+ */
	+ nbuff = 1 +
	+ (((4*(ntot + 1)) + (str->currentPos - str->firstPos))/
	+ str->maxlrec);
	+ str->buffer2 =
	+ (char ) malloc (sizeof(char) (str->maxlrec *nbuff));
	+ memcpy(str->buffer2, str->buffer,
	+ (str->currentPos - str->firstPos));
	+ free(str->buffer);
	+ str->buffer = str->buffer2;
	+ str->buffer2 = NULL;
	+ str->bufferSize = str->maxlrec * nbuff;
	+ xdrmem_create(str->xdr, str->buffer, str->bufferSize, XDR_ENCODE);
	+ if (xdr_setpos(str->xdr, str->currentPos) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple:\n\
	+ Unable to position stream %d at Ntuple %d after realocation.\n",
	+ stream, nTupleId);
	+ return -1;
	+ }
	+ }
	+ }
	+ }
	+ p1 = str->currentPos;
	+ ok = xdr_mcfast_NTuple(str->xdr, dNTu, &ntot, ddl->seqNTuId, version);
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	+ nTupleId);
	+ j = str->ehead->nNTuples;
	+ if (xdr_setpos(str->xdr,p1) == FALSE)
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ if (str->row == MCFIO_WRITE) {
	+ str->ehead->nTupleIds[str->ehead->nNTuples] = ddl->seqNTuId;
	+ str->ehead->ptrNTuples[str->ehead->nNTuples] = p1;
	+ str->ehead->nNTuples++;
	+ }
	+ str->currentPos = xdr_getpos(str->xdr);
	+ str->numWordsC += (ntot/4);
	+ str->numWordsT += ((str->currentPos-p1)/4);
	+ return 1;
	+
	+}
	+/*
	+** Optimized version used exclusively to read the multiplicity value
	+** within an NTuple. It is assumed that the stream is open read direct
	+** access (No checks!), and the event table is available, and the
	+** NTuple is accessible. Once again, No checks! Use at your onw risk.
	+** Also, we do not keep record of the number of byte Read.
	+*/
	+int mcfioC_NTupleMult(int stream, int nTupleId, char * version)
	+{
	+ int i, j, jstr, idtmp, ntot, nbuff;
	+ bool_t ok;
	+ mcfStream *str;
	+ nTuDDL *ddl;
	+ descrGenNtuple *dNTu;
	+
	+ jstr = stream-1;
	+ ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	+ if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	+ else dNTu = ddl->reference->descrNtu;
	+ str = McfStreamPtrList[jstr];
	+ for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	+ if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	+ }
	+ if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTupleMult: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ str->currentPos = str->ehead->ptrNTuples[j];
	+ if (dNTu->multXDROffset == 0)
	+ ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	+ ddl->seqNTuId, version);
	+ else ok = xdr_mcfast_NTupleMult(str, dNTu, version);
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	+ nTupleId);
	+ j = str->ehead->nNTuples;
	+ if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ /*
	+ ** This probably could be optimized away. Note the that the current
	+ ** position of the stream strored in str->currentPos is no longer
	+ ** valied exiting this routine. However, there is enough redundancy
	+ ** in the data structure to figure out where we could go..
	+ */
	+ /* xdr_setpos(str->xdr, str->currentPos); */
	+ return TRUE;
	+
	+}
	+
	+/*
	+** Optimized version used exclusively to read a specific variable
	+** within an NTuple. Valid only if the variable is of fixed size
	+** (e.g. not indexed by multiplicity) or if the data structure organization is
	+** of type parallel array. It is assumed that the stream is open read direct
	+** access (No checks!), and the event table is available, and the
	+** NTuple is accessible. Once again, No checks! Use at your own risk.
	+*/
	+int mcfioC_NTupleVar(int stream, int nTupleId, int ivar, char * version)
	+{
	+ int i, j, jstr, idtmp, ntot, nbuff;
	+ bool_t ok;
	+ mcfStream *str;
	+ nTuDDL *ddl;
	+ descrGenNtuple *dNTu;
	+
	+ jstr = stream-1;
	+ ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	+ if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	+ else dNTu = ddl->reference->descrNtu;
	+ str = McfStreamPtrList[jstr];
	+ for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	+ if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	+ }
	+ if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTupleVar: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ str->currentPos = str->ehead->ptrNTuples[j];
	+ if (dNTu->multXDROffset == 0)
	+ ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	+ ddl->seqNTuId, version);
	+ else ok = xdr_mcfast_NTupleVar(str, dNTu, ivar, version);
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	+ nTupleId);
	+ j = str->ehead->nNTuples;
	+ if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ return TRUE;
	+
	+}
	+/*
	+** Optimized version used exclusively to read a specific variable within a
	+** substructure within an NTuple. Valid only if of type indexed
	+** and if the data structure organization is
	+** of type VAX FORTRAN d/s. It is assumed that the stream is open read direct
	+** access (No checks!), and the event table is available, and the
	+** NTuple is accessible. Once again, No checks! Use at your own risk.
	+*/
	+int mcfioC_NTupleSubVar(int stream, int nTupleId, int ivar, int multIndex,
	+ char * version)
	+{
	+ int i, j, jstr, idtmp, ntot, nbuff;
	+ bool_t ok;
	+ mcfStream *str;
	+ nTuDDL *ddl;
	+ descrGenNtuple *dNTu;
	+
	+ jstr = stream-1;
	+ ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	+ if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	+ else dNTu = ddl->reference->descrNtu;
	+ str = McfStreamPtrList[jstr];
	+ for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	+ if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	+ }
	+ if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTupleVar: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ str->currentPos = str->ehead->ptrNTuples[j];
	+ if (dNTu->multXDROffset == 0)
	+ ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	+ ddl->seqNTuId, version);
	+ else ok = xdr_mcfast_NTupleSubVar(str, dNTu, ivar, multIndex, version);
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	+ nTupleId);
	+ j = str->ehead->nNTuples;
	+ if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ return TRUE;
	+
	+}
	+/*
	+** Optimized version used exclusively to read a specific
	+** substructure within an NTuple. Valid only if of type indexed
	+** and if the data structure organization is
	+** of type VAX FORTRAN d/s. It is assumed that the stream is open read direct
	+** access (No checks!), and the event table is available, and the
	+** NTuple is accessible. Once again, No checks! Use at your own risk.
	+*/
	+int mcfioC_NTupleSubStruct(int stream, int nTupleId, int multIndex,
	+ char * version)
	+{
	+ int i, j, jstr, idtmp, ntot, nbuff;
	+ bool_t ok;
	+ mcfStream *str;
	+ nTuDDL *ddl;
	+ descrGenNtuple *dNTu;
	+
	+ jstr = stream-1;
	+ ddl = mcf_GetNTuByStreamID(stream, nTupleId);
	+ if (ddl->reference == NULL) dNTu = ddl->descrNtu;
	+ else dNTu = ddl->reference->descrNtu;
	+ str = McfStreamPtrList[jstr];
	+ for(i=0, j=-1; i<str->ehead->nNTuples; i++) {
	+ if (str->ehead->nTupleIds[i] == ddl->seqNTuId) j = i;
	+ }
	+ if (xdr_setpos(str->xdr,str->ehead->ptrNTuples[j]) == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTupleVar: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ str->currentPos = str->ehead->ptrNTuples[j];
	+ if (dNTu->multXDROffset == 0)
	+ ok = xdr_mcfast_NTupleXDRPtr(str->xdr, dNTu, &ntot,
	+ ddl->seqNTuId, version);
	+ else ok = xdr_mcfast_NTupleSubStruct(str, dNTu, multIndex, version);
	+ if (ok == FALSE) {
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to encode or decode NTuple I.D. %d \n",
	+ nTupleId);
	+ j = str->ehead->nNTuples;
	+ if (xdr_setpos(str->xdr, str->currentPos) == FALSE)
	+ fprintf(stderr,
	+ " mcfio_NTuple: Unable to position stream at NTuple %d \n", nTupleId);
	+ return -1;
	+ }
	+ return TRUE;
	+
	+}
	Index: trunk/contrib/mcfio/mcfio_FPrintDictionary.f
	===================================================================
	--- trunk/contrib/mcfio/mcfio_FPrintDictionary.f (revision 0)
	+++ trunk/contrib/mcfio/mcfio_FPrintDictionary.f (revision 8889)
	@@ -0,0 +1,108 @@
	+ subroutine mcfio_FPrintDictionary(ilun)
	+
	+c*******************************************************************************
	+c *
	+c mcfio_FPrintDictionary.F -- Fortran version of PrintDictionary *
	+c *
	+c Copyright (c) 1994 Universities Research Association, Inc. *
	+c All rights reserved. *
	+c *
	+c This material resulted from work developed under a Government Contract and *
	+c is subject to the following license: The Government retains a paid-up, *
	+c nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+c works, perform publicly and display publicly by or for the Government, *
	+c including the right to distribute to other Government contractors. Neither *
	+c the United States nor the United States Department of Energy, nor any of *
	+c their employees, makes any warranty, express or implied, or assumes any *
	+c legal liability or responsibility for the accuracy, completeness, or *
	+c usefulness of any information, apparatus, product, or process disclosed, or *
	+c represents that its use would not infringe privately owned rights. *
	+c *
	+c *
	+c Written by Paul Lebrun, Lynn Garren *
	+c *
	+c *
	+c*******************************************************************************
	+
	+ integer ilun
	+ write(ilun,1001)
	+1001 format(//
	+ 1 ' Mcfast I/o Dictionary for Key words used in mcfio_Info',
	+ 2 ' routines'/
	+ 3 ' --------------------------------------------------------',
	+ 4 '-------')
	+
	+ write(ilun,1002)
	+1002 format(/
	+ 1 ' For Streams '/
	+ 2 ' -------------- '/
	+ 3 ' MCFIO_STATUS: The current status of the file; '/
	+ 4 ' the answer can be set to: '/
	+ 5 ' MCFIO_BOF : at beginning of file '/
	+ 6 ' MCFIO_EOF : at the end of file '/
	+ 7 ' MCFIO_RUNNING: At least a valid file header has been',
	+ 8 ' read or written'/
	+ 9 ' MCFIO_READORWRITE: if set MCFIO_READ, open for read only '/
	+ 1 ' if set MCFIO_WRITE, open for write only '/
	+ 2 ' MCFIO_DIRECTORSEQUENTIAL: if set MCFIO_DIRECT, accessing a',
	+ 3 ' UNIX file '/
	+ 4 ' : if set MCFIO_SEQUENTIAL,',
	+ 5 ' accessing a tape '/
	+ 6 ' MCFIO_NUMEVTS : Total number of events encode/decoded',
	+ 7 ' so far.'/
	+ 8 ' MCFIO_NUMBLOCK: The number of blocks defined in the file.')
	+
	+ write(ilun,1003)
	+1003 format(
	+ 1 ' MCFIO_BLOCKIDS: The I.D. of the block defined in the file.'/
	+ 2 ' MCFIO_NUMWORDS: Total number of 4-bytes words',
	+ 2 ' encoded/decoded so far. '/
	+ 3 ' MCFIO_EFFICIENCY: The overhead in blocking and XDR',
	+ 3 ' (*10000 ) '/
	+ 4 ' MCFIO_CREATIONDATE: The date (30 Character) when the file',
	+ 4 ' was written '/
	+ 5 ' MCFIO_TITLE: The title (255 Characters max) for the job '/
	+ 6 ' MCFIO_COMMENT: The comment (255 Characters max) for the job')
	+
	+ write(ilun,1004)
	+1004 format(/
	+ 1 ' For Sequential Access only '/
	+ 2 ' -------------------------- '/
	+ 2 ' MCFIO_FILENUMBER : The Sequential file number currently',
	+ 2 ' accessed.'/
	+ 3 ' MCFIO_MAXLREC: Maximum Record length'/
	+ 4 ' MCFIO_MINLREC: Minumum Record length'/
	+ 5 ' MCFIO_NUMRECORDS: The number of records in the current',
	+ 5 ' event'/
	+ 6 ' MCFIO_RECORDLENGTHS: The record lengths for the current',
	+ 6 ' event'/
	+ 7 ' MCFIO_DEVICENAME: The device name opened by the stream '/
	+ 8 ' (character string, 255 l.)')
	+
	+ write(ilun,1005)
	+1005 format(/
	+ 1 ' For Direct Access only '/
	+ 2 ' ----------------------- '/
	+ 2 ' MCFIO_FILENAME: The UNIX file name opened by the stream '/
	+ 3 ' (character string, 255 l.)')
	+
	+ write(ilun,1006)
	+1006 format(/
	+ 1 ' For Events '/
	+ 2 ' -------------- '/
	+ 3 ' MCFIO_NUMBLOCK: The number of blocks defined in the event.'/
	+ 4 ' MCFIO_BLOCKIDS: The I.D. of the block defined in the event.'/
	+ 5 ' MCFIO_EVENTNUMBER: The Event Number for this event. '/
	+ 6 ' MCFIO_STORENUMBER: The Store Number for this event. '/
	+ 7 ' MCFIO_RUNNUMBER: The Run Number for this event. '/
	+ 8 ' MCFIO_TRIGGERMASK: The Trigger Mask for this event. '/
	+ 9 ' MCFIO_VERSION: The 4-Character version of the event header')
	+
	+ write(ilun,1007)
	+1007 format(/
	+ 1 ' For Blocks '/
	+ 2 ' -------------- '/
	+ 3 ' MCFIO_VERSION: The 4-Character version of a particular',
	+ 4 ' block'/)
	+ return
	+ end
	Index: trunk/contrib/mcfio/mcf_NTuIOUtils.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_NTuIOUtils.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_NTuIOUtils.h (revision 8889)
	@@ -0,0 +1,24 @@
	+/*******************************************************************************
	+* *
	+* mcf_NTuIOUtil.h -- Utilities to manipulate files within the MCFIO Gen. *
	+* Ntuple schema *
	+* *
	+* P. Lebrun, October 1995. *
	+* *
	+*******************************************************************************/
	+nTuDDL *mcf_GetNTuByPtrID(int id);
	+nTuDDL *mcf_GetNTuByStreamID(int stream, int id);
	+int mcf_CheckValidCat(char *category, int dotDotDot);
	+char mcf_ValidStr(char string, int max_length, char *strKind);
	+int mcf_NTuId(int uid, char *category);
	+int mcfioC_GetNTupleIds(int stream, int *ids, int max);
	+int mcfioC_GetNTupleUID(int stream, int id);
	+void mcfioC_GetNTupleCategory(int stream, int id, char **answer);
	+void mcfioC_GetNTupleTitle(int stream, int id, char **answer);
	+void mcfioC_GetNTupleName(int stream, int id, char **answer);
	+void AddNTuDDLtoList(nTuDDL *ddl);
	+void DestroyNTuDDL(nTuDDL *ddl);
	+void DestroyVarGenNtuple(varGenNtuple *var);
	+void CopyVarGenNtuple(varGenNtuple vFrom, varGenNtuple vTo);
	+void DestroyGenNtuple(descrGenNtuple *dNTu);
	+void mcfioC_SetForSaveDecoding(int val);
	Index: trunk/contrib/mcfio/mcf_NTuIOFiles.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_NTuIOFiles.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_NTuIOFiles.h (revision 8889)
	@@ -0,0 +1,15 @@
	+/*******************************************************************************
	+* *
	+* mcf_NTuIOFiles.h -- Utilities to manipulate files within the MCFIO Gen. *
	+* Ntuple schema *
	+* *
	+* P. Lebrun, September 1995. *
	+* *
	+*******************************************************************************/
	+int mcfioC_DeclareNtuple(int uid, char title, char category,
	+ int stream, char *filename);
	+int mcfioC_EndDeclNTuples(int stream);
	+nTuDDL mcf_GetFileNTuDDL(charfilename);
	+void mcf_ComputeNTuOffsets(nTuDDL *ddl);
	+void mcf_ComputeNTuLengths(nTuDDL *ddl);
	+void mcf_ComposeDoth(descrGenNtuple dNtu, char filename);
	Index: trunk/contrib/mcfio/mcfio_Util1.c
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Util1.c (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Util1.c (revision 8889)
	@@ -0,0 +1,914 @@
	+/*******************************************************************************
	+* *
	+* mcfio_Init.c -- Utility routines for the McFast Monte-Carlo *
	+* Initialisation & info routines *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#include <stdlib.h>
	+#ifdef SUNOS
	+#include <floatingpoint.h>
	+#else /* SUNOS */
	+#include <float.h>
	+#endif /* SUNOS */
	+#include <time.h>
	+#include "mcf_nTupleDescript.h"
	+#include "mcf_xdr.h"
	+#include "mcfio_Util1.h"
	+#include "mcfio_Direct.h"
	+#include "mcfio_Sequential.h"
	+#include "mcfio_Dict.h"
	+#include "mcf_ntubld_db.h"
	+#include "mcf_NTuIOFiles.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcf_NTuIOUtils.h"
	+#include "mcfio_UserDictionary.h"
	+#ifndef FALSE
	+#define FALSE 0
	+#endif
	+#ifndef TRUE
	+#define TRUE 1
	+#endif
	+
	+mcfStream **McfStreamPtrList=NULL;
	+unsigned int McfNumOfStreamActive=0;
	+char **McfGenericVersion=NULL;
	+
	+/*
	+** This stuff is needed for dbin utilities...
	+*/
	+struct line_title_c line_title_c_;
	+struct header_c header_c_;
	+struct variable_c variable_c_;
	+/*
	+** Names of variable types for Ntuple utilities
	+*/
	+char *VarTypesNamesF77[N_VAR_TYPES];
	+char *VarTypesNamesC[N_VAR_TYPES];
	+/*
	+** Ntuple global list
	+*/
	+extern nTuDDL **NTuDDLList;
	+extern int NumOfNTuples;
	+
	+
	+void mcfioC_Init(void)
	+/* Global Initialisation routine. Simply set the
	+**
	+*/
	+{
	+ int i;
	+ char env, line;
	+ FILE *Ffp;
	+
	+/*
	+** This is no longer needed...
	+
	+ env = NULL;
	+ env = getenv("MCFIO_DIR");
	+ if (env == NULL) {
	+ printf ("You must first set the environment variable MCFIO_DIR\n");
	+ printf (" by either setting up mcfio (Fermi UPS), or setting \n");
	+ printf
	+ (" this env. variable to the place where mcf_NTuBld.db resides.\n");
	+ exit(0);
	+ } */
	+
	+
	+ /*
	+ ** Check now that the master template exist.
	+
	+ line = (char ) malloc(sizeof(char) (FILENAME_MAX+1));
	+ sprintf(line,"%s/mcf_NTuBld.db", env);
	+ Ffp = fopen(line, "r");
	+ if (Ffp == NULL) {
	+ printf ("The file %s could not be opened. \n", line);
	+ printf (" Please check MCFIO installation. \n");
	+ exit(0);
	+ }
	+ fclose(Ffp);
	+ free(line);
	+
	+*/
	+ /*
	+ ** Use only one version for now. Possible extension here.
	+ */
	+ McfGenericVersion = (char *) malloc(sizeof(char ));
	+ McfGenericVersion = (char ) malloc(sizeof(char) * 8);
	+
	+ VarTypesNamesF77[0]= "Byte ";
	+ VarTypesNamesF77[1]= "Character ";
	+ VarTypesNamesF77[2]= "Integer*2 ";
	+ VarTypesNamesF77[3]= "Logical ";
	+ VarTypesNamesF77[4]= "Integer ";
	+ VarTypesNamesF77[5]= "Real ";
	+ VarTypesNamesF77[6]= "Double Precision";
	+ VarTypesNamesF77[7]= "Complex ";
	+ VarTypesNamesF77[8]= "Double Complex ";
	+ VarTypesNamesF77[9]= "Pointer ";
	+
	+ VarTypesNamesC[0]= "char ";
	+ VarTypesNamesC[1]= "char ";
	+ VarTypesNamesC[2]= "short ";
	+ VarTypesNamesC[3]= "int ";
	+ VarTypesNamesC[4]= "int ";
	+ VarTypesNamesC[5]= "float ";
	+ VarTypesNamesC[6]= "double ";
	+ VarTypesNamesC[7]= "float[2] ";
	+ VarTypesNamesC[8]= "double[2] ";
	+ VarTypesNamesC[9]= "void * ";
	+
	+ if (NTuDDLList != NULL) {
	+ for (i=0; i<NumOfNTuples; i++) DestroyNTuDDL(NTuDDLList[i]);
	+ free(NTuDDLList);
	+ }
	+ NTuDDLList = (nTuDDL *) malloc(sizeof(int )* NTU_START_LIST_SIZE);
	+ NumOfNTuples = 0;
	+
	+ if (McfStreamPtrList == NULL) {
	+ McfStreamPtrList = (mcfStream **)
	+ malloc(sizeof(mcfStream ) MCF_STREAM_NUM_MAX);
	+ for (i=0; i< MCF_STREAM_NUM_MAX; i++) McfStreamPtrList[i] = NULL;
	+ return;
	+ }
	+ for (i=0; i< MCF_STREAM_NUM_MAX; i++) McfStreamPtrList[i] = NULL;
	+ mcfioC_Close(0);
	+ McfNumOfStreamActive=0;
	+
	+}
	+
	+void mcfioC_Close(int istream)
	+/*
	+** Closing a Stream istream is the F77 index to the array of mcf Streams.
	+*/
	+{
	+ int i;
	+
	+ if (McfStreamPtrList == NULL) return;
	+ if ((istream < 0) \|\| (istream > MCF_STREAM_NUM_MAX)) {
	+ fprintf (stderr, "mcf_close, Illegal argument, stream = %d \n", istream);
	+ return;
	+ }
	+ if (istream == 0) {
	+ for (i=0; i<MCF_STREAM_NUM_MAX; i++) {
	+ if (McfStreamPtrList[i] != NULL) {
	+ switch (McfStreamPtrList[i]->dos) {
	+ case MCFIO_DIRECT: case MCFIO_MEMMAPPED:
	+ mcfioC_CloseDirect(i);
	+ break;
	+ case MCFIO_SEQUENTIAL:
	+ mcfioC_CloseSequentialTape(i);
	+ break;
	+ default:
	+ fprintf
	+ (stderr," mcf_close, Internal Error, please report \n");
	+ break;
	+ }
	+ mcfioC_FreeStream(&McfStreamPtrList[i]);
	+ }
	+ }
	+ return;
	+ }
	+ i = istream -1;
	+ if (McfStreamPtrList[i] != NULL) {
	+ switch (McfStreamPtrList[i]->dos) {
	+ case MCFIO_DIRECT: case MCFIO_MEMMAPPED:
	+ mcfioC_CloseDirect(i);
	+ break;
	+ case MCFIO_SEQUENTIAL:
	+ mcfioC_CloseSequentialTape(i);
	+ break;
	+ default:
	+ fprintf
	+ (stderr," mcf_close, Internal Error, please report \n");
	+ break;
	+ }
	+ mcfioC_FreeStream(&McfStreamPtrList[i]);
	+ }
	+}
	+
	+void mcfioC_Rewind(int istream)
	+/*
	+** Closing a Stream istream is the F77 index to the array of mcf Streams.
	+*/
	+{
	+ int i;
	+
	+ if (McfStreamPtrList == NULL) return;
	+ if ((istream <= 0) \|\| (istream > MCF_STREAM_NUM_MAX)) {
	+ fprintf (stderr, "mcfio_Rewind, Illegal argument, stream = %d \n",
	+ istream);
	+ return;
	+ }
	+ i = istream -1;
	+
	+ if (McfStreamPtrList[i] != NULL) {
	+ if(McfStreamPtrList[i]->row == MCFIO_WRITE) {
	+ fprintf
	+ (stderr," mcf_Rewind, Not support for Output Stream \n");
	+ return;
	+ }
	+ switch (McfStreamPtrList[i]->dos) {
	+ case MCFIO_DIRECT: case MCFIO_MEMMAPPED:
	+ mcfioC_RewindDirect(i);
	+ break;
	+ case MCFIO_SEQUENTIAL:
	+ fprintf
	+ (stderr," mcf_Rewind, Sequential, done by a close Sequential File\n\
	+ Then reopening a stream on the same sequential media \n");
	+ break;
	+ default:
	+ fprintf
	+ (stderr," mcf_Rewind, Internal Error, please report \n");
	+ break;
	+ }
	+ McfStreamPtrList[i]->numWordsC = 0;
	+ McfStreamPtrList[i]->numWordsT = 0;
	+ }
	+}
	+
	+void mcfioC_Free_FileHeader(mcfxdrFileHeader **p)
	+{
	+ int i;
	+ mcfxdrFileHeader head = p;
	+
	+ if (head == NULL) return;
	+ for (i=0; i<head->nBlocks; i++)
	+ if (head->blockNames[i] != NULL) free(head->blockNames[i]);
	+ if (head->blockNames != NULL) free (head->blockNames);
	+ if (head->blockIds != NULL) free(head->blockIds);
	+ free(head);
	+ *p = NULL;
	+}
	+
	+void mcfioC_Free_SeqHeader(mcfxdrSequentialHeader **p)
	+{
	+ mcfxdrSequentialHeader head = p;
	+
	+ if (head == NULL) return;
	+ free(head);
	+ *p = NULL;
	+}
	+
	+void mcfioC_Free_EventHeader(mcfxdrEventHeader **p)
	+{
	+ mcfxdrEventHeader head = p;
	+
	+ if (head == NULL) return;
	+ if (head->ptrBlocks != NULL) free(head->ptrBlocks);
	+ if (head->blockIds != NULL) free(head->blockIds);
	+ if (head->ptrNTuples != NULL) free(head->ptrNTuples);
	+ if (head->nTupleIds != NULL) free(head->nTupleIds);
	+ free(head);
	+ *p = NULL;
	+}
	+
	+void mcfioC_Free_EventTable(mcfxdrEventTable **p)
	+{
	+ mcfxdrEventTable table = p;
	+
	+ if (table == NULL) return;
	+ if (table->evtnums != NULL) free(table->evtnums);
	+ if (table->storenums != NULL) free(table->storenums);
	+ if (table->runnums != NULL) free(table->runnums);
	+ if (table->trigMasks != NULL) free(table->trigMasks);
	+ if (table->ptrEvents != NULL) free(table->ptrEvents);
	+ free(table);
	+ *p = NULL;
	+}
	+
	+void mcfioC_FreeStream(mcfStream **stream)
	+{
	+ mcfStream str = stream;
	+ if (str == NULL) return;
	+ if (str->filename != NULL) free (str->filename);
	+ if (str->device != NULL) free (str->device);
	+ if (str->vsn != NULL) free (str->vsn);
	+ if (str->fhead != NULL) mcfioC_Free_FileHeader(&(str->fhead));
	+ if (str->shead != NULL) mcfioC_Free_SeqHeader(&(str->shead));
	+ if (str->ehead != NULL) mcfioC_Free_EventHeader(&(str->ehead));
	+ if (str->table != NULL) mcfioC_Free_EventTable(&(str->table));
	+ if (str->buffer != NULL) free (str->buffer);
	+ if (str->buffer2 != NULL) free (str->buffer2);
	+ free(str);
	+ *stream = NULL;
	+ McfNumOfStreamActive--;
	+}
	+
	+
	+void mcfioC_PrintDictionary(void)
	+{
	+ printf (" \n");
	+ printf
	+ (" Mcfast I/o Dictionary for Key words used in mcfio_Info routines \n");
	+
	+ printf
	+ (" --------------------------------------------------------------- \n");
	+ printf (" \n");
	+ printf (" For Streams \n");
	+ printf (" -------------- \n");
	+ printf (" MCFIO_STATUS: The current status of the file; \n");
	+ printf (" the answer can be set to: \n");
	+ printf
	+ (" MCFIO_BOF : at beginning of file \n");
	+ printf
	+ (" MCFIO_EOF : at the end of file \n");
	+ printf
	+ (" MCFIO_RUNNING: At least a valid file header has been read or written\n");
	+
	+ printf
	+ (" MCFIO_READORWRITE: if set MCFIO_READ, open for read only \n");
	+ printf
	+ (" if set MCFIO_WRITE, open for write only \n");
	+ printf
	+ (" MCFIO_DIRECTORSEQUENTIAL: if set MCFIO_DIRECT, accessing a UNIX file \n");
	+ printf
	+ (" : if set MCFIO_SEQUENTIAL, accessing a tape \n");
	+ printf
	+ (" MCFIO_NUMEVTS : Total number of events encode/decoded so far. \n");
	+ printf
	+ (" MCFIO_NUMBLOCK: The number of blocks defined in the file. \n");
	+
	+ printf
	+ (" MCFIO_BLOCKIDS: The I.D. of the block defined in the file.\n");
	+ printf
	+ (" MCFIO_NUMWORDS: Total number of 4-bytes words encode/decoded so far. \n");
	+ printf
	+ (" MCFIO_EFFICIENCY: The overhead in blocking and XDR (*10000 ) \n");
	+ printf
	+ (" MCFIO_CREATIONDATE: The date (30 Character) when the file was opened \n");
	+ printf
	+ (" MCFIO_CLOSINGDATE: The date (30 Character) when the file was closed \n");
	+ printf
	+ (" MCFIO_TITLE: The title (255 Characters max) for the job \n");
	+ printf
	+ (" MCFIO_COMMENT: The comment (255 Characters max) for the job \n");
	+
	+ printf (" \n");
	+ printf (" For Sequential Access only \n");
	+ printf
	+ (" MCFIO_FILENUMBER : The Sequential file number currently accessed.\n");
	+ printf (" MCFIO_MAXLREC: Maximum Record length\n");
	+ printf (" MCFIO_MINLREC: Minumum Record length\n");
	+ printf
	+ (" MCFIO_NUMRECORDS: The number of records in the current event\n");
	+ printf
	+ (" MCFIO_RECORDLENGTHS: The record lengths for the current event\n");
	+ printf (" MCFIO_DEVICENAME: The device name opened by the stream\n ");
	+ printf (" (character string, 255 l.)\n");
	+ printf (" \n");
	+ printf (" For Direct Access only \n");
	+ printf (" MCFIO_FILENAME: The UNIX file name opened by the stream\n ");
	+ printf (" (character string, 255 l.)\n");
	+
	+ printf (" \n");
	+ printf (" For Events \n");
	+ printf (" -------------- \n");
	+ printf
	+ (" MCFIO_NUMBLOCK: The number of blocks defined in the event.\n");
	+
	+ printf
	+ (" MCFIO_BLOCKIDS: The I.D. of the block defined in the event.\n");
	+ printf
	+ (" MCFIO_EVENTNUMBER: The Event Number for this event. \n");
	+ printf
	+ (" MCFIO_STORENUMBER: The Store Number for this event. \n");
	+ printf
	+ (" MCFIO_RUNNUMBER: The Run Number for this event. \n");
	+ printf
	+ (" MCFIO_TRIGGERMASK: The Trigger Mask for this event. \n");
	+ printf (" MCFIO_VERSION: The 4-Character version of the event header \n ");
	+
	+ printf (" \n");
	+ printf (" For Blocks \n");
	+ printf (" -------------- \n");
	+ printf (" MCFIO_VERSION: The 4-Character version of a particular block \n ");
	+
	+ printf (" \n");
	+ printf (" For NTuples \n");
	+ printf (" -------------- \n");
	+ printf (" MCFIO_NUMNTUPLES: The number of defined NTuples on a stream \n ");
	+ printf (" See also mcfio_GetNTupleIds, mcfio_GetNTupleUID, \n");
	+ printf (" mcfio_GetNTupleCategory, mcfio_GetNTupleTitle and \n");
	+ printf (" mcfio_GetNTupleName \n");
	+
	+}
	+
	+unsigned int mcfioC_InfoNumStream(int *istreams, unsigned int nmax)
	+/*
	+** Returns in the arrary istream the list of active stream indices.
	+**
	+*/
	+{
	+ int i,j;
	+
	+ if (nmax >= MCF_STREAM_NUM_MAX) {
	+ fprintf(stderr, "mcfio_Info, Illegal size of Stream Pointer array \n");
	+ return 0;
	+ }
	+ for (i=0,j=0; i<MCF_STREAM_NUM_MAX; i++) {
	+ if (McfStreamPtrList[i] != NULL) {
	+ if (j < nmax) istreams[j] = McfStreamPtrList[i]->id;
	+ j++;
	+ }
	+ }
	+ return McfNumOfStreamActive;
	+}
	+
	+void mcfioC_InfoStreamInt(int stream, int key, int *values)
	+/*
	+** Information routine for the Stream. Based on key, return in *values
	+** the requested information
	+*/
	+{
	+ int i, num, jstr;
	+ float a;
	+ mcfStream *str;
	+ jstr = stream - 1;
	+ if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	+ stream);
	+ return;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str == NULL) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	+ stream);
	+ return;
	+ }
	+ switch (key) {
	+ case MCFIO_STATUS:
	+ *values = str->status;
	+ break;
	+ case MCFIO_READORWRITE:
	+ *values = str->row;
	+ break;
	+ case MCFIO_DIRECTORSEQUENTIAL:
	+ *values = str->dos;
	+ break;
	+ case MCFIO_NUMWORDS:
	+ *values = str->numWordsT;
	+ break;
	+ case MCFIO_EFFICIENCY:
	+ a = ((float ) (str->numWordsC))/ (float) (str->numWordsT);
	+ values = (int) (10000. a);
	+ break;
	+ case MCFIO_NUMEVTS:
	+ if(str->fhead != NULL) *values = str->fhead->numevts;
	+ break;
	+ case MCFIO_NUMBLOCKS:
	+ if(str->fhead != NULL) *values = str->fhead->nBlocks;
	+ break;
	+ case MCFIO_BLOCKIDS:
	+ /*
	+ ** Crash bug possibility here, if the dimension is wrong !
	+ */
	+ if(str->fhead != NULL) {
	+ for (i=0; i<str->fhead->nBlocks; i++)
	+ values[i] = str->fhead->blockIds[i];
	+ }
	+ break;
	+ /*
	+ ** Now the specific items for Sequential stuff
	+ */
	+ case MCFIO_FILENUMBER:
	+ if (str->dos != MCFIO_SEQUENTIAL) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_FILENUMBER\n",
	+ stream);
	+ return;
	+ }
	+ *values = str->filenumber;
	+ break;
	+ case MCFIO_MAXREC:
	+ if (str->dos != MCFIO_SEQUENTIAL) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_MAXREC\n",
	+ stream);
	+ return;
	+ }
	+ *values = str->maxlrec;
	+ break;
	+ case MCFIO_MINREC:
	+ if (str->dos != MCFIO_SEQUENTIAL) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_MINREC \n",
	+ stream);
	+ return;
	+ }
	+ *values = str->minlrec;
	+ break;
	+ case MCFIO_NUMRECORDS:
	+ if ((str->dos != MCFIO_SEQUENTIAL) \|\| (str->shead == NULL) ) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_NUMRECORDS \n",
	+ stream);
	+ return;
	+ }
	+ *values = str->shead->nRecords;
	+ break;
	+ case MCFIO_RECORDLENGTHS:
	+ if ((str->dos != MCFIO_SEQUENTIAL) \|\| (str->shead == NULL) ) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_RECORDLENGTHS \n",
	+ stream);
	+ return;
	+ }
	+ *values = str->maxlrec;
	+ break;
	+ case MCFIO_NUMNTUPLES:
	+ for (i=0, num=0; i<NumOfNTuples; i++)
	+ if (NTuDDLList[i]->streamId == stream) num++;
	+ *values = num;
	+ break;
	+ default:
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Unrecognized Keyword %d\n", key);
	+ }
	+}
	+
	+void mcfioC_InfoStreamChar(int stream, int key, char answer, int lret)
	+/*
	+** Information routine for the Stream. Based on key, return in *values
	+** the requested information
	+*/
	+{
	+ int i, jstr;
	+ float a;
	+ mcfStream *str;
	+ jstr = stream - 1;
	+ if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str == NULL) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ switch (key) {
	+ case MCFIO_TITLE:
	+ if (str->fhead != NULL) strcpy(answer,str->fhead->title);
	+ break;
	+ case MCFIO_COMMENT:
	+ if (str->fhead != NULL) strcpy(answer,str->fhead->comment);
	+ break;
	+ case MCFIO_CREATIONDATE:
	+ if (str->fhead != NULL) strcpy(answer,str->fhead->date);
	+ break;
	+ case MCFIO_CLOSINGDATE:
	+ if (str->fhead != NULL) strcpy(answer,str->fhead->closingDate);
	+ break;
	+ case MCFIO_FILENAME:
	+ if (str->dos == MCFIO_SEQUENTIAL) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_FILENAME \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ strcpy(answer,str->filename);
	+ break;
	+ case MCFIO_DEVICENAME:
	+ if (str->dos != MCFIO_SEQUENTIAL) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Meaningless request for stream %d, key MCFIO_DEVICENAME \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ strcpy(answer,str->device);
	+ break;
	+ default:
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Unrecognized Keyword %d\n", key);
	+ *lret = 0;
	+ return;
	+
	+ }
	+ *lret = strlen(answer);
	+}
	+void mcfioC_InfoEventInt(int stream, int key, int *values)
	+/*
	+** Information routine for the current Event.
	+** Based on key, return in *values the requested information
	+*/
	+{
	+ int i, jstr;
	+ float a;
	+ mcfStream *str;
	+ jstr = stream - 1;
	+ if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,"mcfio_InfoEvent: Stream id %d is illegal \n",
	+ stream);
	+ return;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str == NULL) {
	+ fprintf(stderr,"mcfio_InfoEvent: Stream id %d is inactive \n",
	+ stream);
	+ return;
	+ }
	+ if (str->ehead ==NULL) {
	+ fprintf(stderr,"mcfio_InfoEvent: Stream id %d is at beginning \n",
	+ stream);
	+ return;
	+ }
	+ switch (key) {
	+ case MCFIO_EVENTNUMBER:
	+ *values = str->ehead->evtnum;
	+ break;
	+ case MCFIO_STORENUMBER:
	+ *values = str->ehead->storenum;
	+ break;
	+ case MCFIO_RUNNUMBER:
	+ *values = str->ehead->runnum;
	+ break;
	+ case MCFIO_TRIGGERMASK:
	+ *values = str->ehead->trigMask;
	+ break;
	+ case MCFIO_NUMBLOCKS:
	+ *values = str->ehead->nBlocks;
	+ break;
	+ case MCFIO_BLOCKIDS:
	+ for(i=0; i<str->ehead->nBlocks; i++)
	+ values[i] = str->ehead->blockIds[i];
	+ break;
	+ case MCFIO_NUMNTUPLES:
	+ *values = str->ehead->nNTuples;
	+ break;
	+ case MCFIO_NTUPLESLIST:
	+ for(i=0; i<str->ehead->nNTuples; i++)
	+ values[i] = str->ehead->nTupleIds[i];
	+ break;
	+ default:
	+ fprintf(stderr,
	+ "mcfio_InfoEvent: Unrecognized Keyword %d\n", key);
	+
	+ }
	+}
	+
	+void mcfioC_SetEventInfo(int stream, int key, int *values)
	+/*
	+** Set anciallary information for the current Event.
	+** Based on key, return in *values the requested information
	+** Only valid for Output Streams.
	+*/
	+{
	+ int i, jstr;
	+ float a;
	+ mcfStream *str;
	+ jstr = stream - 1;
	+ if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	+ stream);
	+ return;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str == NULL) {
	+ fprintf(stderr,"mcfio_SetEvent: Stream id %d is inactive \n",
	+ stream);
	+ return;
	+ }
	+ if (str->ehead ==NULL) {
	+ fprintf(stderr,"mcfio_SetEvent: Stream id %d is at beginning \n",
	+ stream);
	+ return;
	+ }
	+ if (str->row != MCFIO_WRITE) {
	+ fprintf(stderr,
	+ "mcfio_SetEvent: Stream id %d must be an Output stream \n",
	+ stream);
	+ return;
	+ }
	+ switch (key) {
	+ case MCFIO_EVENTNUMBER:
	+ str->ehead->evtnum = *values;
	+ break;
	+ case MCFIO_STORENUMBER:
	+ str->ehead->storenum = *values;
	+ break;
	+ case MCFIO_RUNNUMBER:
	+ str->ehead->runnum = *values;
	+ break;
	+ case MCFIO_TRIGGERMASK:
	+ str->ehead->trigMask = *values;
	+ break;
	+ case MCFIO_NUMBLOCKS: case MCFIO_BLOCKIDS:
	+ fprintf(stderr,
	+ "mcfio_SetEvent: Blocks and Block contents are set by mcfio_Blocks\n" );
	+ return;
	+ default:
	+ fprintf(stderr,
	+ "mcfio_SetEvent: Unrecognized Keyword %d\n", key);
	+
	+ }
	+}
	+
	+void mcfioC_InfoEventChar(int stream, int key, char answer, int lret)
	+/*
	+** Information routine for the current Event.
	+** Based on key, return in *values the requested information
	+*/
	+{
	+ int i, jstr;
	+ float a;
	+ mcfStream *str;
	+ jstr = stream - 1;
	+ if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str == NULL) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ if (str->ehead ==NULL) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is at beginning \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ switch (key) {
	+ case MCFIO_VERSION:
	+ strcpy(answer, str->ehead->version);
	+ break;
	+
	+ default:
	+ fprintf(stderr,
	+ "mcfio_InfoEvent: Unrecognized Keyword %d\n", key);
	+ *lret = 0;
	+ return;
	+
	+ }
	+ *lret = strlen(answer);
	+}
	+
	+void mcfioC_InfoBlockChar(int stream, int blkid,
	+ int key, char answer, int lret)
	+/*
	+** Information routine for a particular block within the current Event.
	+** Based on key, return the requested information in string answer.
	+*/
	+{
	+ int i, jstr, itmp, nn;
	+ u_int pos;
	+ bool_t tt;
	+ XDR *xx;
	+ char* data, *vv;
	+ mcfStream *str;
	+ jstr = stream - 1;
	+ if ((jstr <0) \|\| (jstr >= MCF_STREAM_NUM_MAX)) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is illegal \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ str = McfStreamPtrList[jstr];
	+ if (str == NULL) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is inactive \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ if (str->ehead ==NULL) {
	+ fprintf(stderr,"mcfio_InfoStream: Stream id %d is at beginning \n",
	+ stream);
	+ *lret = 0;
	+ return;
	+ }
	+ pos = 0;
	+ if(str->xdr != NULL) for(i=0; i<str->ehead->nBlocks; i++)
	+ if( str->ehead->blockIds[i] == blkid) pos = str->ehead->ptrBlocks[i];
	+ if (pos == 0) {
	+ fprintf(stderr,
	+ "mcfio_InfoStream: Stream id %d event %d does not contain block %d \n",
	+ stream,str->ehead->evtnum, blkid );
	+ *lret = 0;
	+ return;
	+ }
	+
	+ switch (key) {
	+ case MCFIO_VERSION:
	+ tt = xdr_setpos(str->xdr, pos);
	+ tt = xdr_mcfast_generic(str->xdr, &itmp, &nn, &vv, &data);
	+ xdr_free((xdrproc_t)xdr_string, data);
	+ strcpy(answer, vv);
	+ break;
	+
	+ default:
	+ fprintf(stderr,
	+ "mcfio_InfoEvent: Unrecognized Keyword %d\n", key);
	+ *lret = 0;
	+ return;
	+
	+ }
	+ *lret = strlen(answer);
	+}
	+void mcfioC_GetBlockName(int blkId, char *answer)
	+/*
	+** Get a Block name from the dictionary..It is assume that answer has
	+** pre-malloc, size MCF_XDR_B_TITLE_LENGTH
	+*/
	+{
	+ char *uDescr;
	+ switch (blkId) {
	+ case MCFIO_STDHEP:
	+ strcpy(answer,
	+ " Standard HEP COMMON block, see STDHEP Product");
	+ break;
	+
	+ case MCFIO_STDHEPM:
	+ strcpy(answer,
	+ " Standard HEP COMMON block with multiple interaction, see STDHEP Product");
	+ break;
	+
	+ case MCFIO_STDHEP4:
	+ strcpy(answer,
	+ " Standard HEP COMMON block with Les Houches, see STDHEP Product");
	+ break;
	+
	+ case MCFIO_STDHEP4M:
	+ strcpy(answer,
	+ " Standard HEP COMMON block with Les Houches and multiple interaction");
	+ break;
	+
	+ case MCFIO_HEPEUP:
	+ strcpy(answer,
	+ " Les Houches HEPEUP common block");
	+ break;
	+
	+ case MCFIO_HEPRUP:
	+ strcpy(answer,
	+ " Les Houches HEPRUP common block");
	+ break;
	+
	+ case MCFIO_STDHEPCXX:
	+ strcpy(answer,
	+ " StdHep::Event class, see StdHepC++ Product");
	+ break;
	+
	+ case MCFIO_STDHEPBEG:
	+ strcpy(answer,
	+ " Stdhep begin run record, see STDHEP Product");
	+ break;
	+
	+ case MCFIO_STDHEPEND:
	+ strcpy(answer,
	+ " Stdhep end run record, see STDHEP Product");
	+ break;
	+
	+ case MCFIO_OFFTRACKARRAYS:
	+ strcpy(answer,
	+ " The mcfast Offline Tracks, saved into parallel arrays");
	+ break;
	+
	+ case MCFIO_OFFTRACKSTRUCT:
	+ strcpy(answer,
	+ " The mcfast Offline Tracks, saved as the structure");
	+ break;
	+ default:
	+ sprintf(answer, " Private User Block number %d ", blkId );
	+ uDescr = mcfioC_UserBlockDescript(blkId);
	+ if (uDescr == NULL) fprintf(stderr,
	+ "mcfio_GetBlockName: Warning Unrecognized block I.D. %d\n", blkId);
	+ else answer = uDescr;
	+ }
	+
	+}
	+
	+
	+
	Index: trunk/contrib/mcfio/mcfio_Block.h
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Block.h (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Block.h (revision 8889)
	@@ -0,0 +1,19 @@
	+/*******************************************************************************
	+* *
	+* mcfio_Block.h -- Include file for mcfast Direct i/o layer. *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+*******************************************************************************/
	+int mcfioC_Block(int stream, int blkid,
	+ bool_t xdr_filtercode(XDR xdrs, int blockid, int ntot, char *version));
	+int mcfioC_NTuple(int stream, int nTupleid, char * version);
	+int mcfioC_NTupleMult(int stream, int nTupleid, char * version);
	+int mcfioC_NTupleVar(int stream, int nTupleid, int ivar, char * version);
	+int mcfioC_NTupleSubVar(int stream, int nTupleid, int ivar, int multIndex,
	+ char * version);
	+int mcfioC_NTupleSubStruct(int stream, int nTupleid, int multIndex,
	+ char * version);
	+
	+
	Index: trunk/contrib/mcfio/mcf_ntuBldDbinc.c
	===================================================================
	--- trunk/contrib/mcfio/mcf_ntuBldDbinc.c (revision 0)
	+++ trunk/contrib/mcfio/mcf_ntuBldDbinc.c (revision 8889)
	@@ -0,0 +1,527 @@
	+/*
	+ * dbin.cc
	+ *
	+ * C++ utility routines for the dbin package: see dbin.lex
	+ *
	+ * N.B. The Strings class from the CLHEP library is used.
	+ *
	+ * Torre Wenaus 04/01/1994
	+ *
	+ * Modifications:
	+ * 8/21/95 T. Wenaus Mod history started
	+ * 8/21/95 TW Strings class removed from dbin generated code.
	+ * 8/22/95 TW Strings class removed from dbinc.cc
	+ *
	+ * November 1995: some clean up to be able to run this code and
	+ * standard dbin simulateneously..
	+ * Make some routine & variable static, and change the name of routine
	+ * called from the outside, following the Nirvana/mcfio conventions.
	+ *
	+ */
	+
	+#include <stdlib.h>
	+#include <string.h>
	+#include <stdio.h>
	+#include <limits.h>
	+#include "mcf_ntuBldDbinc.h"
	+#include "mcf_ntubld_db.h"
	+
	+static void dbin_debug();
	+static void lineparse();
	+static void dbinparse(char* str, char* typ, char* nam,
	+ char* var, char* com, char* dim);
	+static void getmembers(long nmems);
	+static void getvalues();
	+static char* stlower(char*);
	+static void chrcat(char* str, char chr);
	+static char* token(char** str, char* sep);
	+static int testsep(char chr, char *sep);
	+static void mcf_ntubld_interpret();
	+
	+static char varname[40], objname[40], curstruct[40];
	+static char chvalues[500], *values, dim[20];
	+static char tok1[30], tok2[30], tok3[100], com[100];
	+static char line[1000];
	+static int n_instance_line_title, n_instance_header, n_instance_variable;
	+
	+static double dvar[100];
	+static float rvar[100];
	+static char chvar[100][80];
	+static char dbpath[FILENAME_MAX+1], filename[FILENAME_MAX+1];
	+static long nvars, morevalues, n_templates;
	+static long inc_depth, n_instance, debug_on;
	+static int isl;
	+static long n_significant, lnlen=0;
	+static FILE inFile, curFile1, curFile2, curFile3, curFile4, curFile5;
	+static const char *fnamep;
	+static void dbin_getrec(char* fname[],void (*)(void));
	+
	+static void dbin_getrec(char* fname[],void (*interpret)(void))
	+{
	+ char chr;
	+ int istat;
	+ long inc_depth_old = 0;
	+ const int nchmx = 300;
	+ /*
	+ ** Start be intializing all these globals, to be able to call this routine
	+ ** more than once..
	+ */
	+ inc_depth = 0;
	+ n_instance = 0;
	+ lnlen = 0;
	+ /* extract path from filename */
	+ strcpy(filename,*fname);
	+ if (strrchr(filename,'/') != NULL) {
	+ strcpy(dbpath,filename);
	+ *(strrchr(dbpath,'/')+1)='\0';
	+ } else {
	+ dbpath[0] = '\0';
	+ }
	+
	+ /* open file */
	+ inFile = fopen(*fname,"r");
	+ if (inFile == NULL) {
	+ fprintf(stdout,"Error opening %s\n",*fname);
	+ return;
	+ }
	+ else
	+ {
	+ if (debug_on) fprintf(stdout,"Opened %s\n",*fname);
	+ }
	+ /* read a line */
	+ while (inc_depth>=0) {
	+ istat=1;
	+ while (istat!=EOF) {
	+ if (inc_depth > inc_depth_old) /* need to open new file */
	+ {
	+ long ifstat;
	+ ifstat=1;
	+ fnamep = (const char *)filename;
	+ if (inc_depth==1) {curFile1 = fopen(fnamep,"r");
	+ if (curFile1==NULL) {
	+ fprintf(stdout,"Error opening %s\n",fnamep);
	+ ifstat=0;
	+ }
	+ else {
	+ if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	+ }
	+ }
	+ if (inc_depth==2) {curFile2 = fopen(fnamep,"r");
	+ if (curFile2==NULL) {
	+ fprintf(stdout,"Error opening %s\n",fnamep);
	+ ifstat=0;
	+ }
	+ else {
	+ if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	+ }
	+ }
	+ if (inc_depth==3) {curFile3 = fopen(fnamep,"r");
	+ if (curFile3==NULL) {
	+ fprintf(stdout,"Error opening %s\n",fnamep);
	+ ifstat=0;
	+ }
	+ else {
	+ if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	+ }
	+ }
	+ if (inc_depth==4) {curFile4 = fopen(fnamep,"r");
	+ if (curFile4==NULL) {
	+ fprintf(stdout,"Error opening %s\n",fnamep);
	+ ifstat=0;
	+ }
	+ else {
	+ if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	+ }
	+ }
	+ if (inc_depth==5) {curFile5 = fopen(fnamep,"r");
	+ if (curFile5==NULL) {
	+ fprintf(stdout,"Error opening %s\n",fnamep);
	+ ifstat=0;
	+ }
	+ else {
	+ if (debug_on) fprintf(stdout,"Opened %s\n",fnamep);
	+ }
	+ }
	+ }
	+ inc_depth_old = inc_depth;
	+ if (inc_depth==0) istat=fgetc(inFile);
	+ if (inc_depth==1) istat=fgetc(curFile1);
	+ if (inc_depth==2) istat=fgetc(curFile2);
	+ if (inc_depth==3) istat=fgetc(curFile3);
	+ if (inc_depth==4) istat=fgetc(curFile4);
	+ if (inc_depth==5) istat=fgetc(curFile5);
	+ chr = istat;
	+ if (chr == '\t') chr = ' '; /* remove tabs */
	+ if (chr == '\n') { /* line is complete; process it */
	+ if (morevalues == 1) { /* line extension containing values */
	+ /* if final significant char is '/', mark next
	+ line as values continuation */
	+ int i;
	+ isl=0;
	+ for (i=0;i<strlen(line);i++) {
	+ if (line[i] == '!') i=strlen(line);
	+ if (line[i] == '/') isl=i;
	+ }
	+ if (isl != 0) {
	+ n_significant = 0;
	+ for (i=isl;i<strlen(line);i++) {
	+ if (line[i] == '!') i=strlen(line);
	+ if (line[i]!='/' && line[i]!=' ' && line[i]!='\t'
	+ && i < strlen(line) ) n_significant++;
	+ }
	+ if (n_significant != 0) morevalues = 0;
	+ } else {
	+ morevalues = 0;
	+ }
	+ strcat(values," ");
	+ if (morevalues == 0) {
	+ strcat(values,line);
	+ } else {
	+ strncat(values,line,isl-1);
	+ }
	+ } else { /* line is not an extension. Parse it. */
	+ dbinparse(line, tok1, tok2, tok3, com, dim);
	+ }
	+ if (morevalues == 0) {
	+ /* no more line extensions to read. Process line. */
	+ /* now interpret the line */
	+ if (tok1[0] != '\0') {
	+ if (debug_on) fprintf(stdout,"%s %s %s\n",tok1,tok2,values);
	+ lineparse();
	+ (*interpret)();
	+ }
	+ }
	+ line[0] = '\0';
	+ lnlen = 0;
	+ } else {
	+ /* add to line */
	+ if (chr != '\r') { line[lnlen++]=chr; line[lnlen]='\0'; }
	+ }
	+ }
	+ inc_depth--; line[0] = '\0';
	+ }
	+ return;
	+}
	+
	+/****************************************************************************/
	+static void lineparse()
	+{
	+ char* tokn, env, envName, tmp1, tmp2;
	+ long l, in_template;
	+ varname[0] = '\0';
	+ objname[0] = '\0';
	+ if (!strcmp(tok1,"end")) {strcpy(curstruct,"--"); in_template = 0;}
	+ if (!strcmp(tok1,"structure")) {strcpy(curstruct,tok2);}
	+ if (!strcmp(tok1,"database")) ;
	+ if (!strcmp(tok1,"incname")) ;
	+ if (!strcmp(tok1,"index")) ;
	+ if (!strcmp(tok1,"provide")) ;
	+ if (!strcmp(tok1,"parent")) ;
	+ if (!strcmp(tok1,"child")) ;
	+ if (!strcmp(tok1,"dimension")) ;
	+ if (!strcmp(tok1,"template")) {in_template = 1; strcpy(curstruct,tok2);
	+ n_instance = 0;}
	+ if (!strcmp(tok1,"command")) {in_template = 1; strcpy(curstruct,tok2);}
	+ if (!strcmp(tok1,"include")) { /* switch input to specified file */
	+ /*
	+ ** Commented out, we use absolute path name in the includes.
	+ ** This allows us to go to more than one directory..
	+ */
	+/* strcpy(filename,dbpath); */
	+/* strcat(filename,tok2); */
	+/*
	+** We now implement translation of environmental variable
	+**
	+*/
	+ if (tok2[0] == '$') {
	+ tmp1 = strchr(&tok2[1], '/');
	+ if (tmp1 == NULL) {
	+ fprintf(stderr, "DBin error, Unkonw path %s\n", tok2);
	+ return;
	+ }
	+ envName = (char ) malloc(sizeof(char) (strlen(tok2)+1));
	+ strcpy(envName, &tok2[1]);
	+ tmp2 = strchr(envName, '/'); *tmp2 = '\0';
	+ env = getenv(envName);
	+ free(envName);
	+
	+ if (env == NULL) {
	+ fprintf(stderr, "DBin error, Unkonw path %s\n", tok2);
	+ return;
	+ }
	+ strcpy(filename,env); l = strlen(env); filename[l] = '/'; l++;
	+ strcpy(&filename[l], tmp1);
	+
	+ } else strcpy(filename, tok2);
	+ inc_depth++;
	+ }
	+ if (!strcmp(tok1,"make")) {
	+ n_instance++;
	+ strcpy(varname,"TEMPLATE_");
	+ strcat(varname,stlower(tok2));
	+ }
	+ if (!strcmp(tok1,"define")) {
	+ /* get first token (name) from values list */
	+ tokn = token(&values," \t");
	+ strcpy(varname,"TEMPLATE_");
	+ strcat(varname,tok2);
	+ strcpy(objname,tok2);
	+ strcat(objname,"_");
	+ strcat(objname,tokn);
	+ }
	+ if (!strcmp(tok1,"call")) {
	+ /* get first token (name) from values list */
	+ tokn = token(&values," \t");
	+ strcpy(varname,"COMMAND_");
	+ strcat(varname,tok2);
	+ }
	+ if (!strncmp(tok1,"int",3) \|\| !strcmp(tok1,"real") \|\| !strcmp(tok1,"double") \|\|
	+ !strncmp(tok1,"char",4) \|\| !strcmp(tok1,"material") ) {
	+ if ((! strncmp(curstruct,"--",2)) && (in_template == 0)) {
	+ fprintf(stdout,"dbin: Parameter \"%s\" not in structure; ignored:\n",
	+ tok2);
	+ fprintf(stdout," %s\n",line);
	+ } else {
	+ /* parse values */
	+ strcpy(varname,curstruct);
	+ strcat(varname,".");
	+ strcat(varname,tok2);
	+ getvalues();
	+ }
	+ }
	+}
	+
	+/****************************************************************************/
	+static void dbinparse(char* str, char* typ,
	+ char* nam, char* var, char* com, char* dim)
	+{
	+/* Parse from line the type, name, value, comment */
	+ int i;
	+ long nc = 0;
	+
	+ nvars = 1;
	+ chvalues[0] = dim[0] = typ[0] = nam[0] = var[0] = com[0] = '\0';
	+ values = chvalues;
	+
	+/* if final significant char is '/', mark next line as values continuation */
	+ isl=strlen(str);
	+ for (i=0;i<strlen(str);i++) {
	+ if (str[i] == '!') i=strlen(str);
	+ if (str[i] == '/') isl=i;
	+ }
	+ morevalues = 0;
	+ if (isl != strlen(str)) {
	+ n_significant = 0;
	+ for (i=isl;i<strlen(str);i++) {
	+ if (str[i] == '!') i=strlen(str);
	+ if (str[i]!='/' && str[i]!=' ' && str[i]!='\t'
	+ && i < strlen(line) ) n_significant++;
	+ }
	+ if (n_significant == 0) morevalues = 1;
	+ }
	+
	+ /* initial whitespace, type, whitespace */
	+ while ((str[nc] == ' ') \|\| (str[nc] == '\t')) ++nc;
	+ while ((str[nc] != ' ') && (str[nc] != '\t')
	+ && (nc < strlen(str))) chrcat(typ,str[nc++]);
	+ while ((str[nc] == ' ') \|\| (str[nc] == '\t')) ++nc;
	+ /* name, whitespace, dimension? */
	+ while ((str[nc] != ' ') && (str[nc] != '\t') && (str[nc] != '(' )
	+ && (nc < strlen(str))) chrcat(nam,str[nc++]);
	+ while ((str[nc] == ' ') \|\| (str[nc] == '\t')
	+ && (nc < strlen(str))) ++nc;
	+ if (str[nc] == '(') { /* have a dimensioned array */
	+ /* get dimension */
	+ while (str[++nc] != ')') chrcat(dim,str[nc]); nc++;
	+ nvars = atol(dim);
	+ }
	+ /* skip over value(s) to comment */
	+ while ( (str[nc] != '!') &&
	+ (str[nc] != '/' \|\| ( morevalues && (nc != isl) ) ) &&
	+ ( (nc < strlen(str)) \|\| ( morevalues && (nc < isl)) ) ) chrcat(chvalues,str[nc++]);
	+ /* comment */
	+ while (((str[nc] == '!') \|\| (str[nc] == '\t'))
	+ && (nc < strlen(str))) ++nc;
	+ while (nc <= strlen(str)) { chrcat(com,str[nc++]); }
	+ /* turn mnemonic num into variable name var */
	+ var = nam;
	+}
	+
	+/****************************************************************************/
	+
	+static void getvalues()
	+{
	+ char* tokn;
	+ long nv=0; while (nv < nvars) {
	+ /* get next token and trim it from the values list. */
	+ if (!strncmp(tok1,"char",4) \|\| !strncmp(tok1,"material",8) ) {
	+ char iq1, iq2;
	+ iq1 = strchr(values,'"');
	+ iq2 = strrchr(values,'"');
	+ if (iq1 != NULL) {
	+ strncpy(chvar[nv],iq1+1,iq2-iq1-1);
	+ chvar[nv][iq2-iq1-1] = '\0';
	+ }
	+ else
	+ strcpy(chvar[nv],values);
	+ } else {
	+ tokn = token(&values," \t");
	+ if (tokn != NULL) {
	+ if (!strncmp(tok1,"int",3)) rvar[nv] = atol(tokn);
	+ if (!strcmp(tok1,"real")) rvar[nv] = atof(tokn);
	+ if (!strcmp(tok1,"double")) dvar[nv] = atof(tokn);
	+ }
	+ }
	+ nv++;
	+ }
	+}
	+
	+/****************************************************************************/
	+
	+static void getmembers(long nmems)
	+{
	+ char tokn, iq1, *iq2;
	+ long n, nq, nv=0;
	+ /* fill string interiors with '@' so they are delineated as tokens */
	+ n=0; nq=0; while (n<strlen(values)) {
	+ if (values[n]=='"') nq++;
	+ if ((values[n]==' '\|\|values[n]=='\t') && nq%2==1) values[n] = '@';
	+ n++;
	+ }
	+ while (nv < nmems) {
	+ /* get next token and trim it from the values list. */
	+ tokn = token(&values," \t");
	+ if ( tokn[0]=='"' ) {
	+ n=0; while (n<strlen(tokn))
	+ { if (tokn[n]=='@') tokn[n] = ' '; n++; }
	+ iq1 = strchr(tokn,'"');
	+ iq2 = strrchr(tokn,'"');
	+ strncpy(chvar[nv],iq1+1,iq2-iq1-1);
	+ chvar[nv][iq2-iq1-1] = '\0';
	+ } else {
	+ strcpy(chvar[nv],tokn);
	+ }
	+ rvar[nv] = atof(tokn);
	+ nv++;
	+ }
	+}
	+
	+/****************************************************************************/
	+static void dbin_debug()
	+{
	+ debug_on = 1;
	+}
	+
	+/****************************************************************************/
	+static void chrcat(char* str, char chr)
	+{
	+ int ln;
	+ ln = strlen(str);
	+ str[ln] = chr;
	+ str[ln+1]='\0';
	+}
	+
	+/****************************************************************************/
	+static char * stlower(char* st) {
	+ int i=0;
	+ while (st[i] != '\0') {
	+ if (st[i] >= 'A' && st[i] <= 'Z') st[i] = st[i] + 'a' - 'A';
	+ i++;
	+ }
	+ return st;
	+}
	+
	+/****************************************************************************/
	+static char* token(char** str, char* sep)
	+{
	+ int i=0;
	+ char if1=NULL, if2=NULL, strend = str + strlen(*str);
	+ /* if1 = rel. pointer to 1st token char */
	+ i=0; while (if1 == NULL && i<strlen(*str)) {
	+ if (!testsep((str+i),sep))
	+ if1= *str+i;
	+ i++;
	+ }
	+ if (if1 == NULL) return if1;
	+ /* if2 = 1st char past the token */
	+ i=0; while (if2 == NULL && i<strlen(if1))
	+ { if (testsep(if1[i],sep)) if2=&if1[i]; i++; }
	+ if (if2<strend && if2 != NULL) {
	+ if (if2 != NULL) *if2 = '\0';
	+ *str = if2+1;
	+ } else {
	+ *str = strend;
	+ }
	+ return if1;
	+}
	+
	+/****************************************************************************/
	+static int testsep(char chr, char *sep)
	+{
	+ int ist=0, i=0;
	+ while (sep[i] != '\0')
	+ if (sep[i++] == chr \|\| chr == '\0' \|\| chr == '\n' ) ist=1;
	+ return ist;
	+}
	+/* Database read routine */
	+/*** Generated automatically using the dbin tool. */
	+/*** Not to be modified by user. */
	+/*
	+** Modifiedt by P.L., to abe able to load all the templates into
	+** one file... And included in this file, to avoid defining too many
	+** global symbols. This clearly breaks the dbin mold, to be discussed
	+** later..
	+*/
	+void mcf_ntubldRead(char* fname)
	+{
	+ void (pf)(); / pointer to interpreter */
	+ inc_depth = 0;
	+ n_instance =0;
	+ lnlen=0;
	+ debug_on = 0;
	+ pf = &mcf_ntubld_interpret;
	+ mcf_ntubldInit();
	+ n_instance_line_title = 0;
	+ n_instance_header = 0;
	+ n_instance_variable = 0;
	+ dbin_getrec(&fname,pf);
	+}
	+static void mcf_ntubld_interpret()
	+{
	+int inum, index, i, ndim, iok;
	+iok=0;
	+if ( !strcmp(varname,"TEMPLATE_line_title") ) {
	+ inum = 0; iok = 1;
	+ getmembers(n_el_line_title);
	+ index = n_instance_line_title;
	+ *n_obj_line_title = n_instance_line_title+1;
	+ strcpy(line_title[index].line,chvar[inum++]);
	+ n_instance_line_title++;
	+}
	+if ( !strcmp(varname,"TEMPLATE_header") ) {
	+ inum = 0; iok = 1;
	+ getmembers(n_el_header);
	+ index = n_instance_header;
	+ *n_obj_header = n_instance_header+1;
	+ strcpy(header[index].title,chvar[inum++]);
	+ strcpy(header[index].version,chvar[inum++]);
	+ strcpy(header[index].namemaxindex,chvar[inum++]);
	+ header[index].maxmult = rvar[inum++];
	+ header[index].orgstyle = rvar[inum++];
	+ header[index].nvar = rvar[inum++];
	+ n_instance_header++;
	+}
	+if ( !strcmp(varname,"TEMPLATE_variable") ) {
	+ inum = 0; iok = 1;
	+ getmembers(n_el_variable);
	+ index = n_instance_variable;
	+ *n_obj_variable = n_instance_variable+1;
	+ strcpy(variable[index].name,chvar[inum++]);
	+ strcpy(variable[index].description,chvar[inum++]);
	+ variable[index].type = rvar[inum++];
	+ strcpy(variable[index].isfixedsize,chvar[inum++]);
	+ variable[index].numdim = rvar[inum++];
	+ for (i=0;i<5;i++) variable[index].dimensions[i] = rvar[inum++];
	+ n_instance_variable++;
	+}
	+}
	Index: trunk/contrib/mcfio/mcf_xdr_Ntuple.h
	===================================================================
	--- trunk/contrib/mcfio/mcf_xdr_Ntuple.h (revision 0)
	+++ trunk/contrib/mcfio/mcf_xdr_Ntuple.h (revision 8889)
	@@ -0,0 +1,32 @@
	+/*******************************************************************************
	+* *
	+* mcf_xdr_Ntuple.h -- Include file for mcfast Xdrlayer used in the *
	+* Ntuple code. Refers to a bunch of structure not included in this file. * Specifies the headers *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warrenty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+*******************************************************************************/
	+bool_t xdr_mcfast_NTuple(XDR xdrs, descrGenNtuple dNTu,
	+ int ntot, int nTupleId, char version);
	+bool_t xdr_mcfast_NTupleXDRPtr(XDR xdrs, descrGenNtuple dNTu,
	+ int ntot, int nTupleId, char version);
	+bool_t xdr_mcfast_NTupleMult(mcfStream *str,
	+ descrGenNtuple dNTu, char version);
	+bool_t xdr_mcfast_NTupleVar(mcfStream *str,
	+ descrGenNtuple dNTu, int ivar, char version);
	+bool_t xdr_mcfast_NTupleSubVar(mcfStream *str,
	+ descrGenNtuple dNTu, int ivar, int multIndex, char version);
	+bool_t xdr_mcfast_NTupleSubStruct(mcfStream *str,
	+ descrGenNtuple dNTu, int multIndex, char version);
	Index: trunk/contrib/mcfio/mcfio_Util1.h
	===================================================================
	--- trunk/contrib/mcfio/mcfio_Util1.h (revision 0)
	+++ trunk/contrib/mcfio/mcfio_Util1.h (revision 8889)
	@@ -0,0 +1,27 @@
	+/*******************************************************************************
	+* *
	+* mcfio_Util1.h -- Include file for mcfast initialisation & info i/o layer. *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+*******************************************************************************/
	+void mcfioC_Init(void);
	+void mcfioC_Close(int istream);
	+void mcfioC_PrintDictionary(void);
	+unsigned int mcfioC_InfoNumSream(int *istreams, unsigned int nmax);
	+void mcfioC_InfoStreamInt(int istream, int key, int *value);
	+void mcfioC_InfoStreamChar(int istream, int key, char answer, int lret);
	+void mcfioC_InfoEventInt(int istream, int key, int *value);
	+void mcfioC_InfoEventChar(int istream, int key, char answer, int lret);
	+void mcfioC_SetEventInfo(int istream, int key, int *value);
	+void mcfioC_Free_FileHeader(mcfxdrFileHeader **p);
	+void mcfioC_Free_SeqHeader(mcfxdrSequentialHeader **p);
	+void mcfioC_Free_EventHeader(mcfxdrEventHeader **p);
	+void mcfioC_Free_EventTable(mcfxdrEventTable **p);
	+void mcfioC_FreeStream(mcfStream **stream);
	+void mcfioC_InfoBlockChar(int stream, int blk, int key,
	+ char answer, int lret);
	+unsigned int mcfioC_InfoNumStream(int *istreams, unsigned int nmax);
	+void mcfioC_GetBlockName(int blkId, char *answer);
	+void mcfioC_Rewind(int istream);
	Index: trunk/contrib/mcfio/mcfio_UserDictionary.c
	===================================================================
	--- trunk/contrib/mcfio/mcfio_UserDictionary.c (revision 0)
	+++ trunk/contrib/mcfio/mcfio_UserDictionary.c (revision 8889)
	@@ -0,0 +1,58 @@
	+/*
	+** A small container to hold a set of user block declaration
	+**
	+* Written by Paul Lebrun, Aug 2001
	+*/
	+#include <stdio.h>
	+#include <string.h>
	+#include <sys/param.h>
	+#include <rpc/types.h>
	+#include <sys/types.h>
	+#include <rpc/xdr.h>
	+#include <limits.h>
	+#include <stdlib.h>
	+#include "mcfio_UserDictionary.h"
	+
	+#define NUMUSERBLOCKDEFAULT 100
	+
	+allMCFIO_UserBlockDecl *AllMCFIO_UserBlockDecl = NULL;
	+
	+
	+char *mcfioC_UserBlockDescript(int blkn)
	+{
	+ int i;
	+ if (AllMCFIO_UserBlockDecl == NULL) return NULL;
	+ for (i=0; i<AllMCFIO_UserBlockDecl->num; i++) {
	+ if (AllMCFIO_UserBlockDecl->decls[i]->blkNum == blkn)
	+ return AllMCFIO_UserBlockDecl->decls[i]->title;
	+ }
	+ return NULL;
	+}
	+
	+void mcfioC_DefineUserBlock(int blkN, char *descr){
	+ int i;
	+ aUserBlockDecl *abd;
	+
	+ if (AllMCFIO_UserBlockDecl == NULL) {
	+
	+ AllMCFIO_UserBlockDecl = (allMCFIO_UserBlockDecl *) malloc (
	+ sizeof(allMCFIO_UserBlockDecl));
	+ AllMCFIO_UserBlockDecl->numPreAlloc = NUMUSERBLOCKDEFAULT;
	+ AllMCFIO_UserBlockDecl->num = 0;
	+ AllMCFIO_UserBlockDecl->decls = (aUserBlockDecl **) malloc(
	+ NUMUSERBLOCKDEFAULT * sizeof(aUserBlockDecl *));
	+ }
	+ if (AllMCFIO_UserBlockDecl->num == AllMCFIO_UserBlockDecl->numPreAlloc) {
	+ AllMCFIO_UserBlockDecl->numPreAlloc += NUMUSERBLOCKDEFAULT;
	+ AllMCFIO_UserBlockDecl->decls =
	+ (aUserBlockDecl *) realloc (((void ) AllMCFIO_UserBlockDecl->decls),
	+ (AllMCFIO_UserBlockDecl->numPreAlloc * sizeof(aUserBlockDecl *)));
	+ }
	+ AllMCFIO_UserBlockDecl->decls[AllMCFIO_UserBlockDecl->num] =
	+ (aUserBlockDecl *) malloc (sizeof(aUserBlockDecl));
	+ abd = AllMCFIO_UserBlockDecl->decls[AllMCFIO_UserBlockDecl->num];
	+ AllMCFIO_UserBlockDecl->num++;
	+ abd->blkNum = blkN;
	+ abd->title = (char ) malloc (sizeof(char) (strlen(descr) + 1));
	+ strcpy(abd->title, descr);
	+}
	Index: trunk/contrib/mcfio/mcfio_SeqDummy.c
	===================================================================
	--- trunk/contrib/mcfio/mcfio_SeqDummy.c (revision 0)
	+++ trunk/contrib/mcfio/mcfio_SeqDummy.c (revision 8889)
	@@ -0,0 +1,65 @@
	+/*******************************************************************************
	+* *
	+* mcfio_SeqDummy.c -- Utility routines for the McFast Monte-Carlo *
	+* Dummy Sequential routines, for the library without Sequential *
	+* *
	+* Copyright (c) 1994 Universities Research Association, Inc. *
	+* All rights reserved. *
	+* *
	+* This material resulted from work developed under a Government Contract and *
	+* is subject to the following license: The Government retains a paid-up, *
	+* nonexclusive, irrevocable worldwide license to reproduce, prepare derivative *
	+* works, perform publicly and display publicly by or for the Government, *
	+* including the right to distribute to other Government contractors. Neither *
	+* the United States nor the United States Department of Energy, nor any of *
	+* their employees, makes any warranty, express or implied, or assumes any *
	+* legal liability or responsibility for the accuracy, completeness, or *
	+* usefulness of any information, apparatus, product, or process disclosed, or *
	+* represents that its use would not infringe privately owned rights. *
	+* *
	+* *
	+* Written by Paul Lebrun *
	+* *
	+* *
	+*******************************************************************************/
	+#include <stdio.h>
	+#include <string.h>
	+#include "mcfio_Sequential.h"
	+
	+int mcfioC_OpenReadSequential(char device, char label, int filenumber)
	+{
	+ fprintf(stderr,
	+ "mcfioC_OpenReadSequential: Not available in this library. \n");
	+ return -1;
	+}
	+
	+
	+int mcfioC_OpenWriteSequential(char device, char label, char *title,
	+ char *comment, int numevts_pred,
	+ int *blkIds, unsigned int nBlocks)
	+{
	+ fprintf(stderr,
	+ "mcfioC_OpenWriteSequential: Not available in this library. \n");
	+ return -1;
	+}
	+
	+int mcfioC_NextEventSequential(int stream)
	+{
	+ fprintf(stderr,
	+ "mcfioC_NextEventSequential: Not available in this library. \n");
	+ return -1;
	+}
	+
	+void mcfioC_CloseSequentialFile(int jstr)
	+{
	+ fprintf(stderr,
	+ "mcfioC_CloseSequentialFile: Not available in this library. \n");
	+ return;
	+}
	+
	+void mcfioC_CloseSequentialTape(int jstr)
	+{
	+ fprintf(stderr,
	+ "mcfioC_CloseSequentialTape: Not available in this library. \n");
	+ return;
	+}

File Metadata

Mime Type: application/octet-stream
Expires: Wed, May 1, 3:24 PM (1 d, 23 h)
Storage Engine: chunks
Storage Format: Chunks
Storage Handle: dIaebxZKYoDl
Default Alt Text: (7 MB)

Offset	End	Complete
0	4194304	Yes
4194304	7727664	Yes

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions