+TITLE
ISAJET 7.74 16-FEB-2006 14:23:44
+PATCH,*ISADECAY.  ISAJET DECAY TABLE.
+USE,ISADECAY.     ISAJET DECAY MODES.
+EOD
+PATCH,*ISAJET.    ISAJET EVENT GENERATOR.
+USE,ISACDE.       ISAJET COMMON BLOCKS.
+USE,ISADATA.      ISAJET BLOCK DATA ALDATA.
+USE,ISAJET.       ISAJET EVENT GENERATION CODE.
+USE,ISASUSY.      ISASUSY MSSM DECAYS.
+USE,ISATAPE.      ISAJET TAPE INPUT/OUTPUT.
+USE,ISARUN.       ISAJET INTERACTIVE INTERFACE (IF=INTERACT)
+EOD
+PATCH,*ISAPLT.    ISAJET ANALYSIS PACKAGE USING HBOOK.
+USE,ISACDE.       ISAJET COMMON BLOCKS.
+USE,ISAPLT.       ISAJET SKELETON ANALYSIS JOB.
+USE,HBOOK4.       DEFAULT IS HBOOK4, OR USE HBOOK3.
+USE,HBOOK4,T=INHIBIT,IF=HBOOK3.
+EOD
+PATCH,*ISASUGRA.
+USE,ISACDE.                            ALL COMMON BLOCKS.
+USE,ISADATA.                           BLOCK DATA ALDATA.
+USE,ISASUSY.                           ISASUSY DECAY/RGE CODE.
+USE,ISASSRUN.                          MAIN PROGRAM CODE.
+USE,P=ISASSRUN,D=SSRUN,T=INHIBIT.      INHIBIT ISASUSY MAIN PROGRAM.
+EOD
+PATCH,*ISASUSY.
+USE,ISACDE.                            ALL COMMON BLOCKS.
+USE,ISADATA.                           BLOCK DATA ALDATA.
+USE,ISASUSY.                           ISASUSY DECAY/RGE CODE.
+USE,ISASSRUN.                          MAIN PROGRAM CODE.
+USE,P=ISASSRUN,D=SUGRUN,T=INHIBIT.     INHIBIT ISASUGRA MAIN PROGRAM.
+EOD
+PATCH,*ISATEXT.   ISAJET INSTRUCTIONS.
+USE,ISACDE.       ISAJET COMMON BLOCKS.
+USE,ISATEXT.      ISAJET DOCUMENTATION.
+USE,ISASSDOC.     ISASUSY DOCUMENTATION.
+USE,PDFLIB.       LATEX FAILS ON MISSING VERBATIM PDF COMMONS.
+EOD
+PATCH,*ISAZEB.    ISAJET EVENT GENERATOR.
+USE,INTERACT.
+USE,CERN.
+USE,ZEBINIT.      INITIALIZE ZEBRA.
+USE,ISACDE.       ISAJET COMMON BLOCKS.
+USE,ISADATA.      ISAJET BLOCK DATA ALDATA.
+USE,ISAJET.       ISAJET EVENT GENERATION CODE.
+USE,ISASUSY.      ISASUSY MSSM DECAYS.
+USE,ISAZEB.       ZEBRA TAPE INPUT/OUTPUT.
+USE,ISARUN.       ISAJET INTERACTIVE INTERFACE (IF=INTERACT)
+EOD
+PATCH,*ISZRUN.    ISAJET ANALYSIS PACKAGE USING HBOOK4 AND ZEBRA
+USE,ISACDE.       ISAJET COMMON BLOCKS.
+USE,ISZRUN.       ISAJET SKELETON ANALYSIS JOB.
+EOD
+PATCH,ANSI.                      GENERIC ANSI FORTRAN.
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+EOD
+PATCH,APOLLO.
+DECK,BLANKDEK.
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD.
+PATCH,CDC.                       CDC 7600 OR CYBER 175.
+USE,SINGLE.                      SINGLE PRECISION.
+USE,LEVEL2.                      LEVEL 2 STORAGE.
+USE,CDCPACK.                     PACK 2 WORDS PER WORD FOR INPUT/OUTPUT.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+EOD
+PATCH,CRAY.                      CRAY XMP OR 2.
+USE,SINGLE.                      SINGLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+EOD
+PATCH,DECS.                      DEC STATION (ULTRIX)
+USE,SUN.
+EOD
+PATCH,ETA.                       ETA-10.
+USE,SINGLE.                      SINGLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+EOD
+PATCH,HPUX.                      HP/9000 7XX RUNNING UNIX.
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,IBM.                       IBM 370 OR 30XX.
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+EOD
+PATCH,IBMRT.                     IBM RS/6000 WITH AIX 3.X
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,IRS.                       IBM RS/6000 WITH AIX 3.X
+USE,IBMRT.
+EOD
+PATCH,LINUX.                     IBM PC WITH LINUX 1.X
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,OSF.                       DIGITAL OSF1 ON ALPHA.
+USE,DOUBLE.                      DOUBLE PRECISION (USES REAL*8).
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,SGI.                       SILICON GRAPHICS 4D/XX.
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,SUN.                       SUN (SPARC)
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,VAX.                       DEC VAX 11/780 OR 8600.
+USE,DOUBLE.                      DOUBLE PRECISION.
+USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
+USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
+USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
+USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
+USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
+USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
+USE,IMPNONE.                     IMPLICIT NONE
+EOD
+PATCH,ISACDE.
+EOD
+DECK,CDEJET.
+KEEP,CONST
      COMMON/CONST/PI,SQRT2,ALFA,GF,UNITS
      SAVE /CONST/
      REAL      PI,SQRT2,ALFA,GF,UNITS
+KEEP,DKYTAB
C          LOOK must be dimensioned to the maximum value of INDEX.
      INTEGER   MXLOOK
      PARAMETER (MXLOOK=500)
      INTEGER   MXDKY
      PARAMETER (MXDKY=3000)
      COMMON/DKYTAB/LOOK(MXLOOK),CBR(MXDKY),MODE(5,MXDKY),MELEM(MXDKY)
      SAVE /DKYTAB/
+CDE,L2DKY,T=PASS,IF=LEVEL2.
      INTEGER   LOOK,MODE,MELEM
      REAL      CBR
+KEEP,L2DKY,IF=LEVEL2.
      LEVEL 2,/DKYTAB/
+KEEP,DYLIM
      COMMON/DYLIM/QMIN,QMAX,QTMIN,QTMAX,YWMIN,YWMAX,XWMIN,XWMAX,THWMIN,
     2  THWMAX,PHWMIN,PHWMAX
     3  ,SETLMQ(12)
      SAVE /DYLIM/
      LOGICAL SETLMQ
      EQUIVALENCE(BLIM1(1),QMIN)
      REAL      QMIN,QMAX,QTMIN,QTMAX,YWMIN,YWMAX,XWMIN,XWMAX,THWMIN,
     +          THWMAX,PHWMIN,PHWMAX,BLIM1(12)
+KEEP,DYPAR
      COMMON/DYPAR/FLW,RNU2(3),ANORM(3),QPOW(3),PTPOW(3)
      SAVE /DYPAR/
      LOGICAL FLW
      REAL      RNU2,ANORM,QPOW,PTPOW
+KEEP,EEPAR
      COMMON/EEPAR/SGMXEE,PLEP,PLEM,RSHMIN,RSHMAX,
     $UPSLON,SIGZ,IBREM,IBEAM,GAMGAM
      SAVE /EEPAR/
      REAL SGMXEE,PLEP,PLEM,RSHMIN,RSHMAX,UPSLON,SIGZ
      LOGICAL IBREM,IBEAM,GAMGAM
+KEEP,FINAL
      COMMON/FINAL/NKINF,SIGF,ALUM,ACCEPT,NRECS
      SAVE /FINAL/
      INTEGER   NKINF,NRECS
      REAL      SIGF,ALUM,ACCEPT
+KEEP,FORCE
      INTEGER   MXFORC
      PARAMETER (MXFORC=40)
      COMMON/FORCE/NFORCE,IFORCE(MXFORC),MFORCE(5,MXFORC)
     $,LOOK2(2,MXFORC),LOOKST(MXFORC),MEFORC(MXFORC)
      SAVE /FORCE/
      INTEGER   NFORCE,IFORCE,MFORCE,LOOK2,LOOKST,MEFORC
+KEEP,FRAME
      COMMON/FRAME/FRAME(5,3),N0JETS,N0W,N0PAIR
      SAVE /FRAME/
      INTEGER   N0JETS,N0W,N0PAIR
      REAL      FRAME
+KEEP,FRGPAR
      COMMON/FRGPAR/PUD,PBARY,SIGQT,PEND,XGEN(8),PSPIN1(8),
     $PMIX1(3,2),PMIX2(3,2),XGENSS(9)
      SAVE /FRGPAR/
      EQUIVALENCE (PMIX1(1,1),PMIXX1(1))
      EQUIVALENCE (PMIX2(1,1),PMIXX2(1))
      EQUIVALENCE(FRPAR(1),PUD)
      REAL      PUD,PBARY,SIGQT,PEND,XGEN,PSPIN1,PMIX1,PMIX2,XGENSS,
     +          PMIXX1(6),PMIXX2(6),FRPAR(32)
+KEEP,HCON
      COMMON/HCON/ANWWWW(4,4,4),ADWWWW(2,4),AIWWWW(4)
     $,HMASS,HGAM,HGAMS(29),ETAHGG,MATCHH(29),ZSTARS(4,2)
     $,IHTYPE,HGAMSS(85,85)
      SAVE /HCON/
+CDE,HCON2,T=PASS,IF=DOUBLE.
+CDE,HCON1,T=PASS,IF=SINGLE.
      INTEGER   MATCHH,IHTYPE
      REAL      HMASS,HGAM,HGAMS,ETAHGG,ZSTARS,HGAMSS
+KEEP,HCON1,IF=SINGLE.
      REAL ANWWWW,ADWWWW,AIWWWW
+KEEP,HCON2,IF=DOUBLE.
      DOUBLE PRECISION ANWWWW,ADWWWW,AIWWWW
+KEEP,IDRUN
      COMMON/IDRUN/IDVER,IDG(2),IEVT,IEVGEN
      SAVE /IDRUN/
      INTEGER   IDVER,IDG,IEVT,IEVGEN
+KEEP,ISAPW
C          ISAPW1 is used to check whether ALDATA is loaded
      COMMON/ISAPW/ISAPW1
      CHARACTER*30 ISAPW1
      SAVE /ISAPW/
+KEEP,ISLOOP
      COMMON/ISLOOP/NEVOLV,NFRGMN,IEVOL,IFRG
      SAVE /ISLOOP/
      INTEGER NEVOLV,NFRGMN,IEVOL,IFRG
+KEEP,ITAPES
      COMMON/ITAPES/ITDKY,ITEVT,ITCOM,ITLIS
      SAVE /ITAPES/
      INTEGER   ITDKY,ITEVT,ITCOM,ITLIS
+KEEP,JETLIM
C          Jet limits
      INTEGER MXLIM
      PARAMETER (MXLIM=8)
      INTEGER MXLX12
      PARAMETER (MXLX12=12*MXLIM)
      COMMON/JETLIM/PMIN(MXLIM),PMAX(MXLIM),PTMIN(MXLIM),PTMAX(MXLIM),
     $YJMIN(MXLIM),YJMAX(MXLIM),PHIMIN(MXLIM),PHIMAX(MXLIM),
     $XJMIN(MXLIM),XJMAX(MXLIM),THMIN(MXLIM),THMAX(MXLIM),
     $SETLMJ(12*MXLIM)
      SAVE /JETLIM/
      COMMON/FIXPAR/FIXP(MXLIM),FIXPT(MXLIM),FIXYJ(MXLIM),
     $FIXPHI(MXLIM),FIXXJ(MXLIM),FIXQM,FIXQT,FIXYW,FIXXW,FIXPHW
      SAVE /FIXPAR/
      COMMON/SGNPAR/CTHS(2,MXLIM),THS(2,MXLIM),YJS(2,MXLIM),XJS(2,MXLIM)  
      SAVE /SGNPAR/
      REAL      PMIN,PMAX,PTMIN,PTMAX,YJMIN,YJMAX,PHIMIN,PHIMAX,XJMIN,
     +          XJMAX,THMIN,THMAX,BLIMS(12*MXLIM),CTHS,THS,YJS,XJS
      LOGICAL SETLMJ
      LOGICAL FIXQM,FIXQT,FIXYW,FIXXW,FIXPHW
      LOGICAL FIXP,FIXPT,FIXYJ,FIXPHI,FIXXJ
      EQUIVALENCE(BLIMS(1),PMIN(1))
+KEEP,JETPAR
      COMMON/JETPAR/P(3),PT(3),YJ(3),PHI(3),XJ(3),TH(3),CTH(3),STH(3)
     1 ,JETTYP(3),SHAT,THAT,UHAT,QSQ,X1,X2,PBEAM(2)
     2 ,QMW,QW,QTW,YW,XW,THW,QTMW,PHIW,SHAT1,THAT1,UHAT1,JWTYP
     3 ,ALFQSQ,CTHW,STHW,Q0W
     4 ,INITYP(2),ISIGS,PBEAMS(5)
      SAVE /JETPAR/
      INTEGER   JETTYP,JWTYP,INITYP,ISIGS
      REAL      P,PT,YJ,PHI,XJ,TH,CTH,STH,SHAT,THAT,UHAT,QSQ,X1,X2,
     +          PBEAM,QMW,QW,QTW,YW,XW,THW,QTMW,PHIW,SHAT1,THAT1,UHAT1,
     +          ALFQSQ,CTHW,STHW,Q0W,PBEAMS
+KEEP,JETSET
      INTEGER   MXJSET,JPACK
      PARAMETER (MXJSET=400,JPACK=1000)
      COMMON/JETSET/NJSET,PJSET(5,MXJSET),JORIG(MXJSET),JTYPE(MXJSET),
     $JDCAY(MXJSET)
      SAVE /JETSET/
+CDE,L2JSET,T=PASS,IF=LEVEL2.
      INTEGER   NJSET,JORIG,JTYPE,JDCAY
      REAL      PJSET
+KEEP,L2JSET,IF=LEVEL2.
      LEVEL2,/JETSET/
+KEEP,JETSIG
      INTEGER   MXSIGS,IOPAK
      PARAMETER (MXSIGS=3000,IOPAK=100)
      COMMON/JETSIG/SIGMA,SIGS(MXSIGS),NSIGS,INOUT(MXSIGS),SIGEVT
      SAVE /JETSIG/
+CDE,L2SIGS,T=PASS,IF=LEVEL2.
      INTEGER   NSIGS,INOUT
      REAL      SIGMA,SIGS,SIGEVT
+KEEP,L2SIGS,T=PASS,IF=LEVEL2.
      LEVEL2,/JETSIG/
+KEEP,JWORK2
      COMMON/JWORK2/JVIR(2),PFINAL(5),SGN,ZMIN,ZMAX,DZMAX,JET,GLFORC(2),
     $ZGOOD,JIN(400),FXTEST(MXJSET)
      SAVE /JWORK2/
      LOGICAL GLFORC,ZGOOD
      INTEGER   JVIR,JET,JIN
      REAL      PFINAL,SGN,ZMIN,ZMAX,DZMAX,FXTEST
+KEEP,JWORK
      COMMON/JWORK/ZZC(MXJSET),JMATCH(MXJSET),TNEW,P1CM(4),
     1J1,J2,J3,J4,J5,E1CM,E2CM,E3CM,E4CM,E5CM
      SAVE /JWORK/
      LOGICAL TNEW
      EQUIVALENCE (J1,JJ(1)),(E1CM,EE(1))
      INTEGER   JMATCH,J1,J2,J3,J4,J5,JJ(5)
      REAL      ZZC,P1CM,E1CM,E2CM,E3CM,E4CM,E5CM,EE(5)
+KEEP,KEYS
      INTEGER MXKEYS
      PARAMETER (MXKEYS=20)
      COMMON/KEYS/IKEYS,KEYON,KEYS(MXKEYS)
      COMMON/XKEYS/REAC
      SAVE /KEYS/,/XKEYS/
      LOGICAL KEYS
      LOGICAL KEYON
      CHARACTER*8 REAC
      INTEGER   IKEYS
+KEEP,KKGRAV
C          KKGravity common
      COMMON/KKGRAV/NEXTRAD,MASSD,KKGSD,SURFD,UVCUT
      INTEGER NEXTRAD
      REAL    MASSD,KKGSD,SURFD
      LOGICAL UVCUT
      SAVE /KKGRAV/
+KEEP,LIMEVL
      COMMON /LIMEVL/ ETTHRS,CONCUT,USELIM
      SAVE /LIMEVL/
      REAL ETTHRS,CONCUT
      LOGICAL USELIM
+KEEP,LISTSS
C          LISTSS IDENT and JETTYPE codes
C       ISGL  ISUPL -ISUPL  ISDNL -ISDNL  ISSTL -ISSTL  ISCHL -ISCHL
C          1      2      3      4      5      6      7      8      9
C      ISBT1 -ISBT1  ISTP1 -ISTP1  ISUPR -ISUPR  ISDNR -ISDNR  ISSTR
C         10     11     12     13     14     15     16     17     18
C     -ISSTR  ISCHR -ISCHR  ISBT2 -ISBT2  ISTP2 -ISTP2   ISW1  -ISW1
C         19     20     21     22     23     24     25     26     27
C       ISW2  -ISW2   ISZ1   ISZ2   ISZ3   ISZ4  ISNEL -ISNEL   ISEL
C         28     29     30     31     32     33     34     35     36
C      -ISEL  ISNML -ISNML  ISMUL -ISMUL  ISNTL -ISNTL ISTAU1-ISTAU1
C         37     38     39     40     41     42     43     44     45
C       ISER  -ISER  ISMUR -ISMUR ISTAU2-ISTAU2      9      1     -1
C         46     47     48     49     50     51     52     53     54
C          2     -2      3     -3      4     -4      5     -5      6
C         55     56     57     58     59     60     61     62     63
C         -6     11    -11     12    -12     13    -13     14    -14
C         64     65     66     67     68     69     70     71     72
C         15    -15     16    -16     10     80    -80     90   ISHL
C         73     74     75     76     77     78     79     80     81
C       ISHH   ISHA   ISHC  -ISHC
C         82     83     84     85
      COMMON/LISTSS/LISTSS(85)
      INTEGER LISTSS
      SAVE /LISTSS/
+KEEP,LSTPRT
      COMMON/LSTPRT/LSTPRT
      SAVE /LSTPRT/
      INTEGER   LSTPRT
+KEEP,LUXPAR
C          Parameters for RANLUX generator
C          Set by ALDATA and READIN but not by RESET
C          LUXSET=.TRUE. after RLUXGO has been called in PRTLIM
      INTEGER LUX
      PARAMETER (LUX=3)
      COMMON/LUXPAR/LUXINT,LUXK1,LUXK2,LUXGO
      INTEGER LUXINT,LUXK1,LUXK2
      LOGICAL LUXGO
+KEEP,MBGEN
      INTEGER   LIMPOM
      PARAMETER (LIMPOM=20)
      COMMON/MBGEN/POMWT(LIMPOM),POMGEN(LIMPOM),MNPOM,MXPOM,PDIFFR,
     $NPOM,XBARY(2),DXBARY(2),XPOM(LIMPOM,2)
      SAVE /MBGEN/
      INTEGER   MNPOM,MXPOM,NPOM
      REAL      POMWT,POMGEN,PDIFFR,XBARY,DXBARY,XPOM
+KEEP,MBPAR
      COMMON/MBPAR/PUD0,PJSPN,PISPN,SIGQT0,XGEN0(2),PMIX01(3,2)
     1,PMIX02(3,2),PBARY0
      SAVE /MBPAR/
      REAL      PUD0,PJSPN,PISPN,SIGQT0,XGEN0,PMIX01,PMIX02,PBARY0
+KEEP,MGCOMS
C=====     Begin common blocks used by MadGraph
      REAL*8            GW, GWWA, GWWZ
      COMMON /COUP1/    GW, GWWA, GWWZ
      SAVE /COUP1/
      REAL*8            GAL(2),GAU(2),GAD(2),GWF(2)
      COMMON /COUP2A/   GAL,   GAU,   GAD,   GWF
      SAVE /COUP2A/
      REAL*8            GZN(2),GZL(2),GZU(2),GZD(2),G1(2)
      COMMON /COUP2B/   GZN,   GZL,   GZU,   GZD,   G1
      SAVE /COUP2B/
      REAL*8            GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH
      COMMON /COUP3/    GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH
      SAVE /COUP3/
      COMPLEX*16        GCHF(2,12)
      COMMON /COUP4/    GCHF
      SAVE /COUP4/
      REAL*8            WMASS,WWIDTH,ZMASS,ZWIDTH
      COMMON /VMASS1/   WMASS,WWIDTH,ZMASS,ZWIDTH
      SAVE /VMASS1/
      REAL*8            AMASS,AWIDTH,HMASS,HWIDTH
      COMMON /VMASS2/   AMASS,AWIDTH,HMASS,HWIDTH
      SAVE /VMASS2/
      REAL*8            FMASS(12), FWIDTH(12)
      COMMON /FERMIONS/ FMASS,     FWIDTH
      SAVE /FERMIONS/
      REAL*8            GG(2), G
      COMMON /COUPQCD/  GG,    G
      SAVE /COUPQCD/
C=====     End common blocks used by MadGraph
+KEEP,MGKIN
C          Double precision PJETS; MXJETS defined in /JETLIM/
C          Format matches MadGraph
      COMMON/MGKIN/PJETS8(0:3,MXLIM+2),AMJET8(MXLIM+2)
      REAL*8 PJETS8,AMJET8
      SAVE /MGKIN/
+KEEP,MGLIMS
C          Limits for MadGraph multiparton processes
      COMMON/MGLIMS/EHMGMN,EHMGMX,YHMGMN,YHMGMX,
     $AMIJMN(MXLIM,MXLIM),AMIJMX(MXLIM,MXLIM),FIXMIJ(MXLIM,MXLIM)
      SAVE /MGLIMS/
      REAL EHMGMN,EHMGMX,YHMGMN,YHMGMX,AMIJMN,AMIJMX
      LOGICAL FIXMIJ
+KEEP,MGSIGS
C
C          Running totals for MadGraph cross sections
C          WTTOT8/NWTTOT  = total cross section
C          WTSUM8/NWT8    = channel cross section
C          IFUNC8, IDENT8 = MadGraph function code channel flavors
C
      INTEGER MXSIG8
      PARAMETER (MXSIG8=1000)
      COMMON /MGSIGS/WTTOT8,WTSUM8(MXSIG8),WTMAX8(MXSIG8),NSIG8,
     $NWTTOT,NWT8(MXSIG8),IFUNC8(MXSIG8),IDENT8(MXLIM+2,MXSIG8),
     $ISORT8(MXSIG8)
      REAL*8 WTTOT8,WTSUM8,WTMAX8
      INTEGER NSIG8,NWTTOT,NWT8,IFUNC8,IDENT8,ISORT8
      SAVE /MGSIGS/
+KEEP,NODCAY
      COMMON/NODCAY/NODCAY,NOETA,NOPI0,NONUNU,NOEVOL,NOHADR,NOGRAV,
     $NOB,NOTAU
      LOGICAL NODCAY,NOETA,NOPI0,NONUNU,NOEVOL,NOHADR,NOGRAV,
     $NOB,NOTAU
      SAVE /NODCAY/
+KEEP,PARTCL
      INTEGER   MXPTCL,IPACK
      PARAMETER (MXPTCL=4000,IPACK=10000)
      COMMON/PARTCL/NPTCL,PPTCL(5,MXPTCL),IORIG(MXPTCL),IDENT(MXPTCL)
     1,IDCAY(MXPTCL)
      SAVE /PARTCL/
+CDE,L2PART,T=PASS,IF=LEVEL2.
      INTEGER   NPTCL,IORIG,IDENT,IDCAY
      REAL      PPTCL
+KEEP,L2PART,IF=LEVEL2.
      LEVEL2,/PARTCL/
+KEEP,PINITS
      COMMON/PINITS/PINITS(5,2),IDINIT(2)
      SAVE /PINITS/
      INTEGER   IDINIT
      REAL      PINITS
+KEEP,PJETS
      INTEGER MXJETS
      PARAMETER (MXJETS=10)
      COMMON/PJETS/PJETS(5,MXJETS),IDJETS(MXJETS),QWJET(5),IDENTW 
     $,PPAIR(5,4),IDPAIR(4),JPAIR(4),NPAIR,IFRAME(MXJETS)
      SAVE /PJETS/
      INTEGER   IDJETS,IDENTW,IDPAIR,JPAIR,NPAIR,IFRAME
      REAL      PJETS,QWJET,PPAIR
+KEEP,PRIMAR
      COMMON/PRIMAR/NJET,SCM,HALFE,ECM,IDIN(2),NEVENT,NTRIES,NSIGMA
      SAVE /PRIMAR/
      INTEGER   NJET,IDIN,NEVENT,NTRIES,NSIGMA
      REAL      SCM,HALFE,ECM
+KEEP,PRTOUT
      COMMON/PRTOUT/NEVPRT,NJUMP
      SAVE /PRTOUT/
      INTEGER   NEVPRT,NJUMP
+KEEP,PTPAR
      COMMON/PTPAR/PTFUN1,PTFUN2,PTGEN1,PTGEN2,PTGEN3,SIGMAX
      SAVE /PTPAR/
      REAL      PTFUN1,PTFUN2,PTGEN1,PTGEN2,PTGEN3,SIGMAX
+KEEP,Q1Q2
      INTEGER MXGOQ,MXGOJ
      PARAMETER (MXGOQ=85,MXGOJ=8)
      COMMON/Q1Q2/GOQ(MXGOQ,MXGOJ),GOALL(MXGOJ),GODY(4),STDDY,
     $GOWW(25,2),ALLWW(2),GOWMOD(25,MXGOJ)
      SAVE /Q1Q2/
      LOGICAL GOQ,GOALL,GODY,STDDY,GOWW,ALLWW,GOWMOD
+KEEP,QCDPAR
      COMMON/QCDPAR/ALAM,ALAM2,CUTJET,ISTRUC
      SAVE /QCDPAR/
      INTEGER   ISTRUC
      REAL      ALAM,ALAM2,CUTJET
+KEEP,QLMASS
      COMMON/QLMASS/AMLEP(100),NQLEP,NMES,NBARY
      SAVE /QLMASS/
      INTEGER   NQLEP,NMES,NBARY
      REAL      AMLEP
+KEEP,QSAVE
      COMMON/QSAVE/QSAVE(29,2)
      SAVE /QSAVE/
      REAL      QSAVE
+KEEP,SEED
      COMMON/SEED/XSEED
      SAVE /SEED/
      CHARACTER*24 XSEED
+KEEP,TCPAR
      COMMON/TCPAR/TCMRHO,TCGRHO
      SAVE /TCPAR/
      REAL TCMRHO,TCGRHO
+KEEP,TIMES
      COMMON/TIMES/TIME1,TIME2
      SAVE /TIMES/
      REAL      TIME1,TIME2
+KEEP,TOTALS
      COMMON/TOTALS/NKINPT,NWGEN,NKEEP,SUMWT,WT
      SAVE /TOTALS/
      INTEGER   NKINPT,NWGEN,NKEEP
      REAL      SUMWT,WT
+KEEP,TYPES
      INTEGER MXTYPE
      PARAMETER (MXTYPE=8)
      COMMON/TYPES/LOC(100),NTYP,NJTTYP(MXTYPE),NWWTYP(2),NWMODE(3)
      COMMON/XTYPES/PARTYP(40),TITLE(10),JETYP(30,MXTYPE),WWTYP(30,2)
     $,WMODES(30,3)
      SAVE /TYPES/,/XTYPES/
      CHARACTER*8 JETYP,WWTYP,TITLE,PARTYP,WMODES
      INTEGER   LOC,NTYP,NJTTYP,NWWTYP,NWMODE
+KEEP,W50510,IF=PDFLIB
C          Copy of PDFLIB common block
      COMMON/W50510/IFLPRT
      INTEGER IFLPRT
      SAVE /W50510/
+KEEP,W50517,IF=PDFLIB
C          Copy of PDFLIB common block
      COMMON/W50517/N6
      INTEGER N6
      SAVE /W50517/
+KEEP,WCON
      COMMON/WCON/SIN2W,WMASS(4),WGAM(4),AQ(12,4),BQ(12,4),COUT(4),
     1MATCH(25,4),WCBR(25,4),CUTOFF,CUTPOW,TBRWW(4,2),RBRWW(12,4,2),EZ,
     2AQDP(12,4),BQDP(12,4),EZDP,WFUDGE
      SAVE /WCON/
+CDE,WCON2,T=PASS,IF=DOUBLE.
+CDE,WCON1,T=PASS,IF=SINGLE.
      INTEGER   MATCH
      REAL      SIN2W,WMASS,WGAM,AQ,BQ,COUT,WCBR,CUTOFF,CUTPOW,TBRWW,
     +          RBRWW,EZ,WFUDGE
      COMMON/WCON2/CUMWBR(25,3)
      REAL CUMWBR
+KEEP,WCON1,T=PASS,IF=SINGLE.
      REAL AQDP,BQDP,EZDP
+KEEP,WCON2,T=PASS,IF=DOUBLE.
      DOUBLE PRECISION AQDP,BQDP,EZDP
+KEEP,WGEN
      COMMON/WGEN/PTGN(3,3),QGEN(3,3),PTSEL(3),QSEL(3),SIGSL(3),NKL,NKH
     1,EMSQ,EMGAM,KSEL,QSELWT(3)
      SAVE /WGEN/
      INTEGER   NKL,NKH,KSEL
      REAL      PTGN,QGEN,PTSEL,QSEL,SIGSL,EMSQ,EMGAM,QSELWT
+KEEP,WSIG
      COMMON/WSIG/SIGLLQ
      SAVE /WSIG/
      REAL      SIGLLQ
+KEEP,WWPAR.
      COMMON/WWPAR/SWW,TWW,UWW,WM2,ZM2,P1WW(5),P2WW(5),P3WW(5),P4WW(5)
     $,PZERO(4,4),S13,P3(5),Q1(5),Q3(5),JQWW(2)
     $,CQ,CV,CA,CV1,CA1,CV3,CA3,CS,CT,CU
      SAVE /WWPAR/
+CDE,WWPAR2,T=PASS,IF=DOUBLE.
+CDE,WWPAR1,T=PASS,IF=SINGLE.
      INTEGER   JQWW
+KEEP,WWPAR1,T=PASS,IF=SINGLE.
      REAL SWW,TWW,UWW,WM2,ZM2,P1WW,P2WW,P3WW,P4WW
     $,PZERO,S13,P3,Q1,Q3
     $,CQ,CV,CA,CV1,CA1,CV3,CA3,CS,CT,CU
+KEEP,WWPAR2,T=PASS,IF=DOUBLE.
      DOUBLE PRECISION SWW,TWW,UWW,WM2,ZM2,P1WW,P2WW,P3WW,P4WW
     $,PZERO,S13,P3,Q1,Q3
     $,CQ,CV,CA,CV1,CA1,CV3,CA3,CS,CT,CU
+KEEP,WWSIG.
      COMMON/WWSIG/WWSIG
      SAVE /WWSIG/
      REAL      WWSIG
+DECK,CDESUSY.
+KEEP,BREMBM
      COMMON/BREMBM/QSQBM,EB,XMIN
      REAL QSQBM,EB,XMIN
      SAVE /BREMBM/
+KEEP,DKYSS3
C
C          Data for SUSY 3-body matrix elements. There is a double 
C          pointer structure, first to modes, and then to poles that
C          make up the matrix element for that mode:
C          MELEM=-I in /DKYTAB/ points to the mode information:
C            J1SS3(I) = start of pole list for this mode
C            J2SS3(I) = end of pole list for this mode
C            WTSS3(I) = maximum weight for this mode
C          J1SS3<J<J2SS3 points to the corresponding poles:
C            KSS3(J)    = pole type
C            AMSS3(J)   = pole mass
C            ZISS3(2,J) = initial couplings
C            ZFSS3(2,J) = final couplings
C          For gaugino -> gaugino f fbar, the pole types are
C            KSS3=1: spin-1 pole in f-fbar channel
C            KSS3=2: spin-0 pole in gaugino-f channel
C            KSS3=3: spin-0 pole in gaugino-fbar channel
C            KSS3=4: spin-0 pole in f-fbar channel
C          The two couplings are the coefficients of 1,gamma_5 or of
C          gamma_mu,gamma_mu*gamma_5. 
C
      INTEGER MXMSS3,MXPSS3
      PARAMETER (MXMSS3=1000)
      PARAMETER (MXPSS3=2000)
      COMMON/DKYSS3/NMSS3,NPSS3,
     $J1SS3(MXMSS3),J2SS3(MXMSS3),WTSS3(MXMSS3),
     $KSS3(MXPSS3),AMSS3(MXPSS3),ZISS3(2,MXPSS3),ZFSS3(2,MXPSS3)
      INTEGER NMSS3,NPSS3,KSS3,J1SS3,J2SS3
      REAL WTSS3,AMSS3
      COMPLEX ZISS3,ZFSS3
+KEEP,SSINF
      COMMON/SSINF/XLAM
      DOUBLE PRECISION XLAM
+KEEP,SSLUN
      COMMON/SSLUN/LOUT
      INTEGER LOUT
      SAVE /SSLUN/
+KEEP,SSMODE
C          MXSS         =  maximum number of modes
C          NSSMOD       = number of modes
C          ISSMOD       = initial particle
C          JSSMOD       = final particles
C          GSSMOD       = width
C          BSSMOD       = branching ratio
C          MSSMOD       = decay matrix element pointer
C          LSSMOD       = logical flag used internally by SSME3
      INTEGER MXSS
      PARAMETER (MXSS=1000)
      COMMON/SSMODE/NSSMOD,ISSMOD(MXSS),JSSMOD(5,MXSS),GSSMOD(MXSS)
     $,BSSMOD(MXSS),MSSMOD(MXSS),LSSMOD
      INTEGER NSSMOD,ISSMOD,JSSMOD,MSSMOD
      REAL GSSMOD,BSSMOD
      LOGICAL LSSMOD
      SAVE /SSMODE/
+KEEP,SSPAR
C          SUSY parameters
C          AMGLSS               = gluino mass
C          AMULSS               = up-left squark mass
C          AMELSS               = left-selectron mass
C          AMERSS               = right-slepton mass
C          AMNiSS               = sneutrino mass for generation i
C          TWOM1                = Higgsino mass = - mu
C          RV2V1                = ratio v2/v1 of vev's
C          AMTLSS,AMTRSS        = left,right stop masses
C          AMT1SS,AMT2SS        = light,heavy stop masses
C          AMBLSS,AMBRSS        = left,right sbottom masses
C          AMB1SS,AMB2SS        = light,heavy sbottom masses
C          AMLLSS,AMLRSS        = left,right stau masses
C          AML1SS,AML2SS        = light,heavy stau masses
C          AMZiSS               = signed mass of Zi
C          ZMIXSS               = Zi mixing matrix
C          AMWiSS               = signed Wi mass
C          GAMMAL,GAMMAR        = Wi left, right mixing angles
C          AMHL,AMHH,AMHA       = neutral Higgs h0, H0, A0 masses
C          AMHC                 = charged Higgs H+ mass
C          ALFAH                = Higgs mixing angle
C          AAT                  = stop trilinear term
C          THETAT               = stop mixing angle
C          AAB                  = sbottom trilinear term
C          THETAB               = sbottom mixing angle
C          AAL                  = stau trilinear term
C          THETAL               = stau mixing angle
C          AMGVSS               = gravitino mass
C          MTQ                  = top mass at MSUSY
C          MBQ                  = bottom mass at MSUSY
C          MLQ                  = tau mass at MSUSY
C          FBMA                 = b-Yukawa at mA scale
C          VUQ                  = Hu vev at MSUSY
C          VDQ                  = Hd vev at MSUSY
C          SGNM3                = sign of gaugino mass M3
      COMMON/SSPAR/AMGLSS,AMULSS,AMURSS,AMDLSS,AMDRSS,AMSLSS
     $,AMSRSS,AMCLSS,AMCRSS,AMBLSS,AMBRSS,AMB1SS,AMB2SS
     $,AMTLSS,AMTRSS,AMT1SS,AMT2SS,AMELSS,AMERSS,AMMLSS,AMMRSS
     $,AMLLSS,AMLRSS,AML1SS,AML2SS,AMN1SS,AMN2SS,AMN3SS
     $,TWOM1,RV2V1,AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,ZMIXSS(4,4)
     $,AMW1SS,AMW2SS
     $,GAMMAL,GAMMAR,AMHL,AMHH,AMHA,AMHC,ALFAH,AAT,THETAT
     $,AAB,THETAB,AAL,THETAL,AMGVSS,MTQ,MBQ,MLQ,FBMA,
     $VUQ,VDQ,SGNM3
      REAL AMGLSS,AMULSS,AMURSS,AMDLSS,AMDRSS,AMSLSS
     $,AMSRSS,AMCLSS,AMCRSS,AMBLSS,AMBRSS,AMB1SS,AMB2SS
     $,AMTLSS,AMTRSS,AMT1SS,AMT2SS,AMELSS,AMERSS,AMMLSS,AMMRSS
     $,AMLLSS,AMLRSS,AML1SS,AML2SS,AMN1SS,AMN2SS,AMN3SS
     $,TWOM1,RV2V1,AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,ZMIXSS
     $,AMW1SS,AMW2SS
     $,GAMMAL,GAMMAR,AMHL,AMHH,AMHA,AMHC,ALFAH,AAT,THETAT
     $,AAB,THETAB,AAL,THETAL,AMGVSS,MTQ,MBQ,MLQ,FBMA,VUQ,VDQ,SGNM3
      REAL AMZISS(4)
      EQUIVALENCE (AMZISS(1),AMZ1SS)
      SAVE /SSPAR/
+KEEP,SSPOLS
C          Polarizations in SUSY decays
C          PTAUj(i)  = P_tau for tauj -> ziss tau
C          PTAUZi(j) = P_tau for ziss -> tauj tau
C          PTAUZZ    = P_tau for z2ss -> z1ss tau tau
C          PTAUWZ    = P_tau for w1ss -> z1ss tau nutau
      COMMON/SSPOLS/PTAU1(4),PTAU2(4),PTAUZ2(2),PTAUZ3(2),PTAUZ4(2),
     $PTAUZZ,PTAUWZ
      SAVE /SSPOLS/
      REAL PTAU1,PTAU2,PTAUZ2,PTAUZ3,PTAUZ4,PTAUZZ,PTAUWZ
+KEEP,SSSM
C          Standard model parameters
C          AMUP,...,AMTP        = quark masses
C          AME,AMMU,AMTAU       = lepton masses
C          AMW,AMZ              = W,Z masses
C          GAMW,GAMZ            = W,Z widths
C          ALFAEM,SN2THW,ALFA3  = SM couplings
C          ALQCD4               = 4 flavor lambda
      COMMON/SSSM/AMUP,AMDN,AMST,AMCH,AMBT,AMTP,AME,AMMU,AMTAU
     $,AMW,AMZ,GAMW,GAMZ,ALFAEM,SN2THW,ALFA2,ALFA3,ALQCD4
      REAL AMUP,AMDN,AMST,AMCH,AMBT,AMTP,AME,AMMU,AMTAU
     $,AMW,AMZ,GAMW,GAMZ,ALFAEM,SN2THW,ALFA2,ALFA3,ALQCD4
      SAVE /SSSM/
+KEEP,SSTMP
C          Temporary parameters for functions
      COMMON/SSTMP/TMP(10),ITMP(10)
      REAL TMP
      INTEGER ITMP
      SAVE /SSTMP/
+KEEP,SSTYPE
C          SM ident code definitions. These are standard ISAJET but
C          can be changed.
      INTEGER IDUP,IDDN,IDST,IDCH,IDBT,IDTP
      INTEGER IDNE,IDE,IDNM,IDMU,IDNT,IDTAU
      INTEGER IDGL,IDGM,IDW,IDZ,IDH
      PARAMETER (IDUP=1,IDDN=2,IDST=3,IDCH=4,IDBT=5,IDTP=6)
      PARAMETER (IDNE=11,IDE=12,IDNM=13,IDMU=14,IDNT=15,IDTAU=16)
      PARAMETER (IDGL=9,IDGM=10,IDW=80,IDZ=90,IDH=81)
C          SUSY ident code definitions. They are chosen to be similar
C          to those in versions < 6.50 but may be changed.
      INTEGER ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1
      INTEGER ISNEL,ISEL,ISNML,ISMUL,ISNTL,ISTAU1
      INTEGER ISUPR,ISDNR,ISSTR,ISCHR,ISBT2,ISTP2
      INTEGER ISNER,ISER,ISNMR,ISMUR,ISNTR,ISTAU2
      INTEGER ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,ISGL
      INTEGER ISHL,ISHH,ISHA,ISHC
      INTEGER ISGRAV
      INTEGER IDTAUL,IDTAUR
      PARAMETER (ISUPL=21,ISDNL=22,ISSTL=23,ISCHL=24,ISBT1=25,ISTP1=26)
      PARAMETER (ISNEL=31,ISEL=32,ISNML=33,ISMUL=34,ISNTL=35,ISTAU1=36)
      PARAMETER (ISUPR=41,ISDNR=42,ISSTR=43,ISCHR=44,ISBT2=45,ISTP2=46)
      PARAMETER (ISNER=51,ISER=52,ISNMR=53,ISMUR=54,ISNTR=55,ISTAU2=56)
      PARAMETER (ISGL=29)
      PARAMETER (ISZ1=30,ISZ2=40,ISZ3=50,ISZ4=60,ISW1=39,ISW2=49)
      PARAMETER (ISHL=82,ISHH=83,ISHA=84,ISHC=86)
      PARAMETER (ISGRAV=91)
      PARAMETER (IDTAUL=10016,IDTAUR=20016)
+KEEP,SUGMG
C          Frozen couplings from RG equations:
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_hd^2     GSS(14) = M_hu^2     GSS(15) = M_er^2
C     GSS(16) = M_el^2     GSS(17) = M_dnr^2    GSS(18) = M_upr^2
C     GSS(19) = M_upl^2    GSS(20) = M_taur^2   GSS(21) = M_taul^2
C     GSS(22) = M_btr^2    GSS(23) = M_tpr^2    GSS(24) = M_tpl^2
C     GSS(25) = mu         GSS(26) = B          GSS(27) = Y_N
C     GSS(28) = M_nr       GSS(29) = A_n        GSS(30) = vdq
C     GSS(31) = vuq
C          Masses:
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:
C     MGUTSS  = M_GUT    GGUTSS  = g_GUT    AGUTSS  = alpha_GUT
      COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
     $FBGUT,FTAGUT,FNGUT
      REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
      SAVE /SUGMG/
+KEEP,SUGNU
C     XNUSUG contains non-universal GUT scale soft terms for SUGRA:
C     XNUSUG(1)=M1 XNUSUG(2)=M2 XNUSUG(3)=M3
C     XNUSUG(4)=A_tau XNUSUG(5)=A_b XNUSUG(6)=A_t
C     XNUSUG(7)=m_Hd XNUSUG(8)=m_Hu XNUSUG(9)=m_eR XNUSUG(10)=m_eL
C     XNUSUG(11)=m_dR XNUSUG(12)=m_uR XNUSUG(13)=m_uL XNUSUG(14)=m_lR
C     XNUSUG(15)=m_lL XNUSUG(16)=m_bR XNUSUG(17)=m_tR XNUSUG(18)=m_tL
C     XNUSUG(19)=mu(Q) XNUSUG(20)=mA(Q)
      COMMON /SUGNU/ XNUSUG(20),INUHM
      REAL XNUSUG
      INTEGER INUHM
      SAVE /SUGNU/
+KEEP,SUGPAS
      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,IGUTST,ASM3,
     $VUMT,VDMT,ASMTP,ASMSS,M3Q,MHDSQ,MHUSQ,MHDSMG,MHUSMG,MUMG,BMG
      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,MHDSQ,MHUSQ,
     $MHDSMG,MHUSMG,MUMG,BMG
      INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG,IGUTST
      SAVE /SUGPAS/
+KEEP,SUGXIN
C     XSUGIN contains the inputs to SUGRA:
C     XSUGIN(1) = M_0        XSUGIN(2) = M_(1/2)  XSUGIN(3) = A_0
C     XSUGIN(4) = tan(beta)  XSUGIN(5) = sgn(mu)  XSUGIN(6) = M_t
C     XSUGIN(7) = SUG BC scale
C     XGMIN(1) = LAM         XGMIN(2)  = M_MES    XGMIN(3)  = XN5
C     XGMIN(4) = tan(beta)   XGMIN(5)  = sgn(mu)  XGMIN(6) = M_t
C     XGMIN(7) = CGRAV       XGMIN(8)  =RSL       XGMIN(9)  = DEL_HD
C     XGMIN(10)  = DEL_HU    XGMIN(11) = DY       XGMIN(12) = N5_1
C     XGMIN(13)  = N5_2      XGMIN(14) = N5_3
C     XNRIN(1) = M_N3        XNRIN(2) = M_MAJ     XNRIN(3) = ANSS 
C     XNRIN(4) = M_N3SS
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/
+KEEP,XMSSM
      COMMON/XMSSM/GOMSSM,GOSUG,GOGMSB,GOAMSB,AL3UNI
     $,XGLSS,XMUSS,XHASS,XTBSS
     $,XQ1SS,XDRSS,XURSS,XL1SS,XERSS
     $,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS
     $,XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS
     $,XM1SS,XM2SS,XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU
     $,XLAMGM,XMESGM,XN5GM,XCMGV,XMGVTO
     $,XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM
     $,XMN3NR,XMAJNR,XANSS,XNRSS,XSBCS,
     $XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
      SAVE /XMSSM/
      REAL XGLSS,XMUSS,XHASS,XTBSS
     $,XQ1SS,XDRSS,XURSS,XL1SS,XERSS
     $,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS
     $,XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS
     $,XM1SS,XM2SS
     $,XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU
     $,XLAMGM,XMESGM,XN5GM,XCMGV,XMGVTO
     $,XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM
     $,XMN3NR,XMAJNR,XANSS,XNRSS,XSBCS,
     $XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
      LOGICAL GOMSSM,GOSUG,GOGMSB,GOAMSB,AL3UNI
+DECK,CDETAPE.
+KEEP,HEPEVT
      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
      REAL 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
+KEEP,ITA
      COMMON/ITA/ITA,ITB
      SAVE /ITA/
      INTEGER   ITA,ITB
+KEEP,RECTP
      COMMON/RECTP/IRECTP,IREC
      SAVE /RECTP/
      INTEGER   IRECTP,IREC
+KEEP,ZEVEL
      INTEGER   MAXLEN
      PARAMETER (MAXLEN=1024)
      COMMON/ZEVEL/IZEVEL(MAXLEN)
      SAVE /ZEVEL/
      EQUIVALENCE(ZEVEL(1),IZEVEL(1))
      EQUIVALENCE(LZEVEL(1),IZEVEL(1))
      EQUIVALENCE (IZVL1,IZEVEL(1))
      EQUIVALENCE (IZVL2,IZEVEL(2))
+CDE,L2ZEVL,T=PASS,IF=LEVEL2.
      INTEGER   IZEVEL,IZVL1,IZVL2
      REAL      ZEVEL(MAXLEN)
      LOGICAL   LZEVEL(MAXLEN)
+KEEP,L2ZEVL,IF=LEVEL2.
      LEVEL2, /ZEVEL/
+KEEP,ZVOUT
      COMMON/ZVOUT/ZVOUT(512)
      SAVE /ZVOUT/
+CDE,L2ZOUT,T=PASS,IF=LEVEL2.
      REAL      ZVOUT
+KEEP,L2ZOUT,IF=LEVEL2.
      LEVEL2,/ZVOUT/
+DECK,CDEZEBRA.
+KEEP,ISABNK                        .
C
      COMMON/ISABNK/BANK,FILISA,FILIS2
      SAVE /ISABNK/
      CHARACTER*12 BANK
      CHARACTER*80 FILISA,FILIS2
C
C  If BANK='ISAP' Zebra bank ISAP (particles) will be written out
C  if BANK='ISAC'     "      ISAC (pseudo calorimeter) will be written out
C  If BANK='ISAL'     "      ISAL (leptons) will be written out
C  if BANK='ISAPISAC' both groups will be written out
C  if BANK='ISAPISACISAL' all groups will be written out
C
C  FILISA= name of ISAJET events file (ZEBRA)
C  FILIS2= name of second file if needed for output
C
+KEEP,ISALNK                        .
      INTEGER NVD,MQREF,MPQREF
      PARAMETER (NVD=100)
      PARAMETER (MQREF=200)
      PARAMETER (MPQREF=10)
      COMMON/ISALNK/LVD(NVD),QREF(MQREF),PQREF(MPQREF)
      SAVE /ISALNK/
      INTEGER LVD          ! vertex links
      INTEGER QREF         ! initial and final parton links
      INTEGER PQREF        ! links to primary jets
+KEEP,ISAUNT                        .
      COMMON/ISAUNT/ISUNIT,ISWRIT
      SAVE /ISAUNT/
      INTEGER ISUNIT,ISWRIT
C  ISUNIT=file number to write(read) ISAJET ZEBRA output
C  ISWRIT=        "   to write if ISUNIT used for reading
+KEEP,IZISAB                        .
      INTEGER IZISAB
      PARAMETER (IZISAB=17)
+KEEP,IZISAC                        .
      INTEGER IZISAC
      PARAMETER (IZISAC=6)
+KEEP,IZISAE                        .
      INTEGER IZISAE
      PARAMETER (IZISAE=17)
+KEEP,IZISAF                        .
      INTEGER IZISAF
      PARAMETER (IZISAF=17)
+KEEP,IZISAJ                        .
      INTEGER IZISAJ
      PARAMETER (IZISAJ=1)
+KEEP,IZISAL                        .
      INTEGER IZISAL
      PARAMETER (IZISAL=7)
+KEEP,IZISAM                        .
      INTEGER IZISAM
      PARAMETER (IZISAM=9)
+KEEP,IZISAQ                        .
      INTEGER IZISAQ
      PARAMETER (IZISAQ=2)
+KEEP,IZISCL                        .
      INTEGER IZISCL
      PARAMETER (IZISCL=1)
+KEEP,IZISCM                        .
C-----------------------------------------------------------------------
C    Created  13-DEC-1989 10:20:16.28  Chip Stewart
C    Link offset of bank ISCM in mother bank ISAB
C-----------------------------------------------------------------------
      INTEGER      IZISCM
      PARAMETER  ( IZISCM = 1)
+KEEP,IZISJT                        .
C-----------------------------------------------------------------------
C    Created  29-JAN-1990   Serban D. Protopopescu
C    Link offset of bank ISJT in mother bank (ISAC)
C-----------------------------------------------------------------------
      INTEGER      IZISJT
      PARAMETER  ( IZISJT = 3  )
+KEEP,IZISMR                        .
C-----------------------------------------------------------------------
C    Created  18-MAY-1989   Serban D. Protopopescu
C    Link offset of bank ISMR in mother bank
C-----------------------------------------------------------------------
      INTEGER      IZISMR
      PARAMETER  ( IZISMR = 2 )
+KEEP,IZISP1                        .
      INTEGER IZISP1
      PARAMETER (IZISP1=1)
+KEEP,IZISP2                        .
      INTEGER IZISP2
      PARAMETER (IZISP2=1)
+KEEP,IZISP3                        .
      INTEGER IZISP3
      PARAMETER (IZISP3=5)
+KEEP,IZISRC                        .
C DEC/CMS REPLACEMENT HISTORY, Element IZISRC.LINK
C *1    25-JAN-1990 14:08:41 CSTEWART "Chip Stewart: LINK FILE FOR ISRC BANK"
C DEC/CMS REPLACEMENT HISTORY, Element IZISRC.LINK
C-----------------------------------------------------------------------
C    Created  11-JAN-1990 16:49:35.86  Chip Stewart
C    Link offset of bank ISRC in mother bank ISAB
C-----------------------------------------------------------------------
      INTEGER      IZISRC
      PARAMETER  ( IZISRC = 2)
+KEEP,IZISV1                        .
      INTEGER IZISV1
      PARAMETER (IZISV1=3)
+KEEP,IZISV2                        .
      INTEGER IZISV2
      PARAMETER (IZISV2=4)
+KEEP,IZPJET
C-----------------------------------------------------------------------
C    Created   7-NOV-1989 18:10:09.84  Chip Stewart
C    Link offset of bank PJET in mother bank PJHD
C-----------------------------------------------------------------------
      INTEGER      IZPJET
      PARAMETER  ( IZPJET = 1)
+KEEP,IZPJHD
C-----------------------------------------------------------------------
C    Created   7-NOV-1989 17:57:58.00  Chip Stewart
C    Link offset of bank PJHD in mother bank ISAE
C-----------------------------------------------------------------------
      INTEGER      IZPJHD
      PARAMETER  ( IZPJHD = 8)
+KEEP,IZPJPT
C-----------------------------------------------------------------------
C    Created   7-NOV-1989 18:10:09.84  Chip Stewart
C    Link offset of bank PJPT in mother bank PJHD
C-----------------------------------------------------------------------
      INTEGER      IZPJPT
      PARAMETER  ( IZPJPT = 1)
+KEEP,LKPJET                        .
C----------------------------------------------------------------------
C-
C-   Name     LKPJET.INC
C-   Purpose  Temporary link area for PJET banks
C-   Created  5-DEC-1989  CHIP STEWART (HBP)
C-   Updated  13-JAN-1990   Harrison B. Prosper
C-   Updated   6-NOV-1990   Chip Stewart  - ADDED ISP1,ISV1
C-
C----------------------------------------------------------------------
C
C ****  JPJET(1)        User flag
C ****  JPJET(2)        System word
C ****  JPJET(3)        First link in area (= KPJET(1))
C
      INTEGER PJLON
      PARAMETER( PJLON = 1 )        ! Activate link area
C
      INTEGER PJLOFF
      PARAMETER( PJLOFF= 0 )        ! De-activate link area
C
      INTEGER MXPJET
      PARAMETER( MXPJET = 8 )
      INTEGER LPJHD,LPJET,LPJPT,LISAQ,LISAJ,LISP1,LISV1
      INTEGER JPJET,KPJET(MXPJET)
      EQUIVALENCE ( LPJHD, KPJET(1)  )
      EQUIVALENCE ( LPJET, KPJET(2)  )
      EQUIVALENCE ( LPJPT, KPJET(3)  )
      EQUIVALENCE ( LISAQ, KPJET(5)  )
      EQUIVALENCE ( LISAJ, KPJET(6)  )
      EQUIVALENCE ( LISP1, KPJET(7)  )
      EQUIVALENCE ( LISV1, KPJET(8)  )
      COMMON /LKPJET/ JPJET(2),KPJET
      SAVE /LKPJET/
+KEEP,PI.
        DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN
C
C last significant (correctly rounded) decimal place on VAX:
C                                                |
C                                                V
        PARAMETER (PI=        3.1415 92653 58979 32384 6)
        PARAMETER (TWOPI=     6.2831 85307 17958 64769 3)
        PARAMETER (HALFPI=    1.5707 96326 79489 66192 3)
        PARAMETER (RADIAN= 0.0174532 92519 94329 5769237)
+KEEP,QUEST
C
C          Zebra common, returns status information
      COMMON /QUEST/ IQUEST(100)
      SAVE /QUEST/
      INTEGER   IQUEST
+KEEP,ZEBCOM                        .
C
C  ZEBCOM is the main zebra common block for event data storage
C
      INTEGER NNQ,NREF
      PARAMETER (NNQ=200000)
      PARAMETER (NREF=9)
      COMMON/ZEBCOM/IXCOM,IXMAIN,IXDVR,FENCE,LISAE,LISAB,LREF,
     $  ZSTOR,ENDZS
      SAVE /ZEBCOM/
      INTEGER IXCOM    ! store number
     $       ,IXMAIN   ! event division number
     $       ,IXDVR    ! run division number
      INTEGER FENCE(8),LREF(NREF),ZSTOR(NNQ),ENDZS
      INTEGER LISAE     ! pointer to ISAE bank
      INTEGER LISAB    ! pointer to ISAB bank
      REAL Q(NNQ)
      INTEGER IQ(NNQ),LQ(NNQ)
      EQUIVALENCE (LISAE,LQ(1)),(LQ(9),IQ(1),Q(1))
C
+KEEP,ZLINKA
C
C              general Zebra link area
C   use with utility subroutines GSLINK,GRLINK,RSLINK and RRLINK
      INTEGER NSLINK,NRLINK,LSLINK,LRLINK
      PARAMETER (NSLINK=100)
      PARAMETER (NRLINK=100)
      COMMON/ZLINKA/LSLINK(NSLINK),LRLINK(NRLINK)
      SAVE /ZLINKA/
+DECK,CDEPLT.
+KEEP,CALOR
      REAL      DELY,YCMIN,YCMAX
      INTEGER   NCY
      PARAMETER (NCY=80,DELY=.1,YCMIN=-4.,YCMAX=4.)
      REAL      DELPHI
      INTEGER   NCPHI
      PARAMETER (NCPHI=72,DELPHI=.087267)
      COMMON/CALOR/ET(NCY,NCPHI),ETEM(NCY,NCPHI),
     $CTHCAL(NCY),STHCAL(NCY),CPHCAL(NCPHI),SPHCAL(NCPHI)
      SAVE /CALOR/
+CDE,L2CAL,T=PASS,IF=LEVEL2.
      REAL      ET,ETEM,CTHCAL,STHCAL,CPHCAL,SPHCAL
+KEEP,L2CAL,IF=LEVEL2
      LEVEL2,/CALOR/
+KEEP,GETJET
      INTEGER   NJMAX
      PARAMETER (NJMAX=50)
      COMMON/GETCOM/JETNO(NCY,NCPHI),NCJET,PCJET(4,NJMAX),ETJET(NJMAX)
      SAVE /GETCOM/
+CDE,L2GETJ,T=PASS,IF=LEVEL2
      INTEGER   JETNO,NCJET
      REAL      PCJET,ETJET
+KEEP,L2GETJ,IF=LEVEL2
      LEVEL2,/GETCOM/
+KEEP,MYHIST
      COMMON/MYHIST/MXHIST,NHSHFT
      SAVE /MYHIST/
      INTEGER   MXHIST,NHSHFT
+PATCH,ISADATA.
+EOD
+DECK,ALDATA.
      BLOCK DATA ALDATA
C          INITIALIZE ALL COMMON BLOCKS
C.......................................................................
C          WARNINGS: MANY VARIABLES SET IN ALDATA ARE ALSO SET BY      .
C          SUBROUTINE RESET.                                           .
C                                                                      .
C          ALDATA SHOULD ALWAYS BE LOADED WHEN USING ISAJET OR WHEN    .
C          READING AN ISAJET TAPE.                                     .
C.......................................................................
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,PJETS
+CDE,PINITS
+CDE,LSTPRT
+CDE,DKYTAB
+CDE,DYLIM
+CDE,EEPAR
+CDE,FRGPAR
+CDE,IDRUN
+CDE,JETLIM
+CDE,JETPAR
+CDE,JETSET
+CDE,JETSIG
+CDE,LIMEVL
+CDE,LUXPAR
+CDE,MBPAR
+CDE,NODCAY
+CDE,PARTCL
+CDE,PRIMAR
+CDE,PRTOUT
+CDE,QCDPAR
+CDE,QLMASS
+CDE,Q1Q2
+CDE,SEED
+CDE,SSPAR
+CDE,TCPAR
+CDE,TOTALS
+CDE,TYPES
+CDE,WCON
+CDE,MBGEN
+CDE,FORCE
+CDE,ZEVEL
+CDE,FINAL
+CDE,KEYS
+CDE,HCON
+CDE,XMSSM
+CDE,SUGNU
+CDE,ISAPW
+CDE,SSTYPE
+CDE,LISTSS
+CDE,SUGXIN
+CDE,SSMODE
C
      INTEGER III,JJJ
      INTEGER MXGOQJ
      PARAMETER (MXGOQJ=MXGOJ*MXGOQ)
      INTEGER MXGOWJ
      PARAMETER (MXGOWJ=25*MXGOJ)
      INTEGER MXT29
      PARAMETER (MXT29=29*MXTYPE)
C          SUSY IDENT codes from /SSTYPE/
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2,
     $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MSW1=-ISW1)
      PARAMETER (MSW2=-ISW2)
      PARAMETER (MSNEL=-ISNEL)
      PARAMETER (MSEL=-ISEL)
      PARAMETER (MSNML=-ISNML)
      PARAMETER (MSMUL=-ISMUL)
      PARAMETER (MSNTL=-ISNTL)
      PARAMETER (MSTAU1=-ISTAU1)
      PARAMETER (MSER=-ISER)
      PARAMETER (MSMUR=-ISMUR)
      PARAMETER (MSTAU2=-ISTAU2)
C
C          DATA FOR IDRUN
C          IDVER=100*VERSION+CYCLE
C     DATA IDVER/600/
C
C          DATA FOR ITAPES
      DATA ITDKY,ITEVT,ITCOM,ITLIS/1,2,5,6/
C
C          DATA FOR LUXPAR
      DATA LUXINT,LUXK1,LUXK2/314159265,0,0/
      DATA LUXGO/.TRUE./
C
C          DATA FOR QLMASS
C          AMLEP LABELED BY INDEX...SEE FLAVOR
C          SETW RESETS W+- AND Z0 MASSES
      DATA AMLEP/.3,.3,.5,1.6,5.0,175.,-1.,-1.,0.,0.,
     $0.,.511003E-3,0.,.105661,0.,1.777,3*-1.,.49767,.49767,
     $79*0./
      DATA NQLEP,NMES,NBARY/61,2,2/
C
C          DATA FOR PJETS
      DATA IDJETS/MXJETS*0/,IDENTW/0/
C
C          DATA FOR PINITS
      DATA IDINIT/2*0/
C
C          DATA FOR LSTPRT
      DATA LSTPRT/0/
C
C          DATA FOR MBPAR
      DATA PUD0/.45/,PJSPN,PISPN/2*.5/,SIGQT0/.35/,XGEN0/.9,1./,PMIX01/
     $.25,.25,.5,0.,.5,1./,PMIX02/.5,.5,1.,0.,0.,1./
      DATA PBARY0/.075/
C
C          DATA FOR MBGEN
      DATA MNPOM,MXPOM/1,LIMPOM/
C
C          DATA FOR SEED
      DATA XSEED/'0'/
C
C          DATA FOR TCPAR
      DATA TCMRHO,TCGRHO/1000.,100./
C
C          DATA FOR FRGPAR
C          F(X)=1-XGEN(1)+XGEN(1)*(XGEN(2)+1)*(1-X)**XGEN(2) FOR U,D,S
C          PETERSON FRAGMENTATION, EPSILON=XGEN(I)*M(I)**2 FOR C,B,T
      DATA PUD,PBARY/.43,.10/
      DATA SIGQT,PEND/.35,.14/
      DATA XGEN/.96,3.,0.,.8,.5,.5,.5,.5/
      DATA PSPIN1/.5,.5,.5,.75,.75,.75,.75,.75/
      DATA PMIX1/.25,.25,.5,0.,.5,1./,PMIX2/.5,.5,1.,0.,0.,1./
      DATA XGENSS/9*.5/
C
C          DATA FOR JETLIM
      DATA BLIMS/MXLX12*-1.E9/
C
C          DATA FOR NODCAY
      DATA NODCAY,NOETA,NOPI0,NONUNU,NOEVOL,NOHADR/6*.FALSE./
      DATA NOGRAV/.FALSE./
C
C          DATA FOR TYPES
      DATA LOC/100*0/,NTYP/100/
      DATA NJTTYP/MXTYPE*0/
      DATA (JETYP(1,JJJ),JJJ=1,MXTYPE)/MXTYPE*'ALL     '/,
     $((JETYP(III,JJJ),III=2,30),JJJ=1,MXTYPE)/MXT29*'        '/
      DATA NWWTYP/2*0/
      DATA (WWTYP(1,JJJ),JJJ=1,2)/2*'ALL     '/,
     $((WWTYP(III,JJJ),III=2,30),JJJ=1,2)/58*'        '/
      DATA JWTYP/4/
C
C          DATA FOR PRIMAR
      DATA IDIN/1120,1120/
      DATA NTRIES/1000/
      DATA NSIGMA/20/
C
C          DATA FOR DKYTAB
      DATA LOOK/MXLOOK*0/
      DATA CBR/MXDKY*0./
      DATA MODE/MXDKY*0,MXDKY*0,MXDKY*0,MXDKY*0,MXDKY*0/
C
C          DATA FOR Q1Q2
      DATA GOQ/MXGOQJ*.TRUE./
      DATA GOALL/MXGOJ*.TRUE./
      DATA GODY/.TRUE.,.FALSE.,.FALSE.,.TRUE./
      DATA GOWW/50*.TRUE./,ALLWW/2*.TRUE./
      DATA GOWMOD/MXGOWJ*.TRUE./
C
C          DATA FOR WCON
      DATA MATCH/
     $0,3,2,5,4,7,6,9,8,11,10,13,12,0,0,17,16,0,0,21,20,0,0,25,24,
     $0,5,0,0,2,0,8,7,0,0,12,11,0,17,0,0,14,21,0,0,18,25,0,0,22,
     $0,0,4,3,0,9,0,0,6,13,0,0,10,0,16,15,0,0,20,19,0,0,24,23,0,
     $0,3,2,5,4,7,6,9,8,11,10,13,12,15,14,17,16,19,18,21,20,23,22,25,24/
      DATA CUTOFF,CUTPOW/.200,1.0/
      DATA WMASS/0.,80.2,80.2,91.19/
      DATA WFUDGE/1.85/
C
C          DATA FOR TOTALS
      DATA NKINPT,NWGEN,NKEEP/3*0/,SUMWT/0./
C
C          DATA FOR DYLIM
      DATA BLIM1/12*-1.E9/
C
C          DATA FOR EEPAR
      DATA PLEP/0./,PLEM/0./,IBREM/.FALSE./,IBEAM/.FALSE./
      DATA GAMGAM/.FALSE./
C
C          DATA FOR PARTCL
      DATA NPTCL/0/
C
C            DATA FOR PRTOUT
      DATA NEVPRT,NJUMP/1,1/
C
C          DATA FOR JETSET
      DATA NJSET/0/
C
C          DATA FOR QCDPAR
      DATA ALAM,ALAM2/.2,.04/,CUTJET/6./,ISTRUC/7/
C
C          DATA FOR FORCE
      DATA NFORCE/0/
C
C          DATA FOR NRECS
      DATA NRECS/0/
C
C          DATA FOR KEYS
      DATA KEYS/MXKEYS*.FALSE./
C
C          DATA FOR MATCHH
      DATA MATCHH/
     $1,3,2,5,4,7,6,9,8,11,10,13,12,
     $15,14,17,16,19,18,21,20,23,22,25,24,
     $26,28,27,29/
      DATA USELIM/.FALSE./
      DATA CONCUT/1.0/
C
C          DATA FOR SUGXIN
      DATA XSUGIN/7*0/
      DATA XNRIN/0.,1.E20,0.,0./
C
C          DATA FOR SSPAR
      DATA AMGVSS/1.E20/
C
C          DATA FOR XMSSM
      DATA GOMSSM/.FALSE./,GOSUG/.FALSE./,GOGMSB/.FALSE./
      DATA GOAMSB/.FALSE./
      DATA AL3UNI/.FALSE./
      DATA XM1SS,XM2SS/1.E20,1.E20/
      DATA XMGVTO/1.E20/
      DATA XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS/1.E20,1.E20,1.E20,1.E20,1.E20/
      DATA XRSLGM,XDHDGM,XDHUGM,XDYGM/1.,0.,0.,0./
      DATA XN51GM,XN52GM,XN53GM/0.,0.,0./
      DATA XMN3NR/0./,XMAJNR/1.E20/,XANSS/0./,XNRSS/0./,XSBCS/0./
      DATA XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
     $/1.,1.,1.,1.,1.,1.,1./
C          DATA FOR SUGNU
      DATA XNUSUG/20*1.E20/
C
C          DATA FOR ISAPW
      DATA ISAPW1/'ALDATA REQUIRED BY FORTRAN G,H'/
C
C          DATA FOR LISTSS
      DATA LISTSS/ISGL,
     $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1,
     $ISTP1,MSTP1,
     $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2,
     $ISTP2,MSTP2,
     $ISW1,MSW1,ISW2,MSW2,ISZ1,ISZ2,ISZ3,ISZ4,
     $ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,ISNTL,MSNTL,
     $ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,ISTAU2,MSTAU2,
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13,
     $14,-14,15,-15,16,-16,10,80,-80,90,82,83,84,86,-86/
C
C          DATA FOR SSMODE
      DATA NSSMOD/0/
C
      END
+EOD
+PATCH,ISAJET.
+EOD
+DECK,ALQCD
      FUNCTION ALQCD(Q2)  
C-----------------------------------------------------------------------
C     Strong coupling formula from page 201 of Barger and Phillips:
C     (using ALQCD4 for 4 flavor Lambda)
C-----------------------------------------------------------------------
      REAL Q2,AS,TH5,TH6,PI,ALQCD4
      LOGICAL FIRST
      SAVE FIRST,PI,TH5,TH6,ALQCD4
      DATA FIRST/.TRUE./
C
      IF(FIRST) THEN
        PI=4.*ATAN(1.)
        TH5=4*AMASS(5)**2
        TH6=4*AMASS(6)**2
        ALQCD4=0.177
        FIRST=.FALSE.
      ENDIF
      IF (Q2.LE.TH5)THEN
        AS=12*PI/(25*LOG(Q2/ALQCD4**2))
      ELSE IF(Q2.GT.TH5.AND.Q2.LE.TH6) THEN
        AS=25*LOG(Q2/ALQCD4**2)-2*LOG(Q2/TH5)
        AS=12*PI/AS
      ELSEIF(Q2.GT.TH6)THEN
        AS=25*LOG(Q2/ALQCD4**2)
        AS=AS-2*(LOG(Q2/TH5)+LOG(Q2/TH6))
        AS=12*PI/AS
      ENDIF
      ALQCD=AS
      RETURN
      END
+EOD
+DECK,AMASS.
      FUNCTION AMASS(ID)
C
C          Returns the mass of the particle with IDENT code ID.
C          Quark-based IDENT code.
C          Ver 7.10: Update masses and split B baryon degeneracy.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QLMASS
+CDE,SSTYPE
C
      INTEGER ID
      REAL AMASS
      REAL AMMES0(10),AMMES1(10),AMBAR0(30),AMBAR1(30)
      INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,IFL1A,IFL2A,IFL3A,IDA
C
C          0- meson mass table
C          pi0, pi+, eta, k+, k0, etap, ad0, d-, ds-, etac
C
      DATA AMMES0/.13496,.13957,.54745,.49367,.49767,.95775,1.8645
     $,1.8693,1.9688,2.9788/
C
C          1- meson mass table
C          rho0, rho+, omega, k*+, k*0, phi, ad*0, d*-, d*s-, jpsi
C
      DATA AMMES1/.7681,.7681,.78195,.89159,.89610,1.0194,2.0071
     $,2.0101,2.1103,3.0969/
C
C          1/2+ baryon mass table
C          x,p,n,-,-,s+,s0,s-,l,xi0,xi-,x,x,x
C          sc++,sc+,sc0,lc+,usc.,dsc.,ssc.,sdc.,suc.,ucc.,dcc.,scc.
C
      DATA AMBAR0/-1.,.93828,.93957,2*-1.,1.1894,1.1925,1.1974
     $,1.1156,1.3149,1.3213,3*-1.,2.4527,2.4529,2.4525,2.2849
     $,2.50,2.50,2.60,2.40,2.40,3.55,3.55,3.70,4*-1./
C
C          3/2+ baryon mass table
C          dl++,dl+,dl0,dl-,-,s*+,s*0,s*-,x,xi*0,xi*-,om-,x,x
C          uuc*,udc*,ddc*,x,usc*,dsc*,ssc*,x,x,,ucc*,dcc*,scc*,ccc*
C
      DATA AMBAR1/1.232,1.232,1.232,1.232,-1.,1.3823,1.3820
     $,1.3875,-1.,1.5318,1.5350,1.6722,2*-1.
     $,2.63,2.63,2.63,-1.,2.70,2.70,2.80,2*-1.,3.75,3.75
     $,3.90,4.80,3*-1./
C
C          Entry
C
      AMASS=-1.
      CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX)
      IDA=IABS(ID)
      IFL1A=IABS(IFL1)
      IFL2A=IABS(IFL2)
      IFL3A=IABS(IFL3)
      IF(IDA.GT.10000.OR.JSPIN.GT.1) GO TO 500
C
C          Diquarks
C
      IF(ID.NE.0.AND.MOD(ID,100).EQ.0) THEN
        AMASS=AMLEP(IFL1A)+AMLEP(IFL2A)
C
C          b and t particles. Only a few b masses are known, but we
C          guess a few others to make sure decays are allowed:
C
      ELSEIF(IFL3A.GT.4) THEN
        IF(IDA.EQ.150.OR.IDA.EQ.250) THEN
          AMASS=5.2786
        ELSEIF(IDA.EQ.151.OR.IDA.EQ.251) THEN
          AMASS=5.3246
        ELSEIF(IDA.EQ.350) THEN
          AMASS=5.3693
        ELSEIF(IDA.EQ.351) THEN
          AMASS=5.3693+0.04
        ELSEIF(IDA.EQ.2150) THEN
          AMASS=5.641
        ELSEIF(IDA.EQ.1150.OR.IDA.EQ.1250.OR.IDA.EQ.2250) THEN
          AMASS=5.641+0.171
        ELSEIF(IDA.EQ.2151) THEN
          AMASS=5.641+.04
        ELSEIF(IDA.EQ.1151.OR.IDA.EQ.1251.OR.IDA.EQ.2251) THEN
          AMASS=5.641+0.171+0.04
        ELSE
          AMASS=AMLEP(IFL2A)+AMLEP(IFL3A)-.03+.04*JSPIN
          IF(IFL1.NE.0) AMASS=AMASS+AMLEP(IFL1A)
        ENDIF
C
C          Quarks and leptons
C
      ELSEIF(IFL2.EQ.0) THEN
        AMASS=AMLEP(INDEX)
C
C          Mesons
C
      ELSEIF(IFL1.EQ.0) THEN
        INDEX=INDEX-36*JSPIN-NQLEP
        INDEX=INDEX-13
        AMASS=(1-JSPIN)*AMMES0(INDEX)+JSPIN*AMMES1(INDEX)
C
C          Baryons
C
      ELSE
        INDEX=INDEX-109*JSPIN-36*NMES-NQLEP
        INDEX=INDEX-13
        AMASS=(1-JSPIN)*AMBAR0(INDEX)+JSPIN*AMBAR1(INDEX)
      ENDIF
      RETURN
C
C          Special hadrons - used only in B decays
C
500   IF(IDA.EQ.10121.OR.IDA.EQ.10111) THEN
        AMASS=1.230
      ELSEIF(IDA.EQ.10131.OR.IDA.EQ.10231) THEN
        AMASS=1.273
      ELSEIF(IDA.EQ.30131.OR.IDA.EQ.30231) THEN
        AMASS=1.412
      ELSEIF(IDA.EQ.132) THEN
        AMASS=1.4254
      ELSEIF(IDA.EQ.232) THEN
        AMASS=1.4324
      ELSEIF(IDA.EQ.10110) THEN
        AMASS=0.980+0.020
      ELSEIF(IDA.EQ.112) THEN
        AMASS=1.275
      ELSEIF(IDA.EQ.10441) THEN
        AMASS=3.686
      ELSEIF(IDA.EQ.20440) THEN
        AMASS=3.4151
      ELSEIF(IDA.EQ.20441) THEN
        AMASS=3.51053
      ELSEIF(IDA.EQ.20442) THEN
        AMASS=3.56617
      ELSEIF(IDA.EQ.IDTAUL.OR.IDA.EQ.IDTAUR) THEN
        AMASS=AMLEP(16)
      ELSE
        AMASS=0
      ENDIF
      RETURN
      END
+EOD
+DECK,AMGMW
      FUNCTION AMGMW(I,J)
C
C          Get masses and widths from ISAJET commons for MadGraph
C          I = particle IDENT
C          J = 1 for mass
C            = 2 for width
C            = 3 for sin^2(theta)
C          Needed to avoid common block name clashes with MadGraph
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,WCON
+CDE,HCON
+CDE,SSTYPE
      INTEGER I,J
      REAL AMGMW,AMASS
C
      IF(J.EQ.1) THEN
        AMGMW=AMASS(I)
      ELSEIF(J.EQ.2.AND.I.EQ.IDW) THEN
        AMGMW=WGAM(2)
      ELSEIF(J.EQ.2.AND.I.EQ.IDZ) THEN
        AMGMW=WGAM(4)
      ELSEIF(J.EQ.2.AND.I.EQ.IDH) THEN
        AMGMW=HGAM
      ELSEIF(J.EQ.3.AND.I.EQ.1) THEN
        AMGMW=SIN2W
      ELSE
        WRITE(ITLIS,*) 'ERROR IN AMGMW: I,J =',I,J
        STOP99
      ENDIF
      RETURN
      END
+EOD
+DECK,CHARGE.
      FUNCTION CHARGE(ID)
C
C          COMPUTE CHARGE OF PARTICLE WITH IDENT CODE ID
C          ICHRG MUST BE DIMENSIONED NQLEP+13
C
+CDE,ITAPES
      DIMENSION ICHRG(75),IFL(3)
C          3 * charge
      DATA ICHRG/0
     $,2,-1,-1,2,-1,2,-1,2,0,0, 0,-3,0,-3,0,-3,0,-3,0,0,0
     $,2,-1,-1,2,-1,2,-1,2,0,0, 0,-3,0,-3,0,-3,0,-3,3,0
     $,2,-1,-1,2,-1,2,-1,2,3,0, 0,-3,0,-3,0,-3,0,-3,3,0
     $,3,0,0,0,0,0,3,3,6,6,0,0,0/
C
      IDABS=IABS(ID)
      CALL FLAVOR(ID,IFL(1),IFL(2),IFL(3),JSPIN,INDEX)
      IF(IDABS.LT.100) GO TO 200
C
      ISUM=0
      DO 100 I=1,3
        ISUM=ISUM+ICHRG(IABS(IFL(I))+1)*ISIGN(1,IFL(I))
  100 CONTINUE
      CHARGE=ISUM/3.
      RETURN
C
200   CHARGE=ICHRG(INDEX+1)*ISIGN(1,ID)
      CHARGE=CHARGE/3.
      RETURN
      END
+EOD
+DECK,CTEQ5L
      DOUBLE PRECISION FUNCTION CTEQ5L(IFL,X,Q)
C ----------------------------------------------------------------------
C          Parameterization of CTEQ5l parton distributions f(ifl,x,q)
C          IFL: 1=u,2=d,3=s,4=c,5=b
C               0=g
C              -1=ubar,-2=dbar,-3=sbar,-4=cbar,-5=bbar
C          Was faux5l by J. Pumplin, 9/99
C          Converted to strict Fortran 77 and Patchy by F. Paige
C ----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      DOUBLE PRECISION X,Q
      INTEGER IFL
      INTEGER NEX,NLF
      PARAMETER (NEX=8, NLF=2)
      DOUBLE PRECISION AM(0:NEX,0:NLF,-5:2)
      DOUBLE PRECISION ALFVEC(-5:2), QMAVEC(-5:2)
      DOUBLE PRECISION MEXVEC(-5:2)
      DOUBLE PRECISION UT1VEC(-5:2), UT2VEC(-5:2)
      DOUBLE PRECISION AF(0:NEX)
      DOUBLE PRECISION TMP,SB,SB1,SB2,SBX,Y,U,PART1,PART2,PART3,PART4
      INTEGER MLFVEC(-5:2)
      INTEGER I,K
C
      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 /
C
      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 /
C
      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 /
C
      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 /
C
      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 /
C
      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 /
C
      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 /
C
      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 /
C
      IF(Q.LE.QMAVEC(IFL).OR.X.GE.1D0) THEN
         CTEQ5L = 0.D0
         RETURN
      ENDIF
      TMP = LOG(Q/ALFVEC(IFL))
      IF(TMP .LE. 0.D0) THEN
         CTEQ5L = 0.D0
         RETURN
      ENDIF
      SB = LOG(TMP)
      SB1 = SB - 1.2D0
      SB2 = SB1*SB1
      DO 100 I = 0, NEX
         AF(I) = 0.D0
         SBX = 1.D0
         DO 110 K = 0, MLFVEC(IFL)
            AF(I) = AF(I) + SBX*AM(I,K,IFL)
            SBX = SB1*SBX
110      CONTINUE
100   CONTINUE
      Y = -LOG(X)
      U = LOG(X/0.00001D0)
      PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
      PART2 = AF(0)*(1.D0 - X) + AF(3)*X 
      PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
      PART4 = UT1VEC(IFL)*LOG(1.D0-X) + 
     $            AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
      CTEQ5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
C          Include threshold factor...
      CTEQ5L = CTEQ5L * (1.D0 - QMAVEC(IFL)/Q)
C
      RETURN
      END
+EOD
+DECK,CTXC2I
      SUBROUTINE CTXC2I(CVAL,IVAL,NSIZE)
C-----------------------------------------------------------------------
C          Convert character variable CVAL to integer array IVAL
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      CHARACTER*(*) CVAL
      INTEGER I,NSIZE
      INTEGER IVAL(NSIZE)
C
      DO 100 I=1,NSIZE
100   IVAL(I)=ICHAR(CVAL(I:I))
C
      RETURN
      END
+EOD
+DECK,CTXI2C
      SUBROUTINE CTXI2C(IVAL,CVAL,NSIZE)
C-----------------------------------------------------------------------
C          Convert integer array IVAL to character variable CVAL
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      CHARACTER*(*) CVAL
      INTEGER I,NSIZE
      INTEGER IVAL(NSIZE)
C
      DO 100 I=1,NSIZE
100   CVAL(I:I)=CHAR(IVAL(I))
C
      RETURN
      END
+EOD
+DECK,CTXIN
      SUBROUTINE CTXIN(NVC,VC,MXVC)
C-----------------------------------------------------------------------
C  Purpose:
C          Restore the context for an ISAJET job:
C          Restore NVC words of VC all common blocks NOT associated only
C          with a single event. Call CTXOUT and this to generate mixed
C          events.
C          PARAMETER (MXVC=20000)
C          REAL    VC(MXVC)
C          ...
C          CALL CTXIN(NVC,VC,MXVC)
C
C          Note that the MSSM common blocks are not saved, so different
C          SUSY runs cannot be mixed.
C
C          Ver. 7.02: Equivalenced dummy variables to avoid mixed 
C                     arguments in MOVLEV or multiple EQUIVALENCEd
C                     arguments to CTXIN/CTXOUT.
C
C  Author:
C          F.E. Paige, April 1992     
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,DKYTAB
+CDE,DYLIM
+CDE,DYPAR
+CDE,EEPAR
+CDE,FINAL
+CDE,FORCE
+CDE,FRGPAR
+CDE,HCON
+CDE,IDRUN
+CDE,ISLOOP
+CDE,ITAPES
+CDE,JETLIM
+CDE,KEYS
+CDE,LIMEVL
+CDE,LSTPRT
+CDE,MBGEN
+CDE,MBPAR
+CDE,NODCAY
+CDE,PRIMAR
+CDE,PRTOUT
+CDE,PTPAR
+CDE,Q1Q2
+CDE,QCDPAR
+CDE,QLMASS
+CDE,TCPAR
+CDE,TIMES
+CDE,TOTALS
+CDE,TYPES
+CDE,WCON
C
      INTEGER NVC,MXVC,NC,NN,I
      REAL VC(MXVC)
      CHARACTER*8 CLIST(290)
      EQUIVALENCE (CLIST(1),PARTYP(1))
C
C          Dummy real variables for integers
      REAL VLOOK(MXLOOK+6*MXDKY)
      EQUIVALENCE (VLOOK(1),LOOK(1))
      REAL VNKINF(5)
      EQUIVALENCE (VNKINF(1),NKINF)
      REAL VFORCE(9*MXFORC+1)
      EQUIVALENCE (VFORCE(1),NFORCE)
      REAL VIDVER(5)
      EQUIVALENCE (VIDVER(1),IDVER)
      REAL VEVOLV(4)
      EQUIVALENCE (VEVOLV(1),NEVOLV)
      REAL VITDKY(4)
      EQUIVALENCE (VITDKY(1),ITDKY)
      REAL VIKEYS(12)
      EQUIVALENCE (VIKEYS(1),IKEYS)
      REAL VSTPRT
      EQUIVALENCE (VSTPRT,LSTPRT)
      REAL VNJET(9)
      EQUIVALENCE (VNJET(1),NJET)
      REAL VEVPRT(2)
      EQUIVALENCE (VEVPRT(1),NEVPRT)
      REAL VKINPT(5)
      EQUIVALENCE (VKINPT(1),NKINPT)
      REAL VLOC(100)
      EQUIVALENCE (VLOC(1),LOC(1))
C          Dummy real variables for logicals
      REAL VFLW(13)
      EQUIVALENCE (VFLW(1),FLW)
      REAL VNODCY(6)
      EQUIVALENCE (VNODCY(1),NODCAY)
      REAL VGOQ(3*MXGOQ+135)
      EQUIVALENCE (VGOQ(1),GOQ(1,1))
C
      NC=0
C          DKYTAB
      NN=MXLOOK+6*MXDKY
      CALL MOVLEV(VC(NC+1),VLOOK(1),NN)
      NC=NC+NN
C          DYLIM
      CALL MOVLEV(VC(NC+1),QMIN,24)
      NC=NC+24
C          DYPAR
      CALL MOVLEV(VC(NC+1),VFLW(1),13)
      NC=NC+13
C          EEPAR
      CALL MOVLEV(VC(NC+1),SGMXEE,1)
      NC=NC+1
C          FINAL
      CALL MOVLEV(VC(NC+1),VNKINF(1),5)
      NC=NC+5
C          FORCE
      NN=9*MXFORC+1
      CALL MOVLEV(VC(NC+1),VFORCE(1),NN)
      NC=NC+NN
C          FRGPAR
      CALL MOVLEV(VC(NC+1),PUD,41)
      NC=NC+41
C          HCON
      CALL MOVLEV(VC(NC+1),HMASS,69)
      NC=NC+69
C          IDRUN
      CALL MOVLEV(VC(NC+1),VIDVER(1),5)
      NC=NC+5
C          ISLOOP
      CALL MOVLEV(VC(NC+1),VEVOLV(1),4)
      NC=NC+4
C          ITAPES
      CALL MOVLEV(VC(NC+1),VITDKY(1),4)
      NC=NC+4
C          JETLIM
      CALL MOVLEV(VC(NC+1),PMIN(1),72)
      NC=NC+72
C          KEYS
      CALL MOVLEV(VC(NC+1),VIKEYS(1),12)
      NC=NC+12
      CALL CTXI2C(VC(NC+1),REAC,8)
      NC=NC+8
C          LIMEVL
      CALL MOVLEV(VC(NC+1),ETTHRS,3)
      NC=NC+3
C          LSTPRT
      CALL MOVLEV(VC(NC+1),VSTPRT,1)
      NC=NC+1
C          MBGEN
      NN=4*LIMPOM+8
      CALL MOVLEV(VC(NC+1),POMWT(1),NN)
      NC=NC+NN
C          MBPAR
      CALL MOVLEV(VC(NC+1),PUD0,19)
      NC=NC+19
C          NODCAY
      CALL MOVLEV(VC(NC+1),VNODCY(1),6)
      NC=NC+6
C          PRIMAR
      CALL MOVLEV(VC(NC+1),VNJET(1),9)
      NC=NC+9
C          PRTOUT
      CALL MOVLEV(VC(NC+1),VEVPRT(1),2)
      NC=NC+2
C          PTPAR
      CALL MOVLEV(VC(NC+1),PTFUN1,6)
      NC=NC+6
C          Q1Q2
      CALL MOVLEV(VC(NC+1),VGOQ(1),3*MXGOQ+135)
      NC=NC+3*MXGOQ+135
C          QCDPAR
      CALL MOVLEV(VC(NC+1),ALAM,4)
      NC=NC+4
C          QLMASS
      CALL MOVLEV(VC(NC+1),AMLEP(1),55)
      NC=NC+55
C          TCPAR
      CALL MOVLEV(VC(NC+1),TCMRHO,2)
      NC=NC+2
C          TIMES
      CALL MOVLEV(VC(NC+1),TIME1,2)
      NC=NC+2
C          TOTALS
      CALL MOVLEV(VC(NC+1),VKINPT(1),5)
      NC=NC+5
C          TYPES
      CALL MOVLEV(VC(NC+1),VLOC(1),100)
      NC=NC+100
      DO 100 I=1,290
        CALL CTXI2C(VC(NC+1),CLIST(I),8)
        NC=NC+8
100   CONTINUE
C          WCON
+SELF,IF=SINGLE
      NN=514
+SELF,IF=DOUBLE
      NN=514+97
+SELF
      CALL MOVLEV(VC(NC+1),SIN2W,NN)
      NC=NC+NN
C
      NVC=NC
      RETURN
      END
+EOD
+DECK,CTXOUT
      SUBROUTINE CTXOUT(NVC,VC,MXVC)
C-----------------------------------------------------------------------
C  Purpose:
C          Save the context for an ISAJET job:
C          Save in NVC words of VC all common blocks NOT associated only
C          with a single event. Call this and CTXIN to generate mixed
C          events.
C          PARAMETER (MXVC=20000)
C          REAL    VC(MXVC)
C          ...
C          CALL CTXIN(NVC,VC,MXVC)
C
C          Note that the MSSM common blocks are not saved, so different
C          SUSY runs cannot be mixed.
C
C          Ver. 7.02: Equivalenced dummy variables to avoid mixed 
C                     arguments in MOVLEV or multiple EQUIVALENCEd
C                     arguments to CTXIN/CTXOUT.
C
C  Author:
C          F.E. Paige, April 1992     
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,DKYTAB
+CDE,DYLIM
+CDE,DYPAR
+CDE,EEPAR
+CDE,FINAL
+CDE,FORCE
+CDE,FRGPAR
+CDE,HCON
+CDE,IDRUN
+CDE,ISLOOP
+CDE,ITAPES
+CDE,JETLIM
+CDE,KEYS
+CDE,LIMEVL
+CDE,LSTPRT
+CDE,MBGEN
+CDE,MBPAR
+CDE,NODCAY
+CDE,PRIMAR
+CDE,PRTOUT
+CDE,PTPAR
+CDE,Q1Q2
+CDE,QCDPAR
+CDE,QLMASS
+CDE,TCPAR
+CDE,TIMES
+CDE,TOTALS
+CDE,TYPES
+CDE,WCON
C
      INTEGER NVC,MXVC,NC,NN,I
      REAL VC(MXVC)
      CHARACTER*8 CLIST(290)
      EQUIVALENCE (CLIST(1),PARTYP(1))
C
C          Dummy real variables for integers
      REAL VLOOK(MXLOOK+6*MXDKY)
      EQUIVALENCE (VLOOK(1),LOOK(1))
      REAL VNKINF(5)
      EQUIVALENCE (VNKINF(1),NKINF)
      REAL VFORCE(9*MXFORC+1)
      EQUIVALENCE (VFORCE(1),NFORCE)
      REAL VIDVER(5)
      EQUIVALENCE (VIDVER(1),IDVER)
      REAL VEVOLV(4)
      EQUIVALENCE (VEVOLV(1),NEVOLV)
      REAL VITDKY(4)
      EQUIVALENCE (VITDKY(1),ITDKY)
      REAL VIKEYS(12)
      EQUIVALENCE (VIKEYS(1),IKEYS)
      REAL VSTPRT
      EQUIVALENCE (VSTPRT,LSTPRT)
      REAL VNJET(9)
      EQUIVALENCE (VNJET(1),NJET)
      REAL VEVPRT(2)
      EQUIVALENCE (VEVPRT(1),NEVPRT)
      REAL VKINPT(5)
      EQUIVALENCE (VKINPT(1),NKINPT)
      REAL VLOC(100)
      EQUIVALENCE (VLOC(1),LOC(1))
C          Dummy real variables for logicals
      REAL VFLW(13)
      EQUIVALENCE (VFLW(1),FLW)
      REAL VNODCY(6)
      EQUIVALENCE (VNODCY(1),NODCAY)
      REAL VGOQ(3*MXGOQ+135)
      EQUIVALENCE (VGOQ(1),GOQ(1,1))
C
      NC=0
C          DKYTAB
      NN=MXLOOK+6*MXDKY
      CALL MOVLEV(VLOOK(1),VC(NC+1),NN)
      NC=NC+NN
C          DYLIM
      CALL MOVLEV(QMIN,VC(NC+1),24)
      NC=NC+24
C          DYPAR
      CALL MOVLEV(VFLW(1),VC(NC+1),13)
      NC=NC+13
C          EEPAR
      CALL MOVLEV(SGMXEE,VC(NC+1),1)
      NC=NC+1
C          FINAL
      CALL MOVLEV(VNKINF(1),VC(NC+1),5)
      NC=NC+5
C          FORCE
      NN=9*MXFORC+1
      CALL MOVLEV(VFORCE(1),VC(NC+1),NN)
      NC=NC+NN
C          FRGPAR
      CALL MOVLEV(PUD,VC(NC+1),41)
      NC=NC+41
C          HCON
      CALL MOVLEV(HMASS,VC(NC+1),69)
      NC=NC+69
C          IDRUN
      CALL MOVLEV(VIDVER(1),VC(NC+1),5)
      NC=NC+5
C          ISLOOP
      CALL MOVLEV(VEVOLV(1),VC(NC+1),4)
      NC=NC+4
C          ITAPES
      CALL MOVLEV(VITDKY(1),VC(NC+1),4)
      NC=NC+4
C          JETLIM
      CALL MOVLEV(PMIN(1),VC(NC+1),72)
      NC=NC+72
C          KEYS
      CALL MOVLEV(VIKEYS(1),VC(NC+1),12)
      NC=NC+12
      CALL CTXC2I(REAC,VC(NC+1),8)
      NC=NC+8
C          LIMEVL
      CALL MOVLEV(ETTHRS,VC(NC+1),3)
      NC=NC+3
C          LSTPRT
      CALL MOVLEV(VSTPRT,VC(NC+1),1)
      NC=NC+1
C          MBGEN
      NN=4*LIMPOM+8
      CALL MOVLEV(POMWT(1),VC(NC+1),NN)
      NC=NC+NN
C          MBPAR
      CALL MOVLEV(PUD0,VC(NC+1),19)
      NC=NC+19
C          NODCAY
      CALL MOVLEV(VNODCY(1),VC(NC+1),6)
      NC=NC+6
C          PRIMAR
      CALL MOVLEV(VNJET(1),VC(NC+1),9)
      NC=NC+9
C          PRTOUT
      CALL MOVLEV(VEVPRT(1),VC(NC+1),2)
      NC=NC+2
C          PTPAR
      CALL MOVLEV(PTFUN1,VC(NC+1),6)
      NC=NC+6
C          Q1Q2
      CALL MOVLEV(VGOQ(1),VC(NC+1),3*MXGOQ+135)
      NC=NC+3*MXGOQ+135
C          QCDPAR
      CALL MOVLEV(ALAM,VC(NC+1),4)
      NC=NC+4
C          QLMASS
      CALL MOVLEV(AMLEP(1),VC(NC+1),55)
      NC=NC+55
C          TCPAR
      CALL MOVLEV(TCMRHO,VC(NC+1),2)
      NC=NC+2
C          TIMES
      CALL MOVLEV(TIME1,VC(NC+1),2)
      NC=NC+2
C          TOTALS
      CALL MOVLEV(VKINPT(1),VC(NC+1),5)
      NC=NC+5
C          TYPES
      CALL MOVLEV(VLOC(1),VC(NC+1),100)
      NC=NC+100
      DO 100 I=1,290
        CALL CTXC2I(CLIST(I),VC(NC+1),8)
        NC=NC+8
100   CONTINUE
C          WCON
+SELF,IF=SINGLE
      NN=514
+SELF,IF=DOUBLE
      NN=514+97
+SELF
      CALL MOVLEV(SIN2W,VC(NC+1),NN)
      NC=NC+NN
C
      IF(NC.LE.MXVC) THEN
        NVC=NC
        RETURN
      ELSE
        WRITE(ITLIS,9000) NC
9000    FORMAT(//' ERROR IN CTXOUT, NC = ',I5)
        STOP99
      ENDIF
      END
+EOD
+DECK,DATIME,IF=VAX,IF=NOCERN.
      SUBROUTINE DATIME(ID,IT)
C          CALL VAX DATE AND TIME.
+CDE,ITAPES
      CHARACTER*8 BUF
      CALL IDATE(IMON,IDAY,IYR)
      CALL TIME(BUF)
      ID=10000*IYR+100*IMON+IDAY
      READ(BUF,'(I2,1X,I2,1X,I2)') K1,K2,K3
      IT=10000*K1+100*K2+K3
      RETURN
      END
+EOD
+DECK,DBLDOT.
+EOD
+DECK,DBLPCM.
      FUNCTION DBLPCM(A,B,C)
C          Calculate com momentum for A-->B+C with double precision.
C          Needed to fix bug on 32-bit machines at high energy.
C          Ver. 7.27: Rewrite order and then take abs value to be sure.
+CDE,ITAPES
+SELF,IF=DOUBLE.
      DOUBLE PRECISION DA,DB,DC,DVAL
+SELF.
C          Convert to double precision
      DA=A
      DB=B
      DC=C
      DVAL=(DA-(DB+DC))*(DA+(DB+DC))*(DA-(DB-DC))*(DA+(DB-DC))
C          Convert back to single precision
      VAL=DVAL
      DBLPCM=SQRT(ABS(VAL))/(2.*A)
      RETURN
      END
+EOD
+DECK,DBLVEC
      SUBROUTINE DBLVEC(P,DP)
C
C          Calculate double precision vector DP for 5-vector P.
C          Exact components are 1,2,5 and larger of +,-
C          Ver 6.44: Always use this, even if IF=SINGLE.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL P(5)
      DOUBLE PRECISION DP(5),DPPL,DPMN
      INTEGER K
C
      DO 100 K=1,5
100   DP(K)=P(K)
      IF(DP(4)+ABS(DP(3)).EQ.0.) RETURN
      IF(DP(3).GT.0.) THEN
        DPPL=DP(4)+DP(3)
        DPMN=(DP(1)**2+DP(2)**2+DP(5)**2)/DPPL
      ELSE
        DPMN=DP(4)-DP(3)
        DPPL=(DP(1)**2+DP(2)**2+DP(5)**2)/DPMN
      ENDIF
      DP(3)=0.5D0*(DPPL-DPMN)
      DP(4)=0.5D0*(DPPL+DPMN)
      RETURN
      END
+EOD
+DECK,DBOOST.
      SUBROUTINE DBOOST(ISIGN,F,P)
C
C          DOUBLE PRECISION BOOST OF 5-VECTOR P BY 5-VECTOR F WITH SIGN
C          OF ISIGN. EXACT COMPONENTS ARE 1,2,5 AND LARGER OF +,-
C
      DIMENSION F(5),P(5)
      DOUBLE PRECISION DF(5),DFPL,DFMN,DP(5),DPPL,DPMN,DBP,DSIGN
C          COPY TO DOUBLE PRECISION
      DO 100 K=1,5
      DF(K)=F(K)
100   DP(K)=P(K)
      IF(ISIGN.GT.0) THEN
        DSIGN=1.D0
      ELSE
        DSIGN=-1.D0
      ENDIF
C          PUT ON DOUBLE PRECISION SHELL
      CALL DBLVEC(P,DP)
C          BOOST
      DBP=0.D0
      DO 110 K=1,3
110   DBP=DBP+DF(K)*DP(K)
      DBP=DBP/DF(5)
      DO 120 K=1,3
120   DP(K)=DP(K)+DSIGN*DF(K)*DP(4)/DF(5)+DF(K)*DBP/(DF(4)+DF(5))
      DP(4)=DF(4)*DP(4)/DF(5)+DSIGN*DBP
C          COPY BACK
      DO 130 K=1,4
130   P(K)=DP(K)
      RETURN
      END
+EOD
+DECK,DECAY
      SUBROUTINE DECAY(IP)
C
C          Decay particle IP from /PARTCL/ using /DKYTAB/ branching
C          ratios and add decay products to /PARTCL/ with IORIG=IP.
C          Forced decay modes are flagged by LOOK<0.
C
C          Auxiliary routines:
C          DECPS1: generate masses for phase space
C          DECPS2: generate 2-body decays and boosts for phase space
C          DECVA:  V-A matrix elements
C          DECTAU: tau decay matrix elements with polarization
C          DECSS3: 3-body SUSY matrix element using /DKYSS3/
C          DECJET: Hadronize partons from decay.
C
C          Matrix element for Dalitz decays and W mass for TP -> W BT
C          are generated explicitly. W width is included.
C
C          Requirements for decay modes:
C          (1) For Dalitz decays, particle 1 must be GM.
C          (2) For V-A quark or lepton decays, particles 1 and 2 must
C              be from (virtual) W.
C          (3) For any decay into quarks, they must appear last.
C
C          Matrix element flags:
C          MELEM=0     phase space
C                1     Dalitz
C                2     omega/phi
C                3     V-A
C                4     top
C                5     tau -> e nu nu
C                6     tau -> pi nu
C                7     tau -> rho nu
C                8     tau -> tau (for NOTAU)
C                9     H -> W f fbar
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,WCON
+CDE,PARTCL
+CDE,DKYTAB
+CDE,JETSET
+CDE,JWORK
+CDE,CONST
+CDE,PRIMAR
+CDE,IDRUN
+CDE,FORCE
+CDE,SSTYPE
+CDE,DKYSS3
C
      REAL PGEN(5,5),BETA(3),REDUCE(5),WPROP,Z,TRY,RANF,AMASS,TWOME
      REAL PSUM(5),SUM,PREST(4,6),DOT,PCM
      REAL AMEE,REE,WTEE,SWAP,WT,A,B,C,GAMMA
      REAL SMAX,SMIN,SVAL,TANMAX,TANMIN,TANVAL
      LOGICAL WDECAY,DECVA,DECTAU,DECJET
      INTEGER IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX,IPOINT,ID1,I1,I2
      INTEGER NADD,NSTART,NEW,NADD1,J,IP,I,IDABS(5)
      INTEGER K,JETIP,IDANTI,NPASS,MEIP,MEA
      REAL DBLPCM,DECSS3,VAL
      REAL ZZSTAR
      INTEGER IW
C
      DATA REDUCE/1.,1.,2.,5.,15./
      DATA PSUM/5*0./
      DATA TWOME/1.022006E-3/
      DATA PREST/24*0./
C
C          Function definitions.
C          Use double precision for PCM on 32-bit machines
C
+SELF,IF=SINGLE.
      PCM(A,B,C)=SQRT((A**2-B**2-C**2)**2-(2.*B*C)**2)/(2.*A)
+SELF,IF=DOUBLE.
      PCM(A,B,C)=DBLPCM(A,B,C)
+SELF.
      DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2)
     $-PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2)
C          Charged W propagator.
      WPROP(Z)=(Z-WMASS(2)**2)**2+(WMASS(2)*WGAM(2))**2
C----------------------------------------------------------------------
C          Select decay mode. Note IDENT(NPTCL+1)...IDENT(NPTCL+5)
C          are always defined even if zero.
C----------------------------------------------------------------------
      IF(IDCAY(IP).NE.0) RETURN
      IDLV1=IDENT(IP)
      CALL FLAVOR(IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX)
C          FLAVOR returns 0 for quark, but want IFL3=6 for top
      IF(IABS(IDLV1).LT.10) IFL3=IDLV1
      NPASS=0
1     CONTINUE
      NPASS=NPASS+1
      WDECAY=.FALSE.
      IF(NPASS.GT.NTRIES) GO TO 9998
      IPOINT=LOOK(INDEX)
      IF(IPOINT.EQ.0) RETURN
C          IPOINT<0 flags a forced decay.
      IF(IPOINT.LT.0) THEN
        I=1
        IF(IDENT(IP).LT.0) I=2
        IPOINT=LOOK2(I,IABS(IPOINT))
      ENDIF
C
C          Select mode.
C
      TRY=RANF()
      IPOINT=IPOINT-1
100   IPOINT=IPOINT+1
      IF(TRY.GT.CBR(IPOINT)) GO TO 100
      NADD=0
      SUM=0.
      NSTART=NPTCL+1
      IF(NPTCL+5.GT.MXPTCL) GO TO 9999
C
C          Set up masses and IDENT codes.
C
      MEIP=MELEM(IPOINT)
      DO 110 I=1,5
        NEW=NPTCL+I
        IDENT(NEW)=MODE(I,IPOINT)
        IDABS(I)=IABS(IDENT(NEW))
        IF(MODE(I,IPOINT).EQ.0) GO TO 110
        NADD=NADD+1
        IDLV1=IDENT(NEW)
        PPTCL(5,NEW)=AMASS(IDLV1)
        SUM=SUM+PPTCL(5,NEW)
110   CONTINUE
      NADD1=NADD-1
      DO 120 J=1,5
        PGEN(J,1)=PPTCL(J,IP)
120   CONTINUE
      PGEN(5,NADD)=PPTCL(5,NPTCL+NADD)
C----------------------------------------------------------------------
C          Carry out appropriate decay
C----------------------------------------------------------------------
C
C          1-body decays.
C          Determine polarization mode for 1-body tau decays
C
      IF(NADD.EQ.1) THEN
        DO 200 J=1,5
          PPTCL(J,NPTCL+1)=PPTCL(J,IP)
200     CONTINUE
        IF(MEIP.EQ.8) THEN
          IF(DECTAU(IP,NADD,MEIP,IDABS,PREST)) THEN
            IDENT(NPTCL+1)=IDTAUL
          ELSE
            IDENT(NPTCL+1)=IDTAUR
          ENDIF
        ENDIF
        GO TO 300
      ENDIF
C
C          2-body phase space decays
C
      IF(NADD.EQ.2.AND.MEIP.EQ.0) THEN
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        GO TO 300
      ENDIF
C
C          N-body phase space decays
C
      IF(NADD.GT.2.AND.MEIP.EQ.0) THEN
        CALL DECPS1(IP,NADD,PGEN)
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        GO TO 300
      ENDIF
C
C          Dalitz decays
C
      IF(NADD.EQ.3.AND.MEIP.EQ.1) THEN
210     AMEE=TWOME*(PPTCL(5,IP)/TWOME)**RANF()
        REE=(TWOME/AMEE)**2
        WTEE=(1.-(AMEE/PPTCL(5,IP))**2)**3*SQRT(1.-REE)*(1.+.5*REE)
        IF(WTEE.LT.RANF()) GO TO 210
        PGEN(5,2)=AMEE
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        GO TO 300
      ENDIF
C
C          omega/phi decays (for reasons lost in history...)
C
      IF(NADD.EQ.3.AND.MEIP.EQ.2) THEN
220     CALL DECPS1(IP,NADD,PGEN)
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        WT=(PPTCL(5,NPTCL+1)*PPTCL(5,NPTCL+2)*PPTCL(5,NPTCL+3))**2
     $  -(PPTCL(5,NPTCL+1)*DOT(2,3))**2
     $  -(PPTCL(5,NPTCL+2)*DOT(1,3))**2
     $  -(PPTCL(5,NPTCL+3)*DOT(1,2))**2
     $  +2.*DOT(1,2)*DOT(2,3)*DOT(1,3)
        IF(WT.LT.RANF()*PPTCL(5,IP)**6/108.) GO TO 220
        GO TO 300
      ENDIF
C
C          V-A decays
C
      IF(NADD.EQ.3.AND.MEIP.EQ.3) THEN
230     CALL DECPS1(IP,NADD,PGEN)
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        IF(.NOT.DECVA(IP,NADD,IDABS,PREST)) GO TO 230
        GO TO 300
      ENDIF
C
C          Top decays
C          Generate mass for TP -> W BT with Breit-Wigner. 
C          W couples to 1+2 so swap 1<->3. Then m2+m3 < m < m0-m1.
C
      IF(NADD.EQ.3.AND.MEIP.EQ.4) THEN
        WDECAY=.TRUE.
        SWAP=PPTCL(5,NPTCL+1)
        PPTCL(5,NPTCL+1)=PPTCL(5,NPTCL+3)
        PPTCL(5,NPTCL+3)=SWAP
        SMAX=(PPTCL(5,IP)-PPTCL(5,NPTCL+1))**2
        SMIN=(PPTCL(5,NPTCL+2)+PPTCL(5,NPTCL+3))**2
        TANMAX=ATAN((SMAX-WMASS(2)**2)/(WMASS(2)*WGAM(2)))
        TANMIN=ATAN((SMIN-WMASS(2)**2)/(WMASS(2)*WGAM(2)))
240     TANVAL=RANF()*(TANMAX-TANMIN)+TANMIN
        SVAL=WMASS(2)**2+WMASS(2)*WGAM(2)*TAN(TANVAL)
        IF(SVAL.LT.SMIN.OR.SVAL.GT.SMAX) GO TO 240
        PGEN(5,2)=SQRT(SVAL)
        PGEN(5,3)=PPTCL(5,NPTCL+3)
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        IF(.NOT.DECVA(IP,NADD,IDABS,PREST)) GO TO 240
        DO 241 K=1,5
          SWAP=PPTCL(K,NPTCL+1)
          PPTCL(K,NPTCL+1)=PPTCL(K,NPTCL+3)
          PPTCL(K,NPTCL+3)=SWAP
241     CONTINUE
        PGEN(5,3)=PPTCL(5,NPTCL+3)
        DO 242 K=1,4
          SWAP=PREST(K,1)
          PREST(K,1)=PREST(K,3)
          PREST(K,3)=SWAP
242     CONTINUE
        GO TO 300
      ENDIF
C
C          TAU decays. These are special because they take polarization
C          into account.
C
      IF(MEIP.EQ.5.OR.MEIP.EQ.6.OR.MEIP.EQ.7) THEN
250     CALL DECPS1(IP,NADD,PGEN)
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        IF(.NOT.DECTAU(IP,NADD,MEIP,IDABS,PREST)) GO TO 250
        GO TO 300
      ENDIF
C
C          3-body SUSY decays
C
      IF(MEIP.LT.0.AND.NADD.EQ.3) THEN
        MEA=IABS(MEIP)
        IF(WTSS3(MEA).LE.0) THEN
          DO 260 I=1,1000
            CALL DECPS1(IP,NADD,PGEN)
            CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
            VAL=DECSS3(IP,MEA)
            WTSS3(MEA)=MAX(WTSS3(MEA),VAL)
260       CONTINUE
          IF(WTSS3(MEA).LE.0) GO TO 9998
        ENDIF
261     CALL DECPS1(IP,NADD,PGEN)
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        VAL=DECSS3(IP,MEA)
        WTSS3(MEA)=MAX(WTSS3(MEA),VAL)
        IF(VAL.LT.WTSS3(MEA)*RANF()) GO TO 261
        GO TO 300
      ENDIF
C
C          H -> W f fbar decays
C          Generate f fbar mass using ZZSTAR function
C
      IF(NADD.EQ.3.AND.MEIP.EQ.9) THEN
        IF(IDENT(NPTCL+1).EQ.80) THEN
          IW=2
        ELSEIF(IDENT(NPTCL+1).EQ.-80) THEN
          IW=3
        ELSEIF(IDENT(NPTCL+1).EQ.90) THEN
          IW=4
        ELSE
          WRITE(ITLIS,*) 'ERROR IN DECAY ... BAD H -> W F FBAR'
          STOP99
        ENDIF
        PGEN(5,2)=ZZSTAR(PPTCL(5,IP),IW)
        IF(PGEN(5,2).LT.PPTCL(5,NPTCL+2)+PPTCL(5,NPTCL+3)+1.0)
     $  GO TO 1
        CALL DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
        GO TO 300
      ENDIF
C
C          Should never fall through
C
      GO TO 9998
C----------------------------------------------------------------------
C          Swap particles and antiparticles if IDENT(IP)<0
C          Note forced modes for antiparticles are conjugated in table.
C----------------------------------------------------------------------
300   CONTINUE
      IF(IDENT(IP).LT.0.AND.IDENT(IP).NE.-20) THEN
        DO 310 I=1,NADD
          ID1=IDENT(NPTCL+I)
          IDENT(NPTCL+I)=IDANTI(ID1)
310     CONTINUE
      ENDIF
C
C          Set IORIG and IDCAY.
C
      NPTCL=NPTCL+NADD
      IDCAY(IP)=IPACK*NSTART+NPTCL
      JETIP=IABS(IORIG(IP))/IPACK
      DO 320 I=NSTART,NPTCL
        IORIG(I)=IP
        IDCAY(I)=0
320   CONTINUE
C
C          Evolve and hadronize partons. If it fails, start over.
C
      IF(IDABS(NADD).LT.10.OR.MOD(IDENT(NPTCL),100).EQ.0) THEN
        IF(.NOT.DECJET(IP,NADD,IDABS,PREST,WDECAY,BETA,GAMMA))
     $  GO TO 1
      ENDIF
C
      RETURN
C----------------------------------------------------------------------
C          Error messages.
C----------------------------------------------------------------------
9999  CALL PRTEVT(0)
      WRITE(ITLIS,99990) NPTCL
99990 FORMAT(//5X,'ERROR IN DECAY...NPTCL > ',I6)
      RETURN
9998  CALL PRTEVT(0)
      WRITE(ITLIS,99980) IP
99980 FORMAT(//5X,'ERROR IN DECAY...NO DECAY FOUND FOR PARTICLE',I6)
      RETURN
      END
+EOD
+DECK,DECJET
      LOGICAL FUNCTION DECJET(IP,NADD,IDABS,PREST,WDECAY,BETA,GAMMA)
C
C          Auxiliary routine for DECAY. Evolve and hadronize partons.
C          Check conservation laws. Return TRUE if OK, FALSE otherwise.
C
C          IP = particle to be decayed.
C          NADD = number of products (NPTCL+1, ..., NPTCL+NADD).
C          IDABS = absolute values of decay IDENT's.
C          PREST = 4-momenta in rest frame.
C          WDECAY = logical flag for real W decay.
C          BETA,GAMMA = boost parameters.
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,WCON
+CDE,PARTCL
+CDE,DKYTAB
+CDE,JETSET
+CDE,JWORK
+CDE,CONST
C   
      REAL PGEN(5,5),RND(5),U(3),BETA(3),IDQK(3),ROT(3,3),PSAVE(3)  
     1,REDUCE(5),WPROP,Z,TRY,RANF,AMASS,TWOME,CHARGE    
      REAL PSUM(5),POLD(4),PNEW(4),SUM,WTMAX,SUM1,SUM2  
      REAL PREST(4,6),PWREST(5),BETAW(3),DOT,PCM    
      REAL AMEE,REE,WTEE,SWAP,RNEW,WT,QCM,PHI,S12,S12MAX,GAMMAW,BP  
      REAL PJET,CTHQK,STHQK,CPHIQK,SPHIQK,SUMQ,A,B,C,GAMMA  
      REAL CHARGW   
      LOGICAL WDECAY    
      INTEGER IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX,IPOINT,ID1,I1,I2,I3  
      INTEGER NADD,NSTART,NEW,NADD1,J,IP,I,IDABS(5),NEXT    
      INTEGER JJ1,II,K1,K,NJSAVE,NJSAV1,NJSAV2,NJ1,NPRTN,KK,NHDRN1  
      INTEGER IFAIL,JSAVE,JETIP,JET,NJADD,NPTLV1,IDANTI,NPJET(5)    
      INTEGER NHDRN,NPJET3,NPTCLW,NPBEG(5)  
C   
C          Copy decay products into /JETSET/ and do QCD evolution.  
C   
      IF(NJSET+NADD.GT.MXJSET) GO TO 9998   
      NJSAVE=NJSET  
      NSTART=NPTCL-NADD+1   
      NPTCL=NSTART-1    
      DO 100 I=1,NADD   
        NJSET=NJSET+1   
        DO 110 K=1,4    
110     PJSET(K,NJSET)=PREST(K,I)   
        PJSET(5,NJSET)=PPTCL(5,NPTCL+I) 
        JORIG(NJSET)=JPACK*I    
        JTYPE(NJSET)=IDENT(NPTCL+I) 
        JDCAY(NJSET)=0  
        JMATCH(NJSET)=JPACK*(NJSAVE+1)+NJSAVE+NADD  
100   CONTINUE  
C   
C          For heavy quarks match 1+2 and 3+(1+2). Boost 1+2 to rest.   
C   
      IF(WDECAY) THEN   
        JMATCH(NJSAVE+1)=NJSAVE+2   
        JMATCH(NJSAVE+2)=NJSAVE+1   
        NJSET=NJSET+1   
        DO 120 K=1,4    
          PWREST(K)=PJSET(K,NJSAVE+1)+PJSET(K,NJSAVE+2) 
          PJSET(K,NJSET)=PWREST(K)  
120     CONTINUE    
        PWREST(5)=SQRT(PWREST(4)**2-PWREST(1)**2-PWREST(2)**2   
     $  -PWREST(3)**2)  
        PJSET(5,NJSET)=PWREST(5)    
        JMATCH(NJSAVE+3)=NJSAVE+4   
        JMATCH(NJSAVE+4)=NJSAVE+3   
        JORIG(NJSAVE+4)=-1  
        IDLV1=JTYPE(NJSAVE+1)   
        CHARGW=CHARGE(IDLV1)    
        IDLV1=JTYPE(NJSAVE+2)   
        CHARGW=CHARGW+CHARGE(IDLV1) 
        JTYPE(NJSAVE+4)=80*SIGN(1.,CHARGW)  
        JDCAY(NJSAVE+4)=0   
C          Boost W vectors to rest. 
        DO 130 K=1,3    
130     BETAW(K)=PWREST(K)/PWREST(4)    
        GAMMAW=PWREST(4)/PWREST(5)  
        NJSAV1=NJSAVE+1 
        NJSAV2=NJSAVE+2 
        DO 140 J=NJSAV1,NJSAV2  
          BP=BETAW(1)*PJSET(1,J)+BETAW(2)*PJSET(2,J)+BETAW(3)*PJSET(3,J)    
          DO 141 K=1,3  
141       PJSET(K,J)=PJSET(K,J)-GAMMAW*BETAW(K)*(PJSET(4,J) 
     $    -BP*GAMMAW/(GAMMAW+1.))   
          PJSET(4,J)=GAMMAW*(PJSET(4,J)-BP) 
140     CONTINUE    
      ENDIF 
C   
C          Do evolution and save new W momentum. Start from parent  
C          mass or NADD*energy. 
      NJSAV1=NJSAVE+1   
      DO 150 J=NJSAV1,NJSET 
        IF(IABS(JTYPE(J)).LT.10.OR.MOD(JTYPE(J),100).EQ.0) THEN 
          JDCAY(J)=-1   
          PJSET(5,J)=AMIN1(PPTCL(5,IP),NADD*PJSET(4,J)) 
        ENDIF   
150   CONTINUE  
C   
      CALL QCDJET(NJSAVE+1) 
C   
      IF(WDECAY) THEN   
        PWREST(4)=PJSET(4,NJSAVE+4) 
        GAMMAW=PWREST(4)/PWREST(5)  
        DO 200 K=1,3    
          PWREST(K)=PJSET(K,NJSAVE+4)   
          BETAW(K)=PWREST(K)/PWREST(4)  
200     CONTINUE    
      ENDIF 
C   
C          Put final partons in particle table - temporary IORIG.   
C          Also include virtual or real W momentum for quark decays.    
C   
      NJ1=NJSAVE+1  
      IF(WDECAY) THEN   
C          Real or virtual W.   
        NPTCL=NPTCL+1   
        NPTCLW=NPTCL    
        DO 210 K=1,5    
210     PPTCL(K,NPTCL)=PJSET(K,NJSAVE+4)    
        IORIG(NPTCL)=IP 
        IDENT(NPTCL)=JTYPE(NJSAVE+4)    
        IDCAY(NPTCL)=0  
C          Jet 3    
        NPBEG(3)=NPTCL+1    
        DO 220 J=NJ1,NJSET  
          IF(JDCAY(J).NE.0) GO TO 220   
          IF(JORIG(J)/JPACK.NE.3) GO TO 220 
          NPTCL=NPTCL+1 
          DO 221 K=1,5  
221       PPTCL(K,NPTCL)=PJSET(K,J) 
          IORIG(NPTCL)=3*IPACK+IP   
          IDENT(NPTCL)=JTYPE(J) 
          IDCAY(NPTCL)=0    
220     CONTINUE    
C          Jets 1 and 2 
        NPJET3=NPTCL    
        DO 230 JET=1,2  
          NPBEG(JET)=NPTCL+1    
          DO 240 J=NJ1,NJSET    
            IF(JDCAY(J).NE.0) GO TO 240 
            IF(JORIG(J)/JPACK.NE.JET) GO TO 240 
            NPTCL=NPTCL+1   
            BP=BETAW(1)*PJSET(1,J)+BETAW(2)*PJSET(2,J)  
     $      +BETAW(3)*PJSET(3,J)    
            DO 241 K=1,3    
241         PPTCL(K,NPTCL)=PJSET(K,J)+GAMMAW*BETAW(K)*(PJSET(4,J)   
     $      +BP*GAMMAW/(GAMMAW+1.)) 
            PPTCL(4,NPTCL)=GAMMAW*(PJSET(4,J)+BP)   
            PPTCL(5,NPTCL)=PJSET(5,J)   
            IORIG(NPTCL)=IPACK*(JORIG(J)/JPACK)+NPTCLW  
            IDENT(NPTCL)=JTYPE(J)   
            IDCAY(NPTCL)=0  
240       CONTINUE  
230     CONTINUE    
C          Quark decays to W plus jet 3; then W decays. 
        IDCAY(IP)=IPACK*NPTCLW+NPJET3   
        IDCAY(NPTCLW)=IPACK*(NPJET3+1)+NPTCL    
      ELSE  
C          Not quark decay, so just copy partons.   
        DO 250 JET=1,NADD   
          NPBEG(JET)=NPTCL+1    
          DO 260 J=NJ1,NJSET    
            IF(JDCAY(J).NE.0) GO TO 260 
            IF(JORIG(J)/JPACK.NE.JET) GO TO 260 
            NPTCL=NPTCL+1   
            DO 261 K=1,5    
261         PPTCL(K,NPTCL)=PJSET(K,J)   
            IORIG(NPTCL)=IPACK*(JORIG(J)/JPACK)+IP  
            IDENT(NPTCL)=JTYPE(J)   
            IDCAY(NPTCL)=0  
260       CONTINUE  
250     CONTINUE    
        IDCAY(IP)=NSTART*IPACK+NPTCL    
      ENDIF 
      NHDRN=NPTCL   
C   
C          Hadronize quarks and rotate to proper angles.    
C   
      DO 300 JET=1,NADD 
        NPRTN=NPBEG(JET)-1  
        DO 310 I=NJ1,NJSET  
          IF(JDCAY(I).NE.0) GO TO 310   
          IF(JORIG(I)/JPACK.NE.JET) GO TO 310   
          NPRTN=NPRTN+1 
          IF(IABS(JTYPE(I)).GE.10.AND.MOD(JTYPE(I),100).NE.0)   
     $    GO TO 330 
C   
C          Fragment parton: 
          NEXT=NPTCL+1  
          PJET=SQRT(PJSET(1,I)**2+PJSET(2,I)**2+PJSET(3,I)**2)  
          CTHQK=PJSET(3,I)/PJET 
          STHQK=1.-CTHQK**2
          IF(STHQK.LT.1) THEN
            STHQK=SQRT(STHQK)
            CPHIQK=PJSET(1,I)/(PJET*STHQK)
            SPHIQK=PJSET(2,I)/(PJET*STHQK)
          ELSE
            STHQK=0
            CPHIQK=1
            SPHIQK=0
          ENDIF
          CALL JETGEN(I)    
          IF(NEXT.GT.NPTCL) GO TO 310   
          ROT(1,1)=CPHIQK*CTHQK 
          ROT(2,1)=SPHIQK*CTHQK 
          ROT(3,1)=-STHQK   
          ROT(1,2)=-SPHIQK  
          ROT(2,2)=CPHIQK   
          ROT(3,2)=0.   
          ROT(1,3)=CPHIQK*STHQK 
          ROT(2,3)=SPHIQK*STHQK 
          ROT(3,3)=CTHQK    
C   
          DO 320 II=NEXT,NPTCL  
            DO 321 K=1,3    
              PSAVE(K)=PPTCL(K,II)  
              PPTCL(K,II)=0.    
321         CONTINUE    
            DO 322 K=1,3    
            DO 322 KK=1,3   
322         PPTCL(K,II)=PPTCL(K,II)+ROT(K,KK)*PSAVE(KK) 
            IORIG(II)=IPACK*JET+NPRTN   
            IDCAY(II)=0 
320       CONTINUE  
          IDCAY(NPRTN)=NEXT*IPACK+NPTCL 
          GO TO 310 
C   
C          or add lepton:   
330       NPTCL=NPTCL+1 
          DO 331 K=1,5  
331       PPTCL(K,NPTCL)=PJSET(K,I) 
          IORIG(NPTCL)=IPACK*JET+NPRTN  
          IDENT(NPTCL)=JTYPE(I) 
          IDCAY(NPTCL)=0    
          IDCAY(NPRTN)=NPTCL*IPACK+NPTCL    
310     CONTINUE    
        NPJET(JET)=NPTCL    
300   CONTINUE  
C   
C          Reset NJSET so decay jets do not appear in /JETSET/  
      NJADD=NJSET   
      NJSET=NJSAVE  
C   
C          Check for at least two particles 
      IF(NPTCL.LT.NHDRN+2) THEN 
        NPTCL=NSTART-1  
        DECJET=.FALSE.  
        RETURN  
      ENDIF 
C   
C          Conserve charge  
C   
      SUMQ=0.   
      NHDRN1=NHDRN+1    
      DO 400 I=NHDRN1,NPTCL 
        IDLV1=IDENT(I)  
        SUMQ=SUMQ+CHARGE(IDLV1) 
400   CONTINUE  
      IDLV1=IDENT(IP)   
      SUMQ=SUMQ-CHARGE(IDLV1)   
C   
      IF(ABS(SUMQ).LT.0.99) GO TO 500  
C   
C          Charge wrong--fix it by swapping UP and DN quarks.   
      DO 410 I=NHDRN1,NPTCL 
        ID1=IDENT(I)    
        IF(IABS(ID1).GT.1000) GO TO 410 
        I1=MOD(IABS(ID1)/100,10)    
        I2=MOD(IABS(ID1)/10,10) 
        I3=MOD(IABS(ID1),10)    
        IF(I1.EQ.1.AND.I2.GT.2.AND.SUMQ*ID1.GT.0.) THEN 
          IDENT(I)=ISIGN(200+10*I2+I3,ID1)  
        ELSEIF(I1.EQ.2.AND.I2.GT.2.AND.SUMQ*ID1.LT.0.) THEN 
          IDENT(I)=ISIGN(100+10*I2+I3,ID1)  
        ELSEIF(I1.EQ.1.AND.I2.EQ.2.AND.SUMQ*ID1.GT.0.) THEN 
          IDENT(I)=110+I3   
        ELSEIF(I1.EQ.1.AND.I2.EQ.1) THEN    
          IDENT(I)=(120+I3)*(-SIGN(1.,SUMQ))    
        ELSE    
          GO TO 410 
        ENDIF   
        SUMQ=SIGN(ABS(SUMQ)-1.,SUMQ)    
        IDLV1=IDENT(I)  
        PPTCL(5,I)=AMASS(IDLV1) 
        PPTCL(4,I)=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2+PPTCL(3,I)**2   
     $  +PPTCL(5,I)**2) 
C          Sum cannot vanish for fractionally charged initial particle. 
        IF(ABS(SUMQ).LT.0.99) GO TO 500   
410   CONTINUE  
C          Failed to conserve charge.   
      NPTCL=NSTART-1    
      DECJET=.FALSE.    
      RETURN    
C   
C          Rescale momenta for correct mass 
C   
500   CONTINUE  
      IF(WDECAY) THEN   
C          Quark decay. First rescale jet3 + W  
        DO 510 K=1,5    
510     PPTCL(K,NPTCL+1)=PPTCL(K,NPTCLW)    
        NPTLV1=NPTCL+1  
        DO 520 K=1,3    
520     PSUM(K)=0.  
        PSUM(4)=PPTCL(5,IP) 
        PSUM(5)=PSUM(4) 
        CALL RESCAL(NPJET(2)+1,NPTLV1,PSUM,IFAIL) 
        IF(IFAIL.NE.0) THEN 
          NPTCL=NSTART-1    
          DECJET=.FALSE.    
          RETURN    
        ENDIF   
        DO 530 K=1,3    
530     BETAW(K)=PPTCL(K,NPTCL+1)/PPTCL(4,NPTCL+1)  
        GAMMAW=PPTCL(4,NPTCL+1)/PPTCL(5,NPTCL+1)    
C          Then rescale W   
        PSUM(4)=PPTCL(5,NPTCLW) 
        PSUM(5)=PSUM(4) 
        CALL RESCAL(NHDRN1,NPJET(2),PSUM,IFAIL) 
        IF(IFAIL.NE.0) THEN 
          NPTCL=NSTART-1    
          DECJET=.FALSE.    
          RETURN    
        ENDIF   
      ELSE  
C          General decay with no W. 
        DO 550 K=1,3    
550     PSUM(K)=0.  
        PSUM(4)=PPTCL(5,IP) 
        PSUM(5)=PSUM(4) 
        NPTLV1=NPTCL    
        CALL RESCAL(NHDRN1,NPTLV1,PSUM,IFAIL)   
        IF(IFAIL.NE.0) THEN 
          NPTCL=NSTART-1    
          DECJET=.FALSE.    
          RETURN    
        ENDIF   
      ENDIF 
C   
C          Boost back to lab frame. Reset IORIG.    
C   
      IF(WDECAY) THEN   
        DO 600 I=NHDRN1,NPTCL  
          JET=IORIG(I)/IPACK    
          IF(JET.NE.1.AND.JET.NE.2) GO TO 600   
          BP=BETAW(1)*PPTCL(1,I)+BETAW(2)*PPTCL(2,I)+BETAW(3)*PPTCL(3,I)    
          DO 610 J=1,3  
610       PPTCL(J,I)=PPTCL(J,I)+GAMMAW*BETAW(J)*(PPTCL(4,I) 
     $    +BP*GAMMAW/(GAMMAW+1.))   
          PPTCL(4,I)=GAMMAW*(PPTCL(4,I)+BP) 
600     CONTINUE    
      ENDIF 
C   
      DO 620 I=NSTART,NPTCL 
        IORIG(I)=MOD(IORIG(I),IPACK)    
        BP=BETA(1)*PPTCL(1,I)+BETA(2)*PPTCL(2,I)+BETA(3)*PPTCL(3,I) 
        DO 621 J=1,3    
          PPTCL(J,I)=PPTCL(J,I)+GAMMA*BETA(J)*(PPTCL(4,I)   
     $    +BP*GAMMA/(GAMMA+1.)) 
621     CONTINUE    
        PPTCL(4,I)=GAMMA*(PPTCL(4,I)+BP)    
620   CONTINUE  
C   
C          Normal exit  
C   
      DECJET=.TRUE. 
      RETURN    
C   
C          Error messages.  
C   
9998  DECJET=.FALSE.
      CALL PRTEVT(0)    
      WRITE(ITLIS,99980) NJSET  
99980 FORMAT(//5X,'ERROR IN DECJET...NJSET > ',I5)  
      RETURN    
      END   
+EOD
+DECK,DECME
+EOD
+DECK,DECPS1
      SUBROUTINE DECPS1(IP,NADD,PGEN)
C
C          Generate masses for uniform NADD-body phase space in DECPS2.
C          Auxiliary routine for DECAY.
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
C
+CDE,ITAPES
+CDE,PARTCL
C
      INTEGER IP,NADD
      REAL PGEN(5,5)
      REAL REDUCE(5),RND(5)
      REAL RANF,PCM,DBLPCM
      REAL WTMAX,SUM1,SUM2,SUM,RNEW,WT,A,B,C
      INTEGER I,NADD1,J,I1,JJ1,JSAVE
C
C          Function definitions.
C
+SELF,IF=SINGLE.
      PCM(A,B,C)=SQRT((A-B-C)*(A+B+C)*(A-B+C)*(A+B-C))/(2.*A)
+SELF,IF=DOUBLE.
      PCM(A,B,C)=DBLPCM(A,B,C)
+SELF.
C
      DATA REDUCE/1.,1.,2.,5.,15./
C
C          Calculate maximum phase-space weight.
C
      IF(NADD.LE.2) RETURN
      NADD1=NADD-1
      WTMAX=1./REDUCE(NADD)
      SUM=0
      DO 100 I=1,NADD
        SUM=SUM+PPTCL(5,NPTCL+I)
100   CONTINUE
      SUM1=PGEN(5,1)
      SUM2=SUM-PPTCL(5,NPTCL+1)
      DO 110 I=1,NADD1
        WTMAX=WTMAX*PCM(SUM1,SUM2,PPTCL(5,NPTCL+I))
        SUM1=SUM1-PPTCL(5,NPTCL+I)
        SUM2=SUM2-PPTCL(5,NPTCL+I+1)
110   CONTINUE
C
C          Generate masses for uniform NADD-body phase space.
C
200   CONTINUE
      RND(1)=1.
      DO 210 I=2,NADD1
        RNEW=RANF()
        I1=I-1
        DO 220 JJ1=1,I1
          J=I-JJ1
          JSAVE=J+1
          IF(RNEW.LE.RND(J)) GO TO 210
          RND(JSAVE)=RND(J)
220     CONTINUE
210   RND(JSAVE)=RNEW
      RND(NADD)=0.
      WT=1.
      SUM1=SUM
      DO 230 I=2,NADD
        SUM1=SUM1-PPTCL(5,NPTCL+I-1)
        PGEN(5,I)=SUM1+RND(I)*(PGEN(5,1)-SUM)
        IF(PGEN(5,I-1).LE.PGEN(5,I)+PPTCL(5,NPTCL+I-1)) GO TO 200
        WT=WT*PCM(PGEN(5,I-1),PGEN(5,I),PPTCL(5,NPTCL+I-1))
230   CONTINUE
      IF(WT.LT.RANF()*WTMAX) GO TO 200
C
      RETURN
      END
+EOD
+DECK,DECPS2
      SUBROUTINE DECPS2(IP,NADD,PGEN,PREST,BETA,GAMMA)
C
C          Carry out decays using masses from DECPS1 or special matrix
C          elements.
C          Auxiliary routine for DECAY.
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
C
+CDE,ITAPES
+CDE,PARTCL
+CDE,CONST
C
      INTEGER IP,NADD
      REAL PGEN(5,5),PREST(4,6)
      REAL PCM,DBLPCM,RANF
      REAL U(3),BETA(3)
      REAL QCM,PHI,A,B,C,GAMMA,BP
      INTEGER I,J,NADD1,II,K,K1
C
C          Function definitions.
C
+SELF,IF=SINGLE.
      PCM(A,B,C)=SQRT((A-B-C)*(A+B+C)*(A-B+C)*(A+B-C))/(2.*A)
+SELF,IF=DOUBLE.
      PCM(A,B,C)=DBLPCM(A,B,C)
+SELF.
C
C          Carry out two-body decays in PGEN frames.
C
      NADD1=NADD-1
100   CONTINUE
      DO 110 I=1,NADD1
        QCM=PCM(PGEN(5,I),PGEN(5,I+1),PPTCL(5,NPTCL+I))
        U(3)=2.*RANF()-1.
        PHI=2.*PI*RANF()
        U(1)=SQRT(1.-U(3)**2)*COS(PHI)
        U(2)=SQRT(1.-U(3)**2)*SIN(PHI)
        DO 120 J=1,3
          PPTCL(J,NPTCL+I)=QCM*U(J)
          PGEN(J,I+1)=-PPTCL(J,NPTCL+I)
120     CONTINUE
        PPTCL(4,NPTCL+I)=SQRT(QCM**2+PPTCL(5,NPTCL+I)**2)
        PGEN(4,I+1)=SQRT(QCM**2+PGEN(5,I+1)**2)
110   CONTINUE
C
      DO 130 J=1,4
        PPTCL(J,NPTCL+NADD)=PGEN(J,NADD)
130   CONTINUE
C
C          Boost PGEN frames to lab frame, saving momenta in rest frame.
C
      DO 200 II=1,NADD1
        I=NADD-II
        DO 210 J=1,3
          BETA(J)=PGEN(J,I)/PGEN(4,I)
210     CONTINUE
        GAMMA=PGEN(4,I)/PGEN(5,I)
        DO 220 K=I,NADD
          K1=NPTCL+K
          BP=BETA(1)*PPTCL(1,K1)+BETA(2)*PPTCL(2,K1)+BETA(3)*PPTCL(3,K1)
          DO 230 J=1,3
            PREST(J,K)=PPTCL(J,K1)
            PPTCL(J,K1)=PPTCL(J,K1)+GAMMA*BETA(J)*(PPTCL(4,K1)
     $      +BP*GAMMA/(GAMMA+1.))
230       CONTINUE
          PREST(4,K)=PPTCL(4,K1)
          PPTCL(4,K1)=GAMMA*(PPTCL(4,K1)+BP)
220     CONTINUE
200   CONTINUE
C
      RETURN
      END
+EOD
+DECK,DECSS3
      FUNCTION DECSS3(IP,MEA)
C
C          Compute matrix element for mode MEA of particle IP using
C          poles and couplings in /DKYSS3/.
C          Auxiliary routine for DECAY.
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
C
+CDE,ITAPES
+CDE,PARTCL
+CDE,CONST
+CDE,DKYSS3
C
      LOGICAL KIN(4),KINP(4)
      INTEGER IP,MEA,I,J,JP,II,PTYPE1,PTYPE2
      REAL DECSS3
      REAL AM0SQ,AM1SQ,AM2SQ,AM3SQ,S12,S13,S23
      REAL D12,D13,D23,D01,D02,D03,AS,BS,CS,DS,MSQ
      REAL DOT4
      COMPLEX A,B,C,D,AC,BC,CC,DC,AP,BP,CP,DP,APC,BPC,CPC,DPC,MMPD
C
      DOT4(I,J)=PPTCL(4,I)*PPTCL(4,J)-PPTCL(1,I)*PPTCL(1,J)-
     $PPTCL(2,I)*PPTCL(2,J)-PPTCL(3,I)*PPTCL(3,J)
C
C          Kinematics
C
      AM0SQ=PPTCL(5,IP)**2
      AM1SQ=PPTCL(5,NPTCL+1)**2
      AM2SQ=PPTCL(5,NPTCL+2)**2
      AM3SQ=PPTCL(5,NPTCL+3)**2
      D12=DOT4(NPTCL+1,NPTCL+2)
      D13=DOT4(NPTCL+1,NPTCL+3)
      D23=DOT4(NPTCL+2,NPTCL+3)
      D01=DOT4(IP,NPTCL+1)
      D02=DOT4(IP,NPTCL+2)
      D03=DOT4(IP,NPTCL+3)
      S12=2*D12+AM1SQ+AM2SQ
      S13=2*D13+AM1SQ+AM3SQ
      S23=2*D23+AM2SQ+AM3SQ
C
C          Generic matrix element
C
C          Loop over diagrams
      DECSS3=0.
      DO J=J1SS3(MEA),J2SS3(MEA)
       PTYPE1=KSS3(J)
       A=ZISS3(1,J)
       B=ZISS3(2,J)
       C=ZFSS3(1,J)
       D=ZFSS3(2,J)
       AC=CONJG(A)
       BC=CONJG(B)
       CC=CONJG(C)
       DC=CONJG(D)
       AS=A*AC
       BS=B*BC
       CS=C*CC
       DS=D*DC
       DO JP=J,J2SS3(MEA)
        MSQ=0.
        DO II=1,4
          KIN(II)=.FALSE.
          KINP(II)=.FALSE.
        END DO
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(J)) KIN(1)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+3)).LT.AMSS3(J)) KIN(2)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+2)).LT.AMSS3(J)) KIN(3)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(J)) KIN(4)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(JP)) KINP(1)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+3)).LT.AMSS3(JP)) KINP(2)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+2)).LT.AMSS3(JP)) KINP(3)=.TRUE.
        IF ((PPTCL(5,IP)-PPTCL(5,NPTCL+1)).LT.AMSS3(JP)) KINP(4)=.TRUE.
        IF (J.EQ.JP) THEN
         IF (PTYPE1.EQ.1.AND.KIN(1)) THEN
          MSQ=32*(((AS+BS)*(CS+DS)+4*REAL(A*BC*C*DC))*D03*D12+
     $            ((AS+BS)*(CS+DS)-4*REAL(A*BC*C*DC))*D02*D13+
     $             (BS-AS)*(CS+DS)*SQRT(AM0SQ*AM1SQ)*D23)/
     $            (S23-AMSS3(J)**2)**2
         ELSE IF (PTYPE1.EQ.2.AND.KIN(2)) THEN
          MSQ=16*(AS+BS)*(CS+DS)*D03*D12/(S12-AMSS3(J)**2)**2
         ELSE IF (PTYPE1.EQ.3.AND.KIN(3)) THEN
          MSQ=16*(AS+BS)*(CS+DS)*D02*D13/(S13-AMSS3(J)**2)**2
         ELSE IF (PTYPE1.EQ.4.AND.KIN(4)) THEN
          MSQ=16*((AS+BS)*(CS+DS)*D01*D23+(AS-BS)*(CS+DS)*D23*
     $        SQRT(AM0SQ*AM1SQ))/(S23-AMSS3(J)**2)**2
         END IF
        END IF          
        IF (J.NE.JP) THEN
        PTYPE2=KSS3(JP)
        AP=ZISS3(1,JP)
        BP=ZISS3(2,JP)
        CP=ZFSS3(1,JP)
        DP=ZFSS3(2,JP)
        APC=CONJG(AP)
        BPC=CONJG(BP)
        CPC=CONJG(CP)
        DPC=CONJG(DP)
         IF (PTYPE1.EQ.2.AND.PTYPE2.EQ.2.AND.KIN(2).AND.KINP(2)) THEN
          MMPD=16*D12*D03*(A*APC+B*BPC)*(C*CPC+D*DPC)/
     $        (S12-AMSS3(J)**2)/(S12-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.3.AND.PTYPE2.EQ.3.AND.KIN(3).AND.KINP(3)) THEN
          MMPD=16*D13*D02*(A*APC+B*BPC)*(C*CPC+D*DPC)/
     $        (S13-AMSS3(J)**2)/(S13-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.4.AND.PTYPE2.EQ.4.AND.KIN(4).AND.KINP(4)) THEN
          MMPD=16*D23*(D01*(A*APC+B*BPC)*(C*CPC+D*DPC)+
     $        SQRT(AM0SQ*AM1SQ)*(A*APC-B*BPC)*(C*CPC-D*DPC))/
     $        (S23-AMSS3(J)**2)/(S23-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.1.AND.PTYPE2.EQ.3.AND.KIN(1).AND.KINP(3)) THEN
          MMPD=(16*D13*D02*((A*C-B*D)*(-APC*CPC+BPC*DPC)+
     $         (A*D-B*C)*(APC*DPC-BPC*CPC))+
     $         8*D23*SQRT(AM0SQ*AM1SQ)*((A*C+B*D)*(APC*CPC-BPC*DPC)-
     $         (A*D+B*C)*(APC*DPC-BPC*CPC)))/
     $         (S23-AMSS3(J)**2)/(S13-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.1.AND.PTYPE2.EQ.2.AND.KIN(1).AND.KINP(2)) THEN
          MMPD=(16*D12*D03*((A*C+B*D)*(-APC*CPC+BPC*DPC)+
     $         (A*D+B*C)*(APC*DPC-BPC*CPC))+
     $         8*D23*SQRT(AM0SQ*AM1SQ)*((A*C-B*D)*(APC*CPC-BPC*DPC)+
     $         (-A*D+B*C)*(APC*DPC+BPC*CPC)))/
     $         (S23-AMSS3(J)**2)/(S12-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.3.AND.PTYPE2.EQ.4.AND.KIN(3).AND.KINP(4)) THEN
          MMPD=((8*D13*D23+4*D23*AM1SQ)*((A*C+B*D)*(APC*CPC+BPC*DPC)+
     $         (A*D+B*C)*(APC*DPC+BPC*CPC))+
     $         4*D23*SQRT(AM0SQ*AM1SQ)*((A*C+B*D)*(APC*CPC-BPC*DPC)+
     $         (A*D+B*C)*(APC*DPC-BPC*CPC)))/
     $         (S13-AMSS3(J)**2)/(S23-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.2.AND.PTYPE2.EQ.4.AND.KIN(2).AND.KINP(4)) THEN
          MMPD=-((8*D12*D23+4*D23*AM1SQ)*((A*C+B*D)*(APC*CPC+BPC*DPC)+
     $         (A*D+B*C)*(APC*DPC+BPC*CPC))+
     $         4*D23*SQRT(AM0SQ*AM1SQ)*((A*C+B*D)*(APC*CPC-BPC*DPC)+
     $         (A*D+B*C)*(APC*DPC-BPC*CPC)))/
     $         (S12-AMSS3(J)**2)/(S23-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
         IF (PTYPE1.EQ.2.AND.PTYPE2.EQ.3.AND.KIN(2).AND.KINP(3)) THEN
          MMPD=((8*D12*D13-4*D23*AM1SQ)*((A*C+B*D)*(APC*CPC+BPC*DPC)+
     $         (A*D+B*C)*(APC*DPC+BPC*CPC))-
     $         4*D23*SQRT(AM0SQ*AM1SQ)*((A*C-B*D)*(APC*CPC-BPC*DPC)+
     $         (A*D-B*C)*(APC*DPC-BPC*CPC)))/
     $         (S12-AMSS3(J)**2)/(S13-AMSS3(JP)**2)
          MSQ=2*REAL(MMPD)
         END IF
        END IF
        DECSS3=DECSS3+MSQ
       END DO
      END DO
C
      RETURN
      END
+EOD
+DECK,DECTAU
      LOGICAL FUNCTION DECTAU(IP,NADD,MEIP,IDABS,PREST)
C
C          Compute matrix elements for polarized tau decay.
C          Polarization determined by tau parent.
C          Auxiliary routine for DECAY. 
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,WCON
+CDE,PARTCL
+CDE,DKYTAB
+CDE,CONST
+CDE,PJETS
+CDE,KEYS
+CDE,XMSSM
+CDE,SSPOLS
+CDE,PRIMAR
C
      REAL PREST(4,6),WT,TAUHEL,S12,S12MAX,PIP,CTHNU,PSUM(4),AMV2,WT1
      REAL DOT,DOT3,RANF,Z
      INTEGER IP,NADD,IDABS(5),IPAR,IDPAR,JET,INU,I,K,I1,I2,IDSIB
      INTEGER IDLV1,IFL1,IFL2,IFL3,JSPIN,INDEX,IDIP
      INTEGER MEIP,IPX,IP1,IP2
C
      DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2)
     $-PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2)
      DOT3(I1,I2)=PREST(1,I1)*PREST(1,I2)+PREST(2,I1)*PREST(2,I2)
     $+PREST(3,I1)*PREST(3,I2)
C
      IDIP=IDENT(IP)
      DECTAU=.TRUE.
      IF(IABS(IDIP).NE.16) GO TO 999
C
C          Use PREST(K,6) for spin vector
C
      PIP=SQRT(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(3,IP)**2)
      DO 100 K=1,3
        PREST(K,6)=PPTCL(K,IP)/PIP
100   CONTINUE
      PREST(4,6)=0.
C
C          Take helicity TAUHEL=0 unless TAU parent is TP, W+-, H+-,
C          or some SUSY particles.
C          Take account of 1-particle decays!
C
      IPX=IP
      TAUHEL=0.
      IPAR=0
      IDPAR=0
110   IF(IORIG(IPX).GT.0) THEN
        IPAR=MOD(IORIG(IPX),IPACK)
        IDPAR=IDENT(IPAR)
        IF(IDPAR.EQ.IDIP) THEN
          IP1=IDCAY(IPAR)/IPACK
          IP2=MOD(IDCAY(IPAR),IPACK)
          IF(IP1.EQ.IP2) THEN
            IPX=IPAR
            GO TO 110
          ENDIF
        ENDIF
        IDPAR=IABS(IDPAR)
        IDSIB=0
C          W/top parent
        IF((IDPAR.GE.6.AND.IDPAR.LE.8).OR.
     $  (IDPAR.GT.100.AND.MOD(IDPAR/10,10).GE.6)) THEN
          TAUHEL=-1.
        ELSEIF(IDPAR.EQ.80) THEN
          TAUHEL=-1.
C          Charged Higgs parent
        ELSEIF(IDPAR.EQ.86) THEN
          TAUHEL=+1.
C          SUSY parent - polarization also depends on sibling IDSIB
        ELSEIF(GOMSSM.AND.IDPAR.GT.20.AND.IDPAR.LT.80) THEN
          I1=IDCAY(IPAR)/IPACK
          I2=MOD(IDCAY(IPAR),IPACK)
          DO 120 I=I1,I2
            IF(IABS(IDENT(I)).GT.20.AND.IABS(IDENT(I)).LT.80)
     $      IDSIB=IABS(IDENT(I))
120       CONTINUE
          IF (IDPAR.EQ.35) THEN
            TAUHEL=-1.
          ELSEIF (IDPAR.EQ.36) THEN
            IF (IDSIB.EQ.30) TAUHEL=PTAU1(1)
            IF (IDSIB.EQ.40) TAUHEL=PTAU1(2)
            IF (IDSIB.EQ.50) TAUHEL=PTAU1(3)
            IF (IDSIB.EQ.60) TAUHEL=PTAU1(4)
          ELSEIF (IDPAR.EQ.56) THEN
            IF (IDSIB.EQ.30) TAUHEL=PTAU2(1)
            IF (IDSIB.EQ.40) TAUHEL=PTAU2(2)
            IF (IDSIB.EQ.50) TAUHEL=PTAU2(3)
            IF (IDSIB.EQ.60) TAUHEL=PTAU2(4)
          ELSEIF (IDPAR.EQ.39) THEN
            IF(IDSIB.EQ.35) TAUHEL=-1.
            IF(IDSIB.EQ.30) TAUHEL=PTAUWZ
          ELSEIF (IDPAR.EQ.49.AND.IDSIB.EQ.35) THEN
            TAUHEL=-1.
          ELSEIF (IDPAR.EQ.40) THEN
            IF(IDSIB.EQ.36) TAUHEL=PTAUZ2(1)
            IF(IDSIB.EQ.56) TAUHEL=PTAUZ2(2)
            IF(IDSIB.EQ.30) TAUHEL=PTAUZZ
          ELSEIF (IDPAR.EQ.50) THEN
            IF(IDSIB.EQ.36) TAUHEL=PTAUZ3(1)
            IF(IDSIB.EQ.56) TAUHEL=PTAUZ3(2)
          ELSEIF (IDPAR.EQ.60) THEN 
            IF(IDSIB.EQ.36) TAUHEL=PTAUZ4(1)
            IF(IDSIB.EQ.56) TAUHEL=PTAUZ4(2)
          ENDIF
        END IF
      ELSE
        IF(KEYS(3)) THEN
          IF(IABS(IDENTW).EQ.80) TAUHEL=-1.
        ELSE
          JET=IABS(IORIG(IP))/IPACK
          IF(JET.GT.0.AND.JET.LE.NJET) THEN
            IF(IDJETS(JET).EQ.80) TAUHEL=-1.
          ENDIF
        ENDIF
      ENDIF
C
C          If NOTAU, just return .TRUE. for TAUL, .FALSE. for TAUR
C
      IF(MEIP.EQ.8) THEN
        IF(RANF().LT.(TAUHEL+1)/2) THEN
          DECTAU=.FALSE.
        ELSE
          DECTAU=.TRUE.
        ENDIF
        RETURN
      ENDIF
C
C          Leptonic decays. DECTAU is always called for TAU- decay
C          products, so selection is independent of IDENT(IP).
C
      IF(MEIP.EQ.5) THEN
        IF(IDENT(NPTCL+1).LT.0) THEN
          WT=PPTCL(5,IP)*(PREST(4,1)-TAUHEL*DOT(1,6))*DOT(2,3)
        ELSEIF(IDENT(NPTCL+2).LT.0) THEN
          WT=PPTCL(5,IP)*(PREST(4,2)-TAUHEL*DOT(2,6))*DOT(1,3)
        ELSE
          WT=PPTCL(5,IP)*(PREST(4,3)-TAUHEL*DOT(3,6))*DOT(1,2)
        ENDIF
        IF(WT.LT.RANF()*PPTCL(5,IP)**4/8.) THEN
          DECTAU=.FALSE.
        ELSE
          DECTAU=.TRUE.
        ENDIF
        RETURN
C
C          Decay to PI + NUT, K + NUT
C
      ELSEIF(MEIP.EQ.6) THEN
        INU=1
        IF(IDABS(2).EQ.15) INU=2
        CTHNU=DOT3(INU,6)/SQRT(DOT3(INU,INU))
        WT=1.-TAUHEL*CTHNU
        IF(WT.LT.RANF()*2.) THEN
          DECTAU=.FALSE.
        ELSE
          DECTAU=.TRUE.
        ENDIF
        RETURN
C
C          Decay to RHO + NUT, A1 + NUT, K* + NUT
C
      ELSEIF(MEIP.EQ.7) THEN
        DO 210 I=1,NADD
210     IF(IDABS(I).EQ.15) INU=I
        DO 220 K=1,4
          PSUM(K)=0.
          DO 221 I=1,NADD
            IF(I.EQ.INU) GO TO 221
            PSUM(K)=PSUM(K)+PREST(K,I)
221       CONTINUE
220     CONTINUE
        AMV2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
        WT1=2.*AMV2/(2.*AMV2+PPTCL(5,IP)**2)
        CTHNU=DOT3(INU,6)/SQRT(DOT3(INU,INU))
        WT=WT1*(1.+TAUHEL*CTHNU)+(1.-WT1)*(1-TAUHEL*CTHNU)
        IF(WT.LT.RANF()*2.) THEN
          DECTAU=.FALSE.
        ELSE
          DECTAU=.TRUE.
        ENDIF
        RETURN
C
C          Ignore matrix element for all other decays
C
      ELSE
        DECTAU=.TRUE.
        RETURN
      ENDIF
C
C          Error
C
999   CALL PRTEVT(0)
      WRITE(ITLIS,99999) IP
99999 FORMAT(//5X,'ERROR IN DECTAU FOR PARTICLE',I6)
      END
+EOD
+DECK,DECVA
      LOGICAL FUNCTION DECVA(IP,NADD,IDABS,PREST)
C
C          Compute matrix element unpolarized for V-A.
C          Auxiliary routine for DECAY. 
C
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,WCON
+CDE,PARTCL
+CDE,DKYTAB
+CDE,JETSET
+CDE,JWORK
+CDE,CONST
+CDE,KEYS
+CDE,PJETS
+CDE,XMSSM
+CDE,SSPOLS
C
      REAL PREST(4,6)
      REAL DOT,RANF,WT
      INTEGER IP,NADD,IDABS(5),I,K,I1,I2,IDIPA
C
      DOT(I1,I2)=PREST(4,I1)*PREST(4,I2)-PREST(1,I1)*PREST(1,I2)
     $-PREST(2,I1)*PREST(2,I2)-PREST(3,I1)*PREST(3,I2)
C
      IDIPA=IABS(IDENT(IP))
      IF(IDENT(NPTCL+1).LT.0) THEN
        WT=PPTCL(5,IP)*PREST(4,1)*DOT(2,3)
      ELSEIF(IDENT(NPTCL+2).LT.0) THEN
        WT=PPTCL(5,IP)*PREST(4,2)*DOT(1,3)
      ELSE
        WT=PPTCL(5,IP)*PREST(4,3)*DOT(1,2)
      ENDIF
      IF(WT.LT.RANF()*PPTCL(5,IP)**4/16.) THEN
        DECVA=.FALSE.
      ELSE
        DECVA=.TRUE.
      ENDIF
      RETURN
      END
+EOD
+DECK,DHELAS
C  *********************************************************************
C  ***                                                               ***
C  ***               coded by H. Murayama & I. Watanabe              ***
C  *** For the formalism and notations, see the following reference: ***
C  ***           H. Murayama, I. Watanabe and K. Hagiwara            ***
C  ***           "HELAS: HELicity Amplitude Subroutines              ***
C  ***               for Feynman diagram evaluation"                 ***
C  ***               KEK Report 91-11, December 1991                 ***
C  ***                                                               ***
C  *********************************************************************
C
C  Converted to double precision by W. Long and T. Seltzer for MadGraph.
C
C  Minor changes for portability by FEP, July 1999. The code is not ANSI
C  standard, but that cannot be helped if MadGraph compatibility is to 
C  be maintained.
C
C ======================================================================
C
      SUBROUTINE BOOSTX(P,Q , PBOOST)
C
C this subroutine performs the lorentz boost of a four-momentum.  the   
C momentum p is assumed to be given in the rest frame of q.  pboost is  
C the momentum p boosted to the frame in which q is given.  q must be a 
C timelike momentum.                                                    
C                                                                       
C input:                                                                
C       real    p(0:3)         : four-momentum p in the q rest  frame   
C       real    q(0:3)         : four-momentum q in the boosted frame   
C                                                                       
C output:                                                               
C       real    pboost(0:3)    : four-momentum p in the boosted frame   
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8    P(0:3),Q(0:3),PBOOST(0:3),PQ,QQ,M,LF
      REAL*8 RXZERO
      PARAMETER( RXZERO=0.0D0 )
C
      QQ=Q(1)**2+Q(2)**2+Q(3)**2
C
      IF ( QQ .NE. RXZERO ) THEN
         PQ=P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3)
         M=SQRT(Q(0)**2-QQ)
         LF=((Q(0)-M)*PQ/QQ+P(0))/M
         PBOOST(0) = (P(0)*Q(0)+PQ)/M
         PBOOST(1) =  P(1)+Q(1)*LF
         PBOOST(2) =  P(2)+Q(2)*LF
         PBOOST(3) =  P(3)+Q(3)*LF
      ELSE
         PBOOST(0)=P(0)
         PBOOST(1)=P(1)
         PBOOST(2)=P(2)
         PBOOST(3)=P(3)
      ENDIF
C
      RETURN
      END
C
C **********************************************************************
C
      SUBROUTINE COUP1X(SW2 , GW,GWWA,GWWZ)
C
C this subroutine sets up the coupling constants of the gauge bosons in 
C the standard model.                                                   
C                                                                       
C input:                                                                
C       real    sw2            : square of sine of the weak angle       
C                                                                       
C output:                                                               
C       real    gw             : weak coupling constant                 
C       real    gwwa           : dimensionless coupling of w-,w+,a      
C       real    gwwz           : dimensionless coupling of w-,w+,z      
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8    SW2,GW,GWWA,GWWZ,ALPHA,FOURPI,EE,SW,CW
      REAL*8 RXONE, RXFOUR, RXOTE, RXPI, RIALPH
      PARAMETER( RXONE=1.0D0, RXFOUR=4.0D0, RXOTE=128.0D0 )
      PARAMETER( RXPI=3.14159265358979323846D0, RIALPH=137.0359895D0 )
C
      ALPHA = RXONE / RXOTE
C      alpha = r_one / r_ialph
      FOURPI = RXFOUR * RXPI
      EE=SQRT( ALPHA * FOURPI )
      SW=SQRT( SW2 )
      CW=SQRT( RXONE - SW2 )
C
      GW    =  EE/SW
      GWWA  =  EE
      GWWZ  =  EE*CW/SW
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE COUP2X(SW2 , GAL,GAU,GAD,GWF,GZN,GZL,GZU,GZD,G1)
C
C this subroutine sets up the coupling constants for the fermion-       
C fermion-vector vertices in the standard model.  the array of the      
C couplings specifies the chirality of the flowing-in fermion.  g??(1)  
C denotes a left-handed coupling, and g??(2) a right-handed coupling.   
C                                                                       
C input:                                                                
C       real    sw2            : square of sine of the weak angle       
C                                                                       
C output:                                                               
C       real    gal(2)         : coupling with a of charged leptons     
C       real    gau(2)         : coupling with a of up-type quarks      
C       real    gad(2)         : coupling with a of down-type quarks    
C       real    gwf(2)         : coupling with w-,w+ of fermions        
C       real    gzn(2)         : coupling with z of neutrinos           
C       real    gzl(2)         : coupling with z of charged leptons     
C       real    gzu(2)         : coupling with z of up-type quarks      
C       real    gzd(2)         : coupling with z of down-type quarks    
C       real    g1(2)          : unit coupling of fermions              
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8 GAL(2),GAU(2),GAD(2),GWF(2),GZN(2),GZL(2),GZU(2),GZD(2),
     &     G1(2),SW2,ALPHA,FOURPI,EE,SW,CW,EZ,EY
C
      REAL*8 RXZERO, RXHALF, RXONE, RXTWO, RTHREE, RXFOUR, RXOTE
      REAL*8 RXPI, RIALPH
      PARAMETER( RXZERO=0.0D0, RXHALF=0.5D0, RXONE=1.0D0, RXTWO=2.0D0,
     $     RTHREE=3.0D0 )
      PARAMETER( RXFOUR=4.0D0, RXOTE=128.0D0 )
      PARAMETER( RXPI=3.14159265358979323846D0, RIALPH=137.0359895D0 )
C
      ALPHA = RXONE / RXOTE
C      alpha = r_one / r_ialph
      FOURPI = RXFOUR * RXPI
      EE=SQRT( ALPHA * FOURPI )
      SW=SQRT( SW2 )
      CW=SQRT( RXONE - SW2 )
      EZ=EE/(SW*CW)
      EY=EE*(SW/CW)
C
      GAL(1) =  EE
      GAL(2) =  EE
      GAU(1) = -EE*RXTWO/RTHREE
      GAU(2) = -EE*RXTWO/RTHREE
      GAD(1) =  EE   /RTHREE
      GAD(2) =  EE   /RTHREE
      GWF(1) = -EE/SQRT(RXTWO*SW2)
      GWF(2) =  RXZERO
      GZN(1) = -EZ*  RXHALF
      GZN(2) =  RXZERO
      GZL(1) = -EZ*(-RXHALF+SW2)
      GZL(2) = -EY
      GZU(1) = -EZ*( RXHALF-SW2*RXTWO/RTHREE)
      GZU(2) =  EY*          RXTWO/RTHREE
      GZD(1) = -EZ*(-RXHALF+SW2   /RTHREE)
      GZD(2) = -EY             /RTHREE
      G1(1)  =  RXONE
      G1(2)  =  RXONE
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE COUP3X(SW2,ZMASS,HMASS , 
     &                  GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH)
C
C this subroutine sets up the coupling constants of the gauge bosons and
C higgs boson in the standard model.                                    
C                                                                       
C input:                                                                
C       real    sw2            : square of sine of the weak angle       
C       real    zmass          : mass of z                              
C       real    hmass          : mass of higgs                          
C                                                                       
C output:                                                               
C       real    gwwh           : dimensionful  coupling of w-,w+,h      
C       real    gzzh           : dimensionful  coupling of z, z, h      
C       real    ghhh           : dimensionful  coupling of h, h, h      
C       real    gwwhh          : dimensionful  coupling of w-,w+,h, h   
C       real    gzzhh          : dimensionful  coupling of z, z, h, h   
C       real    ghhhh          : dimensionless coupling of h, h, h, h   
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8    SW2,ZMASS,HMASS,GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH,
     &        ALPHA,FOURPI,EE2,SC2,V
C
      REAL*8 RXHALF, RXONE, RXTWO, RTHREE, RXFOUR, RXOTE
      REAL*8 RXPI, RIALPH
      PARAMETER( RXHALF=0.5D0, RXONE=1.0D0, RXTWO=2.0D0, RTHREE=3.0D0 )
      PARAMETER( RXFOUR=4.0D0, RXOTE=128.0D0 )
      PARAMETER( RXPI=3.14159265358979323846D0, RIALPH=137.0359895D0 )
C
      ALPHA = RXONE / RXOTE
C      alpha = r_one / r_ialph
      FOURPI = RXFOUR * RXPI
      EE2=ALPHA*FOURPI
      SC2=SW2*( RXONE - SW2 )
      V = RXTWO * ZMASS*SQRT(SC2)/SQRT(EE2)
C
      GWWH  =   EE2/SW2*RXHALF*V
      GZZH  =   EE2/SC2*RXHALF*V
      GHHH  =  -HMASS**2/V*RTHREE
      GWWHH =   EE2/SW2*RXHALF
      GZZHH =   EE2/SC2*RXHALF
      GHHHH = -(HMASS/V)**2*RTHREE
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE COUP4X(SW2,ZMASS,FMASS , GCHF)
C
C This subroutine sets up the coupling constant for the fermion-fermion-
C Higgs vertex in the STANDARD MODEL.  The coupling is COMPLEX and the  
C array of the coupling specifies the chirality of the flowing-IN       
C fermion.  GCHF(1) denotes a left-handed coupling, and GCHF(2) a right-
C handed coupling.                                                      
C                                                                       
C INPUT:                                                                
C       real    SW2            : square of sine of the weak angle       
C       real    ZMASS          : Z       mass                           
C       real    FMASS          : fermion mass                           
C                                                                       
C OUTPUT:                                                               
C       complex GCHF(2)        : coupling of fermion and Higgs          
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 GCHF(2)
      REAL*8    SW2,ZMASS,FMASS,ALPHA,FOURPI,EZ,G
C
      ALPHA=1.D0/128.D0
C      ALPHA=1./REAL(137.0359895)
      FOURPI=4.D0*3.14159265358979323846D0
      EZ=SQRT(ALPHA*FOURPI)/SQRT(SW2*(1.D0-SW2))
      G=EZ*FMASS*0.5D0/ZMASS
C
      GCHF(1) = DCMPLX( -G )
      GCHF(2) = DCMPLX( -G )
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE EAIXXX(EB,EA,SHLF,CHLF,PHI,NHE,NHA , EAI)
C
C This subroutine computes an off-shell electron wavefunction after     
C emitting a photon from the electron beam, with a special care for the 
C small angle region.  The momenta are measured in the laboratory frame,
C where the e- beam is along the positive z axis.                       
C                                                                       
C INPUT:                                                                
C       real    EB             : energy (GeV)    of beam  e-            
C       real    EA             : energy (GeV)    of final photon        
C       real    SHLF           : sin(theta/2)    of final photon        
C       real    CHLF           : cos(theta/2)    of final photon        
C       real    PHI            : azimuthal angle of final photon        
C       integer NHE  = -1 or 1 : helicity        of beam  e-            
C       integer NHA  = -1 or 1 : helicity        of final photon        
C                                                                       
C OUTPUT:                                                               
C       complex EAI(6)         : off-shell electron             |e',A,e>
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 EAI(6),PHS
      REAL*8  EB,EA,SHLF,CHLF,PHI,ME,ALPHA,GAL,RNHE,X,C,S,D,COEFF,
     &        XNNP,XNNM,SNP,CSP
      INTEGER NHE,NHA,NN
C
      ME   = 0.51099906D-3
      ALPHA=1./128.
      GAL  =SQRT(ALPHA*4.*3.14159265D0)
C
      NN=NHA*NHE
      RNHE=NHE
      X=EA/EB
      C=(CHLF+SHLF)*(CHLF-SHLF)
      S=2.*CHLF*SHLF
      D=-1./(EA*EB*(4.*SHLF**2+(ME/EB)**2*C))
      COEFF=-NN*GAL*SQRT(EB)*D
      XNNP=X*(1+NN)
      XNNM=X*(1-NN)
      SNP=SIN(PHI)
      CSP=COS(PHI)
      PHS=DCMPLX( CSP , RNHE*SNP )
C
      EAI((5-3*NHE)/2) = -RNHE*COEFF*ME*S*(1.+XNNP*.5)
      EAI((5-NHE)/2)   =  XNNP*COEFF*ME*CHLF**2*PHS
      EAI((5+NHE)/2)   =  RNHE*COEFF*EB*S*(-2.+XNNM)
      EAI((5+3*NHE)/2) =  XNNM*COEFF*EB*SHLF**2*PHS*2.
C
      EAI(5) =  EB*DCMPLX( 1.-X , 1.-X*C )
      EAI(6) = -EB*X*S*DCMPLX( CSP , SNP )
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE EAOXXX(EB,EA,SHLF,CHLF,PHI,NHE,NHA , EAO)
C
C This subroutine computes an off-shell positron wavefunction after     
C emitting a photon from the positron beam, with a special care for the 
C small angle region.  The momenta are measured in the laboratory frame,
C where the e+ beam is along the negative z axis.                       
C                                                                       
C INPUT:                                                                
C       real    EB             : energy (GeV)    of beam  e+            
C       real    EA             : energy (GeV)    of final photon        
C       real    SHLF           : sin(theta/2)    of final photon        
C       real    CHLF           : cos(theta/2)    of final photon        
C       real    PHI            : azimuthal angle of final photon        
C       integer NHE  = -1 or 1 : helicity        of beam  e+            
C       integer NHA  = -1 or 1 : helicity        of final photon        
C                                                                       
C OUTPUT:                                                               
C       complex EAO(6)         : off-shell positron             <e,A,e'|
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 EAO(6),PHS
      REAL*8  EB,EA,SHLF,CHLF,PHI,ME,ALPHA,GAL,RNHE,X,C,S,D,COEFF,
     &        XNNP,XNNM,SNP,CSP
      INTEGER NHE,NHA,NN
C
      ME   = 0.51099906D-3
      ALPHA=1./128.
      GAL  =SQRT(ALPHA*4.*3.14159265D0)
C
      NN=NHA*NHE
      RNHE=NHE
      X=EA/EB
      C=(CHLF+SHLF)*(CHLF-SHLF)
      S=2.*CHLF*SHLF
      D=-1./(EA*EB*(4.*CHLF**2-(ME/EB)**2*C))
      COEFF=NN*GAL*SQRT(EB)*D
      XNNP=X*(1+NN)
      XNNM=X*(1-NN)
      SNP=SIN(PHI)
      CSP=COS(PHI)
      PHS=DCMPLX( CSP ,-RNHE*SNP )
C
      EAO((5-3*NHE)/2) =              COEFF*ME*S*(1.+XNNP*.5)
      EAO((5-NHE)/2)   = RNHE*XNNP    *COEFF*ME*SHLF**2*PHS
      EAO((5+NHE)/2)   =              COEFF*EB*S*(-2.+XNNM)
      EAO((5+3*NHE)/2) = REAL(NHA-NHE)*COEFF*EB*X*CHLF**2*PHS*2.
C
      EAO(5) = EB*DCMPLX( X-1. , X*C+1. )
      EAO(6) = EB*X*S*DCMPLX( CSP , SNP )
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE FSIXXX(FI,SC,GC,FMASS,FWIDTH , FSI)
C
C this subroutine computes an off-shell fermion wavefunction from a     
C flowing-in external fermion and a vector boson.                       
C                                                                       
C input:                                                                
C       complex*16 fi(6)          : flow-in  fermion                   |fi>
C       complex*16 sc(3)          : input    scalar                      s 
C       complex*16 gc(2)          : coupling constants                 gchf
C       real*8    fmass          : mass  of output fermion f'             
C       real*8    fwidth         : width of output fermion f'             
C                                                                       
C output:                                                               
C       complex fsi(6)         : off-shell fermion             |f',s,fi>
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),SC(3),FSI(6),GC(2),SL1,SL2,SR1,SR2,DS
      REAL*8     PF(0:3),FMASS,FWIDTH,PF2,P0P3,P0M3
C
      FSI(5) = FI(5)-SC(2)
      FSI(6) = FI(6)-SC(3)
C
      PF(0)=DBLE( FSI(5))
      PF(1)=DBLE( FSI(6))
      PF(2)=DIMAG(FSI(6))
      PF(3)=DIMAG(FSI(5))
      PF2=PF(0)**2-(PF(1)**2+PF(2)**2+PF(3)**2)
C
      DS=-SC(1)/DCMPLX(PF2-FMASS**2,MAX(DSIGN(FMASS*FWIDTH ,PF2),0D0))
      P0P3=PF(0)+PF(3)
      P0M3=PF(0)-PF(3)
      SL1=GC(1)*(P0P3*FI(1)+DCONJG(FSI(6))*FI(2))
      SL2=GC(1)*(P0M3*FI(2)      +FSI(6) *FI(1))
      SR1=GC(2)*(P0M3*FI(3)-DCONJG(FSI(6))*FI(4))
      SR2=GC(2)*(P0P3*FI(4)      -FSI(6) *FI(3))
C
      FSI(1) = ( GC(1)*FMASS*FI(1) + SR1 )*DS
      FSI(2) = ( GC(1)*FMASS*FI(2) + SR2 )*DS
      FSI(3) = ( GC(2)*FMASS*FI(3) + SL1 )*DS
      FSI(4) = ( GC(2)*FMASS*FI(4) + SL2 )*DS
C
      RETURN          
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE FSOXXX(FO,SC,GC,FMASS,FWIDTH , FSO)
C
C this subroutine computes an off-shell fermion wavefunction from a     
C flowing-out external fermion and a vector boson.                      
C                                                                       
C input:                                                                
C       complex*16 fo(6)          : flow-out fermion                   <fo|
C       complex*16 sc(6)          : input    scalar                      s 
C       complex*16 gc(2)          : coupling constants                 gchf
C       real*8     fmass          : mass  of output fermion f'             
C       real*8     fwidth         : width of output fermion f'             
C                                                                       
C output:                                                               
C       complex fso(6)         : off-shell fermion             <fo,s,f'|
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FO(6),SC(6),FSO(6),GC(2),SL1,SL2,SR1,SR2,DS
      REAL*8     PF(0:3),FMASS,FWIDTH,PF2,P0P3,P0M3
C
      FSO(5) = FO(5)+SC(2)
      FSO(6) = FO(6)+SC(3)
C
      PF(0)=DBLE( FSO(5))
      PF(1)=DBLE( FSO(6))
      PF(2)=DIMAG(FSO(6))
      PF(3)=DIMAG(FSO(5))
      PF2=PF(0)**2-(PF(1)**2+PF(2)**2+PF(3)**2)
C
      DS=-SC(1)/DCMPLX(PF2-FMASS**2,MAX(DSIGN(FMASS*FWIDTH ,PF2),0D0))
      P0P3=PF(0)+PF(3)
      P0M3=PF(0)-PF(3)
      SL1=GC(2)*(P0P3*FO(3)      +FSO(6) *FO(4))
      SL2=GC(2)*(P0M3*FO(4)+DCONJG(FSO(6))*FO(3))
      SR1=GC(1)*(P0M3*FO(1)      -FSO(6) *FO(2))
      SR2=GC(1)*(P0P3*FO(2)-DCONJG(FSO(6))*FO(1))
C
      FSO(1) = ( GC(1)*FMASS*FO(1) + SL1 )*DS
      FSO(2) = ( GC(1)*FMASS*FO(2) + SL2 )*DS
      FSO(3) = ( GC(2)*FMASS*FO(3) + SR1 )*DS
      FSO(4) = ( GC(2)*FMASS*FO(4) + SR2 )*DS
C
      RETURN          
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE FVIXXX(FI,VC,G,FMASS,FWIDTH , FVI)
C
C this subroutine computes an off-shell fermion wavefunction from a     
C flowing-in external fermion and a vector boson.                       
C                                                                       
C input:                                                                
C       complex fi(6)          : flow-in  fermion                   |fi>
C       complex vc(6)          : input    vector                      v 
C       real    g(2)           : coupling constants                  gvf
C       real    fmass          : mass  of output fermion f'             
C       real    fwidth         : width of output fermion f'             
C                                                                       
C output:                                                               
C       complex fvi(6)         : off-shell fermion             |f',v,fi>
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),VC(6),FVI(6),SL1,SL2,SR1,SR2,D
      REAL*8    G(2),PF(0:3),FMASS,FWIDTH,PF2
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
      COMPLEX*16 CXIMAG
C
      LOGICAL FIRST
      SAVE CXIMAG,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXIMAG=DCMPLX( RXZERO, RXONE )
      ENDIF
C
      FVI(5) = FI(5)-VC(5)
      FVI(6) = FI(6)-VC(6)
C
      PF(0)=DBLE( FVI(5))
      PF(1)=DBLE( FVI(6))
      PF(2)=DIMAG(FVI(6))
      PF(3)=DIMAG(FVI(5))
      PF2=PF(0)**2-(PF(1)**2+PF(2)**2+PF(3)**2)
C
      D=-RXONE/DCMPLX( PF2-FMASS**2,MAX(SIGN(FMASS*FWIDTH,PF2),RXZERO))
      SL1= (VC(1)+       VC(4))*FI(1)
     &    +(VC(2)-CXIMAG*VC(3))*FI(2)
      SL2= (VC(2)+CXIMAG*VC(3))*FI(1)
     &    +(VC(1)-       VC(4))*FI(2)
C
      IF ( G(2) .NE. RXZERO ) THEN
         SR1= (VC(1)-       VC(4))*FI(3)
     &       -(VC(2)-CXIMAG*VC(3))*FI(4)
         SR2=-(VC(2)+CXIMAG*VC(3))*FI(3)
     &       +(VC(1)+       VC(4))*FI(4)
C
         FVI(1) = ( G(1)*((PF(0)-PF(3))*SL1 -DCONJG(FVI(6))*SL2)
     &             +G(2)*FMASS*SR1)*D
         FVI(2) = ( G(1)*(      -FVI(6)*SL1 +(PF(0)+PF(3))*SL2)
     &             +G(2)*FMASS*SR2)*D
         FVI(3) = ( G(2)*((PF(0)+PF(3))*SR1 +DCONJG(FVI(6))*SR2)
     &             +G(1)*FMASS*SL1)*D
         FVI(4) = ( G(2)*(       FVI(6)*SR1 +(PF(0)-PF(3))*SR2)
     &             +G(1)*FMASS*SL2)*D
C
      ELSE          
         FVI(1) = G(1)*((PF(0)-PF(3))*SL1 -DCONJG(FVI(6))*SL2)*D
         FVI(2) = G(1)*(      -FVI(6)*SL1 +(PF(0)+PF(3))*SL2)*D
         FVI(3) = G(1)*FMASS*SL1*D
         FVI(4) = G(1)*FMASS*SL2*D
      END IF
C
      RETURN          
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE FVOXXX(FO,VC,G,FMASS,FWIDTH , FVO)
C
C this subroutine computes an off-shell fermion wavefunction from a     
C flowing-out external fermion and a vector boson.                      
C                                                                       
C input:                                                                
C       complex fo(6)          : flow-out fermion                   <fo|
C       complex vc(6)          : input    vector                      v 
C       real    g(2)           : coupling constants                  gvf
C       real    fmass          : mass  of output fermion f'             
C       real    fwidth         : width of output fermion f'             
C                                                                       
C output:                                                               
C       complex fvo(6)         : off-shell fermion             <fo,v,f'|
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FO(6),VC(6),FVO(6),SL1,SL2,SR1,SR2,D
      REAL*8    G(2),PF(0:3),FMASS,FWIDTH,PF2
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
      COMPLEX*16 CXIMAG
      LOGICAL FIRST
      SAVE CXIMAG,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXIMAG=DCMPLX( RXZERO, RXONE )
      ENDIF
C
      FVO(5) = FO(5)+VC(5)
      FVO(6) = FO(6)+VC(6)
C
      PF(0)=DBLE( FVO(5))
      PF(1)=DBLE( FVO(6))
      PF(2)=DIMAG(FVO(6))
      PF(3)=DIMAG(FVO(5))
      PF2=PF(0)**2-(PF(1)**2+PF(2)**2+PF(3)**2)
C
      D=-RXONE/DCMPLX( PF2-FMASS**2,MAX(SIGN(FMASS*FWIDTH,PF2),RXZERO))
      SL1= (VC(1)+       VC(4))*FO(3)
     &    +(VC(2)+CXIMAG*VC(3))*FO(4)
      SL2= (VC(2)-CXIMAG*VC(3))*FO(3)
     &    +(VC(1)-       VC(4))*FO(4)
C
      IF ( G(2) .NE. RXZERO ) THEN
         SR1= (VC(1)-       VC(4))*FO(1)
     &       -(VC(2)+CXIMAG*VC(3))*FO(2)
         SR2=-(VC(2)-CXIMAG*VC(3))*FO(1)
     &       +(VC(1)+       VC(4))*FO(2)
C
         FVO(1) = ( G(2)*( (PF(0)+PF(3))*SR1        +FVO(6)*SR2)
     &             +G(1)*FMASS*SL1)*D
         FVO(2) = ( G(2)*( DCONJG(FVO(6))*SR1 +(PF(0)-PF(3))*SR2)
     &             +G(1)*FMASS*SL2)*D
         FVO(3) = ( G(1)*( (PF(0)-PF(3))*SL1        -FVO(6)*SL2)
     &             +G(2)*FMASS*SR1)*D
         FVO(4) = ( G(1)*(-DCONJG(FVO(6))*SL1 +(PF(0)+PF(3))*SL2)
     &             +G(2)*FMASS*SR2)*D
C
      ELSE
         FVO(1) = G(1)*FMASS*SL1*D
         FVO(2) = G(1)*FMASS*SL2*D
         FVO(3) = G(1)*( (PF(0)-PF(3))*SL1        -FVO(6)*SL2)*D
         FVO(4) = G(1)*(-DCONJG(FVO(6))*SL1 +(PF(0)+PF(3))*SL2)*D
      END IF
C
      RETURN          
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE GGGGXX(WM,W31,WP,W32,G, VERTEX)
C
C this subroutine computes an amplitude of the four-point coupling of   
C the w-, w+ and two w3/z/a.  the amplitude includes the contributions  
C of w exchange diagrams.  the internal w propagator is given in unitary
C gauge.  if one sets wmass=0.0, then the gggg vertex is given (see sect
C 2.9.1 of the manual).
C                                                                       
C input:                                                                
C       complex wm(0:3)        : flow-out w-                         wm 
C       complex w31(0:3)       : first    w3/z/a                     w31
C       complex wp(0:3)        : flow-out w+                         wp 
C       complex w32(0:3)       : second   w3/z/a                     w32
C       real    g              : coupling of w31 with w-/w+             
C                                                  (see the table below)
C                                                                       
C the possible sets of the inputs are as follows:                       
C   -------------------------------------------                         
C   |  wm  |  w31 |  wp  |  w32 |  g31 |  g32 |                         
C   -------------------------------------------                         
C   |  w-  |  w3  |  w+  |  w3  |  gw  |  gw  |                         
C   |  w-  |  w3  |  w+  |  z   |  gw  | gwwz |                         
C   |  w-  |  w3  |  w+  |  a   |  gw  | gwwa |                         
C   |  w-  |  z   |  w+  |  z   | gwwz | gwwz |                         
C   |  w-  |  z   |  w+  |  a   | gwwz | gwwa |                         
C   |  w-  |  a   |  w+  |  a   | gwwa | gwwa |                         
C   -------------------------------------------                         
C where all the bosons are defined by the flowing-out quantum number.   
C                                                                       
C output:                                                               
C       complex vertex         : amplitude          gamma(wm,w31,wp,w32)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16    WM(6),W31(6),WP(6),W32(6),VERTEX
      COMPLEX*16 DV1(0:3),DV2(0:3),DV3(0:3),DV4(0:3),
     &           DVERTX,V12,V13,V14,V23,V24,V34
      REAL*8       PWM(0:3),PW31(0:3),PWP(0:3),PW32(0:3),G
      REAL*8     DP1(0:3),DP2(0:3),DP3(0:3),DP4(0:3)
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
C
      PWM(0)=DBLE( WM(5))
      PWM(1)=DBLE( WM(6))
      PWM(2)=DIMAG(WM(6))
      PWM(3)=DIMAG(WM(5))
      PWP(0)=DBLE( WP(5))
      PWP(1)=DBLE( WP(6))
      PWP(2)=DIMAG(WP(6))
      PWP(3)=DIMAG(WP(5))
      PW31(0)=DBLE( W31(5))
      PW31(1)=DBLE( W31(6))
      PW31(2)=DIMAG(W31(6))
      PW31(3)=DIMAG(W31(5))
      PW32(0)=DBLE( W32(5))
      PW32(1)=DBLE( W32(6))
      PW32(2)=DIMAG(W32(6))
      PW32(3)=DIMAG(W32(5))
C
      DV1(0)=DCMPLX(WM(1))
      DV1(1)=DCMPLX(WM(2))
      DV1(2)=DCMPLX(WM(3))
      DV1(3)=DCMPLX(WM(4))
      DP1(0)=DBLE(PWM(0))
      DP1(1)=DBLE(PWM(1))
      DP1(2)=DBLE(PWM(2))
      DP1(3)=DBLE(PWM(3))
      DV2(0)=DCMPLX(W31(1))
      DV2(1)=DCMPLX(W31(2))
      DV2(2)=DCMPLX(W31(3))
      DV2(3)=DCMPLX(W31(4))
      DP2(0)=DBLE(PW31(0))
      DP2(1)=DBLE(PW31(1))
      DP2(2)=DBLE(PW31(2))
      DP2(3)=DBLE(PW31(3))
      DV3(0)=DCMPLX(WP(1))
      DV3(1)=DCMPLX(WP(2))
      DV3(2)=DCMPLX(WP(3))
      DV3(3)=DCMPLX(WP(4))
      DP3(0)=DBLE(PWP(0))
      DP3(1)=DBLE(PWP(1))
      DP3(2)=DBLE(PWP(2))
      DP3(3)=DBLE(PWP(3))
      DV4(0)=DCMPLX(W32(1))
      DV4(1)=DCMPLX(W32(2))
      DV4(2)=DCMPLX(W32(3))
      DV4(3)=DCMPLX(W32(4))
      DP4(0)=DBLE(PW32(0))
      DP4(1)=DBLE(PW32(1))
      DP4(2)=DBLE(PW32(2))
      DP4(3)=DBLE(PW32(3))
C
      V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3)
      V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3)
      V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3)
      V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3)
      V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3)
      V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3)
C
         DVERTX = V14*V23 -V13*V24
C
         VERTEX = DCMPLX( DVERTX ) * (G*G)
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE GGGXXX(WM,WP,W3,G , VERTEX)
C
C this subroutine computes an amplitude of the three-point coupling of  
C the gauge bosons.                                                     
C                                                                       
C input:                                                                
C       complex wm(6)          : vector               flow-out w-       
C       complex wp(6)          : vector               flow-out w+       
C       complex w3(6)          : vector               j3 or a    or z   
C       real    g              : coupling constant    gw or gwwa or gwwz
C                                                                       
C output:                                                               
C       complex vertex         : amplitude               gamma(wm,wp,w3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 WM(6),WP(6),W3(6),VERTEX, 
     &        XV1,XV2,XV3,V12,V23,V31,P12,P13,P21,P23,P31,P32
      REAL*8    PWM(0:3),PWP(0:3),PW3(0:3),G
      REAL*8 RXZERO, RTENTH
      PARAMETER( RXZERO=0.0D0, RTENTH=0.1D0 )
C
      PWM(0)=DBLE( WM(5))
      PWM(1)=DBLE( WM(6))
      PWM(2)=DIMAG(WM(6))
      PWM(3)=DIMAG(WM(5))
      PWP(0)=DBLE( WP(5))
      PWP(1)=DBLE( WP(6))
      PWP(2)=DIMAG(WP(6))
      PWP(3)=DIMAG(WP(5))
      PW3(0)=DBLE( W3(5))
      PW3(1)=DBLE( W3(6))
      PW3(2)=DIMAG(W3(6))
      PW3(3)=DIMAG(W3(5))
C
      V12=WM(1)*WP(1)-WM(2)*WP(2)-WM(3)*WP(3)-WM(4)*WP(4)
      V23=WP(1)*W3(1)-WP(2)*W3(2)-WP(3)*W3(3)-WP(4)*W3(4)
      V31=W3(1)*WM(1)-W3(2)*WM(2)-W3(3)*WM(3)-W3(4)*WM(4)
      XV1=RXZERO
      XV2=RXZERO
      XV3=RXZERO
      IF ( ABS(WM(1)) .NE. RXZERO ) THEN
         IF (ABS(WM(1)).GE.MAX(ABS(WM(2)),ABS(WM(3)),ABS(WM(4)))
     $        *RTENTH)
     &      XV1=PWM(0)/WM(1)
      ENDIF
      IF ( ABS(WP(1)) .NE. RXZERO) THEN
         IF (ABS(WP(1)).GE.MAX(ABS(WP(2)),ABS(WP(3)),ABS(WP(4)))
     $        *RTENTH)
     &      XV2=PWP(0)/WP(1)
      ENDIF
      IF ( ABS(W3(1)) .NE. RXZERO) THEN
         IF ( ABS(W3(1)).GE.MAX(ABS(W3(2)),ABS(W3(3)),ABS(W3(4)))
     $        *RTENTH)
     &      XV3=PW3(0)/W3(1)
      ENDIF
      P12= (PWM(0)-XV1*WM(1))*WP(1)-(PWM(1)-XV1*WM(2))*WP(2)
     &    -(PWM(2)-XV1*WM(3))*WP(3)-(PWM(3)-XV1*WM(4))*WP(4)
      P13= (PWM(0)-XV1*WM(1))*W3(1)-(PWM(1)-XV1*WM(2))*W3(2)
     &    -(PWM(2)-XV1*WM(3))*W3(3)-(PWM(3)-XV1*WM(4))*W3(4)
      P21= (PWP(0)-XV2*WP(1))*WM(1)-(PWP(1)-XV2*WP(2))*WM(2)
     &    -(PWP(2)-XV2*WP(3))*WM(3)-(PWP(3)-XV2*WP(4))*WM(4)
      P23= (PWP(0)-XV2*WP(1))*W3(1)-(PWP(1)-XV2*WP(2))*W3(2)
     &    -(PWP(2)-XV2*WP(3))*W3(3)-(PWP(3)-XV2*WP(4))*W3(4)
      P31= (PW3(0)-XV3*W3(1))*WM(1)-(PW3(1)-XV3*W3(2))*WM(2)
     &    -(PW3(2)-XV3*W3(3))*WM(3)-(PW3(3)-XV3*W3(4))*WM(4)
      P32= (PW3(0)-XV3*W3(1))*WP(1)-(PW3(1)-XV3*W3(2))*WP(2)
     &    -(PW3(2)-XV3*W3(3))*WP(3)-(PW3(3)-XV3*W3(4))*WP(4)
C
      VERTEX = -(V12*(P13-P23)+V23*(P21-P31)+V31*(P32-P12))*G
C
      RETURN
      END
      SUBROUTINE HIOXXX(FI,FO,GC,SMASS,SWIDTH , HIO)
C
C this subroutine computes an off-shell scalar current from an external
C fermion pair.
C       
C input:
C       complex fi(6)          : flow-in  fermion                   |fi>
C       complex fo(6)          : flow-out fermion                   <fo|
C       complex gc(2)          : coupling constants                 gchf
C       real    smass          : mass  of output scalar s
C       real    swidth         : width of output scalar s
C       
C output:
C       complex hio(3)         : scalar current             j(<fi|s|fo>)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),FO(6),HIO(3),GC(2),DN
      REAL*8  Q(0:3),SMASS,SWIDTH,Q2
C       
      HIO(2) = FO(5)-FI(5)
      HIO(3) = FO(6)-FI(6)
C       
      Q(0)=DBLE( HIO(2))
      Q(1)=DBLE( HIO(3))
      Q(2)=DIMAG(HIO(3))
      Q(3)=DIMAG(HIO(2))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
C
      DN=-DCMPLX(Q2-SMASS**2,DMAX1(DSIGN(SMASS*SWIDTH,Q2),0.D0))
C
      HIO(1) = ( GC(1)*(FO(1)*FI(1)+FO(2)*FI(2))
     &          +GC(2)*(FO(3)*FI(3)+FO(4)*FI(4)) )/DN
C
      RETURN
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE HSSSXX(S1,S2,S3,G,SMASS,SWIDTH , HSSS)
C
C This subroutine computes an off-shell scalar current from the four-   
C scalar coupling.                                                      
C                                                                       
C INPUT:                                                                
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       complex S3(3)          : third  scalar                        S3
C       real    G              : coupling constant                 GHHHH
C       real    SMASS          : mass  of OUTPUT scalar S'              
C       real    SWIDTH         : width of OUTPUT scalar S'              
C                                                                       
C OUTPUT:                                                               
C       complex HSSS(3)        : scalar current           J(S':S1,S2,S3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 S1(3),S2(3),S3(3),HSSS(3),DG
      REAL*8     Q(0:3),G,SMASS,SWIDTH,Q2
C
      HSSS(2) = S1(2)+S2(2)+S3(2)
      HSSS(3) = S1(3)+S2(3)+S3(3)
C
      Q(0)=DBLE( HSSS(2))
      Q(1)=DBLE( HSSS(3))
      Q(2)=DIMAG(HSSS(3))
      Q(3)=DIMAG(HSSS(2))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
C
      DG=-G/DCMPLX( Q2-SMASS**2,MAX(SIGN(SMASS*SWIDTH ,Q2),0.D0))
C
      HSSS(1) = DG * S1(1)*S2(1)*S3(1)
C
      RETURN
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE HSSXXX(S1,S2,G,SMASS,SWIDTH , HSS)
C
C This subroutine computes an off-shell scalar current from the three-  
C scalar coupling.                                                      
C                                                                       
C INPUT:                                                                
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       real    G              : coupling constant                  GHHH
C       real    SMASS          : mass  of OUTPUT scalar S'              
C       real    SWIDTH         : width of OUTPUT scalar S'              
C                                                                       
C OUTPUT:                                                               
C       complex HSS(3)         : scalar current              J(S':S1,S2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 S1(3),S2(3),HSS(3),DG
      REAL*8  Q(0:3),G,SMASS,SWIDTH,Q2
C
      HSS(2) = S1(2)+S2(2)
      HSS(3) = S1(3)+S2(3)
C
      Q(0)=DBLE( HSS(2))
      Q(1)=DBLE( HSS(3))
      Q(2)=DIMAG(HSS(3))
      Q(3)=DIMAG(HSS(2))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
C
      DG=-G/DCMPLX( Q2-SMASS**2, MAX(SIGN(SMASS*SWIDTH ,Q2),0.D0))
C
      HSS(1) = DG*S1(1)*S2(1)
C
      RETURN
      END
C
C ======================================================================
C ----------------------------------------------------------------------
C
      SUBROUTINE HVSXXX(VC,SC,G,SMASS,SWIDTH , HVS)
C
C this subroutine computes an off-shell scalar current from the vector- 
C scalar-scalar coupling.  the coupling is absent in the minimal sm in  
C unitary gauge.                                                        
C                                                                       
C input:                                                                
C       complex vc(6)          : input vector                          v
C       complex sc(3)          : input scalar                          s
C       complex g              : coupling constant (s charge)           
C       real    smass          : mass  of output scalar s'              
C       real    swidth         : width of output scalar s'              
C                                                                       
C examples of the coupling constant g for susy particles are as follows:
C   -----------------------------------------------------------         
C   |    s1    | (q,i3) of s1  ||   v=a   |   v=z   |   v=w   |         
C   -----------------------------------------------------------         
C   | nu~_l    | (  0  , +1/2) ||   ---   |  gzn(1) |  gwf(1) |         
C   | e~_l     | ( -1  , -1/2) ||  gal(1) |  gzl(1) |  gwf(1) |         
C   | u~_l     | (+2/3 , +1/2) ||  gau(1) |  gzu(1) |  gwf(1) |         
C   | d~_l     | (-1/3 , -1/2) ||  gad(1) |  gzd(1) |  gwf(1) |         
C   -----------------------------------------------------------         
C   | e~_r-bar | ( +1  ,  0  ) || -gal(2) | -gzl(2) | -gwf(2) |         
C   | u~_r-bar | (-2/3 ,  0  ) || -gau(2) | -gzu(2) | -gwf(2) |         
C   | d~_r-bar | (+1/3 ,  0  ) || -gad(2) | -gzd(2) | -gwf(2) |         
C   -----------------------------------------------------------         
C where the sc charge is defined by the flowing-out quantum number.     
C                                                                       
C output:                                                               
C       complex hvs(3)         : scalar current                j(s':v,s)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 VC(6),SC(3),HVS(3),DG,QVV,QPV,G
      REAL*8    QV(0:3),QP(0:3),QA(0:3),SMASS,SWIDTH,Q2
C
      HVS(2) = VC(5)+SC(2)
      HVS(3) = VC(6)+SC(3)
C
      QV(0)=DBLE(  VC(5))
      QV(1)=DBLE(  VC(6))
      QV(2)=DIMAG( VC(6))
      QV(3)=DIMAG( VC(5))
      QP(0)=DBLE(  SC(2))
      QP(1)=DBLE(  SC(3))
      QP(2)=DIMAG( SC(3))
      QP(3)=DIMAG( SC(2))
      QA(0)=DBLE( HVS(2))
      QA(1)=DBLE( HVS(3))
      QA(2)=DIMAG(HVS(3))
      QA(3)=DIMAG(HVS(2))
      Q2=QA(0)**2-(QA(1)**2+QA(2)**2+QA(3)**2)
C
      DG=-G/DCMPLX( Q2-SMASS**2 , MAX(DSIGN( SMASS*SWIDTH ,Q2),0D0) )
      QVV=QV(0)*VC(1)-QV(1)*VC(2)-QV(2)*VC(3)-QV(3)*VC(4)
      QPV=QP(0)*VC(1)-QP(1)*VC(2)-QP(2)*VC(3)-QP(3)*VC(4)
C
      HVS(1) = DG*(2D0*QPV+QVV)*SC(1)
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE HVVXXX(V1,V2,G,SMASS,SWIDTH , HVV)
C
C this subroutine computes an off-shell scalar current from the vector- 
C vector-scalar coupling.                                               
C                                                                       
C input:                                                                
C       complex v1(6)          : first  vector                        v1
C       complex v2(6)          : second vector                        v2
C       real    g              : coupling constant                  gvvh
C       real    smass          : mass  of output scalar s               
C       real    swidth         : width of output scalar s               
C                                                                       
C output:                                                               
C       complex hvv(3)         : off-shell scalar current     j(s:v1,v2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 V1(6),V2(6),HVV(3),DG
      REAL*8    Q(0:3),G,SMASS,SWIDTH,Q2
      REAL*8 RXZERO
      PARAMETER( RXZERO=0.0D0 )
C
      HVV(2) = V1(5)+V2(5)
      HVV(3) = V1(6)+V2(6)
C
      Q(0)=DBLE( HVV(2))
      Q(1)=DBLE( HVV(3))
      Q(2)=DIMAG(HVV(3))
      Q(3)=DIMAG(HVV(2))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
C
      DG=-G/DCMPLX( Q2-SMASS**2 , MAX(SIGN( SMASS*SWIDTH ,Q2),RXZERO) )
C
      HVV(1) = DG*(V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4))
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE IOSXXX(FI,FO,SC,GC , VERTEX)
C
C This subroutine computes an amplitude of the fermion-fermion-scalar   
C coupling.                                                             
C                                                                       
C INPUT:                                                                
C       complex FI(6)          : flow-in  fermion                   |FI>
C       complex FO(6)          : flow-out fermion                   <FO|
C       complex SC(3)          : input    scalar                      S 
C       complex GC(2)          : coupling constants                 GCHF
C                                                                       
C OUTPUT:                                                               
C       complex VERTEX         : amplitude                     <FO|S|FI>
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),FO(6),SC(3),GC(2),VERTEX
C
      VERTEX = SC(1)*( GC(1)*(FI(1)*FO(1)+FI(2)*FO(2))
     &                +GC(2)*(FI(3)*FO(3)+FI(4)*FO(4)) )
C
      RETURN          
      END
C
C ======================================================================
C
      SUBROUTINE IOVXXX(FI,FO,VC,G , VERTEX)
C
C this subroutine computes an amplitude of the fermion-fermion-vector   
C coupling.                                                             
C                                                                       
C input:                                                                
C       complex fi(6)          : flow-in  fermion                   |fi>
C       complex fo(6)          : flow-out fermion                   <fo|
C       complex vc(6)          : input    vector                      v 
C       real    g(2)           : coupling constants                  gvf
C                                                                       
C output:                                                               
C       complex vertex         : amplitude                     <fo|v|fi>
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),FO(6),VC(6),VERTEX
      REAL*8    G(2)
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
      COMPLEX*16 CXIMAG
      LOGICAL FIRST
      SAVE CXIMAG,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXIMAG=DCMPLX( RXZERO, RXONE )
      ENDIF
C
      VERTEX =  G(1)*( (FO(3)*FI(1)+FO(4)*FI(2))*VC(1)
     &                +(FO(3)*FI(2)+FO(4)*FI(1))*VC(2)
     &                -(FO(3)*FI(2)-FO(4)*FI(1))*VC(3)*CXIMAG
     &                +(FO(3)*FI(1)-FO(4)*FI(2))*VC(4)        )
C
      IF ( G(2) .NE. RXZERO ) THEN
         VERTEX = VERTEX
     &          + G(2)*( (FO(1)*FI(3)+FO(2)*FI(4))*VC(1)
     &                  -(FO(1)*FI(4)+FO(2)*FI(3))*VC(2)
     &                  +(FO(1)*FI(4)-FO(2)*FI(3))*VC(3)*CXIMAG
     &                  -(FO(1)*FI(3)-FO(2)*FI(4))*VC(4)        )
      END IF
C
      RETURN
      END
C
C       Subroutine returns the desired fermion or
C       anti-fermion spinor. ie., |f>
C       A replacement for the HELAS routine IXXXXX
C
C       Adam Duff,  1992 August 31
C       <duff@phenom.physics.wisc.edu>
C
      SUBROUTINE IXXXXX(P,FMASS,NHEL,NSF,FI)
C          P        IN: FOUR VECTOR MOMENTUM
C          FMASS    IN: FERMION MASS
C          NHEL     IN: SPINOR HELICITY, -1 OR 1
C          NSF      IN: -1=ANTIFERMION, 1=FERMION
C          FI       OUT: FERMION WAVEFUNCTION
C
C declare input/output variables
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6)
      INTEGER*4 NHEL, NSF
      REAL*8 P(0:3), FMASS
      REAL*8 RXZERO, RXONE, RXTWO
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 )
      REAL*8 PLAT, PABS, OMEGAP, OMEGAM, RS2PA, SPAZ
      COMPLEX*16 CXZERO
C
C declare local variables
C
      LOGICAL FIRST
      SAVE CXZERO,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXZERO=DCMPLX( RXZERO, RXZERO )
      ENDIF
C
C define kinematic parameters
C
      FI(5) = DCMPLX( P(0), P(3) ) * NSF
      FI(6) = DCMPLX( P(1), P(2) ) * NSF
      PLAT = SQRT( P(1)**2 + P(2)**2 )
      PABS = SQRT( P(1)**2 + P(2)**2 + P(3)**2 )
      OMEGAP = SQRT( P(0) + PABS )
C
C do massive fermion case
C
      IF ( FMASS .NE. RXZERO ) THEN
         OMEGAM = FMASS / OMEGAP
         IF ( NSF .EQ. 1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = DCMPLX( OMEGAM, RXZERO )
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( OMEGAP, RXZERO )
                     FI(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FI(2) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( P(1), P(2) )
                     FI(3) = OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FI(4) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = DCMPLX( OMEGAM, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = DCMPLX( OMEGAP, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(2) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), P(2) )
                     FI(3) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(4) = OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = DCMPLX( OMEGAP, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = DCMPLX( OMEGAM, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FI(3) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), P(2) )
                     FI(4) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = DCMPLX( -OMEGAP, RXZERO )
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( -OMEGAM, RXZERO )
                     FI(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(3) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), P(2) )
                     FI(4) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                  END IF
               END IF
            ELSE
               STOP 'IXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE IF ( NSF .EQ. -1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = DCMPLX( -OMEGAP, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = DCMPLX( OMEGAM, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = -OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FI(3) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), P(2) )
                     FI(4) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = DCMPLX( OMEGAP, RXZERO )
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( -OMEGAM, RXZERO )
                     FI(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = -OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(3) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), P(2) )
                     FI(4) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = DCMPLX( OMEGAM, RXZERO )
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( -OMEGAP, RXZERO )
                     FI(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FI(2) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( P(1), P(2) )
                     FI(3) = -OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FI(4) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = DCMPLX( OMEGAM, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = DCMPLX( -OMEGAP, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(2) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), P(2) )
                     FI(3) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(4) = -OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               END IF
            ELSE
               STOP 'IXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE
            STOP 'IXXXXX:  FERMION TYPE MUST BE +1,-1'
         END IF
C
C do massless fermion case
C
      ELSE
         IF ( NSF .EQ. 1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( OMEGAP, RXZERO )
                     FI(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( SPAZ, RXZERO )
                     FI(4) = RXONE / SPAZ
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = CXZERO
                     FI(4) = DCMPLX( OMEGAP, RXZERO )
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(4) = SPAZ / PLAT
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = DCMPLX( OMEGAP, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = RXONE / SPAZ
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = DCMPLX( SPAZ, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = DCMPLX( -OMEGAP, RXZERO )
                     FI(2) = CXZERO
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = SPAZ / PLAT
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  END IF
               END IF
            ELSE
               STOP 'IXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE IF ( NSF .EQ. -1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = DCMPLX( -OMEGAP, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = -RXONE / SPAZ
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = DCMPLX( -SPAZ, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = DCMPLX( OMEGAP, RXZERO )
                     FI(2) = CXZERO
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = -SPAZ / PLAT
     &                     * DCMPLX( -P(1), P(2) )
                     FI(2) = -RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(3) = CXZERO
                     FI(4) = CXZERO
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( -OMEGAP, RXZERO )
                     FI(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = DCMPLX( -SPAZ, RXZERO )
                     FI(4) = -RXONE / SPAZ
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = CXZERO
                     FI(4) = DCMPLX( -OMEGAP, RXZERO )
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FI(1) = CXZERO
                     FI(2) = CXZERO
                     FI(3) = -RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FI(4) = -SPAZ / PLAT
     &                     * DCMPLX( P(1), P(2) )
                  END IF
               END IF
            ELSE
               STOP 'IXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE
            STOP 'IXXXXX:  FERMION TYPE MUST BE +1,-1'
         END IF
      END IF
C
C done
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE J3XXXX(FI,FO,GAF,GZF,ZMASS,ZWIDTH , J3)
C
C this subroutine computes the sum of photon and z currents with the    
C suitable weights ( j(w3) = cos(theta_w) j(z) + sin(theta_w) j(a) ).   
C the output j3 is useful as an input of vvvxxx, jvvxxx or w3w3xx.      
C the photon propagator is given in feynman gauge, and the z propagator 
C is given in unitary gauge.                                            
C                                                                       
C input:                                                                
C       complex fi(6)          : flow-in  fermion                   |fi>
C       complex fo(6)          : flow-out fermion                   <fo|
C       real    gaf(2)         : fi couplings with a                 gaf
C       real    gzf(2)         : fi couplings with z                 gzf
C       real    zmass          : mass  of z                             
C       real    zwidth         : width of z                             
C                                                                       
C output:                                                               
C       complex j3(6)          : w3 current             j^mu(<fo|w3|fi>)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),FO(6),J3(6),
     &        C0L,C1L,C2L,C3L,CSL,C0R,C1R,C2R,C3R,CSR,DZ,DDIF
      REAL*8    GAF(2),GZF(2),Q(0:3),ZMASS,ZWIDTH,ZM2,ZMW,Q2,DA,WW,
     &        CW,SW,GN,GZ3L,GA3L
C
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
      COMPLEX*16 CXIMAG
      LOGICAL FIRST
      SAVE CXIMAG,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXIMAG=DCMPLX( RXZERO, RXONE )
      ENDIF
C
      J3(5) = FO(5)-FI(5)
      J3(6) = FO(6)-FI(6)
C
      Q(0)=-DBLE( J3(5))
      Q(1)=-DBLE( J3(6))
      Q(2)=-DIMAG(J3(6))
      Q(3)=-DIMAG(J3(5))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
      ZM2=ZMASS**2
      ZMW=ZMASS*ZWIDTH
C
      DA=RXONE/Q2
      WW=MAX(DSIGN( ZMW ,Q2),RXZERO)
      DZ=RXONE/DCMPLX( Q2-ZM2 , WW )
      DDIF=DCMPLX( -ZM2 , WW )*DA*DZ
C
C ddif is the difference : ddif=da-dz
C  for the running width, use below instead of the above ww,dz and ddif.
C      ww=max( zwidth*q2/zmass ,r_zero)
C      dz=r_one/dcmplx( q2-zm2 , ww )
C      ddif=dcmplx( -zm2 , ww )*da*dz
C
      CW=RXONE/SQRT(RXONE+(GZF(2)/GAF(2))**2)
      SW=SQRT((RXONE-CW)*(RXONE+CW))
      GN=GAF(2)*SW
      GZ3L=GZF(1)*CW
      GA3L=GAF(1)*SW
      C0L=  FO(3)*FI(1)+FO(4)*FI(2)
      C0R=  FO(1)*FI(3)+FO(2)*FI(4)
      C1L=-(FO(3)*FI(2)+FO(4)*FI(1))
      C1R=  FO(1)*FI(4)+FO(2)*FI(3)
      C2L= (FO(3)*FI(2)-FO(4)*FI(1))*CXIMAG
      C2R=(-FO(1)*FI(4)+FO(2)*FI(3))*CXIMAG
      C3L= -FO(3)*FI(1)+FO(4)*FI(2)
      C3R=  FO(1)*FI(3)-FO(2)*FI(4)
      CSL=(Q(0)*C0L-Q(1)*C1L-Q(2)*C2L-Q(3)*C3L)/ZM2
      CSR=(Q(0)*C0R-Q(1)*C1R-Q(2)*C2R-Q(3)*C3R)/ZM2
C
      J3(1) =  GZ3L*DZ*(C0L-CSL*Q(0))+GA3L*C0L*DA
     &       + GN*(C0R*DDIF-CSR*Q(0)*DZ)
      J3(2) =  GZ3L*DZ*(C1L-CSL*Q(1))+GA3L*C1L*DA
     &       + GN*(C1R*DDIF-CSR*Q(1)*DZ)
      J3(3) =  GZ3L*DZ*(C2L-CSL*Q(2))+GA3L*C2L*DA
     &       + GN*(C2R*DDIF-CSR*Q(2)*DZ)
      J3(4) =  GZ3L*DZ*(C3L-CSL*Q(3))+GA3L*C3L*DA
     &       + GN*(C3R*DDIF-CSR*Q(3)*DZ)
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JEEXXX(EB,EF,SHLF,CHLF,PHI,NHB,NHF,NSF , JEE)
C
C This subroutine computes an off-shell photon wavefunction emitted from
C the electron or positron beam, with a special care for the small angle
C region.  The momenta are measured in the laboratory frame, where the  
C e- (e+) beam is along the positive (negative) z axis.                 
C                                                                       
C INPUT:                                                                
C       real    EB             : energy (GeV)    of beam  e-/e+         
C       real    EF             : energy (GeV)    of final e-/e+         
C       real    SHLF           : sin(theta/2)    of final e-/e+         
C       real    CHLF           : cos(theta/2)    of final e-/e+         
C       real    PHI            : azimuthal angle of final e-/e+         
C       integer NHB  = -1 or 1 : helicity        of beam  e-/e+         
C       integer NHF  = -1 or 1 : helicity        of final e-/e+         
C       integer NSF  = -1 or 1 : +1 for electron, -1 for positron       
C                                                                       
C OUTPUT:                                                               
C       complex JEE(6)         : off-shell photon          J^mu(<e|A|e>)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 JEE(6),COEFF
      REAL*8  CS(2),EB,EF,SHLF,CHLF,PHI,ME,ALPHA,GAL,HI,SF,SFH,X,ME2,Q2,
     &        RFP,RFM,SNP,CSP,RXC,C,S
      INTEGER NHB,NHF,NSF
C
      ME   =0.51099906D-3
      ALPHA=1./128.
      GAL  =SQRT(ALPHA*4.*3.14159265D0)
C
      HI =NHB
      SF =NSF
      SFH=NHB*NSF
      CS((3+NSF)/2)=SHLF
      CS((3-NSF)/2)=CHLF
C CS(1)=CHLF and CS(2)=SHLF for electron
C CS(1)=SHLF and CS(2)=CHLF for positron
      X=EF/EB
      ME2=ME**2
      Q2=-4.*CS(2)**2*(EF*EB-ME2)
     &   +SF*(1.-X)**2/X*(SHLF+CHLF)*(SHLF-CHLF)*ME2
      RFP=(1+NSF)
      RFM=(1-NSF)
      SNP=SIN(PHI)
      CSP=COS(PHI)
C
      IF (NHB.EQ.NHF) THEN
         RXC=2.*X/(1.-X)*CS(1)**2
         COEFF= GAL*2.*EB*SQRT(X)*CS(2)/Q2
     &         *(DCMPLX( RFP )-RFM*DCMPLX( CSP ,-SNP*HI ))*.5
         JEE(1) =  DCMPLX( 0.D0 )
         JEE(2) =  COEFF*DCMPLX( (1.+RXC)*CSP ,-SFH*SNP )
         JEE(3) =  COEFF*DCMPLX( (1.+RXC)*SNP , SFH*CSP )
         JEE(4) =  COEFF*(-SF*RXC/CS(1)*CS(2))
      ELSE
         COEFF= GAL*ME/Q2/SQRT(X)
     &         *(DCMPLX( RFP )+RFM*DCMPLX( CSP , SNP*HI ))*.5*HI
         JEE(1) = -COEFF*(1.+X)*CS(2)*DCMPLX( CSP , SFH*SNP )
         JEE(2) =  COEFF*(1.-X)*CS(1)
         JEE(3) =  JEE(2)*DCMPLX( 0.D0 , SFH )
         JEE(4) =  JEE(1)*SF*(1.-X)/(1.+X)
      ENDIF
C
      C=(CHLF+SHLF)*(CHLF-SHLF)
      S=2.*CHLF*SHLF
C
      JEE(5) = -EB*DCMPLX( 1.-X , SF-X*C )
      JEE(6) =  EB*X*S*DCMPLX( CSP , SNP )
C
      RETURN          
      END
C
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JGGGXX(W1,W2,W3,G, JW3W)
C
C this subroutine computes an off-shell w+, w-, w3, z or photon current 
C from the four-point gauge boson coupling, including the contributions 
C of w exchange diagrams.  the vector propagator is given in feynman    
C gauge for a photon and in unitary gauge for w and z bosons.  if one   
C sets wmass=0.0, then the ggg-->g current is given (see sect 2.9.1 of 
C the manual).                                                          
C                                                                       
C input:                                                                
C       complex w1(6)          : first  vector                        w1
C       complex w2(6)          : second vector                        w2
C       complex w3(6)          : third  vector                        w3
C       real    g             : first  coupling constant               
C                                                  (see the table below)
C                                                                       
C output:                                                               
C       complex jw3w(6)        : w current             j^mu(w':w1,w2,w3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16  W1(6),W2(6),W3(6),JW3W(6)
      COMPLEX*16 DW1(0:3),DW2(0:3),DW3(0:3),
     &           JJ(0:3),DV,W32,W13
      REAL*8     P1(0:3),P2(0:3),P3(0:3),Q(0:3),G,DG2,Q2
C
      REAL*8 RXZERO
      PARAMETER( RXZERO=0.0D0 )
C
      JW3W(5) = W1(5)+W2(5)+W3(5)
      JW3W(6) = W1(6)+W2(6)+W3(6)
C
      DW1(0)=DCMPLX(W1(1))
      DW1(1)=DCMPLX(W1(2))
      DW1(2)=DCMPLX(W1(3))
      DW1(3)=DCMPLX(W1(4))
      DW2(0)=DCMPLX(W2(1))
      DW2(1)=DCMPLX(W2(2))
      DW2(2)=DCMPLX(W2(3))
      DW2(3)=DCMPLX(W2(4))
      DW3(0)=DCMPLX(W3(1))
      DW3(1)=DCMPLX(W3(2))
      DW3(2)=DCMPLX(W3(3))
      DW3(3)=DCMPLX(W3(4))
      P1(0)=DBLE(      W1(5))
      P1(1)=DBLE(      W1(6))
      P1(2)=DBLE(DIMAG(W1(6)))
      P1(3)=DBLE(DIMAG(W1(5)))
      P2(0)=DBLE(      W2(5))
      P2(1)=DBLE(      W2(6))
      P2(2)=DBLE(DIMAG(W2(6)))
      P2(3)=DBLE(DIMAG(W2(5)))
      P3(0)=DBLE(      W3(5))
      P3(1)=DBLE(      W3(6))
      P3(2)=DBLE(DIMAG(W3(6)))
      P3(3)=DBLE(DIMAG(W3(5)))
      Q(0)=-(P1(0)+P2(0)+P3(0))
      Q(1)=-(P1(1)+P2(1)+P3(1))
      Q(2)=-(P1(2)+P2(2)+P3(2))
      Q(3)=-(P1(3)+P2(3)+P3(3))
C
      Q2 =Q(0)**2 -(Q(1)**2 +Q(2)**2 +Q(3)**2)
C
      DG2=DBLE(G)*DBLE(G)
C
      DV = 1.0D0/DCMPLX( Q2 )
C
C  for the running width, use below instead of the above dv.
C      dv = 1.0d0/dcmplx( q2 -mv2 , dmax1(dwv*q2/dmv,0.d0) )
C
      W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3)
C
C     
      W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3)
C     
      JJ(0)=DG2*( DW1(0)*W32 - DW2(0)*W13 )
      JJ(1)=DG2*( DW1(1)*W32 - DW2(1)*W13 )
      JJ(2)=DG2*( DW1(2)*W32 - DW2(2)*W13 )
      JJ(3)=DG2*( DW1(3)*W32 - DW2(3)*W13 )
C     
      JW3W(1) = DCMPLX( JJ(0)*DV )
      JW3W(2) = DCMPLX( JJ(1)*DV )
      JW3W(3) = DCMPLX( JJ(2)*DV )
      JW3W(4) = DCMPLX( JJ(3)*DV )
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JGGXXX(V1,V2,G, JVV)
C
C this subroutine computes an off-shell vector current from the three-  
C point gauge boson coupling.  the vector propagator is given in feynman
C gauge for a massless vector and in unitary gauge for a massive vector.
C                                                                       
C input:                                                                
C       complex v1(6)          : first  vector                        v1
C       complex v2(6)          : second vector                        v2
C       real    g              : coupling constant (see the table below)
C                                                                       
C output:                                                               
C       complex jvv(6)         : vector current            j^mu(v:v1,v2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 V1(6),V2(6),JVV(6),J12(0:3),
     &        SV1,SV2,V12
      REAL*8    P1(0:3),P2(0:3),Q(0:3),G,GS,S
C
      REAL*8 RXZERO
      PARAMETER( RXZERO=0.0D0 )
C
      JVV(5) = V1(5)+V2(5)
      JVV(6) = V1(6)+V2(6)
C
      P1(0)=DBLE( V1(5))
      P1(1)=DBLE( V1(6))
      P1(2)=DIMAG(V1(6))
      P1(3)=DIMAG(V1(5))
      P2(0)=DBLE( V2(5))
      P2(1)=DBLE( V2(6))
      P2(2)=DIMAG(V2(6))
      P2(3)=DIMAG(V2(5))
      Q(0)=-DBLE( JVV(5))
      Q(1)=-DBLE( JVV(6))
      Q(2)=-DIMAG(JVV(6))
      Q(3)=-DIMAG(JVV(5))
      S=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
C
      V12=V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4)
      SV1= (P2(0)-Q(0))*V1(1) -(P2(1)-Q(1))*V1(2)
     &    -(P2(2)-Q(2))*V1(3) -(P2(3)-Q(3))*V1(4)
      SV2=-(P1(0)-Q(0))*V2(1) +(P1(1)-Q(1))*V2(2)
     &    +(P1(2)-Q(2))*V2(3) +(P1(3)-Q(3))*V2(4)
      J12(0)=(P1(0)-P2(0))*V12 +SV1*V2(1) +SV2*V1(1)
      J12(1)=(P1(1)-P2(1))*V12 +SV1*V2(2) +SV2*V1(2)
      J12(2)=(P1(2)-P2(2))*V12 +SV1*V2(3) +SV2*V1(3)
      J12(3)=(P1(3)-P2(3))*V12 +SV1*V2(4) +SV2*V1(4)
C
      GS=-G/S
C
      JVV(1) = GS*J12(0)
      JVV(2) = GS*J12(1)
      JVV(3) = GS*J12(2)
      JVV(4) = GS*J12(3)
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JIOXXX(FI,FO,G,VMASS,VWIDTH , JIO)
C
C this subroutine computes an off-shell vector current from an external 
C fermion pair.  the vector boson propagator is given in feynman gauge  
C for a massless vector and in unitary gauge for a massive vector.      
C                                                                       
C input:                                                                
C       complex fi(6)          : flow-in  fermion                   |fi>
C       complex fo(6)          : flow-out fermion                   <fo|
C       real    g(2)           : coupling constants                  gvf
C       real    vmass          : mass  of output vector v               
C       real    vwidth         : width of output vector v               
C                                                                       
C output:                                                               
C       complex jio(6)         : vector current          j^mu(<fo|v|fi>)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),FO(6),JIO(6),C0,C1,C2,C3,CS,D
      REAL*8    G(2),Q(0:3),VMASS,VWIDTH,Q2,VM2,DD
C
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
      COMPLEX*16 CXIMAG
      LOGICAL FIRST
      SAVE CXIMAG,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXIMAG=DCMPLX( RXZERO, RXONE )
      ENDIF
C
      JIO(5) = FO(5)-FI(5)
      JIO(6) = FO(6)-FI(6)
C
      Q(0)=DBLE( JIO(5))
      Q(1)=DBLE( JIO(6))
      Q(2)=DIMAG(JIO(6))
      Q(3)=DIMAG(JIO(5))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
      VM2=VMASS**2
C
      IF (VMASS.NE.RXZERO) THEN
C
         D=RXONE/DCMPLX( Q2-VM2 , MAX(SIGN( VMASS*VWIDTH ,Q2),RXZERO) )
C  for the running width, use below instead of the above d.
C      d=r_one/dcmplx( q2-vm2 , max( vwidth*q2/vmass ,r_zero) )
C
         IF (G(2).NE.RXZERO) THEN
C
            C0=  G(1)*( FO(3)*FI(1)+FO(4)*FI(2))
     &          +G(2)*( FO(1)*FI(3)+FO(2)*FI(4))
            C1= -G(1)*( FO(3)*FI(2)+FO(4)*FI(1))
     &          +G(2)*( FO(1)*FI(4)+FO(2)*FI(3))
            C2=( G(1)*( FO(3)*FI(2)-FO(4)*FI(1)) 
     &          +G(2)*(-FO(1)*FI(4)+FO(2)*FI(3)))*CXIMAG
            C3=  G(1)*(-FO(3)*FI(1)+FO(4)*FI(2))
     &          +G(2)*( FO(1)*FI(3)-FO(2)*FI(4))
         ELSE
C
            D=D*G(1)
            C0=  FO(3)*FI(1)+FO(4)*FI(2)
            C1= -FO(3)*FI(2)-FO(4)*FI(1)
            C2=( FO(3)*FI(2)-FO(4)*FI(1))*CXIMAG
            C3= -FO(3)*FI(1)+FO(4)*FI(2)
         END IF
C
         CS=(Q(0)*C0-Q(1)*C1-Q(2)*C2-Q(3)*C3)/VM2
C
         JIO(1) = (C0-CS*Q(0))*D
         JIO(2) = (C1-CS*Q(1))*D
         JIO(3) = (C2-CS*Q(2))*D
         JIO(4) = (C3-CS*Q(3))*D
C
      ELSE
         DD=RXONE/Q2
C
         IF (G(2).NE.RXZERO) THEN
            JIO(1) = ( G(1)*( FO(3)*FI(1)+FO(4)*FI(2))
     &                +G(2)*( FO(1)*FI(3)+FO(2)*FI(4)) )*DD
            JIO(2) = (-G(1)*( FO(3)*FI(2)+FO(4)*FI(1))
     &                +G(2)*( FO(1)*FI(4)+FO(2)*FI(3)) )*DD
            JIO(3) = ( G(1)*( FO(3)*FI(2)-FO(4)*FI(1))
     &                +G(2)*(-FO(1)*FI(4)+FO(2)*FI(3)))
     $           *DCMPLX(RXZERO,DD)
            JIO(4) = ( G(1)*(-FO(3)*FI(1)+FO(4)*FI(2))
     &                +G(2)*( FO(1)*FI(3)-FO(2)*FI(4)) )*DD
C
         ELSE
            DD=DD*G(1)
C
            JIO(1) =  ( FO(3)*FI(1)+FO(4)*FI(2))*DD
            JIO(2) = -( FO(3)*FI(2)+FO(4)*FI(1))*DD
            JIO(3) =  ( FO(3)*FI(2)-FO(4)*FI(1))*DCMPLX(RXZERO,DD)
            JIO(4) =  (-FO(3)*FI(1)+FO(4)*FI(2))*DD
         END IF
      END IF
C
      RETURN
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE JSSXXX(S1,S2,G,VMASS,VWIDTH , JSS)
C
C This subroutine computes an off-shell vector current from the vector- 
C scalar-scalar coupling.  The coupling is absent in the minimal SM in  
C unitary gauge.  The propagator is given in Feynman gauge for a        
C massless vector and in unitary gauge for a massive vector.            
C                                                                       
C INPUT:                                                                
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       real    G              : coupling constant (S1 charge)          
C       real    VMASS          : mass  of OUTPUT vector V               
C       real    VWIDTH         : width of OUTPUT vector V               
C                                                                       
C Examples of the coupling constant G for SUSY particles are as follows:
C   -----------------------------------------------------------         
C   |    S1    | (Q,I3) of S1  ||   V=A   |   V=Z   |   V=W   |         
C   -----------------------------------------------------------         
C   | nu~_L    | (  0  , +1/2) ||   ---   |  GZN(1) |  GWF(1) |         
C   | e~_L     | ( -1  , -1/2) ||  GAL(1) |  GZL(1) |  GWF(1) |         
C   | u~_L     | (+2/3 , +1/2) ||  GAU(1) |  GZU(1) |  GWF(1) |         
C   | d~_L     | (-1/3 , -1/2) ||  GAD(1) |  GZD(1) |  GWF(1) |         
C   -----------------------------------------------------------         
C   | e~_R-bar | ( +1  ,  0  ) || -GAL(2) | -GZL(2) | -GWF(2) |         
C   | u~_R-bar | (-2/3 ,  0  ) || -GAU(2) | -GZU(2) | -GWF(2) |         
C   | d~_R-bar | (+1/3 ,  0  ) || -GAD(2) | -GZD(2) | -GWF(2) |         
C   -----------------------------------------------------------         
C where the S1 charge is defined by the flowing-OUT quantum number.     
C                                                                       
C OUTPUT:                                                               
C       complex JSS(6)         : vector current            J^mu(V:S1,S2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 S1(3),S2(3),JSS(6),DG,ADG
      REAL*8  PP(0:3),PA(0:3),Q(0:3),G,VMASS,VWIDTH,Q2,VM2,MP2,MA2,M2D
C
      JSS(5) = S1(2)+S2(2)
      JSS(6) = S1(3)+S2(3)
C
      Q(0)=DBLE( JSS(5))
      Q(1)=DBLE( JSS(6))
      Q(2)=DIMAG(JSS(6))
      Q(3)=DIMAG(JSS(5))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
      VM2=VMASS**2
C
      IF (VMASS.EQ.0.) GOTO 10
C
      DG=G/DCMPLX( Q2-VM2, MAX(SIGN( VMASS*VWIDTH ,Q2),0.D0))
C  For the running width, use below instead of the above DG.
C      DG=G/dCMPLX( Q2-VM2 , MAX( VWIDTH*Q2/VMASS ,0.) )
C
      ADG=DG*S1(1)*S2(1)
C
      PP(0)=DBLE( S1(2))
      PP(1)=DBLE( S1(3))
      PP(2)=DIMAG(S1(3))
      PP(3)=DIMAG(S1(2))
      PA(0)=DBLE( S2(2))
      PA(1)=DBLE( S2(3))
      PA(2)=DIMAG(S2(3))
      PA(3)=DIMAG(S2(2))
      MP2=PP(0)**2-(PP(1)**2+PP(2)**2+PP(3)**2)
      MA2=PA(0)**2-(PA(1)**2+PA(2)**2+PA(3)**2)
      M2D=MP2-MA2
C
      JSS(1) = ADG*( (PP(0)-PA(0)) - Q(0)*M2D/VM2)
      JSS(2) = ADG*( (PP(1)-PA(1)) - Q(1)*M2D/VM2)
      JSS(3) = ADG*( (PP(2)-PA(2)) - Q(2)*M2D/VM2)
      JSS(4) = ADG*( (PP(3)-PA(3)) - Q(3)*M2D/VM2)
C
      RETURN
C
  10  ADG=G*S1(1)*S2(1)/Q2
C
      JSS(1) = ADG*DBLE( S1(2)-S2(2))
      JSS(2) = ADG*DBLE( S1(3)-S2(3))
      JSS(3) = ADG*DIMAG(S1(3)-S2(3))
      JSS(4) = ADG*DIMAG(S1(2)-S2(2))
C
      RETURN
      END
C
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JTIOXX(FI,FO,G , JIO)
C
C this subroutine computes an off-shell vector current from an external 
C fermion pair.  the vector boson propagator is not included in this
C routine.
C                                                                       
C input:                                                                
C       complex fi(6)          : flow-in  fermion                   |fi>
C       complex fo(6)          : flow-out fermion                   <fo|
C       real    g(2)           : coupling constants                  gvf
C                                                                       
C output:                                                               
C       complex jio(6)         : vector current          j^mu(<fo|v|fi>)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FI(6),FO(6),JIO(6)
      REAL*8    G(2)
C
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
      COMPLEX*16 CXIMAG
      LOGICAL FIRST
      SAVE CXIMAG,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXIMAG=DCMPLX( RXZERO, RXONE )
      ENDIF
C
      JIO(5) = FO(5)-FI(5)
      JIO(6) = FO(6)-FI(6)
C
      IF ( G(2) .NE. RXZERO ) THEN
         JIO(1) = ( G(1)*( FO(3)*FI(1)+FO(4)*FI(2))
     &             +G(2)*( FO(1)*FI(3)+FO(2)*FI(4)) )
         JIO(2) = (-G(1)*( FO(3)*FI(2)+FO(4)*FI(1))
     &             +G(2)*( FO(1)*FI(4)+FO(2)*FI(3)) )
         JIO(3) = ( G(1)*( FO(3)*FI(2)-FO(4)*FI(1))
     &             +G(2)*(-FO(1)*FI(4)+FO(2)*FI(3)) )*CXIMAG
         JIO(4) = ( G(1)*(-FO(3)*FI(1)+FO(4)*FI(2))
     &             +G(2)*( FO(1)*FI(3)-FO(2)*FI(4)) )
C
      ELSE
         JIO(1) =  ( FO(3)*FI(1)+FO(4)*FI(2))*G(1)
         JIO(2) = -( FO(3)*FI(2)+FO(4)*FI(1))*G(1)
         JIO(3) =  ( FO(3)*FI(2)-FO(4)*FI(1))*DCMPLX(RXZERO,G(1))
         JIO(4) =  (-FO(3)*FI(1)+FO(4)*FI(2))*G(1)
      END IF
C
      RETURN
      END
C ----------------------------------------------------------------------
C
      SUBROUTINE JVSSXX(VC,S1,S2,G,VMASS,VWIDTH , JVSS)
C
C This subroutine computes an off-shell vector current from the vector- 
C vector-scalar-scalar coupling.  The vector propagator is given in     
C Feynman gauge for a massless vector and in unitary gauge for a massive
C vector.                                                               
C                                                                       
C INPUT:                                                                
C       complex VC(6)          : input  vector                        V 
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       real    G              : coupling constant                 GVVHH
C       real    VMASS          : mass  of OUTPUT vector V'              
C       real    VWIDTH         : width of OUTPUT vector V'              
C                                                                       
C OUTPUT:                                                               
C       complex JVSS(6)        : vector current         J^mu(V':V,S1,S2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 VC(6),S1(3),S2(3),JVSS(6),DG
      REAL*8    Q(0:3),G,VMASS,VWIDTH,Q2,VK,VM2
C
      JVSS(5) = VC(5)+S1(2)+S2(2)
      JVSS(6) = VC(6)+S1(3)+S2(3)
C
      Q(0)=DBLE( JVSS(5))
      Q(1)=DBLE( JVSS(6))
      Q(2)=DIMAG(JVSS(6))
      Q(3)=DIMAG(JVSS(5))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
      VM2=VMASS**2
C
      IF (VMASS.EQ.0.) GOTO 10
C
      DG=G*S1(1)*S2(1)/DCMPLX( Q2-VM2,MAX(SIGN( VMASS*VWIDTH,Q2),0.D0))
C  For the running width, use below instead of the above DG.
C      DG=G*S1(1)*S2(1)/CMPLX( Q2-VM2 , MAX( VWIDTH*Q2/VMASS ,0.))
C
      VK=(Q(0)*VC(1)-Q(1)*VC(2)-Q(2)*VC(3)-Q(3)*VC(4))/VM2
C
      JVSS(1) = DG*(VC(1)-VK*Q(0))
      JVSS(2) = DG*(VC(2)-VK*Q(1))
      JVSS(3) = DG*(VC(3)-VK*Q(2))
      JVSS(4) = DG*(VC(4)-VK*Q(3))
C
      RETURN
C
  10  DG= G*S1(1)*S2(1)/Q2
C
      JVSS(1) = DG*VC(1)
      JVSS(2) = DG*VC(2)
      JVSS(3) = DG*VC(3)
      JVSS(4) = DG*VC(4)
C
      RETURN
      END
C
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JVSXXX(VC,SC,G,VMASS,VWIDTH , JVS)
C
C this subroutine computes an off-shell vector current from the vector- 
C vector-scalar coupling.  the vector propagator is given in feynman    
C gauge for a massless vector and in unitary gauge for a massive vector.
C                                                                       
C input:                                                                
C       complex vc(6)          : input vector                          v
C       complex sc(3)          : input scalar                          s
C       real    g              : coupling constant                  gvvh
C       real    vmass          : mass  of output vector v'              
C       real    vwidth         : width of output vector v'              
C                                                                       
C output:                                                               
C       complex jvs(6)         : vector current             j^mu(v':v,s)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 VC(6),SC(3),JVS(6),DG,VK
      REAL*8    Q(0:3),VMASS,VWIDTH,Q2,VM2,G
C
      JVS(5) = VC(5)+SC(2)
      JVS(6) = VC(6)+SC(3)
C
      Q(0)=DBLE( JVS(5))
      Q(1)=DBLE( JVS(6))
      Q(2)=DIMAG(JVS(6))
      Q(3)=DIMAG(JVS(5))
      Q2=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
      VM2=VMASS**2
C
      IF (VMASS.EQ.0.) GOTO 10
C
      DG=G*SC(1)/DCMPLX( Q2-VM2 , MAX(DSIGN( VMASS*VWIDTH ,Q2),0.D0) )
C  for the running width, use below instead of the above dg.
C      dg=g*sc(1)/dcmplx( q2-vm2 , max( vwidth*q2/vmass ,0.) )
C
      VK=(-Q(0)*VC(1)+Q(1)*VC(2)+Q(2)*VC(3)+Q(3)*VC(4))/VM2
C
      JVS(1) = DG*(Q(0)*VK+VC(1))
      JVS(2) = DG*(Q(1)*VK+VC(2))
      JVS(3) = DG*(Q(2)*VK+VC(3))
      JVS(4) = DG*(Q(3)*VK+VC(4))
C
      RETURN
C
  10  DG=G*SC(1)/Q2
C
      JVS(1) = DG*VC(1)
      JVS(2) = DG*VC(2)
      JVS(3) = DG*VC(3)
      JVS(4) = DG*VC(4)
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JVVXXX(V1,V2,G,VMASS,VWIDTH , JVV)
C
C this subroutine computes an off-shell vector current from the three-  
C point gauge boson coupling.  the vector propagator is given in feynman
C gauge for a massless vector and in unitary gauge for a massive vector.
C                                                                       
C input:                                                                
C       complex v1(6)          : first  vector                        v1
C       complex v2(6)          : second vector                        v2
C       real    g              : coupling constant (see the table below)
C       real    vmass          : mass  of output vector v               
C       real    vwidth         : width of output vector v               
C                                                                       
C the possible sets of the inputs are as follows:                       
C    ------------------------------------------------------------------ 
C    |   v1   |   v2   |  jvv   |      g       |   vmass  |  vwidth   | 
C    ------------------------------------------------------------------ 
C    |   w-   |   w+   |  a/z   |  gwwa/gwwz   | 0./zmass | 0./zwidth | 
C    | w3/a/z |   w-   |  w+    | gw/gwwa/gwwz |   wmass  |  wwidth   | 
C    |   w+   | w3/a/z |  w-    | gw/gwwa/gwwz |   wmass  |  wwidth   | 
C    ------------------------------------------------------------------ 
C where all the bosons are defined by the flowing-out quantum number.   
C                                                                       
C output:                                                               
C       complex jvv(6)         : vector current            j^mu(v:v1,v2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 V1(6),V2(6),JVV(6),J12(0:3),JS,DG,
     &        SV1,SV2,S11,S12,S21,S22,V12
      REAL*8    P1(0:3),P2(0:3),Q(0:3),G,VMASS,VWIDTH,GS,S,VM2,M1,M2
C
      REAL*8 RXZERO
      PARAMETER( RXZERO=0.0D0 )
C
      JVV(5) = V1(5)+V2(5)
      JVV(6) = V1(6)+V2(6)
C
      P1(0)=DBLE( V1(5))
      P1(1)=DBLE( V1(6))
      P1(2)=DIMAG(V1(6))
      P1(3)=DIMAG(V1(5))
      P2(0)=DBLE( V2(5))
      P2(1)=DBLE( V2(6))
      P2(2)=DIMAG(V2(6))
      P2(3)=DIMAG(V2(5))
      Q(0)=-DBLE( JVV(5))
      Q(1)=-DBLE( JVV(6))
      Q(2)=-DIMAG(JVV(6))
      Q(3)=-DIMAG(JVV(5))
      S=Q(0)**2-(Q(1)**2+Q(2)**2+Q(3)**2)
C
      V12=V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4)
      SV1= (P2(0)-Q(0))*V1(1) -(P2(1)-Q(1))*V1(2)
     &    -(P2(2)-Q(2))*V1(3) -(P2(3)-Q(3))*V1(4)
      SV2=-(P1(0)-Q(0))*V2(1) +(P1(1)-Q(1))*V2(2)
     &    +(P1(2)-Q(2))*V2(3) +(P1(3)-Q(3))*V2(4)
      J12(0)=(P1(0)-P2(0))*V12 +SV1*V2(1) +SV2*V1(1)
      J12(1)=(P1(1)-P2(1))*V12 +SV1*V2(2) +SV2*V1(2)
      J12(2)=(P1(2)-P2(2))*V12 +SV1*V2(3) +SV2*V1(3)
      J12(3)=(P1(3)-P2(3))*V12 +SV1*V2(4) +SV2*V1(4)
C
      IF ( VMASS .NE. RXZERO ) THEN
         VM2=VMASS**2
         M1=P1(0)**2-(P1(1)**2+P1(2)**2+P1(3)**2)
         M2=P2(0)**2-(P2(1)**2+P2(2)**2+P2(3)**2)
         S11=P1(0)*V1(1)-P1(1)*V1(2)-P1(2)*V1(3)-P1(3)*V1(4)
         S12=P1(0)*V2(1)-P1(1)*V2(2)-P1(2)*V2(3)-P1(3)*V2(4)
         S21=P2(0)*V1(1)-P2(1)*V1(2)-P2(2)*V1(3)-P2(3)*V1(4)
         S22=P2(0)*V2(1)-P2(1)*V2(2)-P2(2)*V2(3)-P2(3)*V2(4)
         JS=(V12*(-M1+M2) +S11*S12 -S21*S22)/VM2
C
         DG=-G/DCMPLX( S-VM2 , MAX(SIGN( VMASS*VWIDTH ,S),RXZERO) )
C
C  for the running width, use below instead of the above dg.
C         dg=-g/dcmplx( s-vm2 , max( vwidth*s/vmass ,r_zero) )
C
         JVV(1) = DG*(J12(0)-Q(0)*JS)
         JVV(2) = DG*(J12(1)-Q(1)*JS)
         JVV(3) = DG*(J12(2)-Q(2)*JS)
         JVV(4) = DG*(J12(3)-Q(3)*JS)
C
      ELSE
         GS=-G/S
C
         JVV(1) = GS*J12(0)
         JVV(2) = GS*J12(1)
         JVV(3) = GS*J12(2)
         JVV(4) = GS*J12(3)
      END IF
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JW3WXX(W1,W2,W3,G1,G2,WMASS,WWIDTH,VMASS,VWIDTH , JW3W)
C
C this subroutine computes an off-shell w+, w-, w3, z or photon current 
C from the four-point gauge boson coupling, including the contributions 
C of w exchange diagrams.  the vector propagator is given in feynman    
C gauge for a photon and in unitary gauge for w and z bosons.  if one   
C sets wmass=0.0, then the ggg-->g current is given (see sect 2.9.1 of 
C the manual).                                                          
C                                                                       
C input:                                                                
C       complex w1(6)          : first  vector                        w1
C       complex w2(6)          : second vector                        w2
C       complex w3(6)          : third  vector                        w3
C       real    g1             : first  coupling constant               
C       real    g2             : second coupling constant               
C                                                  (see the table below)
C       real    wmass          : mass  of internal w                    
C       real    wwidth         : width of internal w                    
C       real    vmass          : mass  of output w'                     
C       real    vwidth         : width of output w'                     
C                                                                       
C the possible sets of the inputs are as follows:                       
C   ------------------------------------------------------------------- 
C   |  w1  |  w2  |  w3  | g1 | g2 |wmass|wwidth|vmass|vwidth || jw3w | 
C   ------------------------------------------------------------------- 
C   |  w-  |  w3  |  w+  | gw |gwwz|wmass|wwidth|zmass|zwidth ||  z   | 
C   |  w-  |  w3  |  w+  | gw |gwwa|wmass|wwidth|  0. |  0.   ||  a   | 
C   |  w-  |  z   |  w+  |gwwz|gwwz|wmass|wwidth|zmass|zwidth ||  z   | 
C   |  w-  |  z   |  w+  |gwwz|gwwa|wmass|wwidth|  0. |  0.   ||  a   | 
C   |  w-  |  a   |  w+  |gwwa|gwwz|wmass|wwidth|zmass|zwidth ||  z   | 
C   |  w-  |  a   |  w+  |gwwa|gwwa|wmass|wwidth|  0. |  0.   ||  a   | 
C   ------------------------------------------------------------------- 
C   |  w3  |  w-  |  w3  | gw | gw |wmass|wwidth|wmass|wwidth ||  w+  | 
C   |  w3  |  w+  |  w3  | gw | gw |wmass|wwidth|wmass|wwidth ||  w-  | 
C   |  w3  |  w-  |  z   | gw |gwwz|wmass|wwidth|wmass|wwidth ||  w+  | 
C   |  w3  |  w+  |  z   | gw |gwwz|wmass|wwidth|wmass|wwidth ||  w-  | 
C   |  w3  |  w-  |  a   | gw |gwwa|wmass|wwidth|wmass|wwidth ||  w+  | 
C   |  w3  |  w+  |  a   | gw |gwwa|wmass|wwidth|wmass|wwidth ||  w-  | 
C   |  z   |  w-  |  z   |gwwz|gwwz|wmass|wwidth|wmass|wwidth ||  w+  | 
C   |  z   |  w+  |  z   |gwwz|gwwz|wmass|wwidth|wmass|wwidth ||  w-  | 
C   |  z   |  w-  |  a   |gwwz|gwwa|wmass|wwidth|wmass|wwidth ||  w+  | 
C   |  z   |  w+  |  a   |gwwz|gwwa|wmass|wwidth|wmass|wwidth ||  w-  | 
C   |  a   |  w-  |  a   |gwwa|gwwa|wmass|wwidth|wmass|wwidth ||  w+  | 
C   |  a   |  w+  |  a   |gwwa|gwwa|wmass|wwidth|wmass|wwidth ||  w-  | 
C   ------------------------------------------------------------------- 
C where all the bosons are defined by the flowing-out quantum number.   
C                                                                       
C output:                                                               
C       complex jw3w(6)        : w current             j^mu(w':w1,w2,w3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16  W1(6),W2(6),W3(6),JW3W(6)
      COMPLEX*16 DW1(0:3),DW2(0:3),DW3(0:3),
     &           JJ(0:3),J4(0:3),
     &           DV,W12,W32,W13,
     &           JQ
      REAL*8     G1,G2,WMASS,WWIDTH,VMASS,VWIDTH
      REAL*8     P1(0:3),P2(0:3),P3(0:3),Q(0:3),
     &           DG2,DMV,DWV,MV2,Q2
C
      REAL*8 RXZERO
      PARAMETER( RXZERO=0.0D0 )
C
      JW3W(5) = W1(5)+W2(5)+W3(5)
      JW3W(6) = W1(6)+W2(6)+W3(6)
C
      DW1(0)=DCMPLX(W1(1))
      DW1(1)=DCMPLX(W1(2))
      DW1(2)=DCMPLX(W1(3))
      DW1(3)=DCMPLX(W1(4))
      DW2(0)=DCMPLX(W2(1))
      DW2(1)=DCMPLX(W2(2))
      DW2(2)=DCMPLX(W2(3))
      DW2(3)=DCMPLX(W2(4))
      DW3(0)=DCMPLX(W3(1))
      DW3(1)=DCMPLX(W3(2))
      DW3(2)=DCMPLX(W3(3))
      DW3(3)=DCMPLX(W3(4))
      P1(0)=DBLE(      W1(5))
      P1(1)=DBLE(      W1(6))
      P1(2)=DBLE(DIMAG(W1(6)))
      P1(3)=DBLE(DIMAG(W1(5)))
      P2(0)=DBLE(      W2(5))
      P2(1)=DBLE(      W2(6))
      P2(2)=DBLE(DIMAG(W2(6)))
      P2(3)=DBLE(DIMAG(W2(5)))
      P3(0)=DBLE(      W3(5))
      P3(1)=DBLE(      W3(6))
      P3(2)=DBLE(DIMAG(W3(6)))
      P3(3)=DBLE(DIMAG(W3(5)))
      Q(0)=-(P1(0)+P2(0)+P3(0))
      Q(1)=-(P1(1)+P2(1)+P3(1))
      Q(2)=-(P1(2)+P2(2)+P3(2))
      Q(3)=-(P1(3)+P2(3)+P3(3))
C
      Q2 =Q(0)**2 -(Q(1)**2 +Q(2)**2 +Q(3)**2)
      DG2=DBLE(G1)*DBLE(G2)
      DMV=DBLE(VMASS)
      DWV=DBLE(VWIDTH)
      MV2=DMV**2
      IF (VMASS.EQ. RXZERO) THEN
      DV = 1.0D0/DCMPLX( Q2 )
      ELSE
      DV = 1.0D0/DCMPLX( Q2 -MV2 , DMAX1(DSIGN(DMV*DWV,Q2 ),0.D0) )
      ENDIF
C  for the running width, use below instead of the above dv.
C      dv = 1.0d0/dcmplx( q2 -mv2 , dmax1(dwv*q2/dmv,0.d0) )
C
      W12=DW1(0)*DW2(0)-DW1(1)*DW2(1)-DW1(2)*DW2(2)-DW1(3)*DW2(3)
      W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3)
C
      IF ( WMASS .NE. RXZERO ) THEN
         W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3)
C
         J4(0)=DG2*( DW1(0)*W32 + DW3(0)*W12 - 2.D0*DW2(0)*W13 )
         J4(1)=DG2*( DW1(1)*W32 + DW3(1)*W12 - 2.D0*DW2(1)*W13 )
         J4(2)=DG2*( DW1(2)*W32 + DW3(2)*W12 - 2.D0*DW2(2)*W13 )
         J4(3)=DG2*( DW1(3)*W32 + DW3(3)*W12 - 2.D0*DW2(3)*W13 )
C
         JJ(0)=J4(0)
         JJ(1)=J4(1)
         JJ(2)=J4(2)
         JJ(3)=J4(3)
C
      ELSE
C
         W12=DW1(0)*DW2(0)-DW1(1)*DW2(1)-DW1(2)*DW2(2)-DW1(3)*DW2(3)
         W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3)
         W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3)
C
         J4(0)=DG2*( DW1(0)*W32 - DW2(0)*W13 )
         J4(1)=DG2*( DW1(1)*W32 - DW2(1)*W13 )
         J4(2)=DG2*( DW1(2)*W32 - DW2(2)*W13 )
         J4(3)=DG2*( DW1(3)*W32 - DW2(3)*W13 )
C
         JJ(0)=J4(0)
         JJ(1)=J4(1)
         JJ(2)=J4(2)
         JJ(3)=J4(3)
C
      END IF
C
      IF ( VMASS .NE. RXZERO ) THEN
C
         JQ=(JJ(0)*Q(0)-JJ(1)*Q(1)-JJ(2)*Q(2)-JJ(3)*Q(3))/MV2
C
         JW3W(1) = DCMPLX( (JJ(0)-JQ*Q(0))*DV )
         JW3W(2) = DCMPLX( (JJ(1)-JQ*Q(1))*DV )
         JW3W(3) = DCMPLX( (JJ(2)-JQ*Q(2))*DV )
         JW3W(4) = DCMPLX( (JJ(3)-JQ*Q(3))*DV )
C
      ELSE
C
         JW3W(1) = DCMPLX( JJ(0)*DV )
         JW3W(2) = DCMPLX( JJ(1)*DV )
         JW3W(3) = DCMPLX( JJ(2)*DV )
         JW3W(4) = DCMPLX( JJ(3)*DV )
      END IF
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE JWWWXX(W1,W2,W3,GWWA,GWWZ,ZMASS,ZWIDTH,WMASS,WWIDTH ,
     &                  JWWW)
C
C this subroutine computes an off-shell w+/w- current from the four-    
C point gauge boson coupling, including the contributions of photon and 
C z exchanges.  the vector propagators for the output w and the internal
C z bosons are given in unitary gauge, and that of the internal photon  
C is given in feynman gauge.                                            
C                                                                       
C input:                                                                
C       complex w1(6)          : first  vector                        w1
C       complex w2(6)          : second vector                        w2
C       complex w3(6)          : third  vector                        w3
C       real    gwwa           : coupling constant of w and a       gwwa
C       real    gwwz           : coupling constant of w and z       gwwz
C       real    zmass          : mass  of internal z                    
C       real    zwidth         : width of internal z                    
C       real    wmass          : mass  of output w                      
C       real    wwidth         : width of output w                      
C                                                                       
C the possible sets of the inputs are as follows:                       
C   ------------------------------------------------------------------- 
C   |  w1  |  w2  |  w3  |gwwa|gwwz|zmass|zwidth|wmass|wwidth || jwww | 
C   ------------------------------------------------------------------- 
C   |  w-  |  w+  |  w-  |gwwa|gwwz|zmass|zwidth|wmass|wwidth ||  w+  | 
C   |  w+  |  w-  |  w+  |gwwa|gwwz|zmass|zwidth|wmass|wwidth ||  w-  | 
C   ------------------------------------------------------------------- 
C where all the bosons are defined by the flowing-out quantum number.   
C                                                                       
C output:                                                               
C       complex jwww(6)        : w current             j^mu(w':w1,w2,w3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16  W1(6),W2(6),W3(6),JWWW(6)
      COMPLEX*16 DW1(0:3),DW2(0:3),DW3(0:3),
     &           JJ(0:3),JS(0:3),JT(0:3),J4(0:3),
     &           JT12(0:3),JT32(0:3),J12(0:3),J32(0:3),
     &           DZS,DZT,DW,W12,W32,W13,P1W2,P2W1,P3W2,P2W3,
     &           JK12,JK32,JSW3,JTW1,P3JS,KSW3,P1JT,KTW1,JQ
      REAL*8     GWWA,GWWZ,ZMASS,ZWIDTH,WMASS,WWIDTH
      REAL*8     P1(0:3),P2(0:3),P3(0:3),Q(0:3),KS(0:3),KT(0:3),
     &           DGWWA2,DGWWZ2,DGW2,DMZ,DWZ,DMW,DWW,MZ2,MW2,Q2,KS2,KT2,
     &           DAS,DAT
C
      JWWW(5) = W1(5)+W2(5)+W3(5)
      JWWW(6) = W1(6)+W2(6)+W3(6)
C
      DW1(0)=DCMPLX(W1(1))
      DW1(1)=DCMPLX(W1(2))
      DW1(2)=DCMPLX(W1(3))
      DW1(3)=DCMPLX(W1(4))
      DW2(0)=DCMPLX(W2(1))
      DW2(1)=DCMPLX(W2(2))
      DW2(2)=DCMPLX(W2(3))
      DW2(3)=DCMPLX(W2(4))
      DW3(0)=DCMPLX(W3(1))
      DW3(1)=DCMPLX(W3(2))
      DW3(2)=DCMPLX(W3(3))
      DW3(3)=DCMPLX(W3(4))
      P1(0)=DBLE(      W1(5))
      P1(1)=DBLE(      W1(6))
      P1(2)=DBLE(DIMAG(W1(6)))
      P1(3)=DBLE(DIMAG(W1(5)))
      P2(0)=DBLE(      W2(5))
      P2(1)=DBLE(      W2(6))
      P2(2)=DBLE(DIMAG(W2(6)))
      P2(3)=DBLE(DIMAG(W2(5)))
      P3(0)=DBLE(      W3(5))
      P3(1)=DBLE(      W3(6))
      P3(2)=DBLE(DIMAG(W3(6)))
      P3(3)=DBLE(DIMAG(W3(5)))
      Q(0)=-(P1(0)+P2(0)+P3(0))
      Q(1)=-(P1(1)+P2(1)+P3(1))
      Q(2)=-(P1(2)+P2(2)+P3(2))
      Q(3)=-(P1(3)+P2(3)+P3(3))
      KS(0)=P1(0)+P2(0)
      KS(1)=P1(1)+P2(1)
      KS(2)=P1(2)+P2(2)
      KS(3)=P1(3)+P2(3)
      KT(0)=P2(0)+P3(0)
      KT(1)=P2(1)+P3(1)
      KT(2)=P2(2)+P3(2)
      KT(3)=P2(3)+P3(3)
      Q2 =Q(0)**2 -(Q(1)**2 +Q(2)**2 +Q(3)**2)
      KS2=KS(0)**2-(KS(1)**2+KS(2)**2+KS(3)**2)
      KT2=KT(0)**2-(KT(1)**2+KT(2)**2+KT(3)**2)
      DGWWA2=DBLE(GWWA)**2
      DGWWZ2=DBLE(GWWZ)**2
      DGW2  =DGWWA2+DGWWZ2
      DMZ=DBLE(ZMASS)
      DWZ=DBLE(ZWIDTH)
      DMW=DBLE(WMASS)
      DWW=DBLE(WWIDTH)
      MZ2=DMZ**2
      MW2=DMW**2
C
      DAS=-DGWWA2/KS2
      DAT=-DGWWA2/KT2
      DZS=-DGWWZ2/DCMPLX( KS2-MZ2 , DMAX1(DSIGN(DMZ*DWZ,KS2),0.D0) )
      DZT=-DGWWZ2/DCMPLX( KT2-MZ2 , DMAX1(DSIGN(DMZ*DWZ,KT2),0.D0) )
      DW =-1.0D0/DCMPLX( Q2 -MW2 , DMAX1(DSIGN(DMW*DWW,Q2 ),0.D0) )
C  for the running width, use below instead of the above dw.
C      dw =-1.0d0/dcmplx( q2 -mw2 , dmax1(dww*q2/dmw,0.d0) )
C
      W12=DW1(0)*DW2(0)-DW1(1)*DW2(1)-DW1(2)*DW2(2)-DW1(3)*DW2(3)
      W32=DW3(0)*DW2(0)-DW3(1)*DW2(1)-DW3(2)*DW2(2)-DW3(3)*DW2(3)
C
      P1W2= (P1(0)+KS(0))*DW2(0)-(P1(1)+KS(1))*DW2(1)
     &     -(P1(2)+KS(2))*DW2(2)-(P1(3)+KS(3))*DW2(3)
      P2W1= (P2(0)+KS(0))*DW1(0)-(P2(1)+KS(1))*DW1(1)
     &     -(P2(2)+KS(2))*DW1(2)-(P2(3)+KS(3))*DW1(3)
      P3W2= (P3(0)+KT(0))*DW2(0)-(P3(1)+KT(1))*DW2(1)
     &     -(P3(2)+KT(2))*DW2(2)-(P3(3)+KT(3))*DW2(3)
      P2W3= (P2(0)+KT(0))*DW3(0)-(P2(1)+KT(1))*DW3(1)
     &     -(P2(2)+KT(2))*DW3(2)-(P2(3)+KT(3))*DW3(3)
C
      JT12(0)= (P1(0)-P2(0))*W12 + P2W1*DW2(0) - P1W2*DW1(0)
      JT12(1)= (P1(1)-P2(1))*W12 + P2W1*DW2(1) - P1W2*DW1(1)
      JT12(2)= (P1(2)-P2(2))*W12 + P2W1*DW2(2) - P1W2*DW1(2)
      JT12(3)= (P1(3)-P2(3))*W12 + P2W1*DW2(3) - P1W2*DW1(3)
      JT32(0)= (P3(0)-P2(0))*W32 + P2W3*DW2(0) - P3W2*DW3(0)
      JT32(1)= (P3(1)-P2(1))*W32 + P2W3*DW2(1) - P3W2*DW3(1)
      JT32(2)= (P3(2)-P2(2))*W32 + P2W3*DW2(2) - P3W2*DW3(2)
      JT32(3)= (P3(3)-P2(3))*W32 + P2W3*DW2(3) - P3W2*DW3(3)
C
      JK12=(JT12(0)*KS(0)-JT12(1)*KS(1)-JT12(2)*KS(2)-JT12(3)*KS(3))/MZ2
      JK32=(JT32(0)*KT(0)-JT32(1)*KT(1)-JT32(2)*KT(2)-JT32(3)*KT(3))/MZ2
C
      J12(0)=JT12(0)*(DAS+DZS)-KS(0)*JK12*DZS
      J12(1)=JT12(1)*(DAS+DZS)-KS(1)*JK12*DZS
      J12(2)=JT12(2)*(DAS+DZS)-KS(2)*JK12*DZS
      J12(3)=JT12(3)*(DAS+DZS)-KS(3)*JK12*DZS
      J32(0)=JT32(0)*(DAT+DZT)-KT(0)*JK32*DZT
      J32(1)=JT32(1)*(DAT+DZT)-KT(1)*JK32*DZT
      J32(2)=JT32(2)*(DAT+DZT)-KT(2)*JK32*DZT
      J32(3)=JT32(3)*(DAT+DZT)-KT(3)*JK32*DZT
C
      JSW3=J12(0)*DW3(0)-J12(1)*DW3(1)-J12(2)*DW3(2)-J12(3)*DW3(3)
      JTW1=J32(0)*DW1(0)-J32(1)*DW1(1)-J32(2)*DW1(2)-J32(3)*DW1(3)
C
      P3JS= (P3(0)-Q(0))*J12(0)-(P3(1)-Q(1))*J12(1)
     &     -(P3(2)-Q(2))*J12(2)-(P3(3)-Q(3))*J12(3)
      KSW3= (KS(0)-Q(0))*DW3(0)-(KS(1)-Q(1))*DW3(1)
     &     -(KS(2)-Q(2))*DW3(2)-(KS(3)-Q(3))*DW3(3)
      P1JT= (P1(0)-Q(0))*J32(0)-(P1(1)-Q(1))*J32(1)
     &     -(P1(2)-Q(2))*J32(2)-(P1(3)-Q(3))*J32(3)
      KTW1= (KT(0)-Q(0))*DW1(0)-(KT(1)-Q(1))*DW1(1)
     &     -(KT(2)-Q(2))*DW1(2)-(KT(3)-Q(3))*DW1(3)
C
      JS(0)= (KS(0)-P3(0))*JSW3 + P3JS*DW3(0) - KSW3*J12(0)
      JS(1)= (KS(1)-P3(1))*JSW3 + P3JS*DW3(1) - KSW3*J12(1)
      JS(2)= (KS(2)-P3(2))*JSW3 + P3JS*DW3(2) - KSW3*J12(2)
      JS(3)= (KS(3)-P3(3))*JSW3 + P3JS*DW3(3) - KSW3*J12(3)
      JT(0)= (KT(0)-P1(0))*JTW1 + P1JT*DW1(0) - KTW1*J32(0)
      JT(1)= (KT(1)-P1(1))*JTW1 + P1JT*DW1(1) - KTW1*J32(1)
      JT(2)= (KT(2)-P1(2))*JTW1 + P1JT*DW1(2) - KTW1*J32(2)
      JT(3)= (KT(3)-P1(3))*JTW1 + P1JT*DW1(3) - KTW1*J32(3)
C
      W13=DW1(0)*DW3(0)-DW1(1)*DW3(1)-DW1(2)*DW3(2)-DW1(3)*DW3(3)
C
      J4(0)=DGW2*( DW1(0)*W32 + DW3(0)*W12 - 2.D0*DW2(0)*W13 )
      J4(1)=DGW2*( DW1(1)*W32 + DW3(1)*W12 - 2.D0*DW2(1)*W13 )
      J4(2)=DGW2*( DW1(2)*W32 + DW3(2)*W12 - 2.D0*DW2(2)*W13 )
      J4(3)=DGW2*( DW1(3)*W32 + DW3(3)*W12 - 2.D0*DW2(3)*W13 )
C
      JJ(0)=J4(0)
      JJ(1)=J4(1)
      JJ(2)=J4(2)
      JJ(3)=J4(3)
C
      JQ=(JJ(0)*Q(0)-JJ(1)*Q(1)-JJ(2)*Q(2)-JJ(3)*Q(3))/MW2
C
      JWWW(1) = DCMPLX( (JJ(0)-JQ*Q(0))*DW )
      JWWW(2) = DCMPLX( (JJ(1)-JQ*Q(1))*DW )
      JWWW(3) = DCMPLX( (JJ(2)-JQ*Q(2))*DW )
      JWWW(4) = DCMPLX( (JJ(3)-JQ*Q(3))*DW )
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE MOM2CX(ESUM,MASS1,MASS2,COSTH1,PHI1 , P1,P2)
C
C This subroutine sets up two four-momenta in the two particle rest     
C frame.                                                                
C                                                                       
C INPUT:                                                                
C       real    ESUM           : energy sum of particle 1 and 2         
C       real    MASS1          : mass            of particle 1          
C       real    MASS2          : mass            of particle 2          
C       real    COSTH1         : cos(theta)      of particle 1          
C       real    PHI1           : azimuthal angle of particle 1          
C                                                                       
C OUTPUT:                                                               
C       real    P1(0:3)        : four-momentum of particle 1            
C       real    P2(0:3)        : four-momentum of particle 2            
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8    P1(0:3),P2(0:3),
     &        ESUM,MASS1,MASS2,COSTH1,PHI1,MD2,ED,PP,SINTH1
C
      MD2=(MASS1-MASS2)*(MASS1+MASS2)
      ED=MD2/ESUM
      IF (MASS1*MASS2.EQ.0.) THEN
      PP=(ESUM-ABS(ED))*0.5D0
C
      ELSE
      PP=SQRT((MD2/ESUM)**2-2.0D0*(MASS1**2+MASS2**2)+ESUM**2)*0.5D0
      ENDIF
      SINTH1=SQRT((1.0D0-COSTH1)*(1.0D0+COSTH1))
C
      P1(0) = MAX((ESUM+ED)*0.5D0,0.D0)
      P1(1) = PP*SINTH1*COS(PHI1)
      P1(2) = PP*SINTH1*SIN(PHI1)
      P1(3) = PP*COSTH1
C
      P2(0) = MAX((ESUM-ED)*0.5D0,0.D0)
      P2(1) = -P1(1)
      P2(2) = -P1(2)
      P2(3) = -P1(3)
C
      RETURN
      END
C **********************************************************************
C
      SUBROUTINE MOMNTX(ENERGY,MASS,COSTH,PHI , P)
C
C This subroutine sets up a four-momentum from the four inputs.         
C                                                                       
C INPUT:                                                                
C       real    ENERGY         : energy                                 
C       real    MASS           : mass                                   
C       real    COSTH          : cos(theta)                             
C       real    PHI            : azimuthal angle                        
C                                                                       
C OUTPUT:                                                               
C       real    P(0:3)         : four-momentum                          
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8    P(0:3),ENERGY,MASS,COSTH,PHI,PP,SINTH
C
      P(0) = ENERGY
      IF (ENERGY.EQ.MASS) THEN
         P(1) = 0.
         P(2) = 0.
         P(3) = 0.
      ELSE
         PP=SQRT((ENERGY-MASS)*(ENERGY+MASS))
         SINTH=SQRT((1.-COSTH)*(1.+COSTH))
         P(3) = PP*COSTH
         IF (PHI.EQ.0.) THEN
            P(1) = PP*SINTH
            P(2) = 0.
         ELSE
            P(1) = PP*SINTH*COS(PHI)
            P(2) = PP*SINTH*SIN(PHI)
         ENDIF
      ENDIF
      RETURN
      END
C
C
C
C       Subroutine returns the desired fermion or
C       anti-fermion anti-spinor. ie., <f|
C       A replacement for the HELAS routine OXXXXX
C
C       Adam Duff,  1992 August 31
C       <duff@phenom.physics.wisc.edu>
C
      SUBROUTINE OXXXXX(P,FMASS,NHEL,NSF,FO)
C
C          P            IN: FOUR VECTOR MOMENTUM
C          FMASS        IN: FERMION MASS
C          NHEL         IN: ANTI-SPINOR HELICITY, -1 OR 1
C          NSF          IN: -1=ANTIFERMION, 1=FERMION
C          FO           OUT: FERMION WAVEFUNCTION
C
C declare input/output variables
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 FO(6)
      INTEGER*4 NHEL, NSF
      REAL*8 P(0:3), FMASS
C
C declare local variables
C
      REAL*8 RXZERO, RXONE, RXTWO
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 )
      REAL*8 PLAT, PABS, OMEGAP, OMEGAM, RS2PA, SPAZ
      COMPLEX*16 CXZERO
      LOGICAL FIRST
      SAVE CXZERO,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXZERO=DCMPLX( RXZERO, RXZERO )
      ENDIF
C
C define kinematic parameters
C
      FO(5) = DCMPLX( P(0), P(3) ) * NSF
      FO(6) = DCMPLX( P(1), P(2) ) * NSF
      PLAT = SQRT( P(1)**2 + P(2)**2 )
      PABS = SQRT( P(1)**2 + P(2)**2 + P(3)**2 )
      OMEGAP = SQRT( P(0) + PABS )
C
C do massive fermion case
C
      IF ( FMASS .NE. RXZERO ) THEN
         OMEGAM = FMASS / OMEGAP
         IF ( NSF .EQ. 1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = DCMPLX( OMEGAP, RXZERO )
                     FO(2) = CXZERO
                     FO(3) = DCMPLX( OMEGAM, RXZERO )
                     FO(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FO(2) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FO(4) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( P(1), -P(2) )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = DCMPLX( OMEGAP, RXZERO )
                     FO(3) = CXZERO
                     FO(4) = DCMPLX( OMEGAM, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(2) = OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(4) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), -P(2) )
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = DCMPLX( OMEGAM, RXZERO )
                     FO(3) = CXZERO
                     FO(4) = DCMPLX( OMEGAP, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(2) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FO(3) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = DCMPLX( -OMEGAM, RXZERO )
                     FO(2) = CXZERO
                     FO(3) = DCMPLX( -OMEGAP, RXZERO )
                     FO(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(2) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(3) = OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                  END IF
               END IF
            ELSE
               STOP 'OXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE IF ( NSF .EQ. -1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = DCMPLX( OMEGAM, RXZERO )
                     FO(3) = CXZERO
                     FO(4) = DCMPLX( -OMEGAP, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(2) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FO(3) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = -OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = DCMPLX( -OMEGAM, RXZERO )
                     FO(2) = CXZERO
                     FO(3) = DCMPLX( OMEGAP, RXZERO )
                     FO(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(2) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(3) = -OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = DCMPLX( -OMEGAP, RXZERO )
                     FO(2) = CXZERO
                     FO(3) = DCMPLX( OMEGAM, RXZERO )
                     FO(4) = CXZERO
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = -OMEGAP * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FO(2) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = OMEGAM * RS2PA
     &                     * DCMPLX( SPAZ, RXZERO )
                     FO(4) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( P(1), -P(2) )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = DCMPLX( -OMEGAP, RXZERO )
                     FO(3) = CXZERO
                     FO(4) = DCMPLX( OMEGAM, RXZERO )
                  ELSE
                     RS2PA = RXONE / SQRT( RXTWO * PABS )
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = -OMEGAP * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(2) = -OMEGAP * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = OMEGAM * RS2PA / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(4) = OMEGAM * RS2PA * SPAZ / PLAT
     &                     * DCMPLX( P(1), -P(2) )
                  END IF
               END IF
            ELSE
               STOP 'OXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE
            STOP 'OXXXXX:  FERMION TYPE MUST BE +1,-1'
         END IF
C
C do massless case
C
      ELSE
         IF ( NSF .EQ. 1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = DCMPLX( OMEGAP, RXZERO )
                     FO(2) = CXZERO
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = DCMPLX( SPAZ, RXZERO )
                     FO(2) = RXONE / SPAZ
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = DCMPLX( OMEGAP, RXZERO )
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(2) = SPAZ / PLAT
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = CXZERO
                     FO(4) = DCMPLX( OMEGAP, RXZERO )
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = RXONE / SPAZ
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = DCMPLX( SPAZ, RXZERO )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = DCMPLX( -OMEGAP, RXZERO )
                     FO(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = SPAZ / PLAT
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                  END IF
               END IF
            ELSE
               STOP 'OXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE IF ( NSF .EQ. -1 ) THEN
            IF ( NHEL .EQ. 1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = CXZERO
                     FO(4) = DCMPLX( -OMEGAP, RXZERO )
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = -RXONE / SPAZ
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = DCMPLX( -SPAZ, RXZERO )
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = DCMPLX( OMEGAP, RXZERO )
                     FO(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = CXZERO
                     FO(2) = CXZERO
                     FO(3) = -SPAZ / PLAT
     &                     * DCMPLX( -P(1), -P(2) )
                     FO(4) = -RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                  END IF
               END IF
            ELSE IF ( NHEL .EQ. -1 ) THEN
               IF ( P(3) .GE. RXZERO ) THEN
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = DCMPLX( -OMEGAP, RXZERO )
                     FO(2) = CXZERO
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS + P(3) )
                     FO(1) = DCMPLX( -SPAZ, RXZERO )
                     FO(2) = -RXONE / SPAZ
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  END IF
               ELSE
                  IF ( PLAT .EQ. RXZERO ) THEN
                     FO(1) = CXZERO
                     FO(2) = DCMPLX( -OMEGAP, RXZERO )
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  ELSE
                     SPAZ = SQRT( PABS - P(3) )
                     FO(1) = -RXONE / SPAZ
     &                     * DCMPLX( PLAT, RXZERO )
                     FO(2) = -SPAZ / PLAT
     &                     * DCMPLX( P(1), -P(2) )
                     FO(3) = CXZERO
                     FO(4) = CXZERO
                  END IF
               END IF
            ELSE
               STOP 'OXXXXX:  FERMION HELICITY MUST BE +1,-1'
            END IF
         ELSE
            STOP 'OXXXXX:  FERMION TYPE MUST BE +1,-1'
         END IF
      END IF
C
C done
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE ROTXXX(P,Q , PROT)
C
C this subroutine performs the spacial rotation of a four-momentum.     
C the momentum p is assumed to be given in the frame where the spacial  
C component of q points the positive z-axis.  prot is the momentum p    
C rotated to the frame where q is given.                                
C                                                                       
C input:                                                                
C       real    p(0:3)         : four-momentum p in q(1)=q(2)=0 frame   
C       real    q(0:3)         : four-momentum q in the rotated frame   
C                                                                       
C output:                                                               
C       real    prot(0:3)      : four-momentum p in the rotated frame   
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL*8    P(0:3),Q(0:3),PROT(0:3),QT2,QT,PSGN,QQ,P1
C
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
C
      PROT(0) = P(0)
C
      QT2=Q(1)**2+Q(2)**2
C
      IF ( QT2 .EQ. RXZERO ) THEN
          IF ( Q(3) .EQ. RXZERO ) THEN
             PROT(1) = P(1)
             PROT(2) = P(2)
             PROT(3) = P(3)
          ELSE
             PSGN=DSIGN(RXONE,Q(3))
             PROT(1) = P(1)*PSGN
             PROT(2) = P(2)*PSGN
             PROT(3) = P(3)*PSGN
          ENDIF
      ELSE
          QQ=SQRT(QT2+Q(3)**2)
          QT=SQRT(QT2)
          P1=P(1)
          PROT(1) = Q(1)*Q(3)/QQ/QT*P1 -Q(2)/QT*P(2) +Q(1)/QQ*P(3)
          PROT(2) = Q(2)*Q(3)/QQ/QT*P1 +Q(1)/QT*P(2) +Q(2)/QQ*P(3)
          PROT(3) =          -QT/QQ*P1               +Q(3)/QQ*P(3)
      ENDIF
C
      RETURN
      END
C ======================================================================
C
      SUBROUTINE SSSSXX(S1,S2,S3,S4,G , VERTEX)
C
C This subroutine computes an amplitude of the four-scalar coupling.    
C                                                                       
C INPUT:                                                                
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       complex S3(3)          : third  scalar                        S3
C       complex S4(3)          : fourth scalar                        S4
C       real    G              : coupling constant                 GHHHH
C                                                                       
C OUTPUT:                                                               
C       complex VERTEX         : amplitude            Gamma(S1,S2,S3,S4)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 S1(3),S2(3),S3(3),S4(3),VERTEX
      REAL*8     G
C
      VERTEX = G*S1(1)*S2(1)*S3(1)*S4(1)
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE SSSXXX(S1,S2,S3,G , VERTEX)
C
C This subroutine computes an amplitude of the three-scalar coupling.   
C                                                                       
C INPUT:                                                                
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       complex S3(3)          : third  scalar                        S3
C       real    G              : coupling constant                  GHHH
C                                                                       
C OUTPUT:                                                               
C       complex VERTEX         : amplitude               Gamma(S1,S2,S3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 S1(3),S2(3),S3(3),VERTEX
      REAL*8    G
C
      VERTEX = G*S1(1)*S2(1)*S3(1)
C
      RETURN
      END
C
C
C ----------------------------------------------------------------------
C
      SUBROUTINE SXXXXX(P,NSS , SC)
C
C This subroutine computes a complex SCALAR wavefunction.               
C                                                                       
C INPUT:                                                                
C       real    P(0:3)         : four-momentum of scalar boson          
C       integer NSS  = -1 or 1 : +1 for final, -1 for initial           
C                                                                       
C OUTPUT:                                                               
C       complex SC(3)          : scalar wavefunction                   S
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 SC(3)
      REAL*8    P(0:3)
      INTEGER NSS
C
      SC(1) = DCMPLX( 1.0 )
      SC(2) = DCMPLX(P(0),P(3))*NSS
      SC(3) = DCMPLX(P(1),P(2))*NSS
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE VSSXXX(VC,S1,S2,G , VERTEX)
C
C this subroutine computes an amplitude from the vector-scalar-scalar   
C coupling.  the coupling is absent in the minimal sm in unitary gauge. 
C                                                                       
C       complex vc(6)          : input  vector                        v 
C       complex s1(3)          : first  scalar                        s1
C       complex s2(3)          : second scalar                        s2
C       complex g              : coupling constant (s1 charge)          
C                                                                       
C examples of the coupling constant g for susy particles are as follows:
C   -----------------------------------------------------------         
C   |    s1    | (q,i3) of s1  ||   v=a   |   v=z   |   v=w   |         
C   -----------------------------------------------------------         
C   | nu~_l    | (  0  , +1/2) ||   ---   |  gzn(1) |  gwf(1) |         
C   | e~_l     | ( -1  , -1/2) ||  gal(1) |  gzl(1) |  gwf(1) |         
C   | u~_l     | (+2/3 , +1/2) ||  gau(1) |  gzu(1) |  gwf(1) |         
C   | d~_l     | (-1/3 , -1/2) ||  gad(1) |  gzd(1) |  gwf(1) |         
C   -----------------------------------------------------------         
C   | e~_r-bar | ( +1  ,  0  ) || -gal(2) | -gzl(2) | -gwf(2) |         
C   | u~_r-bar | (-2/3 ,  0  ) || -gau(2) | -gzu(2) | -gwf(2) |         
C   | d~_r-bar | (+1/3 ,  0  ) || -gad(2) | -gzd(2) | -gwf(2) |         
C   -----------------------------------------------------------         
C where the s1 charge is defined by the flowing-out quantum number.     
C                                                                       
C output:                                                               
C       complex vertex         : amplitude                gamma(v,s1,s2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 VC(6),S1(3),S2(3),VERTEX,G
      REAL*8    P(0:3)
C
      P(0)=DBLE( S1(2)-S2(2))
      P(1)=DBLE( S1(3)-S2(3))
      P(2)=DIMAG(S1(3)-S2(3))
      P(3)=DIMAG(S1(2)-S2(2))
C
      VERTEX = G*S1(1)*S2(1)
     &        *(VC(1)*P(0)-VC(2)*P(1)-VC(3)*P(2)-VC(4)*P(3))
C
      RETURN
      END
C
      SUBROUTINE VVSSXX(V1,V2,S1,S2,G , VERTEX)
C
C This subroutine computes an amplitude of the vector-vector-scalar-    
C scalar coupling.                                                      
C                                                                       
C INPUT:                                                                
C       complex V1(6)          : first  vector                        V1
C       complex V2(6)          : second vector                        V2
C       complex S1(3)          : first  scalar                        S1
C       complex S2(3)          : second scalar                        S2
C       real    G              : coupling constant                 GVVHH
C                                                                       
C OUTPUT:                                                               
C       complex VERTEX         : amplitude            Gamma(V1,V2,S1,S2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 V1(6),V2(6),S1(3),S2(3),VERTEX
      REAL*8    G
C
      VERTEX = G*S1(1)*S2(1)
     &        *(V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4))
C
      RETURN
      END
C
C
C ======================================================================
C
      SUBROUTINE VVSXXX(V1,V2,SC,G , VERTEX)
C
C this subroutine computes an amplitude of the vector-vector-scalar     
C coupling.                                                             
C                                                                       
C input:                                                                
C       complex v1(6)          : first  vector                        v1
C       complex v2(6)          : second vector                        v2
C       complex sc(3)          : input  scalar                        s 
C       real    g              : coupling constant                  gvvh
C                                                                       
C output:                                                               
C       complex vertex         : amplitude                gamma(v1,v2,s)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 V1(6),V2(6),SC(3),VERTEX
      REAL*8    G
C
      VERTEX = G*SC(1)*(V1(1)*V2(1)-V1(2)*V2(2)-V1(3)*V2(3)-V1(4)*V2(4))
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE VVVXXX(WM,WP,W3,G , VERTEX)
C
C this subroutine computes an amplitude of the three-point coupling of  
C the gauge bosons.                                                     
C                                                                       
C input:                                                                
C       complex wm(6)          : vector               flow-out w-       
C       complex wp(6)          : vector               flow-out w+       
C       complex w3(6)          : vector               j3 or a    or z   
C       real    g              : coupling constant    gw or gwwa or gwwz
C                                                                       
C output:                                                               
C       complex vertex         : amplitude               gamma(wm,wp,w3)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 WM(6),WP(6),W3(6),VERTEX, 
     &        XV1,XV2,XV3,V12,V23,V31,P12,P13,P21,P23,P31,P32
      REAL*8    PWM(0:3),PWP(0:3),PW3(0:3),G
C
      REAL*8 RXZERO, RTENTH
      PARAMETER( RXZERO=0.0D0, RTENTH=0.1D0 )
C
      PWM(0)=DBLE( WM(5))
      PWM(1)=DBLE( WM(6))
      PWM(2)=DIMAG(WM(6))
      PWM(3)=DIMAG(WM(5))
      PWP(0)=DBLE( WP(5))
      PWP(1)=DBLE( WP(6))
      PWP(2)=DIMAG(WP(6))
      PWP(3)=DIMAG(WP(5))
      PW3(0)=DBLE( W3(5))
      PW3(1)=DBLE( W3(6))
      PW3(2)=DIMAG(W3(6))
      PW3(3)=DIMAG(W3(5))
C
      V12=WM(1)*WP(1)-WM(2)*WP(2)-WM(3)*WP(3)-WM(4)*WP(4)
      V23=WP(1)*W3(1)-WP(2)*W3(2)-WP(3)*W3(3)-WP(4)*W3(4)
      V31=W3(1)*WM(1)-W3(2)*WM(2)-W3(3)*WM(3)-W3(4)*WM(4)
      XV1=RXZERO
      XV2=RXZERO
      XV3=RXZERO
      IF ( ABS(WM(1)) .NE. RXZERO ) THEN
         IF (ABS(WM(1)).GE.MAX(ABS(WM(2)),ABS(WM(3)),ABS(WM(4)))
     $        *RTENTH)
     &      XV1=PWM(0)/WM(1)
      ENDIF
      IF ( ABS(WP(1)) .NE. RXZERO) THEN
         IF (ABS(WP(1)).GE.MAX(ABS(WP(2)),ABS(WP(3)),ABS(WP(4)))
     $        *RTENTH)
     &      XV2=PWP(0)/WP(1)
      ENDIF
      IF ( ABS(W3(1)) .NE. RXZERO) THEN
         IF ( ABS(W3(1)).GE.MAX(ABS(W3(2)),ABS(W3(3)),ABS(W3(4)))
     $        *RTENTH)
     &      XV3=PW3(0)/W3(1)
      ENDIF
      P12= (PWM(0)-XV1*WM(1))*WP(1)-(PWM(1)-XV1*WM(2))*WP(2)
     &    -(PWM(2)-XV1*WM(3))*WP(3)-(PWM(3)-XV1*WM(4))*WP(4)
      P13= (PWM(0)-XV1*WM(1))*W3(1)-(PWM(1)-XV1*WM(2))*W3(2)
     &    -(PWM(2)-XV1*WM(3))*W3(3)-(PWM(3)-XV1*WM(4))*W3(4)
      P21= (PWP(0)-XV2*WP(1))*WM(1)-(PWP(1)-XV2*WP(2))*WM(2)
     &    -(PWP(2)-XV2*WP(3))*WM(3)-(PWP(3)-XV2*WP(4))*WM(4)
      P23= (PWP(0)-XV2*WP(1))*W3(1)-(PWP(1)-XV2*WP(2))*W3(2)
     &    -(PWP(2)-XV2*WP(3))*W3(3)-(PWP(3)-XV2*WP(4))*W3(4)
      P31= (PW3(0)-XV3*W3(1))*WM(1)-(PW3(1)-XV3*W3(2))*WM(2)
     &    -(PW3(2)-XV3*W3(3))*WM(3)-(PW3(3)-XV3*W3(4))*WM(4)
      P32= (PW3(0)-XV3*W3(1))*WP(1)-(PW3(1)-XV3*W3(2))*WP(2)
     &    -(PW3(2)-XV3*W3(3))*WP(3)-(PW3(3)-XV3*W3(4))*WP(4)
C
      VERTEX = -(V12*(P13-P23)+V23*(P21-P31)+V31*(P32-P12))*G
C
      RETURN
      END
C
C
C       Subroutine returns the value of evaluated
C       helicity basis boson polarisation wavefunction.
C       Replaces the HELAS routine VXXXXX
C
C       Adam Duff,  1992 September 3
C       <duff@phenom.physics.wisc.edu>
C
      SUBROUTINE VXXXXX(P,VMASS,NHEL,NSV,VC)
C
C          P            IN: BOSON FOUR MOMENTUM
C          VMASS        IN: BOSON MASS
C          NHEL         IN: BOSON HELICITY
C          NSV          IN: INCOMING (-1) OR OUTGOING (+1)
C          VC           OUT: BOSON WAVEFUNCTION
C
C declare input/output variables
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 VC(6)
      INTEGER*4 NHEL, NSV
      REAL*8 P(0:3), VMASS
C
C declare local variables
C
      REAL*8 RXZERO, RXONE, RXTWO
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 )
      REAL*8 PLAT, PABS, RS2, RPLAT, RPABS, RDEN
      COMPLEX*16 CXZERO
      LOGICAL FIRST
      SAVE CXZERO,FIRST
      DATA FIRST/.TRUE./
C
C          Fix compilation with g77
      IF(FIRST) THEN
        FIRST=.FALSE.
        CXZERO=DCMPLX( RXZERO, RXZERO )
      ENDIF
C
C define internal/external momenta
C
      IF ( NSV**2 .NE. 1 ) THEN
         STOP 'VXXXXX:  NSV IS NOT ONE OF -1, +1'
      END IF
C
      RS2 = SQRT( RXONE / RXTWO )
      VC(5) = DCMPLX( P(0), P(3) ) * NSV
      VC(6) = DCMPLX( P(1), P(2) ) * NSV
      PLAT = SQRT( P(1)**2 + P(2)**2 )
      PABS = SQRT( P(1)**2 + P(2)**2 + P(3)**2 )
C
C calculate polarisation four vectors
C
      IF ( NHEL**2 .EQ. 1 ) THEN
         IF ( (PABS .EQ. RXZERO) .OR. (PLAT .EQ. RXZERO) ) THEN
            VC(1) = CXZERO
            VC(2) = DCMPLX( -NHEL * RS2 * DSIGN( RXONE, P(3) ), RXZERO )
            VC(3) = DCMPLX( RXZERO, NSV * RS2 )
            VC(4) = CXZERO
         ELSE
            RPLAT = RXONE / PLAT
            RPABS = RXONE / PABS
            VC(1) = CXZERO
            VC(2) = DCMPLX( -NHEL * RS2 * RPABS * RPLAT * P(1) * P(3),
     &                     -NSV * RS2 * RPLAT * P(2) )
            VC(3) = DCMPLX( -NHEL * RS2 * RPABS * RPLAT * P(2) * P(3),
     &                     NSV * RS2 * RPLAT * P(1) )
            VC(4) = DCMPLX( NHEL * RS2 * RPABS * PLAT,
     &                     RXZERO )
         END IF
      ELSE IF ( NHEL .EQ. 0 ) THEN
         IF ( VMASS .GT. RXZERO ) THEN
            IF ( PABS .EQ. RXZERO ) THEN
               VC(1) = CXZERO
               VC(2) = CXZERO
               VC(3) = CXZERO
               VC(4) = DCMPLX( RXONE, RXZERO )
            ELSE
               RDEN = P(0) / ( VMASS * PABS )
               VC(1) = DCMPLX( PABS / VMASS, RXZERO )
               VC(2) = DCMPLX( RDEN * P(1), RXZERO )
               VC(3) = DCMPLX( RDEN * P(2), RXZERO )
               VC(4) = DCMPLX( RDEN * P(3), RXZERO )
            END IF
         ELSE
            STOP  'VXXXXX: NHEL = 0 IS ONLY FOR MASSIVE BOSONS'
         END IF
      ELSE IF ( NHEL .EQ. 4 ) THEN
         IF ( VMASS .GT. RXZERO ) THEN
            RDEN = RXONE / VMASS
            VC(1) = DCMPLX( RDEN * P(0), RXZERO )
            VC(2) = DCMPLX( RDEN * P(1), RXZERO )
            VC(3) = DCMPLX( RDEN * P(2), RXZERO )
            VC(4) = DCMPLX( RDEN * P(3), RXZERO )
         ELSEIF (VMASS .EQ. RXZERO) THEN
            RDEN = RXONE / P(0)
            VC(1) = DCMPLX( RDEN * P(0), RXZERO )
            VC(2) = DCMPLX( RDEN * P(1), RXZERO )
            VC(3) = DCMPLX( RDEN * P(2), RXZERO )
            VC(4) = DCMPLX( RDEN * P(3), RXZERO )
         ELSE
            STOP 'VXXXXX: NHEL = 4 IS ONLY FOR M>=0'
         END IF
      ELSE
         STOP 'VXXXXX:  NHEL IS NOT ONE OF -1, 0, 1 OR 4'
      END IF
C
C done
C
      RETURN
      END
C
C ----------------------------------------------------------------------
C
      SUBROUTINE W3W3XX(WM,W31,WP,W32,G31,G32,WMASS,WWIDTH , VERTEX)
C
C this subroutine computes an amplitude of the four-point coupling of   
C the w-, w+ and two w3/z/a.  the amplitude includes the contributions  
C of w exchange diagrams.  the internal w propagator is given in unitary
C gauge.  if one sets wmass=0.0, then the gggg vertex is given (see sect
C 2.9.1 of the manual).
C                                                                       
C input:                                                                
C       complex wm(0:3)        : flow-out w-                         wm 
C       complex w31(0:3)       : first    w3/z/a                     w31
C       complex wp(0:3)        : flow-out w+                         wp 
C       complex w32(0:3)       : second   w3/z/a                     w32
C       real    g31            : coupling of w31 with w-/w+             
C       real    g32            : coupling of w32 with w-/w+             
C                                                  (see the table below)
C       real    wmass          : mass  of w                             
C       real    wwidth         : width of w                             
C                                                                       
C the possible sets of the inputs are as follows:                       
C   -------------------------------------------                         
C   |  wm  |  w31 |  wp  |  w32 |  g31 |  g32 |                         
C   -------------------------------------------                         
C   |  w-  |  w3  |  w+  |  w3  |  gw  |  gw  |                         
C   |  w-  |  w3  |  w+  |  z   |  gw  | gwwz |                         
C   |  w-  |  w3  |  w+  |  a   |  gw  | gwwa |                         
C   |  w-  |  z   |  w+  |  z   | gwwz | gwwz |                         
C   |  w-  |  z   |  w+  |  a   | gwwz | gwwa |                         
C   |  w-  |  a   |  w+  |  a   | gwwa | gwwa |                         
C   -------------------------------------------                         
C where all the bosons are defined by the flowing-out quantum number.   
C                                                                       
C output:                                                               
C       complex vertex         : amplitude          gamma(wm,w31,wp,w32)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16    WM(6),W31(6),WP(6),W32(6),VERTEX
      COMPLEX*16 DV1(0:3),DV2(0:3),DV3(0:3),DV4(0:3),DVERTX,
     &           V12,V13,V14,V23,V24,V34
      REAL*8     G31,G32,WMASS,WWIDTH
C
      REAL*8 RXZERO, RXONE
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0 )
C
      DV1(0)=DCMPLX(WM(1))
      DV1(1)=DCMPLX(WM(2))
      DV1(2)=DCMPLX(WM(3))
      DV1(3)=DCMPLX(WM(4))
      DV2(0)=DCMPLX(W31(1))
      DV2(1)=DCMPLX(W31(2))
      DV2(2)=DCMPLX(W31(3))
      DV2(3)=DCMPLX(W31(4))
      DV3(0)=DCMPLX(WP(1))
      DV3(1)=DCMPLX(WP(2))
      DV3(2)=DCMPLX(WP(3))
      DV3(3)=DCMPLX(WP(4))
      DV4(0)=DCMPLX(W32(1))
      DV4(1)=DCMPLX(W32(2))
      DV4(2)=DCMPLX(W32(3))
      DV4(3)=DCMPLX(W32(4))
C
      IF ( DBLE(WMASS) .NE. RXZERO ) THEN
C         dm2inv = r_one / dmw2
C
         V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3)
         V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3)
         V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3)
         V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3)
         V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3)
         V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3)
C
         DVERTX = V12*V34 +V14*V23 -2.D0*V13*V24
C
         VERTEX = DCMPLX( DVERTX ) * (G31*G32)
C
      ELSE
         V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3)
         V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3)
         V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3)
         V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3)
         V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3)
         V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3)
C
         DVERTX = V14*V23 -V13*V24
C
         VERTEX = DCMPLX( DVERTX ) * (G31*G32)
      END IF
C
      RETURN
      END
C
C ======================================================================
C
      SUBROUTINE WWWWXX(WM1,WP1,WM2,WP2,GWWA,GWWZ,ZMASS,ZWIDTH , VERTEX)
C
C this subroutine computes an amplitude of the four-point w-/w+         
C coupling, including the contributions of photon and z exchanges.  the 
C photon propagator is given in feynman gauge and the z propagator is   
C given in unitary gauge.                                               
C                                                                       
C input:                                                                
C       complex wm1(0:3)       : first  flow-out w-                  wm1
C       complex wp1(0:3)       : first  flow-out w+                  wp1
C       complex wm2(0:3)       : second flow-out w-                  wm2
C       complex wp2(0:3)       : second flow-out w+                  wp2
C       real    gwwa           : coupling constant of w and a       gwwa
C       real    gwwz           : coupling constant of w and z       gwwz
C       real    zmass          : mass  of z                             
C       real    zwidth         : width of z                             
C                                                                       
C output:                                                               
C       complex vertex         : amplitude        gamma(wm1,wp1,wm2,wp2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16    WM1(6),WP1(6),WM2(6),WP2(6),VERTEX
      COMPLEX*16 DV1(0:3),DV2(0:3),DV3(0:3),DV4(0:3),
     &           J12(0:3),J34(0:3),J14(0:3),J32(0:3),DVERTX,
     &           SV1,SV2,SV3,SV4,TV1,TV2,TV3,TV4,DZS,DZT,
     &           V12,V13,V14,V23,V24,V34,JS12,JS34,JS14,JS32,JS,JT
      REAL*8       PWM1(0:3),PWP1(0:3),PWM2(0:3),PWP2(0:3),
     &           GWWA,GWWZ,ZMASS,ZWIDTH
      REAL*8     Q(0:3),K(0:3),DP1(0:3),DP2(0:3),DP3(0:3),DP4(0:3),
     &           DGWWA2,DGWWZ2,DGW2,DMZ,DWIDTH,S,T,DAS,DAT
C
      REAL*8 RXZERO, RXONE, RXTWO
      PARAMETER( RXZERO=0.0D0, RXONE=1.0D0, RXTWO=2.0D0 )
C
      PWM1(0)=DBLE( WM1(5))
      PWM1(1)=DBLE( WM1(6))
      PWM1(2)=DIMAG(WM1(6))
      PWM1(3)=DIMAG(WM1(5))
      PWP1(0)=DBLE( WP1(5))
      PWP1(1)=DBLE( WP1(6))
      PWP1(2)=DIMAG(WP1(6))
      PWP1(3)=DIMAG(WP1(5))
      PWM2(0)=DBLE( WM2(5))
      PWM2(1)=DBLE( WM2(6))
      PWM2(2)=DIMAG(WM2(6))
      PWM2(3)=DIMAG(WM2(5))
      PWP2(0)=DBLE( WP2(5))
      PWP2(1)=DBLE( WP2(6))
      PWP2(2)=DIMAG(WP2(6))
      PWP2(3)=DIMAG(WP2(5))
C
      DV1(0)=DCMPLX(WM1(1))
      DV1(1)=DCMPLX(WM1(2))
      DV1(2)=DCMPLX(WM1(3))
      DV1(3)=DCMPLX(WM1(4))
      DP1(0)=DBLE(PWM1(0))
      DP1(1)=DBLE(PWM1(1))
      DP1(2)=DBLE(PWM1(2))
      DP1(3)=DBLE(PWM1(3))
      DV2(0)=DCMPLX(WP1(1))
      DV2(1)=DCMPLX(WP1(2))
      DV2(2)=DCMPLX(WP1(3))
      DV2(3)=DCMPLX(WP1(4))
      DP2(0)=DBLE(PWP1(0))
      DP2(1)=DBLE(PWP1(1))
      DP2(2)=DBLE(PWP1(2))
      DP2(3)=DBLE(PWP1(3))
      DV3(0)=DCMPLX(WM2(1))
      DV3(1)=DCMPLX(WM2(2))
      DV3(2)=DCMPLX(WM2(3))
      DV3(3)=DCMPLX(WM2(4))
      DP3(0)=DBLE(PWM2(0))
      DP3(1)=DBLE(PWM2(1))
      DP3(2)=DBLE(PWM2(2))
      DP3(3)=DBLE(PWM2(3))
      DV4(0)=DCMPLX(WP2(1))
      DV4(1)=DCMPLX(WP2(2))
      DV4(2)=DCMPLX(WP2(3))
      DV4(3)=DCMPLX(WP2(4))
      DP4(0)=DBLE(PWP2(0))
      DP4(1)=DBLE(PWP2(1))
      DP4(2)=DBLE(PWP2(2))
      DP4(3)=DBLE(PWP2(3))
      DGWWA2=DBLE(GWWA)**2
      DGWWZ2=DBLE(GWWZ)**2
      DGW2  =DGWWA2+DGWWZ2
      DMZ   =DBLE(ZMASS)
      DWIDTH=DBLE(ZWIDTH)
C
      V12= DV1(0)*DV2(0)-DV1(1)*DV2(1)-DV1(2)*DV2(2)-DV1(3)*DV2(3)
      V13= DV1(0)*DV3(0)-DV1(1)*DV3(1)-DV1(2)*DV3(2)-DV1(3)*DV3(3)
      V14= DV1(0)*DV4(0)-DV1(1)*DV4(1)-DV1(2)*DV4(2)-DV1(3)*DV4(3)
      V23= DV2(0)*DV3(0)-DV2(1)*DV3(1)-DV2(2)*DV3(2)-DV2(3)*DV3(3)
      V24= DV2(0)*DV4(0)-DV2(1)*DV4(1)-DV2(2)*DV4(2)-DV2(3)*DV4(3)
      V34= DV3(0)*DV4(0)-DV3(1)*DV4(1)-DV3(2)*DV4(2)-DV3(3)*DV4(3)
C
      Q(0)=DP1(0)+DP2(0)
      Q(1)=DP1(1)+DP2(1)
      Q(2)=DP1(2)+DP2(2)
      Q(3)=DP1(3)+DP2(3)
      K(0)=DP1(0)+DP4(0)
      K(1)=DP1(1)+DP4(1)
      K(2)=DP1(2)+DP4(2)
      K(3)=DP1(3)+DP4(3)
C
      S=Q(0)**2-Q(1)**2-Q(2)**2-Q(3)**2
      T=K(0)**2-K(1)**2-K(2)**2-K(3)**2
C
      DAS=-RXONE/S
      DAT=-RXONE/T
      DZS=-RXONE/DCMPLX( S-DMZ**2 , DMAX1(DSIGN(DMZ*DWIDTH,S),RXZERO) )
      DZT=-RXONE/DCMPLX( T-DMZ**2 , DMAX1(DSIGN(DMZ*DWIDTH,T),RXZERO) )
C
      SV1= (DP2(0)+Q(0))*DV1(0) -(DP2(1)+Q(1))*DV1(1)
     &    -(DP2(2)+Q(2))*DV1(2) -(DP2(3)+Q(3))*DV1(3)
      SV2=-(DP1(0)+Q(0))*DV2(0) +(DP1(1)+Q(1))*DV2(1)
     &    +(DP1(2)+Q(2))*DV2(2) +(DP1(3)+Q(3))*DV2(3)
      SV3= (DP4(0)-Q(0))*DV3(0) -(DP4(1)-Q(1))*DV3(1)
     &    -(DP4(2)-Q(2))*DV3(2) -(DP4(3)-Q(3))*DV3(3)
      SV4=-(DP3(0)-Q(0))*DV4(0) +(DP3(1)-Q(1))*DV4(1)
     &    +(DP3(2)-Q(2))*DV4(2) +(DP3(3)-Q(3))*DV4(3)
C
      TV1= (DP4(0)+K(0))*DV1(0) -(DP4(1)+K(1))*DV1(1)
     &    -(DP4(2)+K(2))*DV1(2) -(DP4(3)+K(3))*DV1(3)
      TV2=-(DP3(0)-K(0))*DV2(0) +(DP3(1)-K(1))*DV2(1)
     &    +(DP3(2)-K(2))*DV2(2) +(DP3(3)-K(3))*DV2(3)
      TV3= (DP2(0)-K(0))*DV3(0) -(DP2(1)-K(1))*DV3(1)
     &    -(DP2(2)-K(2))*DV3(2) -(DP2(3)-K(3))*DV3(3)
      TV4=-(DP1(0)+K(0))*DV4(0) +(DP1(1)+K(1))*DV4(1)
     &    +(DP1(2)+K(2))*DV4(2) +(DP1(3)+K(3))*DV4(3)
C
      J12(0)=(DP1(0)-DP2(0))*V12 +SV1*DV2(0) +SV2*DV1(0)
      J12(1)=(DP1(1)-DP2(1))*V12 +SV1*DV2(1) +SV2*DV1(1)
      J12(2)=(DP1(2)-DP2(2))*V12 +SV1*DV2(2) +SV2*DV1(2)
      J12(3)=(DP1(3)-DP2(3))*V12 +SV1*DV2(3) +SV2*DV1(3)
      J34(0)=(DP3(0)-DP4(0))*V34 +SV3*DV4(0) +SV4*DV3(0)
      J34(1)=(DP3(1)-DP4(1))*V34 +SV3*DV4(1) +SV4*DV3(1)
      J34(2)=(DP3(2)-DP4(2))*V34 +SV3*DV4(2) +SV4*DV3(2)
      J34(3)=(DP3(3)-DP4(3))*V34 +SV3*DV4(3) +SV4*DV3(3)
C
      J14(0)=(DP1(0)-DP4(0))*V14 +TV1*DV4(0) +TV4*DV1(0)
      J14(1)=(DP1(1)-DP4(1))*V14 +TV1*DV4(1) +TV4*DV1(1)
      J14(2)=(DP1(2)-DP4(2))*V14 +TV1*DV4(2) +TV4*DV1(2)
      J14(3)=(DP1(3)-DP4(3))*V14 +TV1*DV4(3) +TV4*DV1(3)
      J32(0)=(DP3(0)-DP2(0))*V23 +TV3*DV2(0) +TV2*DV3(0)
      J32(1)=(DP3(1)-DP2(1))*V23 +TV3*DV2(1) +TV2*DV3(1)
      J32(2)=(DP3(2)-DP2(2))*V23 +TV3*DV2(2) +TV2*DV3(2)
      J32(3)=(DP3(3)-DP2(3))*V23 +TV3*DV2(3) +TV2*DV3(3)
C
      JS12=Q(0)*J12(0)-Q(1)*J12(1)-Q(2)*J12(2)-Q(3)*J12(3)
      JS34=Q(0)*J34(0)-Q(1)*J34(1)-Q(2)*J34(2)-Q(3)*J34(3)
      JS14=K(0)*J14(0)-K(1)*J14(1)-K(2)*J14(2)-K(3)*J14(3)
      JS32=K(0)*J32(0)-K(1)*J32(1)-K(2)*J32(2)-K(3)*J32(3)
C
      JS=J12(0)*J34(0)-J12(1)*J34(1)-J12(2)*J34(2)-J12(3)*J34(3)
      JT=J14(0)*J32(0)-J14(1)*J32(1)-J14(2)*J32(2)-J14(3)*J32(3)
C
      DVERTX = (V12*V34 +V14*V23 -RXTWO*V13*V24)*DGW2
C     &        +(dzs*dgwwz2+das*dgwwa2)*js -dzs*dgwwz2*js12*js34/dmz**2
C     &        +(dzt*dgwwz2+dat*dgwwa2)*jt -dzt*dgwwz2*js14*js32/dmz**2
C
      VERTEX = -DCMPLX( DVERTX )
C
      RETURN
      END
+EOD
+DECK,DINCGM.
      DOUBLE PRECISION FUNCTION DINCGM(A,X,EPS)
C***********************************************************************
C* Series expansion of incomplete gamma function, from Abramowitz and  *
C* Stegun. A and X are the two arguments, while EPS is the relative    *
C* precision. More accurately, if X > 0, EPS is the ratio of the last  *
C* term in the series and the sum; note that for X > 0, the series is  *
C* alternating. For X < 0, this ratio is required to be < EPS/100.     *
C***********************************************************************

      DOUBLE PRECISION A,X,EPS,SUM,TERM,XN
C      IF(DABS(A).LT.1.D-10) THEN
C        WRITE(*,*) ' Function diverges for A = 0!'
C        DINCGM = 1.D50
C        RETURN
C      ENDIF
      SUM = 1.D0/A
      TERM = 1.D0    !Term for n = 0
      H = 1.D0
      XN = 1.D0

    1 H = -H*X/XN
      TERM = H/(A+XN)
      XN = XN+1.D0
      SUM = SUM+TERM
      IF((DABS(TERM/SUM).GT.EPS.AND.X.GE.0.D0).OR.
     &   (DABS(TERM/SUM).GT.1.D-2*EPS.AND.X.LE.0.D0)) GOTO 1

      DINCGM = SUM*(X**A)
      RETURN
      END
+EOD
+DECK,DOMSSM
      SUBROUTINE DOMSSM
C-----------------------------------------------------------------------
C          Initialize MSSM masses and decay modes from ISASUSY. 
C          Check for validity with ISAJET masses.
C          Decay modes are transfered to /DKYTAB/ by /SETDKY/.
C
C          F.E. Paige, November, 1992
C
C          Ver. 7.01: Add test so that AMASS is not called if ID = 0
C          Ver. 7.07: Add checking for LEP bounds.
C          Ver. 7.10: Add SUGRA interface
C          Ver. 7.32: Extend to large tanb solution
C          Ver. 7.33: Add gauge-mediated SUSY model
C          Ver. 7.38: NOGRAV turns off gravitino and weaker decays
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C          ISAJET common blocks
+CDE,ITAPES
+CDE,QLMASS
+CDE,XMSSM
+CDE,NODCAY
C          ISASUSY common blocks
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SUGMG
+CDE,SUGPAS
+CDE,SUGXIN
+CDE,SUGNU
C
      INTEGER NOUT
      PARAMETER (NOUT=33)
      INTEGER IDOUT(NOUT)
      REAL AMASS,AMPL
      REAL AMI,SUMGAM,SUMMJ,WIDMX
      REAL QSUSY,ASMB,MBMB,ASMT,MTMT,SUALFS,PI,GG
      DOUBLE PRECISION SSMQCD
      INTEGER I,J,K,IFL1,IFL2,IFL3,JSPIN,INDEX,IALLOW,IITEST
C
      DATA IDOUT/
     $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR,
     $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL,
     $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,
     $ISHL,ISHH,ISHA,ISHC/
      DATA AMPL/2.4E18/,IAL3UN/0/
C
C          Generate masses and decays
C
C     FIRST SET HIGH SCALE FOR SUSY BCs; default is M_GUT
      XSUGIN(7)=XSBCS
      IF (XMGVTO.LT.1.E19) AMGVSS=XMGVTO
      IF(.NOT.GOMSSM) RETURN
      LOUT=ITLIS
      IF (AL3UNI) IAL3UN=1
      IF (INUHM.EQ.1) THEN
        MU=XNUSUG(19)
        AMHA=XNUSUG(20)
        TWOM1=-MU
      END IF
      IF(GOSUG) THEN
C          SUGRA input
C          First solve renormalization group equations
        IF (XMAJNR.LT.1.E19) THEN
          XNRIN(1)=XMN3NR
          XNRIN(2)=XMAJNR
          XNRIN(3)=XANSS
          XNRIN(4)=XNRSS
        ELSE
          XNRIN(2)=1.E20
        END IF
        IF (GOAMSB) THEN
          XA0SU=0.
          XAMIN(1)=XCQAM
          XAMIN(2)=XCDAM
          XAMIN(3)=XCUAM
          XAMIN(4)=XCLAM
          XAMIN(5)=XCEAM
          XAMIN(6)=XCHDAM
          XAMIN(7)=XCHUAM
          CALL SUGRA(XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU,AMASS(6),7)
        ELSE
          CALL SUGRA(XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU,AMASS(6),1)
        END IF
        IF (NOGOOD.EQ.1) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: TACHYONIC PARTICLES!'
        ELSE IF (NOGOOD.EQ.2) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: NO EW SYMMETRY BREAKING!'
        ELSE IF (NOGOOD.EQ.3) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: M(H_P)^2<0!'
        ELSE IF (NOGOOD.EQ.4) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: YUKAWA>10!'
        ELSE IF (NOGOOD.EQ.5) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: Z1SS NOT LSP!'
        ELSE IF (NOGOOD.EQ.7) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: XT EWSB IS BAD!'
        ELSE IF (NOGOOD.EQ.8) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: MHL^2<0!'
        END IF
        IF (MHPNEG.EQ.1) THEN
          WRITE(LOUT,*) 'SUGRA BAD POINT: M(H_P)^2<0!!'
          NOGOOD=3
        END IF
        IF(NOGOOD.NE.0) STOP99
        IF(ITACHY.NE.0) THEN
          WRITE(LOUT,*) 'WARNING: TACHYONIC SLEPTONS AT GUT SCALE'
          WRITE(LOUT,*) '         POINT MAY BE INVALID'
        ENDIF
C          Then calculate masses and decays
        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),
     $ AMASS(6),IALLOW,1)
      ELSE IF(GOGMSB) THEN
C          GMSB input
        XGMIN(8)=XRSLGM
        XGMIN(9)=XDHDGM
        XGMIN(10)=XDHUGM
        XGMIN(11)=XDYGM
        XGMIN(12)=XN51GM
        XGMIN(13)=XN52GM
        XGMIN(14)=XN53GM
C          First solve renormalization group equations
        CALL SUGRA(XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,AMASS(6),2)
        IF (NOGOOD.EQ.1) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: TACHYONIC PARTICLES!'
        ELSE IF (NOGOOD.EQ.2) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: NO EW SYMMETRY BREAKING!'
        ELSE IF (NOGOOD.EQ.3) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: M(H_P)^2<0!'
        ELSE IF (NOGOOD.EQ.4) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: YUKAWA>100!'
        ELSE IF (NOGOOD.EQ.7) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: XT EWSB IS BAD!'
        ELSE IF (NOGOOD.EQ.8) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: MHL^2<0!'
        END IF
        IF (MHPNEG.EQ.1) THEN
          WRITE(LOUT,*) 'GMSB BAD POINT: M(H_P)^2<0!!'
          NOGOOD=3
        END IF
        IF(NOGOOD.NE.0) STOP99
        IF(ITACHY.NE.0) THEN
          WRITE(LOUT,*) 'WARNING: TACHYONIC SLEPTONS AT HIGH SCALE'
          WRITE(LOUT,*) '         POINT MAY BE INVALID'
        ENDIF
C          Then calculate masses and decays
        AMGVSS=XLAMGM*XMESGM*XCMGV/SQRT(3.)/AMPL
        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),
     $  AMASS(6),IALLOW,2)
      ELSE
C          Weak scale input
C          Values of 1.E20 indicate that SSMASS should calculate
C          M_1 and M_2 from M_3
C          First do fermion masses at QSUSY since SUGRA is not called
        QSUSY=SQRT(XQ3SS*XTRSS)
        PI=4.*ATAN(1.)
C          Define heavy quark pole masses and LambdaQCD:
        AMBT=AMASS(5)
        AMTP=AMASS(6)
        ALQCD4=0.177
        ASMB=SUALFS(AMBT**2,.36,AMTP,3)
        MBMB=AMBT*(1.-4*ASMB/3./PI)
        MBQ=SSMQCD(DBLE(MBMB),DBLE(QSUSY))
        ASMT=SUALFS(AMTP**2,.36,AMTP,3)
        MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))*
     $  (ASMT/PI)**2)
        MTQ=SSMQCD(DBLE(MTMT),DBLE(QSUSY))
        MLQ=1.7463
C       Define TANBQ parameters= TANB for MSSM runs, but not for SUGRA
        AMW=80.423
        ALFAEM=1./128.
        SN2THW=.232
        GG=SQRT(4*PI*ALFAEM/SN2THW)
        VUQ=SQRT(2*AMW**2/GG**2/(1.+1./XTBSS**2))
        VDQ=VUQ/XTBSS
        CALL SSMSSM(XGLSS,XMUSS,XHASS,XTBSS,XQ1SS,XDRSS,XURSS,XL1SS,
     $  XERSS,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS,XQ3SS,XBRSS,XTRSS,XL3SS,
     $  XTARSS,XATSS,XABSS,XATASS,XM1SS,XM2SS,AMASS(6),IALLOW,0)
      ENDIF
C
C          Test parameters
C
      IF(IALLOW.NE.0) THEN
        WRITE(LOUT,1000)
1000    FORMAT(//' MSSM WARNING: Z1SS IS NOT LSP')
      ENDIF
      CALL SSTEST(IALLOW)
      IITEST=IALLOW/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1002)
1002    FORMAT(' MSSM WARNING: Z -> Z1SS Z1SS TOO BIG')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1004)
1004    FORMAT(' MSSM WARNING: Z -> CHARGINOS ALLOWED')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1008)
1008    FORMAT(' MSSM WARNING: Z -> Z1SS Z2SS TOO BIG')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1008)
1016    FORMAT(' MSSM WARNING: Z -> SQUARKS OR SLEPTONS')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1032)
1032    FORMAT(' MSSM WARNING: Z -> Z* HL0 TOO BIG')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1064)
1064    FORMAT(' MSSM WARNING: Z -> HL0 HA0 ALLOWED')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,1128)
1128    FORMAT(' MSSM WARNING: Z -> H+ H- ALLOWED')
      ENDIF
C
C          Store masses in /QLMASS/
C
      CALL FLAVOR(ISUPL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMULSS
      CALL FLAVOR(ISDNL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMDLSS
      CALL FLAVOR(ISSTL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMSLSS
      CALL FLAVOR(ISCHL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMCLSS
      CALL FLAVOR(ISBT1,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMB1SS
      CALL FLAVOR(ISTP1,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMT1SS
      CALL FLAVOR(ISUPR,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMURSS
      CALL FLAVOR(ISDNR,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMDRSS
      CALL FLAVOR(ISSTR,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMSRSS
      CALL FLAVOR(ISCHR,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMCRSS
      CALL FLAVOR(ISBT2,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMB2SS
      CALL FLAVOR(ISTP2,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMT2SS
C
      CALL FLAVOR(ISNEL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMN1SS
      CALL FLAVOR(ISEL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMELSS
      CALL FLAVOR(ISNML,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMN2SS
      CALL FLAVOR(ISMUL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMMLSS
      CALL FLAVOR(ISNTL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMN3SS
      CALL FLAVOR(ISTAU1,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AML1SS
      CALL FLAVOR(ISER,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMERSS
      CALL FLAVOR(ISMUR,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AMMRSS
      CALL FLAVOR(ISTAU2,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=AML2SS
C
      CALL FLAVOR(ISGL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMGLSS)
      CALL FLAVOR(ISZ1,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMZ1SS)
      CALL FLAVOR(ISZ2,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMZ2SS)
      CALL FLAVOR(ISZ3,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMZ3SS)
      CALL FLAVOR(ISZ4,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMZ4SS)
      CALL FLAVOR(ISW1,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMW1SS)
      CALL FLAVOR(ISW2,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMW2SS)
C
      CALL FLAVOR(ISHL,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMHL)
      CALL FLAVOR(ISHH,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMHH)
      CALL FLAVOR(ISHA,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMHA)
      CALL FLAVOR(ISHC,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=ABS(AMHC)
C
C          Check decays with ISAJET masses
C          NOGRAV turns off gravitino decays and all weaker ones
C
      WIDMX=0
      IF(NOGRAV) THEN
        DO 90 J=1,NSSMOD
          DO 91 K=1,5
            IF(JSSMOD(K,J).EQ.ISGRAV) WIDMX=MAX(WIDMX,GSSMOD(J))
91        CONTINUE
90      CONTINUE
      ENDIF
      WIDMX=1.01*WIDMX
C
      DO 100 I=1,NOUT
        SUMGAM=0
        AMI=AMASS(IDOUT(I))
        DO 110 J=1,NSSMOD
          IF(IDOUT(I).NE.ISSMOD(J)) GO TO 110
          SUMMJ=0
          DO 111 K=1,5
            IF(JSSMOD(K,J).NE.0) SUMMJ=SUMMJ+AMASS(JSSMOD(K,J))
111       CONTINUE
          IF(SUMMJ.GE.AMI.OR.GSSMOD(J).LT.WIDMX) GSSMOD(J)=0
          SUMGAM=SUMGAM+GSSMOD(J)
110     CONTINUE
        DO 120 J=1,NSSMOD
          IF(IDOUT(I).NE.ISSMOD(J)) GO TO 120
          IF(SUMGAM.NE.0) THEN
            BSSMOD(J)=GSSMOD(J)/SUMGAM
          ELSE
            BSSMOD(J)=0
          ENDIF
120     CONTINUE
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,DRLLYN.
      SUBROUTINE DRLLYN
C
C          Generate QMW (and QTW) for DRELLYAN or HIGGS event using
C          integrated cross section. Then generate decay -- for HIGGS,
C          the mode must be chosen using the integrated cross sections
C          because of interference with W+W->W+W scattering.
C
C          Note that NOGOOD calls the cross section.
C
C          Ver. 6.40: Add technicolor resonances. Use logs for QDEN,
C          PTDEN, WTFAC, etc. Also scale QMW generation by QMAX.
C
C          Ver. 7.01: Correct QDEN to correspond to correct fit form:
C          SIGMA = ANOMR(K)*(QMAX**2/Q**2)**QPOW
C          See QFUNC.
C
C          Ver. 7.14: Add SUSY Higgs
C          Ver. 7.15: Fix bug with THETAW limits by adding epsilon to
C          allowed range. Check for possible invalid Higgs decays.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETSIG
+CDE,TOTALS
+CDE,Q1Q2
+CDE,PARTCL
+CDE,PJETS
+CDE,PINITS
+CDE,WCON
+CDE,PRIMAR
+CDE,DYLIM
+CDE,CONST
+CDE,JETPAR
+CDE,JETLIM
+CDE,WGEN
+CDE,DYPAR
+CDE,KEYS.
+CDE,HCON.
+CDE,ISLOOP
+CDE,IDRUN
+CDE,XMSSM
+CDE,LISTSS
C
      DIMENSION X(2)
      EQUIVALENCE (X(1),X1)
      DIMENSION PREST(5),PL(5),EL(3),EML(3),EMSQL(3)
      DIMENSION WTFAC(3)
      LOGICAL NOGOOD
      LOGICAL YGENJ
      DIMENSION BRANCH(29),LISTJ(29),LISTW(5)
      REAL ACOSH,XXX,ASINH,CHOOSE,RANF,SUM,WTFAC,PTDEN,QDEN,ETA,QPW,
     $S12,BRANCH,SUMBR,BRMODE,AMASS,BRINV,TRY,EMSQL,EL,PL12,PREST,
     $COSTHL,THL,PHL,PTL,SGN,PL,BP,PLPL,PLMN,AMINI,AMFIN,PINI,PFIN,
     $ QPL,QMN,AM1SQ,AM2SQ,ROOT,P1PL,P1MN,P2PL,P2MN,X,EML
      INTEGER NTRY,K,IQ1,IQ2,IFL1,IFL2,LISTJ,IQ,NTRY2,IFL,LISTW,I
      REAL ZZSTAR
      INTEGER IZSTAR,JVIR,N0J
C
      DATA LISTJ/
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
     $10,80,-80,90/
      DATA LISTW/10,80,-80,90,92/
      ACOSH(XXX)=ALOG(XXX+SQRT(XXX**2-1.))
      ASINH(XXX)=ALOG(XXX+SQRT(XXX**2+1.))
C
C          Entry
C
      NPTCL=0
      NTRY=0
200   CONTINUE
      SIGMA=0.
      WT=1.
    1 CONTINUE
      NTRY=NTRY+1
      IF(NTRY.GT.NTRIES) GO TO 999
      SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN)
      NKINPT=NKINPT+1
      SIGMA=0.
      WT=1.
      DO 2 K=1,3
    2 SIGSL(K)=0
C            Choose interval for cross section calculation
      CHOOSE=RANF()
      SUM=0.
      DO 3 K=NKL,NKH
        SUM=SUM+QSELWT(K)
        IF(CHOOSE.LE.SUM) GO TO 30
3     CONTINUE
30    KSEL=K
C          Generate QTW in selected region
      IF(.NOT.FIXQT) THEN
        ETA=(PTGN(1,K)+PTGN(2,K)*RANF())**PTGN(3,K)
        PTSEL(K)=SQRT(ETA-RNU2(K))
        PTDEN=ALOG(ETA)*PTPOW(K)
        WTFAC(1)=ALOG(ABS(PTGN(2,K)))+ALOG(ABS(PTGN(3,K)))
     1  +ALOG(ABS(PTSEL(K)**2+RNU2(K)))*((PTGN(3,K)-1.)/PTGN(3,K))
        PT(3)=PTSEL(K)
      ELSE
        PTDEN=0.
        WTFAC(1)=-1000.
      ENDIF
C          Generate QMW
      IF(.NOT.FIXQM) THEN
        IF(.NOT.K.EQ.2) THEN
          QSEL(K)=QMAX**2*(QGEN(1,K)+QGEN(2,K)*RANF())**QGEN(3,K)
          QDEN=ALOG(QSEL(K)/QMAX**2)*QPOW(K)
          WTFAC(2)=ALOG(ABS(QGEN(2,K)))+ALOG(ABS(QGEN(3,K)))
     1    +ALOG(QSEL(K)/QMAX**2)*((QGEN(3,K)-1.)/QGEN(3,K))
     2    +ALOG(QMAX**2)
          QSEL(K)=SQRT(QSEL(K))
          QMW=QSEL(K)
        ELSE
          ETA=QGEN(3,K)*TAN(QGEN(1,K)+QGEN(2,K)*RANF())
          QSEL(K)=SQRT(ETA+EMSQ)
          WTFAC(2)=ALOG(QGEN(2,K))+ALOG(QGEN(3,K))
     1    +ALOG((ETA/QGEN(3,K))**2+1.)
          QMW=QSEL(K)
          QDEN=ALOG((QMW**2-EMSQ)**2+EMGAM**2)
        ENDIF
      ELSE
        QDEN=0.
        WTFAC(2)=-1000.
      ENDIF
      SIGSL(K)=EXP(ANORM(K)-PTDEN-QDEN)
C
      IF(STDDY) THEN
        WT=EXP(WTFAC(2)-ALOG(QSELWT(K)))
      ELSE
        WT=EXP(WTFAC(1)+WTFAC(2)-ALOG(QSELWT(K)))
      ENDIF      
      QTW=PT(3)
      YW=YWMIN+(YWMAX-YWMIN)*RANF()
      WT=WT*(YWMAX-YWMIN)
      PHIW=PHWMIN+(PHWMAX-PHWMIN)*RANF()
      PHI(3)=AMOD(PHIW+PI,2.*PI)
      QPW=SQRT(QTW**2+QMW**2)*SINH(YW)
      QW=SQRT(QTW**2+QPW**2)
      THW=QPW/QW
      IF(ABS(THW).GT.1.) THW=SIGN(1.,THW)
      THW=ACOS(THW)
      IF(THW.LT.THWMIN-1.E-6.OR.THW.GT.THWMAX+1.E-6) GOTO 1
      XW=QPW/HALFE
      IF(XW.LT.XWMIN.OR.XW.GT.XWMAX) GOTO 1
      IF(.NOT.STDDY) THEN
        IF(.NOT.YGENJ(3)) GOTO 1
        P(3)=PT(3)/STH(3)
        XJ(3)=P(3)*CTH(3)/HALFE
        IF(XJ(3).LT.XJMIN(3).OR.XJ(3).GT.XJMAX(3)) GOTO 1
      ENDIF
C
C          Check integrated cross section
C
      IF(NOGOOD(2)) GO TO 1
      SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN)
      NWGEN=NWGEN+1
      S12=QMW**2
C
C          No decay for KKG:
C          For compatibility reasons, the jet is still the 3rd one.
C          Jets 1 and 2 (W decay products) are voided; no decay step.
C
      IF(KEYS(11)) THEN
        DO 50 I=1,2
          P(I)=0.
          PT(I)=0.
          CTH(I)=0.
          PHI(I)=0.
          EMSQL(I)=0.
          IDJETS(I)=0
50      CONTINUE
        GOTO 350
      ENDIF
C
C          Select W decay mode
C          QMW dependence neglected in branching ratios
C          BRANCH is cum. br. with heavy modes subtracted.
C
      IF(KEYS(3)) THEN
        BRANCH(1)=0.
        SUMBR=0.
        DO 105 IQ1=2,25
          IQ2=MATCH(IQ1,JWTYP)
          IF(IQ2.EQ.0) THEN
            BRMODE=0.
          ELSE
            BRMODE=WCBR(IQ1,JWTYP)-WCBR(IQ1-1,JWTYP)
            IFL1=LISTJ(IQ1)
            IFL2=LISTJ(IQ2)
            IF(S12.LE.(AMASS(IFL1)+AMASS(IFL2))**2) BRMODE=0.
          ENDIF
          BRANCH(IQ1)=BRANCH(IQ1-1)+BRMODE
          SUMBR=SUMBR+BRMODE
105     CONTINUE
        BRINV=1./SUMBR
C
        TRY=RANF()
        DO 110 IQ=1,25
          IF(TRY.LT.BRANCH(IQ)*BRINV.AND.MATCH(IQ,JWTYP).NE.0) THEN
            JETTYP(1)=IQ
            JETTYP(2)=MATCH(IQ,JWTYP)
            GO TO 120
          ENDIF
110     CONTINUE
      ENDIF
C
120   IF(GOMSSM) THEN
        IFL1=LISTSS(JETTYP(1))
        IFL2=LISTSS(JETTYP(2))
      ELSE
        IFL1=LISTJ(JETTYP(1))
        IFL2=LISTJ(JETTYP(2))
      ENDIF
C
C          Select masses of decay products. These are just normal masses
C          except for Z Z* decay of Higgs, where one is virtual.
C
      EML(1)=AMASS(IFL1)
      EML(2)=AMASS(IFL2)
      IF(KEYS(7).AND.EML(1)+EML(2).GT.QMW) THEN
C          WW* or ZZ* decay - generate/check W* or Z* mass
        IF((IABS(IFL1).EQ.80.AND.IABS(IFL2).EQ.80)
     $  .OR.(IFL1.EQ.90.AND.IFL2.EQ.90)) THEN
          IZSTAR=3-2*RANF()
          IF(GOMSSM) THEN
            JVIR=JETTYP(IZSTAR)-76
          ELSE
            JVIR=JETTYP(IZSTAR)-25
          ENDIF
          EML(IZSTAR)=ZZSTAR(QMW,JVIR)
          IF(EML(IZSTAR).LT.ZSTARS(JVIR,IZSTAR)) GO TO 200
C          Other decay - invalid for this QMW
        ELSE
          GO TO 200
        ENDIF
      ENDIF
C
C          Generate W decay in its rest frame and compare with SIGDY2.
C          First set up momenta of decay products:
C
      EMSQL(1)=EML(1)**2
      EMSQL(2)=EML(2)**2
      EL(1)=(S12+EMSQL(1)-EMSQL(2))/(2.*QMW)
      EL(2)=(S12+EMSQL(2)-EMSQL(1))/(2.*QMW)
      PL12=SQRT((S12-(EML(1)+EML(2))**2)*(S12-(EML(1)-EML(2))**2))
     $/(2.*QMW)
C          W momentum
      PREST(1)=QTW*COS(PHIW)
      PREST(2)=QTW*SIN(PHIW)
      PREST(3)=QPW
      PREST(4)=SQRT(QW**2+QMW**2)
      PREST(5)=QMW
      NTRY2=0
C          Generate next W decay
20    CONTINUE
      NTRY2=NTRY2+1
      IF(NTRY2.GT.NTRIES) GO TO 999
      COSTHL=2.*RANF()-1.
      THL=ACOS(COSTHL)
      PHL=2.*PI*RANF()
      PTL=PL12*SIN(THL)
C
      DO 300 I=1,2
        SGN=3-2*I
        PL(1)=SGN*PTL*COS(PHL)
        PL(2)=SGN*PTL*SIN(PHL)
        PL(3)=SGN*PL12*COSTHL
        PL(4)=EL(I)
        PL(5)=EML(I)
C          Boost with W momentum
        BP=0.
        DO 310 K=1,3
310     BP=BP+PL(K)*PREST(K)
        BP=BP/PREST(5)
        DO 320 K=1,3
320     PL(K)=PL(K)+PREST(K)*PL(4)/PREST(5)
     $  +PREST(K)*BP/(PREST(4)+PREST(5))
        PL(4)=PL(4)*PREST(4)/PREST(5)+BP
C          Fill common blocks
        PT(I)=SQRT(PL(1)**2+PL(2)**2)
        P(I)=SQRT(PT(I)**2+PL(3)**2)
        IF(PT(I).GT.0.) THEN
          PHI(I)=ATAN2(PL(2),PL(1))
        ELSE
          PHI(I)=(I-1)*PI
        ENDIF
        IF(PHI(I).LT.0.) PHI(I)=PHI(I)+2.*PI
        CTH(I)=PL(3)/P(I)
        STH(I)=PT(I)/P(I)
        TH(I)=ACOS(CTH(I))
        XJ(I)=PL(3)/HALFE
        IF(CTH(I).GT.0.) THEN
          PLPL=PL(4)+PL(3)
          PLMN=(PT(I)**2+EMSQL(I))/PLPL
        ELSE
          PLMN=PL(4)-PL(3)
          PLPL=(PT(I)**2+EMSQL(I))/PLMN
        ENDIF
        YJ(I)=.5*ALOG(PLPL/PLMN)
300   CONTINUE
C
C          Test cross section
C          Extra kinematics for W+W->W+W
C
      IF(KEYS(7).OR.KEYS(9)) THEN
        SHAT=S12
        IF(GOMSSM) THEN
          AMINI=AMASS(LISTSS(INITYP(1)))
        ELSE
          AMINI=AMASS(LISTJ(INITYP(1)))
        ENDIF
        AMFIN=EML(1)
        PINI=.5*SQRT(S12-4.*AMINI**2)
        PFIN=PL12
        THAT=AMINI**2+AMFIN**2-.5*S12+2.*PINI*PFIN*COSTHL
        UHAT=AMINI**2+AMFIN**2-.5*S12-2.*PINI*PFIN*COSTHL
      ENDIF
C
C          Check W decay
C
      IF(NOGOOD(3)) GO TO 20
C
C          Check W decay with kinematic limits
C
      IF(NOGOOD(4)) GO TO 200
350   NKEEP=NKEEP+1
C
C            Set PBEAM
C
      PBEAM(1)=(1.-X1)*HALFE
      PBEAM(2)=(1.-X2)*HALFE
      IF(NJET.LT.3) GO TO 502
      IFL=LISTJ(JETTYP(3))
      EMSQL(3)=AMASS(IFL)**2
502   CONTINUE
C
C          Set PJETS
C
      IF(KEYS(11)) THEN
        N0J=3
      ELSE
        N0J=1
      ENDIF
      DO 501 I=N0J,NJET
        PJETS(3,I)=P(I)*CTH(I)
        PJETS(1,I)=PT(I)*COS(PHI(I))
        PJETS(2,I)=PT(I)*SIN(PHI(I))
        PJETS(4,I)=SQRT(P(I)**2+EMSQL(I))
        PJETS(5,I)=SQRT(EMSQL(I))
        IF(KEYS(7).AND.GOMSSM) THEN
          IDJETS(I)=LISTSS(JETTYP(I))
        ELSE
          IDJETS(I)=LISTJ(JETTYP(I))
        ENDIF
501   CONTINUE
C          No technicolor IDENT's defined, so...
      IF(KEYS(3)) THEN
        IDENTW=LISTW(JWTYP)
      ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN
        IDENTW=81
      ELSEIF(KEYS(7).AND.GOMSSM) THEN
        IDENTW=IHTYPE
      ELSEIF(KEYS(11)) THEN
        IDENTW=92
      ELSE
        IDENTW=0
      ENDIF
C          W momentum in /PJETS/
      IF(KEYS(11)) THEN
        QWJET(1)=QTW*COS(PHIW)
        QWJET(2)=QTW*SIN(PHIW)
        QWJET(3)=QPW
        QWJET(4)=SQRT(QW**2+QMW**2)
        QWJET(5)=QMW
      ELSE
        DO 503 K=1,4
503     QWJET(K)=PJETS(K,1)+PJETS(K,2)
        QWJET(5)=QMW
      ENDIF
C
C          Set PINITS
      DO 504 I=1,2
        IF(KEYS(7).AND.GOMSSM) THEN
          IDINIT(I)=LISTSS(INITYP(I))
        ELSE
          IDINIT(I)=LISTJ(INITYP(I))
        ENDIF
        PINITS(5,I)=AMASS(IDINIT(I))
        PINITS(1,I)=0.
        PINITS(2,I)=0.
504   CONTINUE
C          Calculate total momentum
      QPL=QWJET(4)+QWJET(3)
      QMN=QWJET(4)-QWJET(3)
      IF(NJET.EQ.3) THEN
        QPL=QPL+PJETS(4,3)+PJETS(3,3)
        QMN=QMN+PJETS(4,3)-PJETS(3,3)
      ENDIF
C          and solve initial kinematics
      AM1SQ=PINITS(5,1)**2
      AM2SQ=PINITS(5,2)**2
      ROOT=SQRT((QPL*QMN-AM1SQ-AM2SQ)**2-4.*AM1SQ*AM2SQ)
      P1PL=(QPL*QMN+AM1SQ-AM2SQ+ROOT)/(2.*QMN)
      P1MN=AM1SQ/P1PL
      P2MN=(QPL*QMN+AM2SQ-AM1SQ+ROOT)/(2.*QPL)
      P2PL=AM2SQ/P2MN
      PINITS(3,1)=.5*(P1PL-P1MN)
      PINITS(4,1)=.5*(P1PL+P1MN)
      PINITS(3,2)=.5*(P2PL-P2MN)
      PINITS(4,2)=.5*(P2PL+P2MN)
      RETURN
C
999   CALL PRTEVT(0)
      WRITE(ITLIS,9999) NTRIES
9999  FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE AN',
     C' EVENT. CHECK LIMITS OR INCREASE NTRIES')
      STOP 99
      END
+EOD
+DECK,EBEAM.
      REAL FUNCTION EBEAM(X,E)
C***********************************************************************
C* Computes the effective single electron spectrum from beamstrahlung at *
C* e+e- colliders, using Peskin expression Eq. 6 of SLAC-TN-04-032.    *
C* Use beamstrahlung  parameter Y; is supposed to work for Y <= 10     *
C* The quantities in the COMMON block are the beamstrahlungs parameter *
C* Y, the bunch length XL in GeV, the number of photons NGAM, and the  *
C* parameters NUCL, NUGAM, W, XKAPPA defined by Chen, as well as the   *
C* pre-factor FAC. Y, E and XLMM are read in by BEAM when it is called *
C* for the first time, with INIT=1; in this first run the other para-  *
C* meters are then computed, and simply used in later calls with       *
C* INIT = 0. This COMMON block should be present in the main program   *
C* in order to guarantee the survival of these parameters. Finally, X  *
C* is the electron energy in units of the nominal beam energy. Notice  *
C* that EBEAM  is only the part which is NOT proportional to           *
C* delta(1-X); the coefficient of the delta-function is simply         *
C* exp(-N).                                                            *
C***********************************************************************
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,EEPAR
C
      REAL X,E,GAMMA
      REAL*8 DX,DE,Z,Y,XL,GAM,RE,XKAPPA,NUCL,NUGAM,NGAM,NGAM2,
     $YY,HTOT,H,HTOT0,DEBEAM,DNFAC
      INTEGER N,NFAC,II
      IF (X.LT.1.E-5) X=1.E-5
      IF (X.GT..99999) X=.99999
      DX=X
      DE=E
      Z=1.D0-DX
      Y=UPSLON
      XL = SIGZ*1.D12/.197327D0
      GAM = DE/5.11D-4
      RE = 1.D0/(137.D0*5.11D-4)
      XKAPPA = 2.D0/(3.D0*Y)
      NUCL = 2.5D0*Y/(SQRT(3.D0)*137.D0**2*GAM*RE)
      NUGAM = NUCL/SQRT(1.D0+Y**.6666666D0)
      NGAM = DSQRT(3.D0)*NUGAM*XL
      NGAM2=NGAM/2.D0
      YY=NGAM2*(XKAPPA*Z/X)**.333333D0
      HTOT=0.D0
      DO N=1,20
        NFAC=1
        DO II=1,N
          NFAC=NFAC*II
        END DO
        DNFAC=DBLE(FLOAT(NFAC))
        H=YY**N/DNFAC/DBLE(GAMMA(FLOAT(N)/3.))
        HTOT0=HTOT
        HTOT=HTOT+H
        IF (ABS(HTOT0-HTOT)/HTOT.LT..001D0.AND.N.GT.3) GO TO 101
      END DO
101   CONTINUE
      DEBEAM=DEXP(-XKAPPA*Z/DX)/Z/DX*HTOT*DEXP(-NGAM2)
      EBEAM=DEBEAM
      IF(EBEAM.LT.0.) EBEAM = 1.E-20
      RETURN
      END
+EOD
+DECK,EEBEG.
      SUBROUTINE EEBEG
C          INITIALIZE E+E- EVENTS FOR DOLOG
+CDE,ITAPES
+CDE,PRIMAR
+CDE,JETLIM
+CDE,JETPAR
      DO 100 I=1,2
      PMIN(I)=HALFE
      PMAX(I)=-1.E9
100   CONTINUE
      QSQ=SCM
      IDIN(1)=-12
      IDIN(2)=12
      RETURN
      END
+EOD
+DECK,EEMAX.
      SUBROUTINE EEMAX
C          FIND UPPER BOUND FOR E+E- CROSS SECTION SUMMED OVER ALLOWED
C          TYPES.
C          VER 7.17: ENSURE XJMIN < XX < XJMAX
C          VER 7.42: ENACT BREMSSTRAHLUNG EFFECT
C          Ver 7.54: Define LOUT for possible SSXINT error message.
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETSIG
+CDE,EEPAR
+CDE,JETLIM
+CDE,JETPAR
+CDE,PRIMAR
+CDE,XMSSM
+CDE,SSSM
+CDE,BREMBM
+CDE,SSLUN
C
      REAL ETEST(3),XDI(3),RSH,XD,XDUMMY,SSFEL,DX,XX
      INTEGER NET,NXD,NX,NX1,IET,IXD,IX,I
C
      NET=1
      NXD=1
      ETEST(1)=ECM
C     Initialize beam/brem spectra convolution and fit
      IF (IBEAM) THEN
        LOUT=ITLIS
        EB=HALFE
        QSQBM=EB**2
        WRITE(ITLIS,*) '   BEGINNING BREM/BEAM CONVOLUTION AND FIT...'
        XDUMMY=SSFEL(.1,1)
      END IF
      IF (IBREM) THEN
        NET=3
        NXD=3
        ETEST(1)=RSHMIN
        IF (RSHMAX.GT.AMZ.AND.RSHMIN.LT.AMZ) THEN
          ETEST(2)=AMZ
        ELSE
          ETEST(2)=RSHMIN+(RSHMAX-RSHMIN)/2.
        END IF
        ETEST(3)=MIN(RSHMAX,.999*ECM)
      END IF
      SGMXEE=0.
      NX=50
      IF(FIXYJ(1)) NX=1
      NX1=NX+1
      DX=(XJMAX(1)-XJMIN(1))/NX
C          SCAN IN X=COS(THETA)
      DO IET=1,NET
       RSH=ETEST(IET)
       SHAT=RSH*RSH
       XDI(1)=-(1.-SHAT/SCM)
       XDI(2)=0.
       XDI(3)=-XDI(1)
       DO IXD=1,NXD
        XD=XDI(IXD)
        X1=(XD+SQRT(XD**2+4*SHAT/SCM))/2.
        X2=X1-XD
        DO 100 IX=1,NX1
         XX=XJMIN(1)+DX*(IX-1)
         IF(XX.LT.XJMIN(1)) XX=XJMIN(1)
         IF(XX.GT.XJMAX(1)) XX=XJMAX(1)
         CTH(1)=XX
         CTH(2)=-XX
         DO 110 I=1,2
         XJ(I)=CTH(I)
         TH(I)=ACOS(CTH(I))
         STH(I)=SIN(TH(I))
         PT(I)=HALFE*STH(I)
         IF(IX.EQ.1) YJ(I)=YJMIN(I)
         IF(IX.EQ.NX1) YJ(I)=YJMAX(I)
         IF(IX.GT.1.AND.IX.LT.NX1)
     1   YJ(I)=.5*ALOG((1.+CTH(I))/(1.-CTH(I)))
110      CONTINUE
C          COMPUTE CROSS SECTION
         IF (GOMSSM) THEN
           CALL SIGSSE
         ELSE
           CALL SIGEE
         END IF
         IF(SIGMA.GT.SGMXEE) SGMXEE=SIGMA
100     CONTINUE
       END DO
      END DO
C          REQUIRE CROSS SECTION BE POSITIVE
      WRITE(ITLIS,1000) SGMXEE
1000  FORMAT(///' MAXIMUM D(SIGMA)/D(COS THETA) = ',E12.4)
      IF(SGMXEE.GT.0) RETURN
      STOP 99
      END
+EOD
+DECK,ELCTRN.
      SUBROUTINE ELCTRN
C          GENERATE E+ E- ----> QK QB EVENT USING SIGEE CROSS SECTION.
+CDE,ITAPES
+CDE,JETSIG
+CDE,EEPAR
+CDE,PRIMAR
+CDE,PJETS
+CDE,PINITS
+CDE,JETPAR
+CDE,JETLIM
+CDE,CONST
+CDE,TOTALS
+CDE,PARTCL
+CDE,XMSSM
+CDE,SSTYPE
      REAL AMQ(2),SSXLAM,RSH,XD,GAM,V,DUMMY
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2,
     $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2,IDSS(85)
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MSW1=-ISW1)
      PARAMETER (MSW2=-ISW2)
      PARAMETER (MSNEL=-ISNEL)
      PARAMETER (MSEL=-ISEL)
      PARAMETER (MSNML=-ISNML)
      PARAMETER (MSMUL=-ISMUL)
      PARAMETER (MSNTL=-ISNTL)
      PARAMETER (MSTAU1=-ISTAU1)
      PARAMETER (MSER=-ISER)
      PARAMETER (MSMUR=-ISMUR)
      PARAMETER (MSTAU2=-ISTAU2)
      DIMENSION LISTJ(30)
      DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     111,-11,12,-12,13,-13,14,-14,15,-15,16,-16,10,80,-80,90,81/
      DATA IDSS/0,
     $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1,
     $ISTP1,MSTP1,
     $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2,
     $ISTP2,MSTP2,ISW1,MSW1,ISW2,MSW2,ISZ1,ISZ2,ISZ3,ISZ4,
     $ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,
     $ISNTL,MSNTL,ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,
     $ISTAU2,MSTAU2,
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13,
     $14,-14,15,-15,16,-16,10,80,-80,90,82,83,84,86,-86/
C          ENTRY
      NPTCL=0
      NREJ=-1
      SIGMA=0.
      NSIGS=0
      DO 10 I=1,MXSIGS
10    SIGS(I)=0.
      WT=1.
C          GENERATE NEXT KINEMATIC POINT
100   CONTINUE
      NREJ=NREJ+1
      IF(NREJ.GT.NTRIES) GO TO 9999
      NKINPT=NKINPT+1
      SUMWT=SUMWT+SIGMA*WT
      IF (IBREM) THEN
        RSH=RSHMIN+(RSHMAX-RSHMIN)*RANF()
        SHAT=RSH**2
        QSQ=SHAT
        XD=(1.-SHAT/SCM)*(-1.+2*RANF())
        X1=(XD+SQRT(XD**2+4*SHAT/SCM))/2.
        X2=X1-XD
      ELSE
        SHAT=SCM
        RSH=SQRT(SHAT)
      END IF  
      PHI(1)=PHIMIN(1)+(PHIMAX(1)-PHIMIN(1))*RANF()
      PHI(2)=AMOD(PHI(1)+PI,2.*PI)
      CTH(1)=XJMIN(1)+(XJMAX(1)-XJMIN(1))*RANF()
      CTH(2)=-CTH(1)
      DO 110 I=1,2
      TH(I)=ACOS(CTH(I))
      STH(I)=SIN(TH(I))
      PT(I)=HALFE*STH(I)
      YJ(I)=.5*ALOG((1+CTH(I))/(1-CTH(I)))
      XJ(I)=CTH(I)
110   CONTINUE
C          CALCULATE CROSS SECTION
      IF (GOMSSM) THEN
        CALL SIGSSE
      ELSE
        CALL SIGEE
      END IF
      WT=XJMAX(1)-XJMIN(1)
C          TEST CROSS SECTION
      IF(SIGMA.GT.SGMXEE) SGMXEE=SIGMA
      IF(SIGMA.LT.SGMXEE*RANF()) GO TO 100
      SUMWT=SUMWT+SIGMA*WT
      NKEEP=NKEEP+1
C          SELECT JET TYPES
      SIGINV=1./SIGMA
      TRY=RANF()
      SUM=0.
      DO 200 I=1,NSIGS
      SUM=SUM+SIGS(I)*SIGINV
      IF(SUM.LT.TRY) GO TO 200
C          FIND REACTION
      ISIGS=I
      SIGEVT=SIGS(ISIGS)
      II=INOUT(I)/IOPAK**2
      JETTYP(1)=MOD(II,IOPAK)
      II=II/IOPAK
      JETTYP(2)=MOD(II,IOPAK)
      GO TO 210
200   CONTINUE
      GO TO 9998
C          SET PJETS. RESET P AND PT INCLUDING MASSES.
210   CONTINUE
      IF (GOMSSM) THEN
        AMQ(1)=AMASS(IDSS(JETTYP(1)))
        AMQ(2)=AMASS(IDSS(JETTYP(2)))
      ELSE
        AMQ(1)=AMASS(LISTJ(JETTYP(1)))
        AMQ(2)=AMASS(LISTJ(JETTYP(2)))
      END IF
      PCM=SQRT(SSXLAM(SHAT,AMQ(1)**2,AMQ(2)**2))/2./RSH
      DO 220 I=1,2
      PJETS(1,I)=PCM*STH(I)*COS(PHI(I))
      PJETS(2,I)=PCM*STH(I)*SIN(PHI(I))
      PJETS(3,I)=PCM*CTH(I)
      PJETS(4,I)=SQRT(PCM**2+AMQ(I)**2)
      PJETS(5,I)=AMQ(I)
      IF (GOMSSM) THEN
        IDJETS(I)=IDSS(JETTYP(I))
      ELSE
        IDJETS(I)=LISTJ(JETTYP(I))
      END IF
      P(I)=PCM
      PT(I)=P(I)*STH(I)
220   CONTINUE
C     IF BREMSSTRAHLUNG, THEN BOOST TO LAB FRAME
      IF (IBREM) THEN
        GAM=(X1+X2)*ECM/2./RSH
        V=-SIGN(1.,(X1-X2))*SQRT(ABS(1.-1./GAM)*(1.+1./GAM))
        DO I=1,2
          DUMMY=PJETS(4,I)
          PJETS(4,I)=GAM*(PJETS(4,I)-V*PJETS(3,I))
          PJETS(3,I)=GAM*(PJETS(3,I)-V*DUMMY)
        END DO
      END IF
      RETURN
C          ERROR MESSAGES
9998  CONTINUE
      CALL PRTEVT(0)
      WRITE(ITLIS,1010)
1010  FORMAT(//' ERROR IN ELCTRN...NO GOOD JET TYPES FOUND')
      STOP 99
9999  CONTINUE
      CALL PRTEVT(0)
      WRITE(ITLIS,1020) NTRIES
1020  FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE AN',
     $' EVENT. CHECK LIMITS OR INCREASE NTRIES.')
      STOP 99
      END
+EOD
+DECK,EPF.
      FUNCTION EPF(A,B,C,D)
C          CALCULATE TOTALLY ANTISYMMETRIC TENSOR EPSILON CONTRACTED
C          WITH FOUR 4-VECTORS.
+CDE,ITAPES
      DIMENSION A(4),B(4),C(4),D(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION EPF
      DOUBLE PRECISION A,B,C,D,CD,BCD
+SELF.
      CD(I,J)=C(I)*D(J)-C(J)*D(I)
      BCD(I,J,K)=B(I)*CD(J,K)-B(J)*CD(I,K)+B(K)*CD(I,J)
      EPF=A(1)*BCD(2,3,4)-A(2)*BCD(1,3,4)+A(3)*BCD(1,2,4)
     1-A(4)*BCD(1,2,3)
      RETURN
      END
+EOD
+DECK,ESTRUC.
      FUNCTION ESTRUC(X,QS)
C
C     THIS IS ELECTRON PARTON DISTRIBUTION FUNCTION;
C     SAME AS USED IN PYTHIA; NOTE! ESTRUC=0 FOR X>.999999
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL ESTRUC,AL,PI,AME,QS,X,BT,XM,T,A,B
C
      AL=1./128.
      PI=4*ATAN(1.)
      AME=.511E-3
      BT=2*AL/PI*(LOG(QS/AME/AME)-1.)
C     KLEISS/SJOSTRAND PRESCRIPTION
C      IF (X.LE..9999) THEN
C        ESTRUC=BT/2.*(1.-X)**(BT/2.-1.)
C      ELSE IF (X.LE..999999.AND.X.GT..9999) THEN
C        ESTRUC=100.**(BT/2.)/(100.**(BT/2.)-1.)*BT/2.*
C    $          (1.-X)**(BT/2.-1.)
C      ELSE
C        ESTRUC=0.
C      END IF
C     FADIN-KURAEV/DREES PRESCRIPTION
      XM=.998
      IF(X.GT.XM) THEN
        T = (1.+.375*BT)*(1.-XM)**(BT/2.)
        A = ((1.0-BT/2.)*T
     &        -.25*BT*(1.5-XM*(1.+XM/2.)))/(1.-XM)
     &        +.25*BT*(1.0+XM)
        A = 2*A/(1.-XM)
        B = .5*BT*T/(1.-XM) - .25*BT*(1.+XM) - A*XM
        ESTRUC = A*X+B
      ELSE
        ESTRUC = .5*BT*((1.-X)**(.5*BT-1.)) * (1.+.375*BT)
     &            -.25*BT*(1.+X)
      ENDIF
      RETURN
      END
+EOD
+DECK,EVOL01
      SUBROUTINE EVOL01
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Setup for process 1 (TWOJET)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,FRAME
      REAL    EVOLMS
      INTEGER I,K,J,NJSAVE,NJFINL
C----------------------------------------------------------------------
C
C          Copy momenta from /PJETS/ to /JETSET/
      N0JETS=NJSET+1
      CALL IPJSET
      NJSAVE=NJSET
C
C          Set flags and maximum off-shell masses and generate
C          initial QCD parton shower.
C
      CALL ISTRAD(1.0)
C
      IF(NJSET.LT.0) RETURN
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      CALL IFRAMS(N0JETS,NJSAVE,1,.FALSE.)
C
C          Set maximum off-shell masses and JDCAY flags.
C
      NJFINL=N0JETS
      DO 310 J=N0JETS,NJSAVE
        IF(IABS(JTYPE(J)).LT.10) THEN
          PJSET(5,J)=EVOLMS(J,1.0)
          JDCAY(J)=-1
        ENDIF
310   CONTINUE
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
      RETURN
      END
+EOD
+DECK,EVOL02
      SUBROUTINE EVOL02
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Setup for process 2 (E+E-)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,KEYS
+CDE,FRAME
      REAL    EVOLMS
      INTEGER I,K,J,NJSAVE,NJFINL
C----------------------------------------------------------------------
C
C          Copy momenta from /PJETS/ to /JETSET/
      N0JETS=NJSET+1
      CALL IPJSET
      NJSAVE=NJSET
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      CALL IFRAMS(N0JETS,NJSAVE,1,.FALSE.)
C
C          Set maximum off-shell masses and JDCAY flags.
C
      NJFINL=N0JETS
      DO 310 J=N0JETS,NJSAVE
        IF((IABS(JTYPE(J)).LT.10).OR.
     $     (IABS(JTYPE(J)).GE.21.AND.IABS(JTYPE(J)).LE.29).OR.
     $     (IABS(JTYPE(J)).GE.41.AND.IABS(JTYPE(J)).LE.46))THEN
          PJSET(5,J)=EVOLMS(J,1.0)
          JDCAY(J)=-1
        ENDIF
310   CONTINUE
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
      RETURN
      END
+EOD
+DECK,EVOL03
      SUBROUTINE EVOL03
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Setup for process 3 (DRELLYAN)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,Q1Q2
+CDE,FRAME
+CDE,WCON
      REAL    EVOLMS,BP
      INTEGER I,K,J,NJFINL
C----------------------------------------------------------------------
C
C          Add W momentum and recoil jets
      N0JETS=NJSET+1
      IF(.NOT.STDDY) THEN
        DO 101 I=3,NJET
          NJSET=NJSET+1
          JORIG(NJSET)=JPACK*I
          JTYPE(NJSET)=IDJETS(I)
          JDCAY(NJSET)=0
          DO 105 K=1,5
105       PJSET(K,NJSET)=PJETS(K,I)
          IFRAME(I)=1
101     CONTINUE
        NJSET=NJSET+1
        N0W=NJSET
        JORIG(NJSET)=0
        JTYPE(NJSET)=IDENTW
        JDCAY(NJSET)=(N0W+1)*JPACK+N0W+2
        DO 120 K=1,5
120     PJSET(K,NJSET)=QWJET(K)
      ENDIF
C
C          Add W decays
      DO 110 I=1,2
        NJSET=NJSET+1
        JORIG(NJSET)=JPACK*I
        JTYPE(NJSET)=IDJETS(I)
        JDCAY(NJSET)=0
        DO 115 K=1,5
115     PJSET(K,NJSET)=PJETS(K,I)
        IFRAME(I)=2
        IF(STDDY) IFRAME(I)=1
110   CONTINUE
C
C          Set flags and maximum off-shell masses and generate
C          initial QCD parton shower.
C
      CALL ISTRAD(WFUDGE)
C
      IF(NJSET.LT.0) RETURN
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      IF(STDDY) THEN
        CALL IFRAMS(3,4,1,.FALSE.)
      ELSE
        CALL IFRAMS(N0W+1,N0W+2,2,.FALSE.)
        CALL IFRAMS(N0JETS,N0W,1,.FALSE.)          
      ENDIF
C
C          Set maximum off-shell masses and JDCAY flags.
C
      IF(STDDY) THEN
        NJFINL=3
        DO 310 J=3,4
          IF(IABS(JTYPE(J)).LT.10) THEN
            PJSET(5,J)=QMW
            JDCAY(J)=-1
          ENDIF
310     CONTINUE
      ELSE
        NJFINL=N0JETS
        DO 320 J=N0W+1,N0W+2
          IF(IABS(JTYPE(J)).LT.10) THEN
            PJSET(5,J)=QMW
            JDCAY(J)=-1
          ENDIF
320     CONTINUE
C          Need fudge factor for DRELLYAN
        DO 321 J=N0JETS,N0W
          IF(IABS(JTYPE(J)).LT.10) THEN
            PJSET(5,J)=EVOLMS(J,WFUDGE)
            JDCAY(J)=-1
          ENDIF
321     CONTINUE
      ENDIF
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
C          Reset FRAME using W momentum modified by evolution
      IF(.NOT.STDDY) THEN
        BP=0.
        DO 400 K=1,3
400     BP=BP+FRAME(K,1)*PJSET(K,N0W)
        BP=BP/FRAME(5,1)
        DO 410 K=1,3
          FRAME(K,2)=PJSET(K,N0W)+FRAME(K,1)*PJSET(4,N0W)/FRAME(5,1)
     $    +FRAME(K,1)*BP/(FRAME(4,1)+FRAME(5,1))
410     CONTINUE
        FRAME(4,2)=FRAME(4,1)*PJSET(4,N0W)/FRAME(5,1)+BP
      ENDIF
C
      RETURN
      END
+EOD
+DECK,EVOL05
      SUBROUTINE EVOL05
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Setup for process 5 (SUPERSYM)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,FRAME
      REAL    EVOLMS
      INTEGER I,K,J,NJSAVE,NJFINL,JTABS
C----------------------------------------------------------------------
C
C          Copy momenta from /PJETS/ to /JETSET/
      N0JETS=NJSET+1
      CALL IPJSET
      NJSAVE=NJSET
C
C          Set flags and maximum off-shell masses and generate
C          initial QCD parton shower.
C
      CALL ISTRAD(1.0)
C
      IF(NJSET.LT.0) RETURN
C
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      CALL IFRAMS(N0JETS,NJSAVE,1,.FALSE.)
C
C          Set maximum off-shell masses and JDCAY flags.
C
        NJFINL=N0JETS
        DO 325 J=N0JETS,NJSAVE
          JTABS=IABS(JTYPE(J))
          IF(JTABS.GT.20.AND.JTABS.LT.30) THEN
          PJSET(5,J)=EVOLMS(J,1.0)
          JDCAY(J)=-1
        ENDIF
325   CONTINUE
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
      RETURN
      END
+EOD
+DECK,EVOL06
      SUBROUTINE EVOL06
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Setup for process 6 (WPAIR)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,KEYS
+CDE,FRAME
      REAL    OFF,BP
      INTEGER I,K,J,NJSAVE,NJFINL,JTRUE
C----------------------------------------------------------------------
C
C          Copy momenta from /PJETS/ to /JETSET/
      N0JETS=NJSET+1
      CALL IPJSET
C
C          Add extra momenta for WPAIR
      N0PAIR=NJSET+1
      DO 130 J=1,NPAIR
        NJSET=NJSET+1
        JORIG(NJSET)=JPACK*JPAIR(J)
        JTYPE(NJSET)=IDPAIR(J)
        JDCAY(NJSET)=0
        DO 135 K=1,5
135     PJSET(K,NJSET)=PPAIR(K,J)
130   CONTINUE
      DO 140 J=1,NPAIR,2
        JET=JPAIR(J)
        JTRUE=N0PAIR+J-1
        JDCAY(N0JETS+JET-1)=JTRUE*JPACK+JTRUE+1
140   CONTINUE
      NJSAVE=NJSET
C
C          Set flags and maximum off-shell masses and generate
C          initial QCD parton shower.
C
      CALL ISTRAD(1.0)
C
      IF(NJSET.LT.0) RETURN
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      DO 200 I=3,NJSAVE,2
        JMATCH(I)=I+1
200   JMATCH(I+1)=I
      DO 230 I=1,2
        DO 231 K=1,5
231     FRAME(K,I)=PJSET(K,N0JETS+I-1)
        IFRAME(I)=I
230   CONTINUE
C
C          Set up and generate final state QCD parton shower.
C          Boost PJSET with -FRAME.
C
      DO 240 J=1,NJSAVE
        JET=JORIG(J)/JPACK
        IF(JET.EQ.0) JET=3
        IF(JET.GT.10) GO TO 240
        IF(IDJETS(JET).EQ.10) GO TO 240
C          Do this boost in double precision for 32-bit machines
        CALL DBOOST(-1,FRAME(1,JET),PJSET(1,J))
240   CONTINUE
C
C          Set maximum off-shell masses and JDCAY flags.
C
      NJFINL=N0PAIR
      DO 330 J=1,NPAIR
        IF(IABS(JTYPE(N0PAIR+J-1)).LT.10) THEN
          PJSET(5,N0PAIR+J-1)=PJETS(5,JPAIR(J))
          JDCAY(N0PAIR+J-1)=-1
        ENDIF
330   CONTINUE
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
      RETURN
      END
+EOD
+DECK,EVOL07
      SUBROUTINE EVOL07
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Setup for process 7 (HIGGS)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PINITS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,FRAME
      REAL    EVOLMS,BP
      INTEGER I,K,J,NJSAVE,NJFINL,JTRUE
      DOUBLE PRECISION DPASS(5),DSUM(5)
      INTEGER IDABS1,IDABS2
C----------------------------------------------------------------------
C
C          Copy momenta from /PJETS/ to /JETSET/
      N0JETS=NJSET+1
      CALL IPJSET
C
C          Add extra momenta for WPAIR
      IDABS1=IABS(IDJETS(1))
      IDABS2=IABS(IDJETS(2))
      IF(IDABS1.EQ.80.OR.IDABS1.EQ.90.OR.IDABS2.EQ.80.OR.
     $IDABS2.EQ.90) THEN
        N0PAIR=NJSET+1
        DO 130 J=1,NPAIR
          NJSET=NJSET+1
          JORIG(NJSET)=JPACK*JPAIR(J)
          JTYPE(NJSET)=IDPAIR(J)
          JDCAY(NJSET)=0
          DO 135 K=1,5
135       PJSET(K,NJSET)=PPAIR(K,J)
130     CONTINUE
        DO 140 J=1,NPAIR,2
          JET=JPAIR(J)
          JTRUE=N0PAIR+J-1
          JDCAY(N0JETS+JET-1)=JTRUE*JPACK+JTRUE+1
140     CONTINUE
      ENDIF
      NJSAVE=NJSET
C
C          Set flags and maximum off-shell masses and generate
C          initial QCD parton shower.
C
      IF(IABS(IDINIT(1)).LT.80) THEN
        CALL ISTRAD(1.0)
        IF(NJSET.LT.0) RETURN
C
C
C          Special initial state evolution for W-W fusion.
      ELSE
        CALL HEVOLV
        IF(NJSET.LT.0) RETURN
        DO 141 J=1,NJSET
141     JMATCH(J)=0
        DO 142 JET=1,2
          J=NJSET+1-2*JET
          PJSET(5,J)=-PJSET(5,JET)
142     JDCAY(J)=-2
        CALL QCDINI(NJSET-3,NJSET-1)
        IF(NJSET.LT.0) RETURN
      ENDIF
C
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      DO 200 I=3,NJSAVE,2
        JMATCH(I)=I+1
        JMATCH(I+1)=I
200   CONTINUE
      IF(NPAIR.EQ.0) THEN
        CALL DBLVEC(PJSET(1,N0JETS),DSUM)
        CALL DBLVEC(PJSET(1,N0JETS+1),DPASS)
        DO 231 K=1,4
231     DSUM(K)=DSUM(K)+DPASS(K)
        DSUM(5)=DSQRT(DSUM(4)**2-DSUM(1)**2-DSUM(2)**2-DSUM(3)**2)
        DO 232 K=1,5
          FRAME(K,1)=DSUM(K)
          FRAME(K,2)=FRAME(K,1)
232     CONTINUE
      ELSE
        DO 233 I=1,2
          DO 234 K=1,5
            FRAME(K,I)=PJSET(K,N0JETS+I-1)
234       CONTINUE
          IFRAME(I)=I
233     CONTINUE
      ENDIF
C
C          Set up and generate final state QCD parton shower.
C          Boost PJSET with -FRAME.
C
      DO 240 J=1,NJSAVE
        JET=JORIG(J)/JPACK
        IF(JET.EQ.0) JET=3
        IF(JET.GT.10) GO TO 240
C          Do this boost in double precision for 32-bit machines
        CALL DBOOST(-1,FRAME(1,JET),PJSET(1,J))
240   CONTINUE
C
C          Set maximum off-shell masses and JDCAY flags.
C
      IF(NPAIR.EQ.0) THEN
        NJFINL=N0JETS
        DO 340 J=N0JETS,NJSAVE
          IF(IABS(JTYPE(J)).LT.10) THEN
            PJSET(5,J)=EVOLMS(J,1.0)
            JDCAY(J)=-1
          ENDIF
340     CONTINUE
      ELSE
        NJFINL=N0PAIR
        DO 341 J=1,NPAIR
          IF(IABS(JTYPE(N0PAIR+J-1)).LT.10) THEN
            PJSET(5,N0PAIR+J-1)=PJETS(5,JPAIR(J))
            JDCAY(N0PAIR+J-1)=-1
          ENDIF
341     CONTINUE
      ENDIF
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
      RETURN
      END
+EOD
+DECK,EVOL11.
      SUBROUTINE EVOL11
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-        Setup for process 11 (EXTRADIM)
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,Q1Q2
+CDE,FRAME
+CDE,WCON
C
      INTEGER K,NJFINL,J
      REAL EVOLMS
C----------------------------------------------------------------------
C
C          Add recoil jet (jet 3)
      NJSET=NJSET+1
      N0JETS=NJSET
      JORIG(NJSET)=JPACK*3
      JTYPE(NJSET)=IDJETS(3)
      JDCAY(NJSET)=0
      DO 105 K=1,5
105   PJSET(K,NJSET)=PJETS(K,3)
      IFRAME(3)=1

C          Add W (=KKG)
      NJSET=NJSET+1
      N0W=NJSET
      JORIG(NJSET)=0
      JTYPE(NJSET)=IDENTW
      JDCAY(NJSET)=0
      DO 120 K=1,5
120   PJSET(K,NJSET)=QWJET(K)
C
C          Set flags and maximum off-shell masses and generate
C          initial QCD parton shower.
C
      CALL ISTRAD(1.0)
      IF(NJSET.LT.0) RETURN
C
C          Final state evolution.
C          Define Lorentz frames and JMATCH pointers for jet evolution
C          and fragmentation.
C
      CALL IFRAMS(N0JETS,N0W,1,.FALSE.)
C
C          Set maximum off-shell masses and JDCAY flags.
C
      NJFINL=N0JETS
      DO 321 J=N0JETS,N0W
        IF(IABS(JTYPE(J)).LT.10) THEN
          PJSET(5,J)=EVOLMS(J,WFUDGE)
          JDCAY(J)=-1
        ENDIF
321   CONTINUE
C
C          Produce final-state QCD parton cascade
C
      CALL QCDJET(NJFINL)
C
      RETURN
      END
+EOD
+DECK,EVOLMS
      FUNCTION EVOLMS(J,FUDGE)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-     Set evolution mass scale for parton J
C-
C-   Returned value  : maximum mass
C-
C-   Inputs  : 
C-     J    = index to PJSET array
C-     FUDGE= fudge factor
C-
C-   Created  16-AUG-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL    EVOLMS,FUDGE
      INTEGER J
+CDE,LIMEVL
+CDE,JETSET
+CDE,JETPAR
C----------------------------------------------------------------------
C
      IF ( USELIM ) THEN
        EVOLMS=SQRT(PJSET(1,J)**2+PJSET(2,J)**2)*CONCUT
      ELSE
        EVOLMS=FUDGE*SQRT(QSQ)
      ENDIF
  999 RETURN
      END
+EOD
+DECK,EVOLVE
      SUBROUTINE EVOLVE
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        Call for each process a subroutine to set up
C-        Lorentz frames and perform initial and final QCD jet
C-        evolution in leading-log approximation.
C-
C-   Created  13-AUG-1991   Frank E. Paige,Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PINITS
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,KEYS
+CDE,FRAME
      REAL BP,PINCOM
      INTEGER I,K,J,JJET,IFR
C----------------------------------------------------------------------
C          Initialize
      NJSET=0
      N0JETS=0
      N0W=0
      N0PAIR=0
C
C          Copy momenta from /PINITS/ to /JETSET/
      IF(.NOT.KEYS(2)) THEN
        DO 100 I=1,2
          NJSET=NJSET+1
          JORIG(NJSET)=JPACK*(10+I)
          JTYPE(NJSET)=IDINIT(I)
          JDCAY(NJSET)=JPACK*I+I
          DO 105 K=1,5
105       PJSET(K,NJSET)=PINITS(K,I)
100     CONTINUE
      ENDIF
C
C       Handle each process separately
C
      IF(KEYS(1).OR.KEYS(8)) THEN
        CALL EVOL01
      ELSEIF(KEYS(2)) THEN
        CALL EVOL02
      ELSEIF(KEYS(3)) THEN
        CALL EVOL03
      ELSEIF(KEYS(5)) THEN
        CALL EVOL05
      ELSEIF(KEYS(6).OR.KEYS(10)) THEN
        CALL EVOL06
      ELSEIF(KEYS(7).OR.KEYS(9)) THEN
        CALL EVOL07
      ELSEIF(KEYS(11)) THEN
        CALL EVOL11
      ELSEIF(KEYS(12)) THEN
        CALL EVOL01
      ENDIF
C
      IF(NJSET.LT.0) RETURN
C
C          Boost /JETSET/ partons back to PP COM
C
      DO 500 J=1,NJSET
        JJET=JORIG(J)/JPACK
        IF ( JJET.EQ.0 ) THEN
          IFR=1
        ELSE
          IF(JJET.GT.10) GO TO 500
          IF(IDJETS(JJET).EQ.10.AND.KEYS(6)) GO TO 500
          IFR=IFRAME(JJET)
        ENDIF
        BP=0.
        DO 505 K=1,3
505     BP=BP+FRAME(K,IFR)*PJSET(K,J)
        BP=BP/FRAME(5,IFR)
        DO 510 K=1,3
510     PJSET(K,J)=PJSET(K,J)+FRAME(K,IFR)*PJSET(4,J)/FRAME(5,IFR)
     1  +FRAME(K,IFR)*BP/(FRAME(4,IFR)+FRAME(5,IFR))
        PJSET(4,J)=FRAME(4,IFR)*PJSET(4,J)/FRAME(5,IFR)+BP
500   CONTINUE
C
C          Reset PBEAM
      DO 530 J=1,NJSET
        IF(JDCAY(J).EQ.JPACK*J+J) THEN
          JJET=JORIG(J)/JPACK-10
          PINCOM=.5*(PJSET(4,J)+ABS(PJSET(3,J)))
          PBEAM(JJET)=HALFE-PINCOM
        ENDIF
530   CONTINUE
C
C          Check for zero energy partons
      CALL IRMOV0
C
      RETURN
      END
+EOD
+DECK,FBRBM.
      REAL FUNCTION FBRBM(X)
C
C     Integrand for convolution of 
C     bremsstrahlung with beamstrahlung spectra
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,BREMBM
C
      REAL EBEAM,ESTRUC,X
C
      FBRBM=EBEAM(X,EB)*ESTRUC(XMIN/X,QSQBM)/X
      RETURN
      END
+EOD
+DECK,FLAVOR.
      SUBROUTINE FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX)
C
C          This subroutine unpacks the IDENT code ID=+/-IJKL
C
C          Mesons--
C          I=0, J<=K, +/- is sign for J
C          ID=110 for PI0, ID=220 for ETA, etc.
C
C          Baryons--
C          I<=J<=K in general
C          J<I<K for second state antisymmetric in (I,J), eg. L = 2130
C
C          Other--
C          ID=1,...,6 for quarks
C          ID=9 for gluon
C          ID=10 for photon
C          ID=11,...,16 for leptons
C          ID=20 for KS, ID=-20 for KL
C
C          I=21...26 for left scalar quarks
C          I=29 for gluino
C          I=30 for Z1SS
C          I=31...36 for left scalar leptons
C          I=39 for W1SS
C          I=40 for Z2SS
C          I=41...46 for right scalar quarks
C          I=49 for W2SS
C          I=50 for Z3SS
C          I=51...56 for right scalar leptons
C          I=60 for Z4SS
C
C          ID=80 for W+
C          ID=81,...,89 for Higgs mesons
C          ID=90 for Z0
C          ID=91 for gravitino
C          ID=92 for graviton
C
C          Incomplete meson multiplets used in b decays:
C          ID=10121     A1+(1260)
C          ID=10111     A10(1260)
C          ID=10131     K1+(1270)
C          ID=10231     K10(1270)
C          ID=30131     K1*+(1400)
C          ID=30231     K1*0(1400)
C          ID=132       K2*+(1430)
C          ID=232       K2*0(1430)
C          ID=10110     F0(980)     (mass = 1000 to allow K+K- decay)
C          ID=112       F2(1270)
C          ID=10441     PSI(2S)
C          ID=20440     CHI0
C          ID=20441     CHI1
C          ID=20442     CHI2
C
C          Diquarks--
C          ID=+/-IJ00, I<J for diquark composed of I,J.
C
C          INDEX is a sequence number used internally
C
C          Ver. 7.03: Make more robust by returning INDEX = 0 for
C          bad ID codes. Does not check for valid baryons, e.g.,
C          uuu with J = 1/2. Test on LABEL(1:3) = 'ERR' for this.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QLMASS
+CDE,SSTYPE
C
      INTEGER ID,IFL1,IFL2,IFL3,JSPIN,INDEX
      INTEGER I,J,K,IDABS,INDXSP
C
      IDABS=IABS(ID)
C
C          Select case
C
      IF(IDABS.GT.NQLEP-1.AND.IDABS.LT.80) GO TO 400
      IF(IDABS.GT.92.AND.IDABS.LE.100) GO TO 400
C          Quarks: ID < 100
      IF(IDABS.LT.100) GO TO 200
      I=MOD(IDABS/1000,10)
      J=MOD(IDABS/100,10)
      K=MOD(IDABS/10,10)
      JSPIN=MOD(IDABS,10)
C          Special hadrons
      IF(IDABS.GE.10000.OR.JSPIN.GT.1) GO TO 500
      IF(I.EQ.9.OR.J.EQ.9.OR.K.EQ.9) GO TO 400
C          Mesons: 100 < ID < 1000
      IF(IDABS.LT.1000) GO TO 100
C          Diquarks: ID > 1000 but K = 0
      IF(K.EQ.0.AND.JSPIN.EQ.0) GO TO 300
C
C          Baryons
C          Only X,Y baryons are QQX, QQY, Q=U,D,S.
C
      IF(I.GT.K.OR.J.GT.K.OR.J.EQ.0) GO TO 400
      IF(K.GT.6.AND.(I.GT.3.OR.J.GT.3)) GO TO 400
      IFL1=ISIGN(I,ID)
      IFL2=ISIGN(J,ID)
      IFL3=ISIGN(K,ID)
      IF(K.LE.6) THEN
        INDEX=MAX0(I-1,J-1)**2+I+MAX0(I-J,0)+(K-1)*K*(2*K-1)/6
     1  +109*JSPIN+36*NMES+NQLEP+13
      ELSE
        INDEX=MAX0(I-1,J-1)**2+I+MAX0(I-J,0)+9*(K-7)+91
     1  +109*JSPIN+36*NMES+NQLEP+13
      ENDIF
      RETURN
C
C          Mesons
C
100   CONTINUE
      IF(J.GT.K) GO TO 400
      IF(J.EQ.K.AND.ID.LT.0) GO TO 400
      IFL1=0
      IFL2=ISIGN(J,ID)
      IFL3=ISIGN(K,-ID)
      INDEX=J+K*(K-1)/2+36*JSPIN+NQLEP
      INDEX=INDEX+13
      RETURN
C
C          Quarks, leptons, etc
C
200   CONTINUE
      IFL1=0
      IFL2=0
      IFL3=0
      JSPIN=0
      INDEX=IDABS
      IF(IDABS.LT.20) RETURN
C          Define INDEX=20 for KS, INDEX=21 for KL
      INDEX=IDABS+1
      IF(ID.EQ.20) INDEX=20
C          INDEX=NQLEP+1,...,NQLEP+13 for W+, Higgs, Z0, GVSS, GRAV
      IF(IDABS.LT.80) RETURN
      INDEX=NQLEP+IDABS-79
      RETURN
C
C          Diquarks
C
300   IF(JSPIN.GT.0.OR.I.GT.J) GO TO 400
      IF(I.GT.6.OR.J.GT.6) GO TO 400
      IFL1=ISIGN(I,ID)
      IFL2=ISIGN(J,ID)
      IFL3=0
      JSPIN=0
      INDEX=109*NBARY+36*NMES+NQLEP+13+I+J*(J-1)/2
      RETURN
C
C          Error
C
400   CONTINUE
      IFL1=0
      IFL2=0
      IFL3=0
      JSPIN=0
      INDEX=0
      RETURN
C
C          Special mesons - used only for B decays
C
500   INDXSP=400
      IF(IDABS.EQ.10121) THEN
        INDEX=INDXSP+1
      ELSEIF(IDABS.EQ.10111) THEN
        INDEX=INDXSP+2
      ELSEIF(IDABS.EQ.10131) THEN
        INDEX=INDXSP+3
      ELSEIF(IDABS.EQ.10231) THEN
        INDEX=INDXSP+4
      ELSEIF(IDABS.EQ.30131) THEN
        INDEX=INDXSP+5
      ELSEIF(IDABS.EQ.30231) THEN
        INDEX=INDXSP+6
      ELSEIF(IDABS.EQ.132) THEN
        INDEX=INDXSP+7
      ELSEIF(IDABS.EQ.232) THEN
        INDEX=INDXSP+8
      ELSEIF(IDABS.EQ.10110) THEN
        INDEX=INDXSP+9
      ELSEIF(IDABS.EQ.112) THEN
        INDEX=INDXSP+10
      ELSEIF(IDABS.EQ.10441) THEN
        INDEX=INDXSP+11
      ELSEIF(IDABS.EQ.20440) THEN
        INDEX=INDXSP+12
      ELSEIF(IDABS.EQ.20441) THEN
        INDEX=INDXSP+13
      ELSEIF(IDABS.EQ.20442) THEN
        INDEX=INDXSP+14
      ELSEIF(IDABS.EQ.IDTAUL) THEN
        INDEX=INDXSP+15
      ELSEIF(IDABS.EQ.IDTAUR) THEN
        INDEX=INDXSP+16
      ELSE
        INDEX=0
      ENDIF
      IF(INDEX.GT.0) THEN
        IFL1=0
        IFL2=ISIGN(J,ID)
        IFL3=ISIGN(K,-ID)
      ELSE
        IFL1=0
        IFL2=0
        IFL3=0
      ENDIF
C
      RETURN
      END
+EOD
+DECK,FORTOP.
      SUBROUTINE FORTOP
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-     add to force list forced decays for all heavy q particles
C-     if there was a request to force a heavy q decay
C-     Zero IFORCE after use
C-
C-   Created  15-DEC-1989   Serban D. Protopopescu
C-
C    Ver 7.30: Decay top quark rather than hadron, so no longer needed.
C----------------------------------------------------------------------
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,FORCE
C----------------------------------------------------------------------
      RETURN
      END
+EOD
+DECK,FRGJET
      SUBROUTINE FRGJET(JET)
C
C          Hadronize all partons in /JETSET/ corresponding to jet JET.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PINITS
+CDE,PARTCL
+CDE,CONST
+CDE,JETSET
+CDE,JWORK
+CDE,KEYS
+CDE,Q1Q2
+CDE,FRAME
C
      REAL ROT(3,3),POLD(5),PNEW(5),PSUM(5)
      REAL CPHI,SPHI,AMSUM,ESUM,PJ,CTHJ,STHJ,PTJ
      INTEGER K,K1,K2,IP,NPLV1,IFAIL,NBEGIN,JET,NFRAG,NFRGMX,JETJ,
     $JTABS,NFIRST,J
C
      DATA PSUM/5*0./
C
C          NFRAG counter protects against possible infinite loop.
C
      NFRAG=0
      NFRGMX=10*MXJSET
201   NBEGIN=NPTCL+1
      NFRAG=NFRAG+1
C
C          Loop over partons
C 
      ESUM=0.
      DO 220 J=1,NJSET
        IF(JDCAY(J).NE.0) GO TO 220
        JETJ=JORIG(J)/JPACK
        IF(JETJ.NE.JET) GO TO 220
        ESUM=ESUM+PJSET(4,J)
C
C          Generate Field-Feynman jet for each quark or gluon, or...
C
        JTABS = IABS(JTYPE(J))
        IF(JTABS.LT.10) THEN
          NFIRST=NPTCL+1
          CALL JETGEN(J)
          IF(NPTCL.LT.NFIRST) GO TO 220
C
C          Rotate hadrons to parton direction
C
          PTJ=PJSET(1,J)**2+PJSET(2,J)**2
          PJ=SQRT(PTJ+PJSET(3,J)**2)
          PTJ=SQRT(PTJ)
C          Following is to fix occasional bug on 32-bit machines
          IF(PJ.GT.0.) THEN
            CTHJ=PJSET(3,J)/PJ
            STHJ=PTJ/PJ
          ELSE
            CTHJ=1.
            STHJ=0.
          ENDIF
          IF(PTJ.GT.0.) THEN
            CPHI=PJSET(1,J)/PTJ
            SPHI=PJSET(2,J)/PTJ
          ELSE
            CPHI=SIGN(1.,PJSET(3,J))
            SPHI=0.
          ENDIF
          ROT(1,1)=CPHI*CTHJ
          ROT(2,1)=SPHI*CTHJ
          ROT(3,1)=-STHJ
          ROT(1,2)=-SPHI
          ROT(2,2)=CPHI
          ROT(3,2)=0.
          ROT(1,3)=CPHI*STHJ
          ROT(2,3)=SPHI*STHJ
          ROT(3,3)=CTHJ
          DO 230 IP=NFIRST,NPTCL
            DO 235 K=1,3
              POLD(K)=PPTCL(K,IP)
              PPTCL(K,IP)=0
235         CONTINUE
            DO 240 K1=1,3
            DO 240 K2=1,3
240         PPTCL(K1,IP)=PPTCL(K1,IP)+ROT(K1,K2)*POLD(K2)
230       CONTINUE
C
C          ... hadronize all other partons with delta function.
C
        ELSE
          IF((IABS(JTYPE(J)).EQ.80.OR.IABS(JTYPE(J)).EQ.90).AND.
     $    .NOT.KEYS(2).AND..NOT.KEYS(12)) GO TO 210
          IF(NPTCL.GE.MXPTCL) GO TO 9999
          NPTCL=NPTCL+1
          DO 255 K=1,5
            PPTCL(K,NPTCL)=PJSET(K,J)
255       CONTINUE
          IORIG(NPTCL)=-J
          IDENT(NPTCL)=JTYPE(J)
          IDCAY(NPTCL)=0
        ENDIF
220   CONTINUE
C
C          Sum masses and insert jet label
C
      AMSUM=0.
      DO 260 IP=NBEGIN,NPTCL
        AMSUM=AMSUM+PPTCL(5,IP)
        IORIG(IP)=ISIGN(IABS(IORIG(IP))+IPACK*JET,IORIG(IP))
260   CONTINUE
C
C          Require sum of masses less than jet energy.
C
      IF(AMSUM.GT.ESUM.AND.NBEGIN.NE.NPTCL.AND.NFRAG.LT.NFRGMX) THEN
        NPTCL=NBEGIN-1
        GO TO 201
      ENDIF
C
C          For WPAIR events rescale jet to W mass.
C
      IF((KEYS(6).OR.KEYS(7).OR.KEYS(9).OR.KEYS(10)).AND.JET.LT.10) 
     $ THEN
        IF(IABS(JTYPE(JET+N0JETS-1)).LT.80) RETURN
        IF(AMSUM.GE.PJSET(5,JET+N0JETS-1)) THEN
          IF(NFRAG.GT.NFRGMX) RETURN
          NPTCL=NBEGIN-1
          GO TO 201
        ENDIF
        PSUM(4)=PJSET(5,JET+N0JETS-1)
        PSUM(5)=PSUM(4)
        NPLV1=NPTCL
        CALL RESCAL(NBEGIN,NPLV1,PSUM,IFAIL)
      ENDIF
C
210   RETURN
C
C          Error
C
9999  CALL PRTEVT(0)
      WRITE(ITLIS,9998) NPTCL
9998  FORMAT(//' ERROR IN FRGJET ... NPTCL > ',I6)
      RETURN
      END
+EOD
+DECK,FRGMNT
      SUBROUTINE FRGMNT
C
C          Control jet fragmentation.  Boost to frames defined in
C          EVOLVE and call JETGEN.
C
C          EVOLVE initializes /PJSET/ as follows--
C          1      - 2            = PINITS (except for E+E-)
C          N0W    - N0W          = QWJET  (for DRELLYAN, NJET=3)
C          N0JETS - N0JETS+NJET  = PJETS
C          N0PAIR - N0PAIR+NPAIR = PPAIR  (for WPAIR)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PINITS
+CDE,PARTCL
+CDE,CONST
+CDE,JETSET
+CDE,JWORK
+CDE,KEYS
+CDE,Q1Q2
+CDE,FRAME
C
      REAL PSUM(5),PALLJ(5),P12(5),PIN(5,2),PWREST(5),PADD(5)
      REAL POLD(5),PNEW(5)
      REAL PINPL,PINMN,BP,PT2AVE,PTADD,RANF,PHIADD,PALLPL,PALLMN
      REAL PALLX,PALLY
      INTEGER K,J,JJET,NZERO,IB,NPTCL1,NPTCL2,IFAIL,JET,NPJET1,NPLV1
      INTEGER NPJET3,IP,NP1,NP2,NFIRST,IP1,IFR,NLJ
      DOUBLE PRECISION DSUM(5),DPASS(5)
C
C          Initialize
      DO 100 K=1,5
100   DSUM(K)=0.
      NLJ=NJET
      IF(KEYS(3)) NLJ=NJET+1
      DO 101 J=1,NLJ
        JJET=N0JETS+J-1
        IF(JJET.EQ.N0W) GOTO 101
        CALL DBLVEC(PJSET(1,JJET),DPASS)
        DO 102 K=1,4
102     DSUM(K)=DSUM(K)+DPASS(K)
101   CONTINUE
      DSUM(5)=DSQRT(DSUM(4)**2-DSUM(1)**2-DSUM(2)**2-DSUM(3)**2)
      DO 103 K=1,5
103   PALLJ(K)=DSUM(K)
C
      NZERO=NPTCL+1
C
C          Fragment partons from initial state shower
C
      IF(.NOT.KEYS(2)) THEN
        DO 110 J=1,NJSET
          IF(JDCAY(J).EQ.JPACK*J+J) THEN
            IB=JORIG(J)/JPACK-10
            DO 120 K=1,5
120         PIN(K,IB)=PJSET(K,J)
          ENDIF
110     CONTINUE
C
        CALL FRGJET(11)
        CALL FRGJET(12)
C
        NPTCL1=NPTCL+1
        NPTCL2=NPTCL1+1
        IF(NPTCL1.GT.MXPTCL) GO TO 9999
        PINPL=.5*(PIN(4,1)+PIN(3,1)+PIN(4,2)+PIN(3,2))
        PINMN=.5*(PIN(4,1)-PIN(3,1)+PIN(4,2)-PIN(3,2))
        PPTCL(1,NPTCL1)=0.
        PPTCL(2,NPTCL1)=0.
        PPTCL(3,NPTCL1)=HALFE-PINPL
        PPTCL(4,NPTCL1)=HALFE-PINPL
        PPTCL(5,NPTCL1)=0.
        PPTCL(1,NPTCL2)=0.
        PPTCL(2,NPTCL2)=0.
        PPTCL(3,NPTCL2)=-(HALFE-PINMN)
        PPTCL(4,NPTCL2)=HALFE-PINMN
        PPTCL(5,NPTCL2)=0.
        DO 130 K=1,4
130     PSUM(K)=-PALLJ(K)
        PSUM(4)=PSUM(4)+ECM
        PSUM(5)=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
        IF(PSUM(5).GE.0.) THEN
          PSUM(5)=SQRT(PSUM(5))
          CALL RESCAL(NZERO,NPTCL2,PSUM,IFAIL)
        ENDIF
C
        DO 140 K=1,4
140     PBEAMS(K)=PPTCL(K,NPTCL1)+PPTCL(K,NPTCL2)
        PBEAMS(5)=SQRT(PBEAMS(4)**2-PBEAMS(1)**2-PBEAMS(2)**2
     $  -PBEAMS(3)**2)
      ENDIF
C
C          Boost partons from final jets with -FRAME
C
200   DO 210 J=1,NJSET
        JET=JORIG(J)/JPACK
        IF ( JET.EQ.0 ) THEN
          IFR=1
        ELSE
          IF(JET.GT.10) GO TO 210
          IF(KEYS(6)) THEN
            IF(IDJETS(JET).EQ.10) GO TO 210
          ENDIF
          IFR=IFRAME(JET)
        ENDIF
C
C          Do this boost in double precision for 32-bit machines
        CALL DBOOST(-1,FRAME(1,IFR),PJSET(1,J))
210   CONTINUE
C
C          Fragment partons from final jets
C
      NPJET1=NPTCL+1
      DO 220 K=1,4
220   PSUM(K)=0
C
C          Conserve mass of 1+2 for DRELLYAN (automatic for WPAIR)
C
      IF(KEYS(3)) THEN
        CALL FRGJET(1)
        CALL FRGJET(2)
        IF(STDDY) THEN
          DO 230 K=1,4
            PSUM(K)=PJSET(K,3)+PJSET(K,4)
  230     CONTINUE
        ELSE
          DO 240 K=1,4
            PSUM(K)=PJSET(K,N0W+1)+PJSET(K,N0W+2)
  240     CONTINUE
        ENDIF
        PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)
        NPLV1=NPTCL
        CALL RESCAL(NPJET1,NPLV1,PSUM,IFAIL)
C          EXTRADIM has only jet3 + graviton
      ELSEIF(KEYS(11)) THEN
        CALL FRGJET(3)
        CALL FRGJET(0)
        NPLV1=NPTCL
        DO 241 K=1,4
          PSUM(K)=PJSET(K,3)+PJSET(K,4)
241     CONTINUE
        PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)
        CALL RESCAL (NPJET1,NPLV1,PSUM,IFAIL)
      ELSE
C          All other processes
        DO 242 J=1,NJET
          JJET=N0JETS+J-1
          CALL FRGJET(J)
          DO 243 K=1,4
  243     PSUM(K)=PSUM(K)+PJSET(K,JJET)
  242   CONTINUE
        PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)
        NPLV1=NPTCL
        CALL RESCAL(NPJET1,NPLV1,PSUM,IFAIL)
      ENDIF
C
C           Add extra jets for DRELLYAN
      IF(KEYS(3).AND..NOT.STDDY) THEN
        NPJET3=NPTCL+1
        DO 245 J=3,NJET
245     CALL FRGJET(J)
        NPTCL1=NPTCL+1
        IF(NPTCL1.GT.MXPTCL) GO TO 9999
        DO 250 K=1,4
          PPTCL(K,NPTCL1)=PJSET(K,N0W)
250     PSUM(K)=PJSET(K,N0W)
        PPTCL(5,NPTCL1)=PJSET(5,N0W)
        DO 246 J=3,NJET
          JJET=N0JETS+J-3
          DO 246 K=1,4
            PSUM(K)=PSUM(K)+PJSET(K,JJET)
  246   CONTINUE    
        PSUM(5)=SQRT(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2)
        CALL RESCAL(NPJET3,NPTCL1,PSUM,IFAIL)
        DO 260 K=1,5
260     PWREST(K)=PPTCL(K,NPTCL1)
      ENDIF
C
C          Boost partons back to PP COM
C
      DO 300 J=1,NJSET
        JET=JORIG(J)/JPACK
        IF ( JET.EQ.0 ) THEN
          IFR=1
        ELSE
          IF(JET.GT.10) GO TO 300
          IF(KEYS(6)) THEN
            IF(IDJETS(JET).EQ.10) GO TO 300
          ENDIF
          IFR=IFRAME(JET)
        ENDIF
        BP=0.
        DO 305 K=1,3
305     BP=BP+FRAME(K,IFR)*PJSET(K,J)
        BP=BP/FRAME(5,IFR)
        DO 310 K=1,3
310     PJSET(K,J)=PJSET(K,J)+FRAME(K,IFR)*PJSET(4,J)/FRAME(5,IFR)
     $  +FRAME(K,IFR)*BP/(FRAME(4,IFR)+FRAME(5,IFR))
        PJSET(4,J)=FRAME(4,IFR)*PJSET(4,J)/FRAME(5,IFR)+BP
300   CONTINUE
C
C          Reset FRAME to boost hadrons to PP COM
C
      IF(KEYS(1).OR.KEYS(2).OR.(KEYS(3).AND.NJET.EQ.2).OR.KEYS(5)
     $.OR.(KEYS(7).AND.NPAIR.EQ.0).OR.KEYS(8)) THEN
        DO 410 K=1,5
          FRAME(K,1)=PALLJ(K)
410     CONTINUE
      ELSEIF(KEYS(3).AND.NJET.GT.2) THEN
        DO 420 K=1,5
420     FRAME(K,1)=PALLJ(K)
        BP=0.
        DO 430 K=1,3
430     BP=BP+FRAME(K,1)*PWREST(K)
        BP=BP/FRAME(5,1)
        DO 440 K=1,3
          FRAME(K,2)=PWREST(K)+FRAME(K,1)*PWREST(4)/FRAME(5,1)
     $    +FRAME(K,1)*BP/(FRAME(4,1)+FRAME(5,1))
440     CONTINUE
        FRAME(4,2)=FRAME(4,1)*PWREST(4)/FRAME(5,1)+BP
      ENDIF
C
C          Boost hadrons back to PP COM
C
      DO 500 IP=NZERO,NPTCL
        JET=IABS(IORIG(IP))/IPACK
        IF(JET.GT.10) GO TO 500
        IF(KEYS(6)) THEN
          IF(IDJETS(JET).EQ.10) GO TO 500
        ENDIF
        IF(JET.EQ.0) THEN
          IFR=1
        ELSE
          IFR=IFRAME(JET)
        ENDIF
        BP=0.
        DO 510 K=1,3
510     BP=BP+FRAME(K,IFR)*PPTCL(K,IP)
        BP=BP/FRAME(5,IFR)
        DO 520 K=1,3
520     PPTCL(K,IP)=PPTCL(K,IP)+FRAME(K,IFR)*PPTCL(4,IP)/FRAME(5,IFR)
     $  +FRAME(K,IFR)*BP/(FRAME(4,IFR)+FRAME(5,IFR))
        PPTCL(4,IP)=FRAME(4,IFR)*PPTCL(4,IP)/FRAME(5,IFR)+BP
500   CONTINUE
C
C          Add intrinsic PT
C
      IF(.NOT.KEYS(2)) THEN
        PT2AVE=.1*SQRT(QSQ)
        PTADD=SQRT(-PT2AVE*ALOG(RANF()))
        PHIADD=2.*PI*RANF()
        PADD(1)=2.*PTADD*COS(PHIADD)
        PADD(2)=2.*PTADD*SIN(PHIADD)
C          Must use large and small components carefully to calculate
C          mass on 32-bit machines.
        PALLPL=0.
        PALLMN=0.
        PALLX=0.
        PALLY=0.
        DO 525 IP=NZERO,NPTCL
          PALLX=PALLX+PPTCL(1,IP)
          PALLY=PALLY+PPTCL(2,IP)
          IF(PPTCL(3,IP).GT.0.) THEN
            PALLPL=PALLPL+(PPTCL(4,IP)+PPTCL(3,IP))
            PALLMN=PALLMN+(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(5,IP)**2)
     $      /(PPTCL(4,IP)+PPTCL(3,IP))
          ELSE
            PALLMN=PALLMN+(PPTCL(4,IP)-PPTCL(3,IP))
            PALLPL=PALLPL+(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(5,IP)**2)
     $      /(PPTCL(4,IP)-PPTCL(3,IP))
          ENDIF
525     CONTINUE
        POLD(1)=PALLX
        POLD(2)=PALLY
        POLD(3)=.5*(PALLPL-PALLMN)
        POLD(4)=.5*(PALLPL+PALLMN)
        POLD(5)=SQRT(PALLPL*PALLMN-PALLX**2-PALLY**2)
        PNEW(1)=PADD(1)+POLD(1)
        PNEW(2)=PADD(2)+POLD(2)
        PNEW(3)=POLD(3)
        PNEW(4)=SQRT(PNEW(1)**2+PNEW(2)**2+PNEW(3)**2+POLD(5)**2)
        PNEW(5)=POLD(5)
C
        DO 530 IP=NZERO,NPTCL
          BP=0.
          DO 531 K=1,3
531       BP=BP+POLD(K)*PPTCL(K,IP)
          BP=BP/POLD(5)
          DO 532 K=1,3
532       PPTCL(K,IP)=PPTCL(K,IP)-POLD(K)*PPTCL(4,IP)/POLD(5)
     $    +POLD(K)*BP/(POLD(4)+POLD(5))
          PPTCL(4,IP)=PPTCL(4,IP)*POLD(4)/POLD(5)-BP
C
          BP=0.
          DO 533 K=1,3
533       BP=BP+PNEW(K)*PPTCL(K,IP)
          BP=BP/PNEW(5)
          DO 534 K=1,3
534       PPTCL(K,IP)=PPTCL(K,IP)+PNEW(K)*PPTCL(4,IP)/PNEW(5)
     $    +PNEW(K)*BP/(PNEW(4)+PNEW(5))
          PPTCL(4,IP)=PPTCL(4,IP)*PNEW(4)/PNEW(5)+BP
530     CONTINUE
C
C            Add opposite PT to beam jets
        DO 541 K=1,4
541     PBEAMS(K)=-PNEW(K)
        PBEAMS(4)=PBEAMS(4)+ECM
        PBEAMS(5)=PBEAMS(4)**2-PBEAMS(1)**2-PBEAMS(2)**2 -PBEAMS(3)**2
        IF ( PBEAMS(5).GT.0 ) THEN
          PBEAMS(5)=SQRT(PBEAMS(5))
        ELSE
          PBEAMS(4)=SQRT(PBEAMS(4)**2-PBEAMS(5)+4.)
          PBEAMS(5)=2.
        ENDIF
      ENDIF
C
C          Decay hadrons
C
      NP1=NZERO
600   NP2=NPTCL
      DO 610 IP=NP1,NP2
        NFIRST=NPTCL+1
        JET=IABS(IORIG(IP))/IPACK
        CALL DECAY(IP)
        DO 620 IP1=NFIRST,NPTCL
620     IORIG(IP1)=ISIGN(IABS(IORIG(IP1))+IPACK*JET,IORIG(IP1))
610   CONTINUE
      NP1=NP2+1
      IF(NP1.LE.NPTCL) GO TO 600
      RETURN
C
C          Error
C
9999  CALL PRTEVT(0)
      WRITE(ITLIS,9998) NPTCL
9998  FORMAT(//' ERROR IN FRGMNT ... NPTCL > ',I6)
      RETURN
      END
+EOD
+DECK,GAMMA.
      FUNCTION GAMMA(X)
+CDE,ITAPES
      DIMENSION C(13)
      DATA C
     1/ 0.00053 96989 58808, 0.00261 93072 82746, 0.02044 96308 23590,
     2  0.07309 48364 14370, 0.27964 36915 78538, 0.55338 76923 85769,
     3  0.99999 99999 99998,-0.00083 27247 08684, 0.00469 86580 79622,
     4  0.02252 38347 47260,-0.17044 79328 74746,-0.05681 03350 86194,
     5  1.13060 33572 86556/
      Z=X
      IF(X .GT. 0.0) GO TO 1
      IF(X .EQ. AINT(X)) GO TO 5
      Z=1.0-Z
    1 F=1.0/Z
      IF(Z .LE. 1.0) GO TO 4
      F=1.0
    2 IF(Z .LT. 2.0) GO TO 3
      Z=Z-1.0
      F=F*Z
      GO TO 2
    3 Z=Z-1.0
    4 GAMMA=
     1 F*((((((C(1)*Z+C(2))*Z+C(3))*Z+C(4))*Z+C(5))*Z+C(6))*Z+C(7))/
     2   ((((((C(8)*Z+C(9))*Z+C(10))*Z+C(11))*Z+C(12))*Z+C(13))*Z+1.0)
      IF(X .GT. 0.0) RETURN
      GAMMA=3.141592653589793/(SIN(3.141592653589793*X)*GAMMA)
      RETURN
    5 GAMMA=0.
      WRITE(ITLIS,10) X
      RETURN
   10 FORMAT(1X,'GAMMA ... ARGUMENT IS NON-POSITIVE INTEGER = ',E20.5)
      END
+EOD
+DECK,GETPT.
      SUBROUTINE GETPT(PT0,PTMEAN)
C          GENERATE PT WITH 1/(1+B*PT**2)**4 DISTRIBUTION
C          (APPROXIMATELY AN EXPONENTIAL FOR PT < 2 GEV.)
C          CON1=16/(3*PI)
C          CON2=-1/3
+CDE,ITAPES
      DATA CON1/1.697652726/,CON2/-.3333333333/
      R=RANF()
      ARG=AMAX1(R**CON2-1.,0.)
      PT0=PTMEAN*CON1*SQRT(ARG)
      RETURN
      END
+EOD
+DECK,GETTOT.
      SUBROUTINE GETTOT(PRFLAG)
C
C          Calculate total cross section within jet limits.
C          If PRFLAG=.TRUE. print summary.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,FINAL
+CDE,TIMES
+CDE,TOTALS
+CDE,KEYS
+CDE,Q1Q2
+CDE,CONST
+CDE,JETLIM
+CDE,DYLIM
+CDE,TYPES
+CDE,IDRUN
+CDE,SEED
+CDE,PRIMAR
+CDE,ISLOOP
+CDE,MGSIGS
C
      REAL DELPHI,SIGF2,FRAC,TMEAN,ALUM2,SIGF3
      LOGICAL PRFLAG
      INTEGER I,II,KK
      REAL TMP
      LOGICAL MGFLAG
      INTEGER L,LINT,LK1,LK2
C
C          Calculate jet cross sections
C
      SIGF=0.
      ALUM=0.
      ACCEPT=0.
      NKINF=NKINPT
C          For 2-body processes we can use the totals.
C          For MadGraph we must sum the partial cross sections.
      MGFLAG=KEYS(12)
      IF(NKINPT.GT.0.AND..NOT.MGFLAG) THEN
        SIGF=SUMWT/NKINPT
        DELPHI=2.*PI
        IF(KEYS(1).OR.KEYS(2).OR.KEYS(5).OR.KEYS(6).OR.KEYS(8)
     $  .OR.KEYS(9)) THEN
          DELPHI=PHIMAX(1)-PHIMIN(1)
        ELSEIF(KEYS(3).AND..NOT.STDDY) THEN
          DELPHI=PHWMAX-PHWMIN
        ENDIF
        SIGF=SIGF*DELPHI/(2.*PI)
      ELSEIF(MGFLAG) THEN
        DO 10 I=1,NSIG8
          SIGF=SIGF+WTSUM8(I)/NWT8(I)
10      CONTINUE
      ENDIF
C
C          Print summary if desired
C
      IF(.NOT.PRFLAG) RETURN
C
C          Print header and title
      WRITE(ITLIS,100)
100   FORMAT('1',30('*')/' *',28X,'*'/
     1' *',5X,'ISAJET RUN SUMMARY',5X,'*'/
     2' *',28X,'*'/1X,30('*')//)
      WRITE(ITLIS,101) TITLE
101   FORMAT(//11X,10A8)
      IF(NKINPT.EQ.0) GO TO 300
C
C          Print cross section
      WRITE(ITLIS,102) NKINPT
102   FORMAT(//' NO. KINEMATIC POINTS GENERATED      =',I13)
      SIGF2=SIGF*NEVOLV*NFRGMN
      WRITE(ITLIS,103) SIGF2
103   FORMAT(//' MONTE CARLO JET CROSS SECTION       =',E13.4,' MB')
      IF(SIGF.EQ.0.) WRITE(ITLIS,111)
111   FORMAT(' CROSS SECTION IS ZERO IF VARIABLES ARE FIXED')
C
C          Print W decay acceptance
      IF(KEYS(3)) THEN
        ACCEPT=FLOAT(NKEEP)/FLOAT(NWGEN)
        WRITE(ITLIS,105) ACCEPT
105     FORMAT(//' ACCEPTANCE FOR W DECAYS             =',E13.4)
      ELSEIF(KEYS(7)) THEN
        ACCEPT=FLOAT(NKEEP)/FLOAT(NWGEN)
        WRITE(ITLIS,106) ACCEPT
106     FORMAT(//' ACCEPTANCE FOR H DECAYS             =',E13.4)
      ENDIF
C
C          Print luminosity
      IF(SIGF.GT.0.) THEN
        ALUM=NEVENT/SIGF
        IF(KEYS(4)) ALUM=NKINPT/SIGF
        WRITE(ITLIS,104) ALUM
104     FORMAT(//' EQUIVALENT INTEGRAL LUMINOSITY      =',E13.4,
     $  ' /MB')
      ENDIF
C
C          Print final multijet cross sections
      IF(KEYS(12)) THEN
        WRITE(ITLIS,9001)
9001    FORMAT(//6X,'FINAL MULTIJET CROSS SECTIONS'/
     $  6X,'PROCESS',18X,'SIGMA',10X,'MAX(SIGMA)')
        DO 992 I=1,NSIG8
          II=ISORT8(I)
          TMP=WTSUM8(II)/NWT8(II)
          WRITE(ITLIS,9002) (IDENT8(KK,II),KK=1,5),TMP,WTMAX8(II)
9002      FORMAT(2X,5I5,2E15.5)
992     CONTINUE
        WRITE(ITLIS,*)
      ENDIF
C
C          Print statistics for multiple evolution and fragmentation
      IF(NEVOLV.GT.1.OR.NFRGMN.GT.1) THEN
        FRAC=FLOAT(IEVGEN)/FLOAT(IEVT)
        WRITE(ITLIS,201) IEVGEN
201     FORMAT(//' NUMBER OF ACCEPTED EVENTS           =',I13)
        WRITE(ITLIS,202) FRAC
202     FORMAT(' FRACTION OF ACCEPTED EVENTS         =',E13.4)
        SIGF3=SIGF2*FRAC
        WRITE(ITLIS,203) SIGF3
203     FORMAT(' CROSS SECTION FOR ACCEPTED EVENTS   =',E13.4)
      ENDIF
C
C          Print mean time per event
300   TMEAN=(TIME2-TIME1)/NEVENT
      WRITE(ITLIS,301) TMEAN
301   FORMAT(//' MEAN TIME PER GENERATED EVENT       =',E13.4,
     $' SEC')
C
C          Print final seed(s)
+SELF,IF=NORANLUX
      CALL RANFMT
      WRITE(ITLIS,302) XSEED
302   FORMAT(//' FINAL RANDOM NUMBER SEED            =',A24)
+SELF,IF=RANLUX
      CALL RLUXAT(L,LINT,LK1,LK2)
      WRITE(ITLIS,302) LINT,LK1,LK2
302   FORMAT(//' FINAL RANLUX SEEDS                  =',3I12)
+SELF
C
C          Print run identifier
      WRITE(ITLIS,303) IDG
303   FORMAT(//' END OF ISAJET RUN                   =',2I9.6)
      RETURN
      END
+EOD
+DECK,HEAVYX.
      SUBROUTINE HEAVYX(X,EPS)
C
C          GENERATE X FOR HEAVY PARTICLE FRAGMENTATION ACCORDING TO
C          THE PETERSON FORM
C          D(X)=1/(X*(1-1/X-EPS/(1-X))**2)
C              =D0(X)*D1(X)*D2(X)
C          D0(X)=(1-X)**2/((1-X)**2+EPS)**2
C          D1(X)=X
C          D2(X)=(((1-X)**2+EPS)/((1-X)**2+EPS*X))**2
C          USING X=1-Y**POW
C
      DATA ALN4/1.3863/
C
C          CHOOSE POW FOR X=1-Y**POW.
C          GENERATE FLAT IN X IF EPS>1.
      IF(EPS.LT.1.) THEN
        POW=ALOG((3.+EPS)/EPS)/ALN4
        YMX=(EPS*(3.*POW-1.)/(POW+1.))**(.5/POW)
        ZMX=1-YMX**POW
        D0MX=(1-ZMX)**2/((1.-ZMX)**2+EPS)**2*POW*YMX**(POW-1.)
        D2MX=2./(2.-SQRT(EPS))
      ELSE
        POW=1.
        ZMX=0.
        D0MX=(1.-ZMX)**2/((1.-ZMX)**2+EPS)**2
        D2MX=1.+EPS
      ENDIF
C
C          GENERATE Z ACCORDING TO (1-Z)**2/((1-Z)**2+EPS*Z)**2
1     CONTINUE
      Y=RANF()
      Z=1.-Y**POW
C
      D0Z=(1.-Z)**2/((1.-Z)**2+EPS)**2*POW*Y**(POW-1.)
      IF(D0Z.LT.RANF()*D0MX) GO TO 1
C
C          CHECK REMAINING FACTORS
      D1=Z
      D2=(((1.-Z)**2+EPS)/((1.-Z)**2+EPS*Z))**2
      IF(D1*D2.LT.RANF()*D2MX) GO TO 1
C
C          GOOD X
      X=Z
      RETURN
      END
+EOD
+DECK,HEVOLV.
      SUBROUTINE HEVOLV
C
C          CARRY OUT BACKWARDS EVOLUTION QK --> QK + W FOR LONGITUDINAL
C          W-W FUSION, GENERATING Z AND KT**2 FROM RELATION OF W AND
C          QUARK STRUCTURE FUNCTIONS.
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PJETS
+CDE,JETSET
+CDE,PRIMAR
+CDE,WCON
+CDE,CONST
+CDE,IDRUN
+CDE,HCON
C
      DIMENSION X(2)
      EQUIVALENCE (X1,X(1))
      DIMENSION FZIQ(13),IWPICK(2),PFINAL(5),BST1(5),BST2(5),B2B1(5)
      DIMENSION PSAVE(5,2)
C          LAMBDA FUNCTION
      ALAMF(A,B,C)=SQRT((A-B-C)**2-4.*B*C)
C
      NJSAVE=NJSET
      NREJ2=-1
C
C          INITIALIZE
      DO 10 I=1,2
      DO 10 K=1,5
10    PSAVE(K,I)=PJSET(K,I)
20    CONTINUE
      DO 30 I=1,2
      DO 30 K=1,5
30    PJSET(K,I)=PSAVE(K,I)
      DO 40 K=1,5
40    PFINAL(K)=QWJET(K)
      NJSET=NJSAVE
C
C          CHOOSE A W AND DO BACKWARDS EVOLUTION FOR QK -> QK + W.
C
      IF(RANF().LT..5) THEN
        IWPICK(1)=1
        IWPICK(2)=2
        SGN=+1.
      ELSE
        IWPICK(1)=2
        IWPICK(2)=1
        SGN=-1.
      ENDIF
      DO 100 JJ=1,2
C
C          OTHER PARTICLE IS W FOR JJ=1, QUARK FOR JJ=2:
      IF(JJ.EQ.1) THEN
        J1=IWPICK(1)
        J2=IWPICK(2)
      ELSE
        J1=IWPICK(2)
        J2=NJSAVE+1
        SGN=-SGN
      ENDIF
      JTLV1=JTYPE(J1)
      IF(JTLV1.EQ.10) THEN
        IW=1
      ELSEIF(JTLV1.EQ.80) THEN
        IW=2
      ELSEIF(JTLV1.EQ.-80) THEN
        IW=3
      ELSEIF(JTLV1.EQ.90) THEN
        IW=4
      ENDIF
      XV=(PJSET(4,J1)+ABS(PJSET(3,J1)))/ECM
      AMV=AMASS(JTLV1)
C
C          GENERATE VARIABLES FOR BRANCHING
C          FIND MAXIMUM OF INTEGRAND USING 20 POINTS IN LOG(Z)
      FMAX=0.
      ZMULT=(1./XV)**.05
      ZIZ=XV
      DO 110 IZ=1,19
      ZIZ=ZIZ*ZMULT
      FSUM=0.
      DO 115 IQ=2,13
      IF(MATCH(IQ,IW).NE.0) THEN
        IFL=IQ/2
        CIQ=AQ(IFL,IW)**2+BQ(IFL,IW)**2
        FSUM=FSUM+CIQ*(1.-ZIZ)/ZIZ*STRUC(XV/ZIZ,AMV**2,IQ,IDIN(J1))
      ENDIF
115   CONTINUE
      FMAX=AMAX1(FMAX,FSUM)
110   CONTINUE
C          GENERATE Z UNIFORMLY IN (XV,1) AND TEST
      NREJ1=-1
120   ZV=XV+(1.-XV)*RANF()
      FZ=0.
      DO 130 IQ=2,13
      IF(MATCH(IQ,IW).NE.0) THEN
        IFL=IQ/2
        CIQ=AQ(IFL,IW)**2+BQ(IFL,IW)**2
        FZIQ(IQ)=CIQ*(1.-ZV)/ZV*STRUC(XV/ZV,AMV**2,IQ,IDIN(J1))
      ELSE
        FZIQ(IQ)=0.
      ENDIF
130   FZ=FZ+FZIQ(IQ)
      IF(FZ.LT.FMAX*RANF()) THEN
        NREJ1=NREJ1+1
        IF(NREJ1.GT.NTRIES) GO TO 9999
        GO TO 120
      ENDIF
C          DETERMINE QUARK TYPE
      TRY=RANF()
      SUM=0.
      DO 140 IQ=2,13
      IQ1=IQ
      SUM=SUM+FZIQ(IQ)/FZ
140   IF(SUM.GT.TRY) GO TO 150
150   IQ3=MATCH(IQ1,IW)
      IQ3=MATCH(IQ3,4)
C          GENERATE T=-K**2 AND UNIFORM PHI
      T=AMV**2*(1./RANF()-1.)
      PHIK=2.*PI*RANF()
C
C          SOLVE KINEMATICS FOR THIS SIDE
      S=(PJSET(4,J1)+PJSET(4,J2))**2-(PJSET(1,J1)+PJSET(1,J2))**2
     $-(PJSET(2,J1)+PJSET(2,J2))**2-(PJSET(3,J1)+PJSET(3,J2))**2
      SP=S/ZV
      IFL1=IQ1/2
      IFL2=JTYPE(J2)
      IFL3=IQ3/2
      AM1=AMASS(IFL1)
      AM2=PJSET(5,J2)
      AM3=AMASS(IFL3)
      AM1SQ=AM1**2
      AM2SQ=AM2**2
      AM3SQ=AM3**2
      IF(SGN.LT.0.) THEN
        P2PL=PJSET(4,J2)+PJSET(3,J2)
        P2MN=AM2SQ/P2PL
      ELSE
        P2MN=PJSET(4,J2)-PJSET(3,J2)
        P2PL=AM2SQ/P2MN
      ENDIF
C          STEP 1: SOLVE FOR PP1=PJSET(K,NEWV)
      IF(SGN.GT.0.) THEN
        PP1PL=(SP-AM1SQ-AM2SQ+ALAMF(SP,AM1SQ,AM2SQ))/(2.*P2MN)
        PP1MN=AM1SQ/PP1PL
      ELSE
        PP1MN=(SP-AM1SQ-AM2SQ+ALAMF(SP,AM1SQ,AM2SQ))/(2.*P2PL)
        PP1PL=AM1SQ/PP1MN
      ENDIF
C          STEP 2: SOLVE FOR K = VIRTUAL W MOMENTUM
      DEN=PP1PL*P2MN-PP1MN*P2PL
      AKPL=(+PP1PL*(S+T-AM2SQ)+P2PL*(T+AM3SQ-AM1SQ))/DEN
      AKMN=(-PP1MN*(S+T-AM2SQ)-P2MN*(T+AM3SQ-AM1SQ))/DEN
      WPL=PP1PL-AKPL
      WMN=PP1MN-AKMN
      AKT2=T+AKPL*AKMN
C          STEP 3: START OVER IF AKT2 UNPHYSICAL
      IF(AKT2.LE.0..OR.PP1PL.GE.ECM.OR.PP1MN.GE.ECM.OR.
     $P2PL.GE.ECM.OR.P2MN.GE.ECM) THEN
        NREJ2=NREJ2+1
        IF(NREJ2.GT.NTRIES) GO TO 9999
        GO TO 20
      ENDIF
C
C          SAVE NEW VECTORS
      NJ1=NJSET+1
      NJ2=NJSET+2
      AKT=SQRT(AKT2)
      AKX=AKT*COS(PHIK)
      AKY=AKT*SIN(PHIK)
      PJSET(1,J1)=AKX
      PJSET(2,J1)=AKY
      PJSET(3,J1)=.5*(AKPL-AKMN)
      PJSET(4,J1)=.5*(AKPL+AKMN)
      PJSET(5,J1)=-SQRT(T)
      JDCAY(J1)=JPACK*NJ1+NJ2
      JET=IABS(JORIG(J1))/JPACK
C
      PJSET(1,NJ1)=0.
      PJSET(2,NJ1)=0.
      PJSET(3,NJ1)=.5*(PP1PL-PP1MN)
      PJSET(4,NJ1)=.5*(PP1PL+PP1MN)
      PJSET(5,NJ1)=AM1
      JORIG(NJ1)=JPACK*JET+J1
      JTYPE(NJ1)=IFL1
      JDCAY(NJ1)=0
C
      PJSET(1,NJ2)=-AKX
      PJSET(2,NJ2)=-AKY
      PJSET(3,NJ2)=.5*(WPL-WMN)
      PJSET(4,NJ2)=.5*(WPL+WMN)
      PJSET(5,NJ2)=AM3
      JORIG(NJ2)=JPACK*JET+J1
      JTYPE(NJ2)=IFL3
      JDCAY(NJ2)=0
C
C          BOOST OTHER VECTORS TO NEW FRAME GIVEN BY DIFFERENCE OF
C          OLD AND NEW FINAL MOMENTA.
      DO 200 K=1,4
      BST1(K)=PFINAL(K)
200   BST2(K)=PJSET(K,J1)+PJSET(K,J2)
      BMASS=PFINAL(5)
      BST1(5)=BMASS
      BST2(5)=BMASS
C
C          PARAMETERS FOR COMBINED BOOSTS.
      BDOTB=BST1(4)*BST2(4)-BST1(1)*BST2(1)-BST1(2)*BST2(2)
     $-BST1(3)*BST2(3)
      DO 210 K=1,4
210   B2B1(K)=BST2(K)-BST1(K)
C
      B44=BDOTB/BMASS**2
      BI41=1./BMASS
      BI42=(BDOTB-BMASS**2-B2B1(4)*BMASS)/(BMASS**2*(BST2(4)+BMASS))
      B4K1=BI41
      B4K2=(BMASS**2-BDOTB-B2B1(4)*BMASS)/(BMASS**2*(BST1(4)+BMASS))
      BIK1=-1./(BMASS*(BST1(4)+BMASS))
      BIK2=1./(BMASS*(BST2(4)+BMASS))
      BIK3=(BMASS**2-BDOTB)/(BMASS**2*(BST1(4)+BMASS)
     $*(BST2(4)+BMASS))
C
C          BOOST FINAL JETS
      DO 220 J=1,NJSET
      IF(J.EQ.J1.OR.J.EQ.J2) GO TO 220
      IF(PJSET(5,J).LT.0.) GO TO 220
      BP1=0.
      BP21=0.
      DO 221 K=1,3
      BP1=BP1+BST1(K)*PJSET(K,J)
221   BP21=BP21+B2B1(K)*PJSET(K,J)
      DO 222 K=1,3
222   PJSET(K,J)=PJSET(K,J)
     $+(B2B1(K)*BI41+BST2(K)*BI42)*PJSET(4,J)
     $+B2B1(K)*BP1*BIK1+BST2(K)*BP21*BIK2+BST2(K)*BP1*BIK3
      PJSET(4,J)=B44*PJSET(4,J)+BP21*B4K1+BP1*B4K2
220   CONTINUE
C
C          RESET VIRTUAL MOMENTA
      DO 230 J=1,NJSET
      IF(J.EQ.J1.OR.J.EQ.J2) GO TO 230
      IF(PJSET(5,J).GE.0.) GO TO 230
      JX1=JDCAY(J)/JPACK
      JX2=JDCAY(J)-JPACK*JX1
      DO 231 K=1,4
231   PJSET(K,J)=PJSET(K,JX1)-PJSET(K,JX2)
      AMJ=PJSET(4,J)**2-PJSET(1,J)**2-PJSET(2,J)**2-PJSET(3,J)**2
      PJSET(5,J)=-SQRT(ABS(AMJ))
230   CONTINUE
C
C          RESET PFINAL AND NJSET
      DO 240 K=1,4
240   PFINAL(K)=PJSET(K,J2)+PJSET(K,NJ1)
      PFINAL(5)=SQRT(SP)
      NJSET=NJSET+2
100   CONTINUE
      RETURN
C
9999  CONTINUE
      WRITE(ITLIS,9998) IEVT
9998  FORMAT(/' ***** ERROR IN HEVOLV ... EVENT',I8,' DISCARDED *****')
      NJSET=-1
      RETURN
      END
+EOD
+DECK,HIGGS.
      SUBROUTINE HIGGS
C
C          FINISH HIGGS GENERATION STARTED BY DRLLYN FOR DECAY
C          HIGGS --> W W.
C
C          VER 7.14: TEST BOTH JET1 AND JET2 FOR W,Z FOR SAFETY
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,HCON
C
      DIMENSION X(2)
      EQUIVALENCE (X(1),X1)
C
      IDABS1=IABS(IDJETS(1))
      IDABS2=IABS(IDJETS(2))
      IF(IDABS1.NE.80.AND.IDABS1.NE.90.AND.
     $IDABS2.NE.80.AND.IDABS2.NE.90) THEN
        NPAIR=0
        DO 100 I=1,4
        IDPAIR(I)=0
        JPAIR(I)=0
        DO 110 K=1,5
110     PPAIR(K,I)=0.
100     CONTINUE
      ELSE
        CALL WPAIR
      ENDIF
      RETURN
      END
+EOD
+DECK,IDANTI
      INTEGER FUNCTION IDANTI(ID)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Return value of antiparticle id
C-
C-   Inputs  :
C-   ID = particle id
C-
C-   Created   1-JUN-1988   Serban D. Protopopescu
C-   3-Jan-1993: Expand self-conjugate list for MSSM and simplify
C                structure.  FEP
C    17-Mar-1997: Correctly handle mesons with IDENT>10000
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
      INTEGER ID,IFL1,IFL2,IFL3,IDABS
      INTEGER NSELF,I
      PARAMETER (NSELF=14)
      INTEGER IDSELF(NSELF)
      SAVE IDSELF
      DATA IDSELF/9,10,20,29,30,40,50,60,81,82,83,84,90,91/
C----------------------------------------------------------------------
      IDABS=IABS(ID)
      IFL1=MOD(IDABS/1000,10)
C
C          Baryons and diquarks
C
      IF(IFL1.NE.0) THEN
        IDANTI=-ID
        RETURN
      ENDIF
C
C          Mesons
C
      IF(IDABS.GT.100.AND.IFL1.EQ.0) THEN
        IFL2=MOD(IDABS/100,10)
        IFL3=MOD(IDABS/10,10)
        IF(IFL2.EQ.IFL3) THEN
          IDANTI=+ID
        ELSE
          IDANTI=-ID
        ENDIF
        RETURN
      ENDIF
C
C          Other particles
C
      DO 100 I=1,NSELF
        IF(IDABS.EQ.IDSELF(I)) THEN
          IDANTI=+ID
          RETURN
        ENDIF
100   CONTINUE
      IDANTI=-ID
      RETURN
      END
+EOD
+DECK,IDGEN.
      SUBROUTINE IDGEN
C
C          Call system date and time routines (non-standard) to set up
C          run identification:
C          IDVER=100*VERSN     (integer ISAJET version number)
C          IDG(1)=YYMMDD       (integer year-month-day)
C          IDG(2)=HHMMSS       (integer hour-minute-second)
C
+CDE,ITAPES
+CDE,IDRUN
+SELF,IF=CDC,ETA.
      CHARACTER*10 CHAR,DATE,TIME
+SELF,IF=SUN,SGI.
      DIMENSION ISUN(3)
+SELF.
C          Default run id is zero.
      IYMD=0.
      IHMS=0.
+SELF,IF=CDC,IF=NOCERN.
C          Call CDC date and time and convert to integer.
      CHAR=DATE()
      READ(CHAR,'(1X,I2,1X,I2,1X,I2,1X)') IA,IB,IC
      IYMD=10000*IC+100*IA+IB
      CHAR=TIME()
      READ(CHAR,'(1X,I2,1X,I2,1X,I2,1X)') IA,IB,IC
      IHMS=10000*IA+100*IB+IC
+SELF,IF=ETA,IF=NOCERN.
C          Call ETA date and time and convert to integer.
      CHAR=DATE()
      READ(CHAR,'(I2,1X,I2,1X,I2)') IA,IB,IC
      IYMD=10000*IC+100*IA+IB
      CHAR=TIME()
      READ(CHAR,'(I2,1X,I2,1X,I2)') IA,IB,IC
      IHMS=10000*IA+100*IB+IC
+SELF,IF=SGI,IF=NOCERN.
C          Call Silicon Graphics date and time
      CALL IDATE(ISUN(1),ISUN(2),ISUN(3))
      IYMD=10000*ISUN(3)+100*ISUN(2)+ISUN(1)
      CALL ITIME(ISUN)
      IHMS=10000*ISUN(1)+100*ISUN(2)+ISUN(3)
+SELF,IF=SUN,IF=NOCERN.
C          Call SUN date and time
      CALL IDATE(ISUN)
      IYMD=10000*(MOD(ISUN(3),100))+100*ISUN(2)+ISUN(1)
      CALL ITIME(ISUN)
      IHMS=10000*ISUN(1)+100*ISUN(2)+ISUN(3)
+SELF,IF=IBM,VAX,CERN.
C          Call DATIME for date and time. (In Cern library)
      CALL DATIME(IYMD,IHMS)
+SELF.
      IDG(1)=IYMD
      IDG(2)=IHMS
      RETURN
      END
+EOD
+DECK,IFRAMS
      SUBROUTINE IFRAMS(N1,N2,IFR,PAIR)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-     Initialize a center of mass frame for partons N1 to N2
C-     partons must be consecutive unless PAIR is true
C-     
C-   Inputs  : 
C-   N1  = first parton 
C-   N2  = last parton
C-   IFR = index of frame
C-   PAIR= if false N1, N2 denote a range
C-      if true N1 and N2 form a pair
C-
C-   Created  14-AUG-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PJETS
+CDE,JETSET
+CDE,JWORK
+CDE,FRAME
      INTEGER I,J,K,JADD,N1,N2,IFR
      DOUBLE PRECISION DPASS(5),DSUM(5)
      LOGICAL PAIR
C----------------------------------------------------------------------
C
      IF ( N2-N1.EQ.1.OR.PAIR ) THEN
        JMATCH(N1)=N2
        JMATCH(N2)=N1
        JADD=N2-N1
      ELSE
        JADD=1
        DO 201 I=N1,N2
          JMATCH(I)=JPACK*N1+N2
201     CONTINUE
      ENDIF
C          Need double precision boosts
      CALL DBLVEC(PJSET(1,N1),DSUM)
      DO 211 I=N1+JADD,N2
        CALL DBLVEC(PJSET(1,I),DPASS)
        DO 210 K=1,4
210     DSUM(K)=DSUM(K)+DPASS(K)
        DSUM(5)=DSQRT(DSUM(4)**2-DSUM(1)**2-DSUM(2)**2-DSUM(3)**2)
211   CONTINUE
      DO 212 K=1,5
        FRAME(K,IFR)=DSUM(K)
212   CONTINUE
C
C          Set up and generate final state QCD parton shower.
C          Boost PJSET with -FRAME.
C
      DO 240 J=N1,N2,JADD
        CALL DBOOST(-1,FRAME(1,IFR),PJSET(1,J))
240   CONTINUE
C
999   RETURN
      END
+EOD
+DECK,INISAP
      SUBROUTINE INISAP(CMSE,XREAC,BEAMS,WZ,NDCAYS,DCAYS,
     $  ETMIN,RCONE,OK)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-     initialize ISAJET for externally supplied partons
C-   Inputs  : 
C-   CMSE     = center of mass energy
C-   XREAC    = reaction
C-   BEAMS(2) = chose 'P ' or 'AP'
C-   ETMIN    = minimum ET of supplied partons
C-   RCONE    = minimum cone (R) between supplied partons
C-   WZ = option 'W' or 'Z', ' ' no W's or Z's
C-   NDCAYS= number of decay options
C-   DCAYS= list of particles W or Z are allowed to decay into
C-
C-   Controls:
C-   OK   = true if initialization is possible
C-   Created   8-OCT-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,KEYS
+CDE,IDRUN
+CDE,LIMEVL
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,TYPES
C
      REAL CMSE
      CHARACTER*8 XREAC
      CHARACTER*2 BEAMS(2)
      REAL    ETMIN,RCONE
      CHARACTER*1 WZ
      INTEGER NDCAYS
      CHARACTER*4 DCAYS(*)
      LOGICAL OK
      LOGICAL DUMY,SETTYP
      INTEGER I
C----------------------------------------------------------------------
      OK=.TRUE.
      CALL RESET
      IEVT=0
      ECM=CMSE
      SCM=ECM**2
      HALFE=ECM/2.
      ETTHRS=ETMIN
C          fudge factor 1.5 to approximate ET distributions and widths
      CONCUT=SIN(RCONE)/1.5
      IF(RCONE.GT.1.5) CONCUT=1.0
      USELIM=.TRUE.
      IKEYS=0
      DO 18 I=1,8
18    KEYS(I)=.FALSE.
      KEYON=.FALSE.
      REAC=XREAC
C
      IF(XREAC.EQ.'TWOJET  ') THEN
        KEYS(1)=.TRUE.
        IKEYS=1
C
      ELSEIF(XREAC.EQ.'DRELLYAN') THEN
        KEYS(3)=.TRUE.
        IKEYS=3
        IF(WZ.EQ.'Z') GODY(4)=.TRUE.
        IF(WZ.EQ.'W') THEN
          GODY(2)=.TRUE.
          GODY(3)=.TRUE.
        ENDIF
        NJTTYP(1)=NDCAYS
        NJTTYP(2)=0
        NJTTYP(3)=0
        DO 21 I=1,NDCAYS
          JETYP(I,1)=DCAYS(I)
   21   CONTINUE
C
      ELSEIF(XREAC.EQ.'MINBIAS ') THEN
        KEYS(4)=.TRUE.
        IKEYS=4
C
      ELSEIF(XREAC.EQ.'SUPERSYM'.OR.XREAC.EQ.'SUSY    ') THEN
        KEYS(5)=.TRUE.
        IKEYS=5
C
      ELSEIF(XREAC.EQ.'WPAIR   ') THEN
        KEYS(6)=.TRUE.
        IKEYS=6
C
      ELSEIF(XREAC.EQ.'HIGGS   ') THEN
        KEYS(7)=.TRUE.
        IKEYS=7
C
      ELSEIF(XREAC.EQ.'PHOTON  ') THEN
        KEYS(8)=.TRUE.
        IKEYS=8
      ENDIF
C
      IF(IKEYS.EQ.0) THEN
        OK=.FALSE.
        GOTO 999
      ENDIF
C
      CALL SETCON
      IDIN(1)=1120    
      IDIN(2)=-1120   
      IF (BEAMS(1).EQ.'P ') IDIN(1)=1120
      IF (BEAMS(2).EQ.'P ') IDIN(2)=1120
      IF (BEAMS(1).EQ.'AP') IDIN(1)=-1120
      IF (BEAMS(2).EQ.'AP') IDIN(2)=-1120
      DUMY=SETTYP(0)
      CALL SETW
      CALL IDGEN
      CALL SETDKY(.FALSE.)
      CALL MBSET
      CALL PRTLIM
      CALL TIMER(1)
  999 RETURN
      END
+EOD
+DECK,IPARTNS
      SUBROUTINE IPARTNS(NPRTNS,IDS,PRTNS,IDQ,WEIGHT,WZDK)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-     fill PJETS array from a list of input partons
C-   Inputs  : 
C-     NPRTNS          = number of partons
C-     IDS(NPRTNS)     = parton ids
C-     PRTNS(4,NPRTNS) = parton 4 vectors
C-     IDQ(2)          = initial partons
C-     WEIGHT          = weight
C-     WZDK            = if true last 2 partons are from W,Z decay
C-     
C-
C-   Created   8-OCT-1991   Serban D. Protopopescu
C-   Updated  17-APR-1996   Serban D. Protopopescu  
C-    added entry evcuts to supply evolution limits
C-    modified DrellYan (keys(3)) to stay within VECBOS jet ranking 
C-   Updated  16-JUN-1998   F. Paige
C-    Removed ISAZEB dependence: use ISPJET and do not call ISPETA
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER NPRTNS,IDS(NPRTNS),IDQ(2)
      REAL    PRTNS(4,NPRTNS),WEIGHT
      LOGICAL WZDK
+CDE,FINAL
+CDE,IDRUN
+CDE,JETPAR
+CDE,KEYS
+CDE,NODCAY
+CDE,PARTCL
+CDE,PJETS
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,TOTALS
      REAL    SUM(4),AMASS
      INTEGER K,J,IWZ,ID,NQS
      INTEGER MAXQ
      PARAMETER (MAXQ=15)
      INTEGER I,NP,JDORD(MAXQ),JIORD(MAXQ),NPJ
      REAL    ETAQ(MAXQ),PHIQ(MAXQ),THQ(MAXQ),PTQ(MAXQ)
      REAL    ETCUT,ETIN,RCUT,RIN,R
      REAL    PPI
      REAL    PXPT(MAXQ),PXETA(MAXQ),PXPHI(MAXQ)
      LOGICAL DOEVOL,DOEVIN
      DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN
      PARAMETER (PI=        3.1415 92653 58979 32384 6 D0)
      PARAMETER (TWOPI=     6.2831 85307 17958 64769 3 D0)
      PARAMETER (HALFPI=    1.5707 96326 79489 66192 3 D0)
      PARAMETER (RADIAN= 0.0174532 92519 94329 5769237 D0)
C----------------------------------------------------------------------
C
      NJET=0
C
C          handle W's and Z's
C          
      IEVT=IEVT+1 
      IWZ=0
      NQS=NPRTNS
      IF(WZDK) NQS=NPRTNS-2
      DO 1 J=1,NPRTNS
        ID=IABS(IDS(J))
        IF(ID.GT.79) THEN
          IF(ID.EQ.90) JWTYP=4
          IF(IDS(J).EQ.80) JWTYP=2
          IF(IDS(J).EQ.-80) JWTYP=3
          IDENTW=IDS(J)
          DO 2 K=1,4
            QWJET(K)=PRTNS(K,J)
   2      CONTINUE
          QWJET(5)=SQRT(QWJET(4)**2-QWJET(1)**2-QWJET(2)**2-QWJET(3)**2)
          IWZ=J
        ENDIF
   1  CONTINUE
      DO 4 J=NQS+1,NPRTNS
        ID=IABS(IDS(J))
        NJET=NJET+1
        DO 3 K=1,4
          PJETS(K,NJET)=PRTNS(K,J)
    3   CONTINUE
        IDJETS(NJET)=IDS(J)
        PJETS(5,NJET)=AMASS(ID)
    4 CONTINUE
C          W,Z decays were not in input
      IF(IWZ.NE.0.AND.NJET.EQ.0) THEN    
        NJET=2
        CALL ISWDKY
      ENDIF
C
C      fill with the other partons
C
      DO 5 K=1,4
        SUM(K)=0
   5  CONTINUE
      DO 11 J=1,NQS
        ID=IABS(IDS(J))
        IF(IWZ.NE.J.AND.ID.LT.11) THEN
          NJET=NJET+1
          IDJETS(NJET)=IDS(J)
          DO 12 K=1,4
            PJETS(K,NJET)=PRTNS(K,J)
  12      CONTINUE
          PJETS(5,NJET)=PRTNS(4,J)**2-PRTNS(1,J)**2-PRTNS(2,J)**2-
     $      PRTNS(3,J)**2
          IF ( PJETS(5,NJET).GT.0. ) THEN
            PJETS(5,NJET)=SQRT(PJETS(5,NJET))
          ELSE
            PJETS(4,NJET)=SQRT(PRTNS(4,J)**2-PJETS(5,NJET))
            PJETS(5,NJET)=0.
          ENDIF
        ENDIF
        DO 13 K=1,4
          SUM(K)=SUM(K)+PRTNS(K,J)
  13    CONTINUE
  11  CONTINUE
C
C        eta and phi of incoming partons 
      IF(DOEVOL) THEN
        NP=NQS-1
        DO 114 I=1,NP
          PPI=SQRT(PRTNS(1,I)**2+PRTNS(2,I)**2+PRTNS(3,I)**2)
          IF(PPI.GT.0.AND.PPI.GT.ABS(PRTNS(3,I))) THEN
            THQ(I)=ACOS(PRTNS(3,I)/PPI)
            ETAQ(I)=-LOG(TAN(THQ(I)/2))
          ELSE
            THQ(I)=0
            ETAQ(I)=SIGN(999.,PRTNS(3,I))
          ENDIF
          PTQ(I)=SQRT(PRTNS(1,I)**2+PRTNS(2,I)**2)
          IF(PTQ(I).GT.0) THEN
            PHIQ(I)=ATAN2(PRTNS(2,I),PRTNS(1,I))
            IF(PHIQ(I).LT.0) PHIQ(I)=PHIQ(I)+TWOPI
          ELSE
            PHIQ(I)=0
          ENDIF
 114    CONTINUE
C
C ... Order partons in pt
C
        DO 115 I = 1 , NP
          JIORD(I) = I
          PXPT(I)=PTQ(I)
 115    CONTINUE
        CALL ISASRT(PXPT(1),NP,JIORD)
        DO 116 I = 1 , NP
          PXPT(I)=PTQ(I)
          PXETA(I)=ETAQ(I)
          PXPHI(I)=PHIQ(I)
          JDORD(I) = JIORD(NP-I+1)
 116    CONTINUE
        DO 117 I = 1 , NP
          PTQ(I)=PXPT(JDORD(I))
          ETAQ(I)=PXETA(JDORD(I))
          PHIQ(I)=PXPHI(JDORD(I))
 117    CONTINUE
      ENDIF
C
C
  15  CONTINUE
      PBEAM(1)=(ECM-SUM(4)-SUM(3))/2.
      PBEAM(2)=(ECM-SUM(4)+SUM(3))/2.
      QSQ=SQRT(SUM(4)**2-SUM(3)**2-SUM(2)**2-SUM(1)**2)
      CALL RANFMT 
      NPTCL=0
      IF(KEYS(3)) THEN
        STDDY=.FALSE.
        IF(NQS.EQ.1.OR.NJET.LT.3) STDDY=.TRUE.
      ENDIF
      CALL IPRTNS(NQS,PRTNS,IDQ)
      IF(.NOT.NOEVOL) THEN
        CALL EVOLVE
C
C            special check for VECBOS
        IF(DOEVOL) THEN  
C       Find parton jets
          CALL ISPJET(RCUT,ETCUT,NPJ,PXPT,PXPHI,PXETA)  
          IF(NPJ.GE.NP.AND.PXPT(NP).GT.PTQ(NP)) THEN
            R=SQRT((PXETA(NP)-ETAQ(NP))**2+(PXPHI(NP)-PHIQ(NP))**2)
            IF(R.GT.RCUT) GOTO 15
          ENDIF
        ENDIF
C
        IF(.NOT.NOHADR) THEN
          CALL FRGMNT
          CALL MBIAS
        ENDIF
      ENDIF
      WT=WEIGHT
      SUMWT=SUMWT+WT
      SIGF=SUMWT
      NKINF=IEVT
      NEVENT=IEVT
  999 RETURN
C
C     Entry point to set parameters
C
      ENTRY EVCUTS(RIN,ETIN,DOEVIN)
      RCUT=RIN
      ETCUT=ETIN
      DOEVOL=DOEVIN
      RETURN
      END
+EOD
+DECK,IPJSET
      SUBROUTINE IPJSET
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-       Initialize PJSET starting from PJETS
C-
C-   Created  14-AUG-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PRIMAR
+CDE,PJETS
+CDE,JETSET
      INTEGER I,K
C----------------------------------------------------------------------
      DO 110 I=1,NJET
        NJSET=NJSET+1
        JORIG(NJSET)=JPACK*I
        JTYPE(NJSET)=IDJETS(I)
        JDCAY(NJSET)=0
        DO 115 K=1,5
115     PJSET(K,NJSET)=PJETS(K,I)
        IFRAME(I)=1
110   CONTINUE
  999 RETURN
      END
+EOD
+DECK,IPRTNS
      SUBROUTINE IPRTNS(NPRTNS,PRTNS,IDQ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-      Fill PINITS common block
C-   Inputs  : 
C-     IDQ(2)= id's of partons starting reaction
C-
C-   Created  10-OCT-1991   Serban D. Protopopescu
C-   Renamed from IPINIT to avoid name clash with Cern Library
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER NPRTNS,IDQ(2)
      REAL    PRTNS(4,NPRTNS)
+CDE,JETPAR
+CDE,PINITS
      REAL AMASS, AM1SQ,AM2SQ,ROOT,QPL,QMN,P1PL,P1MN,P2PL,P2MN
      INTEGER I
C----------------------------------------------------------------------
C          sum P+ and P-, shat
C          assumes sum of transverse momenta is zero
      QPL=0
      QMN=0
      DO 1 I=1,NPRTNS
        QPL=QPL+PRTNS(4,I)+PRTNS(3,I)
        QMN=QMN+PRTNS(4,I)-PRTNS(3,I)
    1 CONTINUE
      SHAT=QPL*QMN
C
C          fill PINITS
      DO 2 I=1,2
        IDINIT(I)=IDQ(I)
        PINITS(5,I)=AMASS(IDQ(I))
        PINITS(1,I)=0.
        PINITS(2,I)=0.
    2 CONTINUE
C          and solve initial kinematics
      AM1SQ=PINITS(5,1)**2
      AM2SQ=PINITS(5,2)**2
      ROOT=SQRT((QPL*QMN-AM1SQ-AM2SQ)**2-4.*AM1SQ*AM2SQ)
      P1PL=(QPL*QMN+AM1SQ-AM2SQ+ROOT)/(2.*QMN)
      P1MN=AM1SQ/P1PL
      P2MN=(QPL*QMN+AM2SQ-AM1SQ+ROOT)/(2.*QPL)
      P2PL=AM2SQ/P2MN
      PINITS(3,1)=.5*(P1PL-P1MN)
      PINITS(4,1)=.5*(P1PL+P1MN)
      PINITS(3,2)=.5*(P2PL-P2MN)
      PINITS(4,2)=.5*(P2PL+P2MN)
  999 RETURN
      END
+EOD
+DECK,IRMOV0.
      SUBROUTINE IRMOV0
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-      remove 0's from PJSET
C-
C-   Created  15-OCT-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,JETSET
+CDE,JWORK
      INTEGER NCOUNT,I,J,K
C----------------------------------------------------------------------
C
C         remove zeroes
      NCOUNT=NJSET
      DO 160 I=3,NJSET  
  151   IF (PJSET(4,I).EQ.0.AND.I.LT.NCOUNT) THEN
          DO 155 K=I+1,NCOUNT
            DO 154 J=1,5    
              PJSET(J,K-1)=PJSET(J,K)   
  154       CONTINUE    
            JORIG(K-1)=JORIG(K) 
            JTYPE(K-1)=JTYPE(K) 
            JDCAY(K-1)=JDCAY(K) 
            ZZC(K-1)=ZZC(K)
            JMATCH(K-1)=JMATCH(K)
            IF(JMATCH(K-1).GT.I) JMATCH(K-1)=JMATCH(K-1)-1
  155     CONTINUE  
          NCOUNT=NCOUNT-1
          GOTO 151
        ENDIF
  160 CONTINUE  
      NJSET=NCOUNT  
C          remove last one if 0
      IF(PJSET(4,NJSET).EQ.0) NJSET=NJSET-1  
  999 RETURN
      END
+EOD
+DECK,ISABEG.
      SUBROUTINE ISABEG(IFL)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-       Initialize a process before event generation
C-
C-   Created   5-FEB-1988   Serban D. Protopopescu
C-
C    Ver 7.14: Do logic after setting physics parameters
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,NODCAY
+CDE,IDRUN
+CDE,KEYS
+CDE,PRIMAR
+CDE,JETPAR
+CDE,ISLOOP
+CDE,XMSSM
+CDE,ISAPW
C
      INTEGER IFL,I
      LOGICAL FIRST
      SAVE FIRST
      CHARACTER*30 ISAPW2
      SAVE ISAPW2
      DATA FIRST/.TRUE./
C          ISAPW2 is used to check whether ALDATA is loaded
      DATA ISAPW2/'ALDATA REQUIRED BY FORTRAN G,H'/
C
C          Initialize
C
      IF(ISAPW1.NE.ISAPW2) THEN
        PRINT*, ' ISABEG ERROR: BLOCK DATA ALDATA HAS NOT BEEN LOADED.'
        PRINT*, ' ISAJET CANNOT RUN WITHOUT IT.'
        PRINT*, ' PLEASE READ THE FINE MANUAL FOR ISAJET.'
        STOP99
      ENDIF
C
      IF (FIRST) THEN
        FIRST=.FALSE.
      ELSE
        CALL SETNXT
      ENDIF
      IEVT=0
      IEVGEN=0
      NEVENT=0
      IEVOL=1
      IFRG=1
C
C          Read in user data and decay table
C
      CALL READIN(IFL)
      IF(IFL.NE.0) GOTO 999
      CALL IDGEN
      IF(GOMSSM) THEN
        CALL DOMSSM
      ENDIF
      IF ((KEYS(2).OR.KEYS(10)).AND..NOT.GOMSSM) THEN
        CALL SETH
      END IF
      CALL SETDKY(.FALSE.)
C
C          Generate NSIGMA unevolved events for SIGF calculation
C
C          TWOJET events
      IF(KEYS(1)) THEN
        CALL MBSET
        CALL SETW
        CALL LOGIC
        CALL PRTLIM
        CALL PTFUN
        DO 105 I=1,NSIGMA
105     CALL TWOJET
        CALL TIMER(1)
C
C          E+E- events
      ELSE IF(KEYS(2)) THEN
        CALL SETW
        CALL LOGIC
        CALL PRTLIM
        CALL EEBEG
        CALL EEMAX
        DO 205 I=1,NSIGMA
205     CALL ELCTRN
        CALL TIMER(1)
C
C          DRELLYAN events
      ELSE IF(KEYS(3)) THEN
        CALL SETW
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL QFUNC
        DO 305 I=1,NSIGMA
305     CALL DRLLYN
        CALL TIMER(1)
C
C          MINBIAS events
      ELSE IF(KEYS(4)) THEN
        PBEAM(1)=HALFE
        PBEAM(2)=HALFE
        CALL PRTLIM
        CALL MBSET
        CALL TIMER(1)
C
C          SUPERSYM events
      ELSE IF(KEYS(5)) THEN
        CALL SETW
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL PTFUN
        DO 505 I=1,NSIGMA
505     CALL TWOJET
        CALL TIMER(1)
C
C          WPAIR events
      ELSE IF(KEYS(6)) THEN
        CALL SETW
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL PTFUN
        DO 605 I=1,NSIGMA
        CALL TWOJET
605     CALL WPAIR
        CALL TIMER(1)
C
C          HIGGS events
      ELSE IF(KEYS(7)) THEN
        CALL SETW
        IF(GOMSSM) THEN
          CALL SETHSS
        ELSE
          CALL SETH
        ENDIF
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL QFUNC
        DO 705 I=1,NSIGMA
705     CALL DRLLYN
        CALL TIMER(1)
C
C          PHOTON events
      ELSEIF(KEYS(8)) THEN
        CALL MBSET
        CALL SETW
        CALL LOGIC
        CALL PRTLIM
        CALL PTFUN
        DO 805 I=1,NSIGMA
805     CALL TWOJET
        CALL TIMER(1)
C
C          TCOLOR events
      ELSE IF(KEYS(9)) THEN
        CALL SETW
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL QFUNC
        DO 905 I=1,NSIGMA
905     CALL DRLLYN
        CALL TIMER(1)
C
C          WHIGGS events
      ELSE IF(KEYS(10)) THEN
        CALL SETW
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL PTFUN
        DO 906 I=1,NSIGMA
        CALL TWOJET
906     CALL WHIGGS
        CALL TIMER(1)
C
C          EXTRADIM events
      ELSE IF(KEYS(11)) THEN
        CALL SETW
        CALL SETKKG
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL QFUNC
        DO 1105 I=1,NSIGMA
          CALL DRLLYN
1105    CONTINUE
        CALL TIMER(1)
C
C          ZJJ events
C          ZJJ0 initializes cross sections, so no event loop
      ELSEIF(KEYS(12)) THEN
        CALL SETW
        CALL MGINIT
        CALL MBSET
        CALL LOGIC
        CALL PRTLIM
        CALL ZJJ0
        CALL TIMER(1)
      ELSE
        STOP 99
      ENDIF
999   RETURN
      END
+EOD
+DECK,ISAEND.
      SUBROUTINE ISAEND
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-       Terminate an ISAJET run
C-
C-   Created   4-FEB-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
      CALL TIMER(2)
      CALL GETTOT(.TRUE.)
  999 RETURN
      END
+EOD
+DECK,ISAEVT.
      SUBROUTINE ISAEVT(I,OK,DONE)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-
C-         Normal operation:
C-    Generate one ISAJET event and return.
C-
C-         "ISALEP" generation:
C-    Generate a TWOJET or DRELLYAN hard scattering. Then make NEVOLVE 
C-    evolutions and NHADRON fragmentations, rejecting events which 
C-    fail the desired cuts using logical functions
C-         REJJET()   tests the QCD evolution stage, e.g. by requiring
C-                    a heavy quark.
C-         REJFRG()   tests the fragmentation stage, e.g. by requiring
C-                    a high-pt lepton.
C-    These functions default to .FALSE.; i.e. they do not reject any 
C-    events. Note that one hard scattering can give more than one 
C-    event. You must choose NEVOLVE and NHADRON carefully.
C-         IEVT   = event number. This is incremented NEVOLVE * NHADRON 
C-                  times for each hard scattering; i.e. it counts the
C-                  number of potential events.
C-         IEVGEN = counter for generated events.
C-         NEVENT = maximum value of hard scatterings. Hence the limit
C-                  for IEVT is NEVENT * NEVOLVE * NHADRON.
C-    The cross section SIGF contains an extra factor of
C-         1 / (NEVOLVE * NHADRON)
C-    to produce the correct final cross section using the weight
C-         SIGF / NEVENT
C-
C-   Input:
C-    I      = number used to control printout
C-   Output:
C-    OK     = logical flag for good event.
C-    DONE   = logical flag for job completion.
C-
C-   Created   3-FEB-1988   Serban D. Protopopescu
C-   Updated  17-APR-1990 Serban D. Protopopescu (add ISALEP option) 
C-   22-JUL-1992: Move PRTEVT and GETTOT statements to end so they
C-                work for TWOJET and DRELLYAN with NOVOLVE. (FEP)
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,IDRUN
+CDE,KEYS
+CDE,NODCAY
+CDE,PRIMAR
+CDE,JETPAR
+CDE,PARTCL
+CDE,JETSET
+CDE,ISLOOP
C
      LOGICAL REJJET,REJFRG,OK,DONE
      INTEGER NPASS,I,NLIMIT
C
      NPASS=0
      OK=.TRUE.
      DONE=.FALSE.
      NLIMIT=NEVENT*NEVOLV*NFRGMN
C
C          Twojet or Drell-Yan events. The evolution and fragmentation
C          loops are done with GO TO statements so that we can exit
C          the loops with a good event and reenter them.
C
      IF(KEYS(1).OR.KEYS(3)) THEN
100     CONTINUE
        IF(IEVOL.EQ.1.AND.IFRG.EQ.1) THEN
          NPASS=NPASS+1
          IF(NPASS.GT.NTRIES) THEN
            WRITE(ITLIS,1001) NTRIES
1001        FORMAT(//' IT IS TAKING MORE THAN',I6,' TRIES TO MAKE',
     $      ' AN EVENT IN ISAEVT.'/
     $      ' CHECK YOUR LIMITS OR OR INCREASE NTRIES.'/
     $      ' CHECK NEVOLVE, NHADRON, AND YOUR REJJET AND REJFRG',
     $      ' FUNCTIONS IF ANY.'/
     $      ' JOB TERMINATED.')
            STOP 99
          ENDIF
          CALL RANFMT
C          Generate appropriate hard scattering
          IF(KEYS(1)) THEN
            CALL TWOJET
          ELSE
            CALL DRLLYN
          ENDIF
        ENDIF
C          QCD evolution
        IF(NOEVOL) THEN
          IEVT=IEVT+NEVOLV*NFRGMN
          GOTO 9999
        ENDIF
C          Continue if in fragmentation loop
        IF(IFRG.NE.1) GO TO 120
C          Begin multiple evolution loop
110       CONTINUE
          NJSET=0
          IEVT=IEVT+1
          CALL EVOLVE
          IEVT=IEVT-1
          IF(NJSET.LT.0) THEN
            IEVT=IEVT+NFRGMN
            GO TO 111
          ENDIF
          IF(REJJET()) THEN
            IEVT=IEVT+NFRGMN
            GO TO 111
          ENDIF
          IF(NOHADR) THEN
            IEVT=IEVT+NFRGMN
            GO TO 9999
          ENDIF
C          Begin multiple fragmentation loop
120         CONTINUE
            NPTCL=0
            CALL FRGMNT
            IEVT=IEVT+1
            IF(REJFRG()) GO TO 121
C          Finish good event
            CALL MBIAS
            IFRG=IFRG+1
            IF(IFRG.GT.NFRGMN) IFRG=1
            IF(IFRG.EQ.1) THEN
              IEVOL=IEVOL+1
              IF(IEVOL.GT.NEVOLV) IEVOL=1
            ENDIF
            GOTO 9999
C          Fragmentation failed - increment counter and loop
121         IFRG=IFRG+1
            IF(IFRG.GT.NFRGMN) THEN
              IFRG=1
            ELSE
              GO TO 120
            ENDIF
C          End of multiple fragmentation loop
C          Evolution failed - increment counter and loop
111       IEVOL=IEVOL+1
          IF(IEVOL.GT.NEVOLV) THEN
            IEVOL=1
            IFRG=1
            GO TO 100
          ELSE
            GO TO 110
          ENDIF
C
C          E+E- events
C
      ELSE IF(KEYS(2)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL ELCTRN
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(.NOT.NOHADR) CALL FRGMNT
        ENDIF
C
C          MINBIAS events
C
      ELSE IF(KEYS(4)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        NPTCL=0
        IF(.NOT.(NOEVOL.OR.NOHADR)) CALL MBIAS
C
C          SUPERSYM events
C
      ELSE IF(KEYS(5)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL TWOJET
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GO TO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          WPAIR events
C
      ELSE IF(KEYS(6)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL TWOJET
        CALL WPAIR
C
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GO TO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          HIGGS events
C
      ELSE IF(KEYS(7)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL DRLLYN
        CALL HIGGS
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GOTO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          PHOTON events
C
      ELSEIF(KEYS(8)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL TWOJET
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GOTO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          TCOLOR events, e.g. techni-rho
C
      ELSEIF(KEYS(9)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL DRLLYN
        CALL HIGGS
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GOTO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          WHIGGS events
C
      ELSE IF(KEYS(10)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL TWOJET
        CALL WHIGGS
C
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GO TO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          EXTRADIM events
C
      ELSE IF(KEYS(11)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL DRLLYN
C 
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GO TO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
C
C          ZJJ events
C
      ELSEIF(KEYS(12)) THEN
        IEVT=IEVT+1
        CALL RANFMT
        CALL ZJJ
C
        IF(.NOT.NOEVOL) THEN
          CALL EVOLVE
          IF(NJSET.LT.0) GO TO 9999
          IF(.NOT.NOHADR) THEN
            CALL FRGMNT
            CALL MBIAS
          ENDIF
        ENDIF
      ENDIF
C
C          Event complete
C
 9999 IEVGEN=IEVGEN+1
      IF(NJSET.LT.0) OK=.FALSE.
      IF(IEVT.GT.NLIMIT) THEN
        OK=.FALSE.
        DONE=.TRUE.
      ELSEIF(IEVT.EQ.NLIMIT) THEN
        DONE=.TRUE.
      ENDIF
      IF(OK) THEN
        CALL PRTEVT(I)
        CALL GETTOT(.FALSE.)
      ENDIF
      RETURN
      END
+EOD
+DECK,ISAINI.
      SUBROUTINE ISAINI(JTDKY,JTEVT,JTCOM,JTLIS)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-         INITIALIZE PROCESSES
C-
C-   Inputs  : 
C          JTDKY = +/- UNIT NUMBER FOR DECAY TABLE FILE.
C                      IF IT IS NEGATIVE, DECAY TABLE IS NOT PRINTED.
C          JTEVT = +/- UNIT NUMBER FOR OUTPUT EVENT FILE.
C                      IF IT IS NEGATIVE, ONLY STABLE PARTICLES ARE
C                      WRITTEN ON IT.
C          JTCOM =     UNIT NUMBER FOR COMMAND FILE.
C          JTLIS =     UNIT NUMBER FOR LISTING.
C-
C-   Created   3-FEB-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
C
+CDE,IDRUN
+CDE,ITAPES
C
C          ENTRY.
      ITDKY=IABS(JTDKY)
      ITEVT=JTEVT
      ITCOM=IABS(JTCOM)
      ITLIS=IABS(JTLIS)
C
      IEVT=0
      CALL SETCON
      CALL RESET
      IF(JTDKY.GT.0) THEN
        CALL SETDKY(.TRUE.)
      ELSE
        CALL SETDKY(.FALSE.)
      ENDIF
C
  999 RETURN
      END
+EOD
+DECK,ISAJET.
      SUBROUTINE ISAJET(JTDKY,JTEVT,JTCOM,JTLIS)
C
C          Main subroutine for ISAJET, a Monte Carlo event generator
C          for  P P ,  AP P , and  E+ E-  interactions at high energy.
C
C          Frank E. Paige and Serban D. Protopopescu
C          Brookhaven National Laboratory
C          Upton, New York, USA
C
C          JTDKY = +/- unit number for decay table file.
C                      If it is negative, decay table is not printed.
C          JTEVT = +/- unit number for output event file.
C                      If it is negative, only stable particles are
C                      written on it.
C          JTCOM =     unit number for command file.
C          JTLIS =     unit number for listing.
C
C          Instead of calling this subroutine the user may wish to 
C          control the program himself using:
C          ISAINI      overall initialization
C          ISABEG      run initialization
C          ISAEVT      generation of one event
C          ISAEND      run termination
C          ISAWBG      initial record writing
C          ISAWEV      event record writing
C          ISAWND      end record writing
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,IDRUN
+CDE,PRIMAR
+CDE,ISLOOP
C
      INTEGER JTDKY,JTEVT,JTCOM,JTLIS,IFL,ILOOP
      LOGICAL OK,DONE
      SAVE ILOOP
C
C          Initialize ISAJET
C
      CALL ISAINI(JTDKY,JTEVT,JTCOM,JTLIS)
C
C          Read instructions; terminate for STOP command or error.
C
    1 IFL=0
      CALL ISABEG(IFL)
      IF(IFL.NE.0) RETURN
C          Write begin-run record
      CALL ISAWBG
C
C          Event loop
C
      ILOOP=0
  101 CONTINUE
        ILOOP=ILOOP+1
C          Generate one event - discard if .NOT.OK
        CALL ISAEVT(ILOOP,OK,DONE)
C          Write event record
        IF(OK) CALL ISAWEV
      IF(.NOT.DONE) GO TO 101
C
C          Calculate cross section and luminosity
C
      CALL ISAEND
C          Write end-of-run record
      CALL ISAWND
      GO TO 1
C
C          Entry point for error recovery.
C          CALL RSTART will continue generation on next event.
C
      ENTRY RSTART
      IF(IEVT.EQ.0) RETURN
      IF(IEVT.GE.NEVENT*NEVOLV*NFRGMN) GO TO 1
      GO TO 101
      END
+EOD
+DECK,ISASRT
      SUBROUTINE ISASRT(X,NCH,IMAP)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Sorts a floating point array X into ascending order.
C-                         The array IMAP contains ordered list of pointers
C-
C-   Inputs  : X - Floating point array
C-             NCH  - Number of elements in X
C-   Outputs : IMAP - pointer to ordered list in X
C-   Controls: None
C-
C-   Created   3-OCT-1988   Rajendran Raja
C-   Based on the Algorithm of D.L.Shell, High speed sorting
C-   procedure , Communications of the ACM, Vol 2, July 1959, PP 30-32
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL X(*)
      REAL TEMP
      INTEGER IMAP(*),NCH,M,I,J,K,IM,IT
C----------------------------------------------------------------------
      M=NCH
   10 M=M/2       !binary chop
      IF(M.EQ.0)GO TO 999
      K=NCH-M
      J=1
   20 I=J
   30 IM=I+M
      IF(X(I).LE.X(IM))GO TO 40
      TEMP = X(I)
      X(I) = X(IM)
      X(IM) = TEMP
      IT = IMAP(I)
      IMAP(I)=IMAP(IM)
      IMAP(IM)=IT
      I = I-M
      IF(I.GE.1)GO TO 30
   40 J=J+1
      IF(J.GT.K)GO TO 10
      GO TO 20
  999 RETURN
      END
+DECK,ISPJET
      SUBROUTINE ISPJET(DRCUT,ETCUT,NPJ,PJPT,PJPHI,PJETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : COMBINES PARTONS INTO PARTON JETS
C-                         based on PJCONE
C-   Inputs
C-        DRCUT  - dR=sqrt(dETA**2+dPHI**2) cut around Leading Partons.
C-        ETCUT  - Transverse Energy cut (minimum for defining a JET ).
C-
C-   Outputs : 
C-        NPJ       = No. of Parton Jets found.
C-        PJPT(NPJ) = pt of partons
C-        PJPHI(NPJ)= phi "
C-        PJETA(NPJ)= eta "
C-        
C-   created  16-APR-1996   Serban D. Protopopescu   
C-   Updated  16-JUN-1998   F. Paige
C-    Copy of ISAZEB routine ISA_PJETS to be used by IPARTNS
C-    
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PJETS
+CDE,JETSET
C
      INTEGER NPJ
      REAL    DRCUT
      REAL    PJPHI(*), PJETA(*), PJPT(*)
      INTEGER NP, JP, J, JO, JOP1, JOP2, JP1, JP2, ISKP, IP
      REAL    X1, Y1, PHI1, PHI2,TH
      REAL    DETA, DPHI, DR,  ETCUT
      INTEGER NPMAX
      PARAMETER (NPMAX=50)
      INTEGER JIORD(NPMAX), JDORD(NPMAX), JCNN(NPMAX,NPMAX)
      INTEGER JSKP(NPMAX)
      INTEGER I, JJ, K
      REAL    PJIN(4,NPMAX), PINPHI(NPMAX), PINETA(NPMAX)
      REAL    PINPT(NPMAX),PDMPT(NPMAX)
      REAL    PJ(4,NPMAX)
      REAL    EPS
      DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN
C
C last significant (correctly rounded) decimal place on VAX:
C                                                |
C                                                V
        PARAMETER (PI=        3.1415 92653 58979 32384 6 D0)
        PARAMETER (TWOPI=     6.2831 85307 17958 64769 3 D0)
        PARAMETER (HALFPI=    1.5707 96326 79489 66192 3 D0)
        PARAMETER (RADIAN= 0.0174532 92519 94329 5769237 D0)
C
      PARAMETER( EPS = 1.0E-5 )
C----------------------------------------------------------------------
C
      NP=0
      DO 10 I=1,NJSET
        IF(JDCAY(I).EQ.0.AND.IABS(JTYPE(I)).LT.10) THEN
          NP = NP + 1
          DO 11 K=1,4
            PJIN(K,NP)=PJSET(K,I)
   11     CONTINUE
          PINPT(NP)  = SQRT( PJIN(1,NP)**2+PJIN(2,NP)**2 )
          PINPHI(NP) = ATAN2 (PJIN(2,NP),PJIN(1,NP)+EPS)
          IF(PINPHI(NP).LT.0.)PINPHI(NP)=PINPHI(NP)+TWOPI
          TH = ATAN2 (PINPT(NP),PJIN(3,NP)+EPS)
          PINETA(NP) = -ALOG ( ABS(TAN(TH/2.)) + EPS )
          IF(NP.GE.NPMAX) GOTO 35
        ENDIF
   10 CONTINUE
   35 CONTINUE    ! jump here if more than NPMAX partons
C
C ... Order partons in pt
C
      DO 100 JP = 1 , NP
        JIORD(JP) = JP
  100 PDMPT(JP)=PINPT(JP)
      CALL ISASRT(PDMPT(1),NP,JIORD)
      DO 105 JP = 1 , NP
  105 JDORD(JP) = JIORD(NP-JP+1)
C
C ... Combine partons close in r space
C
      DO 110 J = 1 , NP
        JO=JDORD(J)
  110 JCNN(JO,1)=0
      ISKP=0
      DO 120 JP1 = 1 , NP-1
        JOP1=JDORD(JP1)
C ... Check if parton already connected to other one
        IF ( JCNN(JOP1,1).EQ.-1 ) GOTO 120
        DO 130 JP2 = JP1+1 , NP
          JOP2=JDORD(JP2)
C ... Check if parton already connected to other one
          IF ( JCNN(JOP2,1).EQ.-1 ) GOTO 130
          DETA = PINETA(JOP1) - PINETA(JOP2)
          PHI1 = PINPHI(JOP1)
          PHI2 = PINPHI(JOP2)
          X1 = COS(PHI2-PHI1)
          Y1 = SIN(PHI2-PHI1)
          IF(X1.EQ.0.0) THEN
            DPHI = HALFPI
          ELSE
            DPHI = ATAN2(Y1,X1)
          END IF
          DR = SQRT(DETA**2+DPHI**2)
C --- Criterion for combining partons
          IF ( DR.LT.DRCUT ) THEN
            JCNN(JOP1,1)=JCNN(JOP1,1)+1
            JCNN(JOP2,1)=-1
            JCNN(JOP1,JCNN(JOP1,1)+1)=JOP2
            ISKP=ISKP+JCNN(JOP1,1)
            JSKP(ISKP)=JOP2
          ELSE
            GOTO 130
          ENDIF
  130   CONTINUE
  120 CONTINUE
C
C ... Bookkeeping for parton jets
C
      DO 150 IP = 1 , NPJ
        PJPHI(IP)=0.
        PJETA(IP)=0.
        PJPT(IP) =0.
  150 CONTINUE
      NPJ=0
      DO 200 JP1 = 1 , NP
        JOP1=JDORD(JP1)
C ... Already connected, single parton, or has others to connect to
        IF ( JCNN(JOP1,1).GE.0 ) THEN
          NPJ=NPJ+1
          DO 151 K=1,4
            PJ(K,NPJ)=PJIN(K,JOP1)
  151     CONTINUE
          PJPHI(NPJ) = PINPHI(JOP1)
          PJETA(NPJ) = PINETA(JOP1)
          PJPT(NPJ) = PINPT(JOP1)
          IF ( JCNN(JOP1,1).EQ.0 ) GOTO 205
          DO 210 JJ = 1 , JCNN(JOP1,1)
            PJ(1,NPJ) = PJ(1,NPJ) + PJIN(1,JCNN(JOP1,JJ+1))
            PJ(2,NPJ) = PJ(2,NPJ) + PJIN(2,JCNN(JOP1,JJ+1))
            PJ(3,NPJ) = PJ(3,NPJ) + PJIN(3,JCNN(JOP1,JJ+1))
            PJ(4,NPJ) = PJ(4,NPJ) + PJIN(4,JCNN(JOP1,JJ+1))
  210     CONTINUE
          PJPT(NPJ) = SQRT( PJ(1,NPJ)**2 + PJ(2,NPJ)**2 )
          PJPHI(NPJ) = ATAN2 (PJ(2,NPJ),PJ(1,NPJ)+EPS)
          IF(PJPHI(NPJ).LT.0.)PJPHI(NPJ)=PJPHI(NPJ)+TWOPI
          TH = ATAN2 (PJPT(NPJ),PJ(3,NPJ)+EPS)
          PJETA(NPJ) = -ALOG ( ABS(TAN(TH/2.)) + EPS )
C ... Criterion for dropping a parton jet ( et < etcut )
  205     IF ( PJPT(NPJ).GT.ETCUT ) GOTO 200
          NPJ=NPJ-1
        ENDIF
  200 CONTINUE
C
C ... Order pjets in pt
C
      DO 300 JP = 1 , NPJ
        JIORD(JP) = JP
  300 PDMPT(JP)=PJPT(JP)
      CALL ISASRT(PDMPT(1),NPJ,JIORD)
      DO 305 JP = 1 , NPJ
        PINPT(JP)=PJPT(JP)
        PINETA(JP)=PJETA(JP)
        PINPHI(JP)=PJPHI(JP)
  305 JDORD(JP) = JIORD(NPJ-JP+1)
      DO 306 JP = 1 , NPJ
        PJPT(JP)=PINPT(JDORD(JP))
        PJETA(JP)=PINETA(JDORD(JP))
        PJPHI(JP)=PINPHI(JDORD(JP))
  306 CONTINUE
C-
  999 RETURN
      END
+DECK,ISTRAD
      SUBROUTINE ISTRAD(FUDGE)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-      Set parameters and call QCDINI to generate initial
C-      state radiation
C-   Inputs  : 
C-     FUDGE= fudge factor
C-
C-   Created  16-AUG-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL    FUDGE
+CDE,LIMEVL
+CDE,JETSET
+CDE,JWORK
+CDE,JETPAR
      REAL    OFF
      INTEGER I
C----------------------------------------------------------------------
C
      IF ( USELIM.AND.CONCUT.LT.1.0 ) THEN
        OFF=ETTHRS
      ELSEIF( .NOT.USELIM) THEN
        OFF=SQRT(QSQ)*FUDGE
      ELSE
        OFF=SQRT(QSQ)
      ENDIF
      DO 150 I=1,2
        PJSET(5,I)=-OFF
150   JDCAY(I)=-2
      JMATCH(1)=0
      JMATCH(2)=0
C
      CALL QCDINI(1,2)
  999 RETURN
      END
+EOD
+DECK,ISWDKY
      SUBROUTINE ISWDKY
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-       decay W's and Z's as done in ISAJET
C-
C-   Created   6-MAY-1991   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,CONST
+CDE,FRAME
+CDE,JETPAR
+CDE,JETSET
+CDE,JWORK
+CDE,PJETS
+CDE,PARTCL
+CDE,PRIMAR
+CDE,WCON
      REAL X(2)    
      EQUIVALENCE (X(1),X1) 
      REAL PREST(5),PL(5),EL(3),EML(3),EMSQL(3)    
      REAL WTFAC(3)    
      REAL BRANCH(29)
      INTEGER LISTJ(29),LISTW(4)   
      REAL RANF,SUM,PTDEN,QDEN,ETA,
     $S12,SUMBR,BRMODE,AMASS,BRINV,TRY,PL12,
     $COSTHL,THL,PHL,PTL,SGN,BP,PLPL,PLMN,AMINI,AMFIN,PINI,PFIN, 
     $ QPL,QMN,AM1SQ,AM2SQ,ROOT,P1PL,P1MN,P2PL,P2MN
      INTEGER NADD,K,IQ1,IQ2,IFL1,IFL2,IQ,IFL,I   
      REAL EY
      REAL QWPL,QWMN
C   
      DATA LISTJ/   
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,  
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,    
     $10,80,-80,90/ 
      DATA LISTW/10,80,-80,90/  
C----------------------------------------------------------------------
C   
C          Entry    
C   
      NPTCL=0   
C   
C          Kinematics. Note that YW is the true rapidity and QW is
C          the true 3-momentum. See DRLLYN.
C   
      QMW=QWJET(5)
      QTW=SQRT(QWJET(1)**2+QWJET(2)**2)
      QW=SQRT(QWJET(1)**2+QWJET(2)**2+QWJET(3)**2)
      IF(QTW.NE.0) THEN
        PHIW=ATAN2(QWJET(2),QWJET(1))
        IF(PHIW.LT.0) PHIW=PHIW+2*PI
      ELSE
        PHIW=0
      ENDIF
      QWPL=QWJET(4)+QWJET(3)
      QWMN=QWJET(4)-QWJET(3)
      IF(QWPL.GT.0..AND.QWMN.GT.0.) THEN
        YW=0.5*ALOG(QWPL/QWMN)
      ELSE
        YW=999.*SIGN(1.,QWJET(3))
      ENDIF
      IF(QW.NE.0.) THEN
        THW=ACOS(QWJET(3)/QW)
      ELSE
        THW=0.
      ENDIF
C   
C          Select W decay mode  
C          QMW dependence neglected in branching ratios 
C          BRANCH is cum. br. with heavy modes subtracted.  
C   
      S12=QMW**2    
      BRANCH(1)=0.    
      SUMBR=0.    
      DO 105 IQ1=2,25 
        IQ2=MATCH(IQ1,JWTYP)  
        IF(IQ2.EQ.0) THEN 
          BRMODE=0.   
        ELSE  
          BRMODE=WCBR(IQ1,JWTYP)-WCBR(IQ1-1,JWTYP)    
          IFL1=LISTJ(IQ1) 
          IFL2=LISTJ(IQ2) 
          IF(S12.LE.(AMASS(IFL1)+AMASS(IFL2))**2) BRMODE=0.   
        ENDIF 
        BRANCH(IQ1)=BRANCH(IQ1-1)+BRMODE  
        SUMBR=SUMBR+BRMODE    
105   CONTINUE    
      BRINV=1./SUMBR  
C   
      TRY=RANF()  
      DO 110 IQ=1,25  
        IF(TRY.LT.BRANCH(IQ)*BRINV.AND.MATCH(IQ,JWTYP).NE.0) THEN 
          JETTYP(1)=IQ    
          JETTYP(2)=MATCH(IQ,JWTYP)   
          GO TO 120   
        ENDIF 
110   CONTINUE    
C   
120   IFL1=LISTJ(JETTYP(1)) 
      IFL2=LISTJ(JETTYP(2)) 
C   
C          Select masses of decay products. 
C   
      EML(1)=AMASS(IFL1)    
      EML(2)=AMASS(IFL2)    
C   
C          Generate W decay in its rest frame 
C          First set up momenta of decay products:  
C   
      EMSQL(1)=EML(1)**2    
      EMSQL(2)=EML(2)**2    
      EL(1)=(S12+EMSQL(1)-EMSQL(2))/(2.*QMW)    
      EL(2)=(S12+EMSQL(2)-EMSQL(1))/(2.*QMW)    
      PL12=SQRT((S12-(EML(1)+EML(2))**2)*(S12-(EML(1)-EML(2))**2))  
     $/(2.*QMW) 
C          W momentum   
      DO 140 K=1,5
140   PREST(K)=QWJET(K)
C          Generate next W decay    
20    CONTINUE  
      COSTHL=2.*RANF()-1.   
      THL=ACOS(COSTHL)  
      PHL=2.*PI*RANF()  
      PTL=PL12*SIN(THL) 
C   
      DO 300 I=1,2  
        SGN=3-2*I   
        PL(1)=SGN*PTL*COS(PHL)  
        PL(2)=SGN*PTL*SIN(PHL)  
        PL(3)=SGN*PL12*COSTHL   
        PL(4)=EL(I) 
        PL(5)=EML(I)    
C          Boost with W momentum    
        BP=0.   
        DO 310 K=1,3    
310     BP=BP+PL(K)*PREST(K)    
        BP=BP/PREST(5)  
        DO 320 K=1,3    
320     PL(K)=PL(K)+PREST(K)*PL(4)/PREST(5) 
     $  +PREST(K)*BP/(PREST(4)+PREST(5))    
        PL(4)=PL(4)*PREST(4)/PREST(5)+BP    
C          Fill common blocks   
        PT(I)=SQRT(PL(1)**2+PL(2)**2)   
        P(I)=SQRT(PT(I)**2+PL(3)**2)    
        IF(PT(I).GT.0.) THEN    
          PHI(I)=ATAN2(PL(2),PL(1)) 
        ELSE    
          PHI(I)=(I-1)*PI   
        ENDIF   
        IF(PHI(I).LT.0.) PHI(I)=PHI(I)+2.*PI    
        CTH(I)=PL(3)/P(I)   
        STH(I)=PT(I)/P(I)   
        TH(I)=ACOS(CTH(I))  
        XJ(I)=PL(3)/HALFE   
        IF(CTH(I).GT.0.) THEN   
          PLPL=PL(4)+PL(3)  
          PLMN=(PT(I)**2+EMSQL(I))/PLPL 
        ELSE    
          PLMN=PL(4)-PL(3)  
          PLPL=(PT(I)**2+EMSQL(I))/PLMN 
        ENDIF   
        YJ(I)=.5*ALOG(PLPL/PLMN)    
300   CONTINUE  
C   
C          Set PJETS    
C   
      DO 501 I=1,2
        PJETS(3,I)=P(I)*CTH(I)  
        PJETS(1,I)=PT(I)*COS(PHI(I))    
        PJETS(2,I)=PT(I)*SIN(PHI(I))    
        PJETS(4,I)=SQRT(P(I)**2+EMSQL(I))   
        PJETS(5,I)=SQRT(EMSQL(I))   
        IDJETS(I)=LISTJ(JETTYP(I))  
501   CONTINUE  
  999 RETURN
      END
+EOD
+DECK,JETGEN.
      SUBROUTINE JETGEN(J)
C
C          FRAGMENT JET J IN /JETSET/ INTO PRIMARY HADRONS USING THE
C          ALGORITHM OF FIELD AND FEYNMAN WITH
C          F(X)=1-XGEN(1)+XGEN(1)*(XGEN(2)+1)*(1-X)**XGEN(2)
C          FOR LIGHT QUARKS AND THE PETERSON F(X) WITH
C          EPSILON=XGEN(I)*AMASS(I)**2
C          FOR HEAVY QUARKS.
C          INCLUDE BARYONS USING DIQUARKS WITH PROBABILITY PBARY.
C          PROBABILITY PSPIN1 FOR SPIN 1 DEPENDS ON HEAVIEST FLAVOR.
C          FRAGMENT A GLUON LIKE A RANDOM QUARK.
C
C          Ver 7.30: Use delta function fragmentation for top quark.
C
C
+CDE,ITAPES
+CDE,JETSET
+CDE,PARTCL
+CDE,FRGPAR
+CDE,CONST
+CDE,MBPAR
C
      LOGICAL HEAVY
      NBEGIN=NPTCL+1
      PSUM=0.
      IFLBEG=JTYPE(J)
      HEAVY=.FALSE.
      IF(IABS(IFLBEG).GT.3.AND.IFLBEG.NE.9) HEAVY=.TRUE.
      PBEG=SQRT(PJSET(1,J)**2+PJSET(2,J)**2+PJSET(3,J)**2)
C          TOP QUARK...
      IF(IABS(IFLBEG).GE.6.AND.IABS(IFLBEG).LE.8) THEN
        NPTCL=NPTCL+1
        PPTCL(1,NPTCL)=0
        PPTCL(2,NPTCL)=0
        PPTCL(3,NPTCL)=PBEG
        PPTCL(4,NPTCL)=PJSET(4,J)
        PPTCL(5,NPTCL)=PJSET(5,J)
        IORIG(NPTCL)=-J
        IDCAY(NPTCL)=0
        IDENT(NPTCL)=JTYPE(J)
        RETURN
      ENDIF
C          EQUIVALENT QUARK FOR GLUON
      IF(IFLBEG.NE.9) GO TO 200
      IFLBEG=INT(RANF()/PUD)+1
      IF(RANF().GT..5) IFLBEG=-IFLBEG
C          CONSTRUCT FIRST QUARK
200   LOOP=0
      IFL1=IFLBEG
      CALL GETPT(PT1,SIGQT)
      PHI1=2.*PI*RANF()
      PX1=PT1*COS(PHI1)
      PY1=PT1*SIN(PHI1)
      PPLUS=PBEG+PJSET(4,J)
      PTRUE=PPLUS
935   CONTINUE
C          CONSTRUCT NEXT QUARK
300   LOOP=LOOP+1
      IF(PPLUS.LT.PEND.OR.LOOP.GT.10000) RETURN
C          IFL2 CAN BE DIQUARK ONLY IF IFL1 IS NOT
      IF(MOD(IFL1,100).EQ.0) GO TO 305
      IF(RANF().LT.PBARY) GO TO 310
      IFL2=ISIGN(INT(RANF()/PUD)+1,-IFL1)
      GO TO 320
305   IFL2=ISIGN(INT(RANF()/PUD)+1,+IFL1)
      GO TO 320
310   IQ1=INT(RANF()/PUD)+1
      IQ2=INT(RANF()/PUD)+1
      IF(IQ1.LE.IQ2) GO TO 315
      ISWAP=IQ1
      IQ1=IQ2
      IQ2=ISWAP
315   IFL2=ISIGN(1000*IQ1+100*IQ2,IFL1)
320   CONTINUE
      CALL GETPT(PT2,SIGQT)
      PHI2=2.*PI*RANF()
      PX2=PT2*COS(PHI2)
      PY2=PT2*SIN(PHI2)
C          CONSTRUCT MESON WITH FLAVOR MIXING
C          SPECIAL CASE - SUPERSYM
      IFLABS=IABS(IFL1)
      IF(IFLABS.GT.20.AND.IFLABS.LT.30) THEN
        IDHAD=IFL1
        GOTO 470
      ENDIF
      IF(MOD(IFL1,100).EQ.0) GO TO 420
      IF(MOD(IFL2,100).EQ.0) GO TO 425
      IHIGH=MAX0(IABS(IFL1),IABS(IFL2))
      JSPIN=INT(RANF()+PSPIN1(IHIGH))
      ID1=IFL1
      ID2=IFL2
      IF(ID1+ID2.NE.0) GO TO 400
      RND=RANF()
      ID1=IABS(ID1)
      ID1=INT(PMIX1(ID1,JSPIN+1)+RND)+INT(PMIX2(ID1,JSPIN+1)+RND)+1
      ID2=-ID1
400   IF(IABS(ID1).LE.IABS(ID2)) GO TO 410
      ISAVE=ID1
      ID1=ID2
      ID2=ISAVE
410   IDHAD=ISIGN(100*IABS(ID1)+10*IABS(ID2)+JSPIN,ID1)
      GO TO 470
C          CONSTRUCT BARYON IDENT.
420   ID3=MOD(IFL1/100,10)
      ID2=IFL1/1000
      ID1=IFL2
      GO TO 430
425   ID3=MOD(IFL2/100,10)
      ID2=IFL2/1000
      ID1=IFL1
430   IF(IABS(ID1).LE.IABS(ID2)) GO TO 431
      ISWAP=ID1
      ID1=ID2
      ID2=ISWAP
431   IF(IABS(ID2).LE.IABS(ID3)) GO TO 432
      ISWAP=ID2
      ID2=ID3
      ID3=ISWAP
432   IF(IABS(ID1).LE.IABS(ID2)) GO TO 440
      ISWAP=ID1
      ID1=ID2
      ID2=ISWAP
440   JSPIN=1
      IF(ID1.EQ.ID2.AND.ID2.EQ.ID3) GO TO 450
      IHIGH=IABS(ID3)
      JSPIN=INT(RANF()+PSPIN1(IHIGH))
450   IF(JSPIN.EQ.1.OR.ID1.EQ.ID2.OR.ID2.EQ.ID3) GO TO 460
      IF(RANF().GT.PISPN) GO TO 460
      ISWAP=ID1
      ID1=ID2
      ID2=ISWAP
460   IDHAD=1000*IABS(ID1)+100*IABS(ID2)+10*IABS(ID3)+JSPIN
      IDHAD=ISIGN(IDHAD,IFL1)
470   CONTINUE
      AM=AMASS(IDHAD)
      PX=PX1+PX2
      PY=PY1+PY2
      AMT2=PX**2+PY**2+AM**2
C          IF LEADING PARTICLE, FIND MINIMUM X
      XMIN=0.
      IF(LOOP.EQ.1) XMIN=AMIN1(SQRT(AMT2)/PPLUS,1.)
C          SELECT X
C          USE FIELD-FEYNMAN FUNCTION FOR LIGHT QUARKS.
C          USE PETERSON FRAGMENTATION FOR HEAVY QUARKS.
C          USE DISTRIBUTION FOR HEAVIER QUARK FOR DIQUARKS.
      II1=IABS(IFL1)
      IF(MOD(II1,100).EQ.0) II1=MOD(II1/100,10)
      IF(II1.LE.3) THEN
        X=RANF()
        IF(RANF().LT.XGEN(1)) X=1.-X**(1./(XGEN(2)+1.))
      ELSEIF(II1.LE.9) THEN
        CALL HEAVYX(X,XGEN(II1)/AM**2)
      ELSEIF(II1.GT.20.AND.II1.LT.30) THEN
        CALL HEAVYX(X,XGENSS(II1-20)/AM**2)
      ENDIF
      X=XMIN+(1.-XMIN)*X
      QPLUS=X*PPLUS
      QPLUS=AMAX1(QPLUS,1.E-6)
      QMINUS=AMT2/QPLUS
      P0=.5*(QPLUS+QMINUS)
      PZ=.5*(QPLUS-QMINUS)
C          DISCARD PARTICLE IF PZ<0
      IF(PZ.LT.0..AND..NOT.(HEAVY.AND.LOOP.EQ.1)) GO TO 500
C          ADD PARTICLE TO /PARTCL/
      IF(NPTCL.GE.MXPTCL) GO TO 9999
      NPTCL=NPTCL+1
      PPTCL(1,NPTCL)=PX
      PPTCL(2,NPTCL)=PY
      PPTCL(3,NPTCL)=PZ
      PPTCL(4,NPTCL)=P0
      PPTCL(5,NPTCL)=AM
      IORIG(NPTCL)=-J
      IDCAY(NPTCL)=0
      IDENT(NPTCL)=IDHAD
      PSUM=PSUM+QPLUS
C          SWAP QUARKS AND CONTINUE IF SUFFICIENT PPLUS
500   CONTINUE
      PX1=-PX2
      PY1=-PY2
      IFL1=-IFL2
      PPLUS=(1.-X)*PPLUS
      GO TO 300
C
9999  CALL PRTEVT(0)
      WRITE(ITLIS,10) NPTCL
10    FORMAT(//5X,'ERROR IN JETGEN...NPTCL >',I5)
      RETURN
      END
+EOD
+DECK,KKGF1
      REAL FUNCTION KKGF1(S,T,M2)
      REAL S,T,M2
      REAL XG,YG
      XG = T/S
      YG = M2/S
      KKGF1 =
     &   ( -4.*XG*(1.+XG)*(1.+2.*XG+2.*XG**2) 
     &     + YG*(1.+6.*XG+18.*XG**2+16.*XG**3) 
     &     - 6.*YG**2*XG*(1.+2.*XG) + YG**3*(1.+4.*XG) ) / 
     &   ( XG*(YG-1.-XG) )
      RETURN
      END
+EOD
+DECK,KKGF2
      REAL FUNCTION KKGF2(S,T,M2)
      REAL S,T,M2
      REAL XG,YG
      XG = T/S
      YG = M2/S
      KKGF2 =
     &   ( -4.*XG*(1.+XG**2) + YG*(1.+XG)*(1.+8.*XG+XG**2) - 
     &      3.*YG**2*(1.+4.*XG+XG**2) + 4.*YG**3*(1.+XG) - 2.*YG**4 ) /
     &   ( XG*(YG-1.-XG) )
      RETURN
      END
+EOD
+DECK,KKGF3
      REAL FUNCTION KKGF3(S,T,M2)
      REAL S,T,M2
      REAL XG,YG
      XG = T/S
      YG = M2/S
      KKGF3 = 
     &   ( 1. + 2.*XG + 3.*XG**2 + 2.*XG**3 + XG**4 - 2.*YG*(1.+XG**3)
     &     + 3.*YG**2*(1.+XG**2) - 2.*YG**3*(1.+XG) + YG**4 ) /
     &   ( XG*(YG-1.-XG) )
      RETURN
      END
+EOD
+DECK,LABEL.
      FUNCTION LABEL(ID)
C
C          Return the CHARACTER*8 label for the particle ID.
C          Quark-based IDENT code.
C          MSSM names for squarks, sleptons, Higgs bosons.
C
C          Ver. 7.49: Offset of INDEX must match that in FLAVOR.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QLMASS
+CDE,SSTYPE
C
+SELF,IF=LEVEL2.
C          DUMMY COMMON BLOCK TO ALLOW LEVEL2 STORAGE.
      COMMON/XLABEL/LLEP,LMES0,LMES1,LBAR0,LABAR0,LBAR1,LABAR1,LQQ,LAQQ
      LEVEL2,/XLABEL/
+SELF.
      INTEGER ID
      CHARACTER*8 LABEL
      CHARACTER*8 LLEP,LMES0,LMES1,LBAR0,LABAR0,LBAR1,LABAR1
      CHARACTER*8 LQQ,LAQQ
      DIMENSION LLEP(149)
      DIMENSION LMES0(64),LMES1(64)
      DIMENSION LBAR0(109),LABAR0(109),LBAR1(109),LABAR1(109)
      DIMENSION LQQ(21),LAQQ(21)
      INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,I,J,IDABS
C
C          Diquark labels
C
      DATA LQQ/
     1'UU0. ','UD0. ','DD0. ','US0. ','DS0. ','SS0. ','UC0. ','DC0. ',
     2'SC0. ','CC0. ','UB0. ','DB0. ','SB0. ','CB0. ','BB0. ','UT0. ',
     3'DT0. ','ST0. ','CT0. ','BT0. ','TT0. '/
      DATA LAQQ/
     1'AUU0.','AUD0.','ADD0.','AUS0.','ADS0.','ASS0.','AUC0.','ADC0.',
     2'ASC0.','ACC0.','AUB0.','ADB0.','ASB0.','ACB0.','ABB0.','AUT0.',
     3'ADT0.','AST0.','ACT0.','ABT0.','ATT0.'/
C
C          Quark and lepton labels
C
      DATA LLEP/
     $'     ','UP   ','UB   ','DN   ','DB   ','ST   ','SB   ','CH   ',
     $'CB   ','BT   ','BB   ','TP   ','TB   ','Y    ','YB   ','X    ',
     $'XB   ','GL   ','ERR  ','GM   ','ERR  ','NUE  ','ANUE ','E-   ',
     $'E+   ','NUM  ','ANUM ','MU-  ','MU+  ','NUT  ','ANUT ','TAU- ',
     $'TAU+ ','ERR  ','ERR  ','ERR  ','ERR  ','ERR  ','ERR  ','KS   ',
     $'ERR  ','ERR  ','KL   ',
     $'UPL  ','UBL  ','DNL  ','DBL  ','STL  ','SBL  ','CHL  ','CBL  ',
     $'BT1  ','BB1  ','TP1  ','TB1  ','ERR  ','ERR  ','ERR  ','ERR  ',
     $'GLSS ','ERR  ','Z1SS ','ERR  ','NUEL ','ANUEL','EL-  ','EL+  ',
     $'NUML ','ANUML','MUL- ','MUL+ ','NUTL ','ANUTL','TAU1-','TAU1+',
     $'ERR  ','ERR  ','ERR  ','ERR  ','W1SS+','W1SS-','Z2SS ','ERR  ',
     $'UPR  ','UBR  ','DNR  ','DBR  ','STR  ','SBR  ','CHR  ','CBR  ',
     $'BT2  ','BB2  ','TP2  ','TB2  ','ERR  ','ERR  ','ERR  ','ERR  ',
     $'W2SS+','W2SS-','Z3SS ','ERR  ','NUER ','ANUER','ER-  ','ER+  ',
     $'NUMR ','ANUMR','MUR- ','MUR+ ','NUTR ','ANUTR','TAU2-','TAU2+',
     $'ERR  ','ERR  ','ERR  ','ERR  ','ERR  ','ERR  ','Z4SS ','ERR  ',
     $'W+   ','W-   ','HIGGS','ERR  ','HL0  ','ERR  ','HH0  ','ERR  ',
     $'HA0  ','ERR  ','H40  ','AH40 ','H+   ','H-   ','H2+  ','H2-  ',
     $'H1++ ','H1-- ','H2++ ','H2-- ','Z0   ','ERR  ','GVSS ','ERR  ',
     $'GRAV ','ERR  '/
C
C          0- meson labels
C
      DATA LMES0/
     1'PI0  ','PI+  ','ETA  ','PI-  ','K+   ','K0   ','ETAP ','AK0  ',
     2'K-   ','AD0  ','D-   ','DS-  ','ETAC ','DS+  ','D+   ','D0   ',
     2'B+   ','B0   ','BS   ','BC   ','ETAB ','ABC  ','ABS  ','AB0  ',
     3'B-   ','UT.  ','DT.  ','ST.  ','CT.  ','BT.  ','TT.  ','TB.  ',
     4'TC.  ','TS.  ','TD.  ','TU.  ','UY.  ','DY.  ','SY.  ','CY.  ',
     5'BY.  ','TY.  ','YY.  ','YT.  ','YB.  ','YC.  ','YS.  ','YD.  ',
     6'YU.  ','UX.  ','DX.  ','SX.  ','CX.  ','BX.  ','TX.  ','YX.  ',
     7'XX.  ','XY.  ','XT.  ','XB.  ','XC.  ','XS.  ','XD.  ','XU.  '/
C
C          1- meson labels
C
      DATA LMES1/
     1'RHO0 ','RHO+ ','OMEG ','RHO- ','K*+  ','K*0  ','PHI  ','AK*0 ',
     2'K*-  ','AD*0 ','D*-  ','DS*- ','JPSI ','DS*+ ','D*+  ','D*0  ',
     3'B*+  ','B*0  ','BS*  ','BC*  ','UPSL ','ABC* ','ABS* ','AB0* ',
     4'B*-  ','UT*  ','DT*  ','ST*  ','CT*  ','BT*  ','TT*  ','TB*  ',
     5'TC*  ','TS*  ','TD*  ','TU*  ','UY*  ','DY*  ','SY*  ','CY*  ',
     6'BY*  ','TY*  ','YY*  ','YT*  ','YB*  ','YC*  ','YS*  ','YD*  ',
     7'YU*  ','UX*  ','DX*  ','SX*  ','CX*  ','BX*  ','TX*  ','YX*  ',
     8'XX*  ','XY*  ','XT*  ','XB*  ','XC*  ','XS*  ','XD*  ','XU*  '/
C
C          1/2+ baryon labels
C
      DATA LBAR0/
     1'ERR  ','P    ','N    ','ERR  ','ERR  ','S+   ','S0   ','S-   ',
     2'L    ','XI0  ','XI-  ','ERR  ','ERR  ','ERR  ','SC++ ','SC+  ',
     3'SC0  ','LC+  ','USC. ','DSC. ','SSC. ','SDC. ','SUC. ','UCC. ',
     4'DCC. ','SCC. ','ERR  ','ERR  ','ERR  ','ERR  ','UUB. ','UDB. ',
     5'DDB. ','DUB. ','USB. ','DSB. ','SSB. ','SDB. ','SUB. ','UCB. ',
     6'DCB. ','SCB. ','CCB. ','CSB. ','CDB. ','CUB. ','UBB. ','DBB. ',
     7'SBB. ','CBB. ','ERR  ','ERR  ','ERR  ','ERR  ','ERR  ','UUT. ',
     8'UDT. ','DDT. ','DUT. ','UST. ','DST. ','SST. ','SDT. ','SUT. ',
     9'UCT. ','DCT. ','SCT. ','CCT. ','CST. ','CDT. ','CUT. ','UBT. ',
     1'DBT. ','SBT. ','CBT. ','BBT. ','BCT. ','BST. ','BDT. ','BUT. ',
     2'UTT. ','DTT. ','STT. ','CTT. ','BTT. ','ERR  ','ERR  ','ERR  ',
     3'ERR  ','ERR  ','ERR  ','UUY. ','UDY. ','DDY. ','DUY. ','USY. ',
     4'DSY. ','SSY. ','SDY. ','SUY. ','UUX. ','UDX. ','DDX. ','DUX. ',
     5'USX. ','DSX. ','SSX. ','SDX. ','SUX. '/
      DATA LABAR0/
     1'ERR  ','AP   ','AN   ','ERR  ','ERR  ','AS-  ','AS0  ','AS+  ',
     2'AL   ','AXI0 ','AXI+ ','ERR  ','ERR  ','ERR  ','ASC--','ASC- ',
     3'ASC0 ','ALC- ','AUSC.','ADSC.','ASSC.','ASDC.','ASUC.','AUCC.',
     4'ADCC.','ASCC.','ERR  ','ERR  ','ERR  ','ERR  ','AUUB.','AUDB.',
     5'ADDB.','ADUB.','AUSB.','ADSB.','ASSB.','ASDB.','ASUB.','AUCB.',
     6'ADCB.','ASCB.','ACCB.','ACSB.','ACDB.','ACUB.','AUBB.','ADBB.',
     7'ASBB.','ACBB.','ERR  ','ERR  ','ERR  ','ERR  ','ERR  ','AUUT.',
     8'AUDT.','ADDT.','ADUT.','AUST.','ADST.','ASST.','ASDT.','ASUT.',
     9'AUCT.','ADCT.','ASCT.','ACCT.','ACST.','ACDT.','ACUT.','AUBT.',
     1'ADBT.','ASBT.','ACBT.','ABBT.','ABCT.','ABST.','ABDT.','ABUT.',
     2'AUTT.','ADTT.','ASTT.','ACTT.','ABTT.','ERR  ','ERR  ','ERR  ',
     3'ERR  ','ERR  ','ERR  ','AUUY.','AUDY.','ADDY.','ADUY.','AUSY.',
     4'ADSY.','ASSY.','ASDY.','ASUY.','AUUX.','AUDX.','ADDX.','ADUX.',
     5'AUSX.','ADSX.','ASSX.','ASDX.','ASUX.'/
C
C          3/2+ baryon labels
C
      DATA LBAR1/
     1'DL++ ','DL+  ','DL0  ','DL-  ','ERR  ','S*+  ','S*0  ','S*-  ',
     2'ERR  ','XI*0 ','XI*- ','OM-  ','ERR  ','ERR  ','UUC* ','UDC* ',
     3'DDC* ','ERR  ','USC* ','DSC* ','SSC* ','ERR  ','ERR  ','UCC* ',
     4'DCC* ','SCC* ','CCC* ','ERR  ','ERR  ','ERR  ','UUB* ','UDB* ',
     5'DDB* ','ERR  ','USB* ','DSB* ','SSB* ','ERR  ','ERR  ','UCB* ',
     6'DCB* ','SCB* ','CCB* ','ERR  ','ERR  ','ERR  ','UBB* ','DBB* ',
     7'SBB* ','CBB* ','BBB* ','ERR  ','ERR  ','ERR  ','ERR  ','UUT* ',
     8'UDT* ','DDT* ','ERR  ','UST* ','DST* ','SST* ','ERR  ','ERR  ',
     9'UCT* ','DCT* ','SCT* ','CCT* ','ERR  ','ERR  ','ERR  ','UBT* ',
     1'DBT* ','SBT* ','CBT* ','BBT* ','ERR  ','ERR  ','ERR  ','ERR  ',
     2'UTT* ','DTT* ','STT* ','CTT* ','BTT* ','TTT* ','ERR  ','ERR  ',
     3'ERR  ','ERR  ','ERR  ','UUY* ','UDY* ','DDY* ','ERR  ','USY* ',
     4'DSY* ','SSY* ','ERR  ','ERR  ','UUX* ','UDX* ','DDX* ','ERR  ',
     5'USX* ','DSX* ','SSX* ','ERR  ','ERR  '/
      DATA LABAR1/
     1'ADL--','ADL- ','ADL0 ','ADL+ ','ERR  ','AS*- ','AS*0 ','AS*+ ',
     2'ERR  ','AXI*0','AXI*+','AOM+ ','ERR  ','ERR  ','AUUC*','AUDC*',
     3'ADDC*','ERR  ','AUSC*','ADSC*','ASSC*','ERR  ','ERR  ','AUCC*',
     4'ADCC*','ASCC*','ACCC*','ERR  ','ERR  ','ERR  ','AUUB*','AUDB*',
     5'ADDB*','ERR  ','AUSB*','ADSB*','ASSB*','ERR  ','ERR  ','AUCB*',
     6'ADCB*','ASCB*','ACCB*','ERR  ','ERR  ','ERR  ','AUBB*','ADBB*',
     7'ASBB*','ACBB*','ABBB*','ERR  ','ERR  ','ERR  ','ERR  ','AUUT*',
     8'AUDT*','ADDT*','ERR  ','AUST*','ADST*','ASST*','ERR  ','ERR  ',
     9'AUCT*','ADCT*','ASCT*','ACCT*','ERR  ','ERR  ','ERR  ','AUBT*',
     1'ADBT*','ASBT*','ACBT*','ABBT*','ERR  ','ERR  ','ERR  ','ERR  ',
     2'AUTT*','ADTT*','ASTT*','ACTT*','ABTT*','ATTT*','ERR  ','ERR  ',
     3'ERR  ','ERR  ','ERR  ','AUUY*','AUDY*','ADDY*','ERR  ','AUSY*',
     4'ADSY*','ASSY*','ERR  ','ERR  ','AUUX*','AUDX*','ADDX*','ERR  ',
     5'AUSX*','ADSX*','ASSX*','ERR  ','ERR  '/
C
C          Entry
C
      LABEL='ERR'
      IDABS=IABS(ID)
      IF(IDABS.EQ.0) THEN
        LABEL='     '
        RETURN
      ENDIF
      CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX)
      IF(INDEX.LE.0) RETURN
      IF(IDABS.GT.10000.OR.JSPIN.GT.1) GO TO 500
      IF(IDABS.LT.100) GO TO 200
      IF(IDABS.LT.1000) GO TO 100
      IF(ID.NE.0.AND.MOD(ID,100).EQ.0) GO TO 300
C
C          Baryons
C
      INDEX=INDEX-109*JSPIN-36*NMES-NQLEP
      INDEX=INDEX-13
      IF(JSPIN.EQ.0.AND.ID.GT.0) LABEL=LBAR0(INDEX)
      IF(JSPIN.EQ.0.AND.ID.LT.0) LABEL=LABAR0(INDEX)
      IF(JSPIN.EQ.1.AND.ID.GT.0) LABEL=LBAR1(INDEX)
      IF(JSPIN.EQ.1.AND.ID.LT.0) LABEL=LABAR1(INDEX)
      GO TO 999
C
C          Mesons
C
100   CONTINUE
      I=MAX0(IFL2,IFL3)
      J=-MIN0(IFL2,IFL3)
      INDEX=MAX0(I-1,J-1)**2+I+MAX0(I-J,0)
      IF(JSPIN.EQ.0) LABEL=LMES0(INDEX)
      IF(JSPIN.EQ.1) LABEL=LMES1(INDEX)
      GO TO 999
C
C          Quarks, leptons, etc.
C
200   CONTINUE
      INDEX=2*INDEX
      IF(ID.LE.0) INDEX=INDEX+1
      LABEL=LLEP(INDEX)
      GO TO 999
300   I=IABS(IFL1)
      J=IABS(IFL2)
      INDEX=I+J*(J-1)/2
      IF(ID.GT.0) LABEL=LQQ(INDEX)
      IF(ID.LT.0) LABEL=LAQQ(INDEX)
      RETURN
C
C          Special hadrons - used only in B decays
C
500   CONTINUE
      IF(ID.EQ.10121) THEN
        LABEL='A1+'
      ELSEIF(ID.EQ.-10121) THEN
        LABEL='A1-'
      ELSEIF(ID.EQ.10111) THEN
        LABEL='A10'
      ELSEIF(ID.EQ.10131) THEN
        LABEL='K1+'
      ELSEIF(ID.EQ.-10131) THEN
        LABEL='K1-'
      ELSEIF(ID.EQ.10231) THEN
        LABEL='K10'
      ELSEIF(ID.EQ.-10231) THEN
        LABEL='AK10'
      ELSEIF(ID.EQ.30131) THEN
        LABEL='K1*+'
      ELSEIF(ID.EQ.-30131) THEN
        LABEL='K1*-'
      ELSEIF(ID.EQ.30231) THEN
        LABEL='K1*0'
      ELSEIF(ID.EQ.-30231) THEN
        LABEL='AK1*0'
      ELSEIF(ID.EQ.132) THEN
        LABEL='K2*+'
      ELSEIF(ID.EQ.-132) THEN
        LABEL='K2*-'
      ELSEIF(ID.EQ.232) THEN
        LABEL='K2*0'
      ELSEIF(ID.EQ.-232) THEN
        LABEL='AK2*0'
      ELSEIF(ID.EQ.10110) THEN
        LABEL='F0'
      ELSEIF(ID.EQ.112) THEN
        LABEL='F2'
      ELSEIF(ID.EQ.10441) THEN
        LABEL='PSI2'
      ELSEIF(ID.EQ.20440) THEN
        LABEL='CHI0'
      ELSEIF(ID.EQ.20441) THEN
        LABEL='CHI1'
      ELSEIF(ID.EQ.20442) THEN
        LABEL='CHI2'
      ELSEIF(ID.EQ.IDTAUL) THEN
        LABEL='TAUL-'
      ELSEIF(ID.EQ.-IDTAUL) THEN
        LABEL='TAUL+'
      ELSEIF(ID.EQ.IDTAUR) THEN
        LABEL='TAUR-'      
      ELSEIF(ID.EQ.-IDTAUR) THEN
        LABEL='TAUR+'      
      ELSE
        LABEL='ERR'
      ENDIF
999   RETURN
      END
+EOD
+DECK,LBOOST.
      SUBROUTINE LBOOST(PREST,N,P1,P2)
C
C            BOOST 4-VECTORS P1 TO PREST REST FRAME
C            PUT RESULTING 4-VECTORS IN P2
C
+CDE,ITAPES
      DIMENSION PREST(4),P1(4,N),P2(4,N)
      DO 1 I=1,N
      WCN=SQRT(PREST(4)**2-PREST(1)**2-PREST(2)**2-PREST(3)**2)
      II=(I-1)*4
      P2(4,I)=(P1(4,I)*PREST(4)-P1(1,I)*PREST(1)-P1(2,I)*PREST(2)
     1         -P1(3,I)*PREST(3))/WCN
      FACT=(P2(4,I)+P1(4,I))/(WCN+PREST(4))
      DO 2 K=1,3
    2 P2(K,I)=P1(K,I)-FACT*PREST(K)
    1 CONTINUE
      RETURN
      END
+EOD
+DECK,LOGERR.
      SUBROUTINE LOGERR(IMSG,I,IERR)
C
C          ERROR MESSAGES
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2

C
C        ERRORS IN JET PARAMETERS
C
      IERR=IERR+1
      IF(IMSG.EQ.0) WRITE(ITLIS,81)
81    FORMAT(//5X,'DEFAULT LIMITS HAVE BEEN SET')
      IF(IMSG.EQ.1) WRITE(ITLIS,1001) I,PMIN(I),PMAX(I)
 1001 FORMAT(//10X,'BAD LIMITS FOR P(',I2,')=',2E12.4)
      IF(IMSG.EQ.2) WRITE(ITLIS,1002) I,PTMIN(I),PTMAX(I)
 1002 FORMAT(//10X,'BAD LIMITS FOR PT(',I2,')=',2E12.4)
      IF(IMSG.EQ.3) WRITE(ITLIS,1003) I,THMIN(I),THMAX(I)
 1003 FORMAT(//10X,'BAD LIMITS FOR THETA(',I2,')=',2E12.4)
      IF(IMSG.EQ.4) WRITE(ITLIS,1004) I,XJMIN(I),XJMAX(I)
 1004 FORMAT(//10X,'BAD LIMITS FOR X(',I2,')=',2E12.4)
      IF(IMSG.EQ.5) WRITE(ITLIS,1005) I,XJ(I),P(I)
 1005 FORMAT(//5X,'X AND P FOR JET',I2,' ARE INCOMPATIBLE',2E12.4)
      IF(IMSG.EQ.6) WRITE(ITLIS,1006) I,THMIN(I),THMAX(I)
 1006 FORMAT(//10X,'LIMITS FOR THETA MUST BE .GT.0 AND .LT.PI. PRESENT'
     C  ,' LIMITS FOR JET NO.',I3,' ARE',2E12.4)
      IF(IMSG.EQ.7) WRITE(ITLIS,1007) I,XJ(I),X1,X2
 1007 FORMAT(//5X,'FIXED X VALUE FOR JET NO.',I3,' IS',E12.4,2X,
     C  'THIS IS INCOMPATIBLE WITH ALLOWED X LIMITS',2E12.4)
C
C           ERRORS IN W(Z0) PARAMETERS
C
      IF(IMSG.EQ.101) WRITE(ITLIS,901) XW,XWMIN,XWMAX
  901 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED XW',E12.4,
     C  ' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS',2E12.4)
      IF(IMSG.EQ.102) WRITE(ITLIS,902) YW,YWMIN,YWMAX
  902 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED YW',
     C  E12.4,' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS ')
      IF(IMSG.EQ.103) WRITE(ITLIS,903) QMW,QMIN,QMAX
  903 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED QMW',
     C  E12.4,' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS',
     C  E12.4)
      IF(IMSG.EQ.104) WRITE(ITLIS,904) XW,YW,QTW
  904 FORMAT(//5X,'FIXED VALUES FOR XW,YW,AND QTW',3E12.4,
     C  ' ARE UNPHYSICAL')
      IF(IMSG.EQ.105) WRITE(ITLIS,905) QTW,QTMIN,QTMAX
  905 FORMAT(//5X,'CHOICE OF PARAMETERS GIVES A FIXED QTW',E12.4
     C  ,' ,THIS VALUE IS INCOMPATIBLE WITH THE LIMITS',2E12.4)
      IF(IMSG.EQ.106) WRITE(ITLIS,906) XW,YW,QMW
  906 FORMAT(//5X,'FIXED VALUS FOR XW,YW,AND QMW',3E12.4,
     C  ' ARE UNPHYSICAL')
      IF(IMSG.EQ.107) WRITE(ITLIS,907) QTMIN,QTMAX
  907 FORMAT(//5X,'BAD LIMITS FOR QTW',2E12.4)
      IF(IMSG.EQ.108) WRITE(ITLIS,908) QMIN,QMAX
  908 FORMAT(//5X,'BAD LIMITS FOR QMW',2E12.4)
      IF(IMSG.EQ.109) WRITE(ITLIS,909) THWMIN,THWMAX
  909 FORMAT(//5X,'BAD LIMITS FOR THW',2E12.4,2X,' REMEMBER TH MUST',
     C  ' BE IN RADIANS AND LIE BETWEEN 0 AND PI')
      IF(IMSG.EQ.110) WRITE(ITLIS,910) PHWMIN,PHWMAX
  910 FORMAT(//5X,'BAD LIMITS FOR PHW',2E12.4,' ,REMEMBER PHW MUST',
     C  ' BE IN RADIANS AND PHMAX-PHMIN MUST BE LESS THAN 2PI')
      IF(IMSG.EQ.111) WRITE(ITLIS,911) XWMIN,XWMAX
  911 FORMAT(//5X,'BAD LIMITS FOR XW',2E12.4)
      IF(IMSG.EQ.112) WRITE(ITLIS,912) YWMIN,YWMAX
  912 FORMAT(//5X,'BAD LIMITS FOR YW',2E12.4)
      IF(IMSG.EQ.113) WRITE(ITLIS,913)
  913 FORMAT(//5X,'SORRY, BUT YOU CANNOT FIX THETA FOR DRELLYAN EVENTS.'
     C,'  THINK OF SOMETHING ELSE.')
      IF(IMSG.EQ.114) WRITE(ITLIS,914)
  914 FORMAT(//5X,'YOU CANNOT FIX PARAMETERS FOR THE DECAY OF A',
     C  ' DRELL YAN JET')
      IF(IMSG.EQ.115) WRITE(ITLIS,915)
  915 FORMAT(//5X,'YOU CANNOT FIX QTW,QMW,YW AND XW SIMULTANEUOSLY')
C
C       ERRORS IN E+E- PARAMETERS
C
      IF(IMSG.EQ.116)
     1WRITE(ITLIS,631) THMIN(1),THMAX(1),THMIN(2),THMAX(2)
631   FORMAT(//10X,'THETA LIMITS',2E12.4,' FOR JET 1 AND',2E12.4
     C  ,' FOR JET 2 ARE INCOMPATIBLE')
C
      RETURN
      END
+EOD
+DECK,LOGIC.
      SUBROUTINE LOGIC
C
C                            10/ 3/80
C            STARTING FROM USER DATA FIND OUT WHICH PARAMETERS SHOULD
C            BE FIXED AND WHICH LIMITS SHOULD BE SET
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      LOGICAL COMB(8)
      DIMENSION DELPH(3)
C
C        LOGICAL FUNCTIONS
C
      LOGICAL LOGP,LOGPT,LOGYTH,LOGX,LOGPHI
      LOGICAL LOGQM,LOGQT,LOGYW,LOGTHW,LOGPHW,LOGXW
      LOGICAL LOGMIJ,LOGMGM,LOGMGY
      DATA UNDEF/-.9E9/
      DATA ZERO/.00001/,ONE/.99999/
C
C            INVERSE HYPERBOLIC COSINE FUNCTION
      ACOSH(X)=ALOG(X+SQRT(X**2-1.0))
C            INVERSE HYPERBOLIC SINE FUNCTION
      ASINH(X)=ALOG(X+SQRT(X**2+1.0))
C
C          INITIALIZE CONSTANTS
C
      HALFPI=PI/2.
      IFATAL=0
      IERR=0
      DO 1 I=1,36
      SETLMJ(I)=.TRUE.
      IF(BLIMS(I).GT.UNDEF) SETLMJ(I)=.FALSE.
    1 CONTINUE
      DO 2 I=1,12
      SETLMQ(I)=.TRUE.
      IF(BLIM1(I).GT.UNDEF) SETLMQ(I)=.FALSE.
    2 CONTINUE
C
C          SET STANDARD DRELL-YAN IF FIXED QTW=0.
      IF(KEYS(3)) THEN
        IF(QTMIN.EQ.0..AND.QTMAX.LT.UNDEF) THEN
          STDDY=.TRUE.
        ELSE
          STDDY=.FALSE.
        ENDIF
      ELSEIF(KEYS(7).OR.KEYS(9)) THEN
        STDDY=.TRUE.
      ELSEIF(KEYS(11)) THEN
        STDDY=.FALSE.
      ENDIF
C
      IF(STDDY) THEN
        NJET=2
        FIXPT(3)=.TRUE.
        PT(3)=0.
        PTMIN(3)=0.
        PTMAX(3)=0.
        FIXPHI(3)=.FALSE.
        PHIMIN(3)=0.
        PHIMAX(3)=2.*PI
        DELPH(3)=2.*PI
        FIXPHW=.TRUE.
        PHWMIN=0.
        PHWMAX=-1.E9
        PHIW=0.
        QTMIN=0.
        QTMAX=-1.E9
        QTW=0.
        FIXQT=.FALSE.
      ENDIF
C
C      CHECK THAT PARAMETER RANGES MAKE SENSE
C
C            DO LOGIC FOR P
      IF(.NOT.LOGP(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR PT
      IF(.NOT.LOGPT(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR THETA AND YJ(RAPIDITY)
      IF(.NOT.LOGYTH(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR XJ(FEYNMAN X)
C            XJ LIMITS DO NOT REDEFINE PT LIMITS
      IF(.NOT.LOGX(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR PHI
C            NOTE THAT PHI INTERVAL IS DEFINED BY PHIMAX-PHIMIN
      IF(.NOT.LOGPHI(IERR,DELPH)) IFATAL=IFATAL+1
C
C            DO LOGIC FOR MADGRAPH IF APPLICABLE
      IF(KEYS(12)) THEN
        IF(.NOT.LOGMGM(IERR)) IFATAL=IFATAL+1
        IF(.NOT.LOGMGY(IERR)) IFATAL=IFATAL+1
        IF(.NOT.LOGMIJ(IERR)) IFATAL=IFATAL+1
      ENDIF
C
C          SET DEFAULT PT LIMITS IF NONE WERE SET
      IF((KEYS(1).OR.KEYS(5).OR.KEYS(6).OR.KEYS(10)).AND.
     $(PTMAX(1).GT..99*HALFE).AND.(PTMAX(2).GT..99*HALFE)) THEN
        PTMIN(1)=0.1*HALFE
        PTMIN(2)=PTMIN(1)
        PTMAX(1)=0.4*HALFE
        PTMAX(2)=PTMAX(1)
        CALL LOGERR(0,1,IERR)
      ENDIF
C
C          CHECK Y LIMITS WITH FINAL PT LIMITS.
      IF(KEYS(1).OR.KEYS(5).OR.KEYS(6).OR.KEYS(10)) THEN
        YMXPT=ALOG(ECM/PTMIN(1))
        DO 11 I=1,2
        YJMAX(I)=AMIN1(YJMAX(I),YMXPT)
11      YJMIN(I)=AMAX1(YJMIN(I),-YMXPT)
      ENDIF
C
C            DO LOGIC FOR DRELL YAN VARIABLES
      IF(KEYS(3).OR.KEYS(7).OR.KEYS(9).OR.KEYS(11)) THEN
C            DO LOGIC FOR QM
        IF(.NOT.LOGQM(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR QT
        IF(.NOT.LOGQT(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR YW
        IF(.NOT.LOGYW(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR THETA
        IF(.NOT.LOGTHW(IERR)) IFATAL=IFATAL+1
C            DO LOGIC FOR PHW
C            NOTE THAT PHW INTERVAL DEFINED BY PHWMAX-PHWMIN
        IF(.NOT.LOGPHW(IERR,DELPH)) IFATAL=IFATAL+1
C            DO LOGIC FOR XW
        IF(.NOT.LOGXW(IERR)) IFATAL=IFATAL+1
C
      ENDIF
C
C            CHECK FOR INCONSISTENCIES
      DO 21 I=1,NJET
      SMIN=SIN(THMIN(I))
      SMAX=SIN(THMAX(I))
      IF(SMAX.LT.SMIN) SMIN=SMAX
      PT1=PMIN(I)*SMIN
      IF(PT1.GT.PTMIN(I)) PTMIN(I)=PT1
      SMAX=1.0
      IF(THMAX(I).LT.ONE*HALFPI) SMAX=SIN(ONE*THMAX(I))
      IF(THMIN(I).GT.ONE*HALFPI) SMAX=SIN(ONE*THMIN(I))
      PT1=PMAX(I)*SMAX
      IF(PT1.LT.ONE*PTMAX(I)) PTMAX(I)=PT1
      IF(PTMAX(I).LT.ONE*PTMIN(I)) CALL LOGERR(2,I,IFATAL)
      IF(PMAX(I).LT.ONE*PMIN(I)) CALL LOGERR(1,I,IFATAL)
      IF(THMAX(I).LT.ONE*THMIN(I)) CALL LOGERR(3,I,IFATAL)
      IF(XJMAX(I).LT.ONE*XJMIN(I)) CALL LOGERR(4,I,IFATAL)
      IF(ABS(XJMAX(I)).GT.1.0+ZERO.OR.ABS(XJMIN(I)).GT.1.0+ZERO)
     1    CALL LOGERR(4,I,IFATAL)
      IF(THMIN(I).LT.-ZERO.OR.THMAX(I).GT.PI+ZERO)
     $CALL LOGERR(6,I,IFATAL)
C
      IF(FIXXJ(I)) THEN
        X1=PMAX(I)*COS(THMIN(I))/HALFE
        X2=PMIN(I)*COS(THMAX(I))/HALFE
        X3=PMAX(I)*COS(THMIN(I))/HALFE
        IF(X3.LT.X2) X2=X3
        IF(X1.EQ.X2) XJ(I)=X1
        IF(XJ(I).LT.ONE*X2.OR.XJ(I).GT.X1/ONE) CALL LOGERR(7,I,IFATAL)
      ENDIF
C
   21 CONTINUE
C
C            CHECK THAT PARAMETERS FOR DRELL YAN ARE CONSISTENT
C
      IF(KEYS(3)) THEN
        COMB(1)=.FALSE.
        DO 31 I=1,2
        COMB(1)=COMB(1).OR.FIXP(I).OR.FIXPT(I).OR.FIXYJ(I).OR.FIXPHI(I)
     1  .OR.FIXXJ(I)
   31   CONTINUE
        IF(COMB(1)) CALL LOGERR(114,1,IFATAL)
        COMB(1)=FIXQT.AND.FIXQM
        COMB(2)=FIXQT.AND.FIXYW
        COMB(3)=FIXQM.AND.FIXYW
        COMB(4)=COMB(1).AND.FIXYW
        COMB(5)=COMB(1).AND.FIXXW
        COMB(6)=COMB(2).AND.FIXXW
        COMB(7)=COMB(3).AND.FIXXW
        IF(COMB(4).AND.FIXXW) CALL LOGERR(115,1,IFATAL)
        IF(COMB(4)) FIXXW=.TRUE.
C
        IF(COMB(4)) THEN
          FIXXW=.TRUE.
          XW=SQRT(QTW**2+QMW**2)*SINH(YW)/HALFE
          IF(XW.LT.XWMIN-ZERO.OR.XW.GT.XWMAX+ZERO)
     $     CALL LOGERR(101,1,IFATAL)
          XWMIN=XW
          XWMAX=XW
        ENDIF
C
        IF(COMB(5)) THEN
          FIXYW=.TRUE.
          YW=ASINH(HALFE*XW/SQRT(QTW**2+QMW**2))
      IF(YW.LT.YWMIN-ZERO.OR.YW.GT.YWMAX+ZERO)
     $CALL LOGERR(102,1,IFATAL)
          YWMIN=YW
          YWMAX=YW
        ENDIF
C
        IF(COMB(6)) THEN
        IF(XW.NE.0.) THEN
          QMW2=((XW*HALFE)/SINH(YW))**2-QTW**2
          IF(QMW2.GE.0) THEN
            QMW=SQRT(QMW2)
      IF(QMW.LT.ONE*QMIN.OR.QMW.GT.QMAX/ONE)
     $CALL LOGERR(103,1,IFATAL)
          ENDIF
          CALL LOGERR(104,1,IFATAL)
        ENDIF
        ENDIF
C
        IF(COMB(7).AND.(YW.NE.0)) THEN
          FIXQT=.TRUE.
          FIXPT(3)=.TRUE.
          QTW2=((XW*HALFE)/SINH(YW))**2-QMW**2
          IF(QTW2.GE.0) THEN
            QTW=SQRT(QTW2)
            PT(3)=QTW
      IF(QTW.LT.ONE*QTMIN.OR.QTW.GT.QTMAX/ONE)
     $CALL LOGERR(105,1,IFATAL)
          ENDIF
          CALL LOGERR(106,1,IFATAL)
        ENDIF
C
        IF(QTMIN.GT.QTMAX/ONE) CALL LOGERR(107,1,IFATAL)
        IF(QMIN.GT.QMAX/ONE) CALL LOGERR(108,1,IFATAL)
        IF(THWMIN.GT.THWMAX/ONE) CALL LOGERR(109,1,IFATAL)
        IF(PHWMIN.GT.PHWMAX/ONE) CALL LOGERR(110,1,IFATAL)
        IF(XWMIN.GT.XWMAX/ONE) CALL LOGERR(111,1,IFATAL)
        IF(YWMIN.GT.YWMAX+ZERO) CALL LOGERR(112,1,IFATAL)
        IF(ABS(XWMIN).GT.1.0+ZERO.OR.ABS(XWMAX).GT.1.0+ZERO)
     1  CALL LOGERR(111,1,IFATAL)
      IF(THWMIN.LT.-ZERO.OR.THWMAX.GT.PI+ZERO)
     $CALL LOGERR(109,1,IFATAL)
      ENDIF
C
C          SPECIAL LOGIC FOR E+E- EVENTS
C
      IF(KEYS(2)) THEN
        THLOW=AMAX1(THMIN(1),PI-THMAX(2))
        THHIGH=AMAX1(THMAX(1),PI-THMIN(2))
        IF(THHIGH-THLOW.LT.ZERO.AND..NOT.(FIXYJ(1).OR.FIXYJ(2))) THEN
          CALL LOGERR(116,1,IFATAL)
        ELSE
          DO 61 I=1,2
          FIXYJ(I)=FIXYJ(1).OR.FIXYJ(2)
          FIXXJ(I)=FIXXJ(1).OR.FIXXJ(2)
          FIXPT(I)=FIXPT(1).OR.FIXPT(2)
          THMIN(I)=THLOW
          THMAX(I)=THHIGH
          IF(FIXYJ(I)) THMAX(I)=THMIN(I)
          XJMIN(I)=COS(THMAX(I))
          XJMAX(I)=COS(THMIN(I))
          PTMIN(I)=HALFE*AMIN1(SIN(THMIN(I)),SIN(THMAX(I)))
          IF(ABS(XJMAX(I)).LT.1.) YJMAX(I)=
     1    .5*ALOG((1.+XJMAX(I))/(1.-XJMAX(I)))
          IF(ABS(XJMIN(I)).LT.1.) YJMIN(I)=
     1    .5*ALOG((1.+XJMIN(I))/(1.-XJMIN(I)))
   61     CONTINUE
        ENDIF
      ENDIF
C
C
      IF(IFATAL.NE.0) THEN
        WRITE(ITLIS,1020) IFATAL
 1020   FORMAT(////10X,I10,' FATAL ERRORS, JOB TERMINATED')
        STOP 99
      ENDIF
C
C
      RETURN
      END
+EOD
+DECK,LOGMGM.
      LOGICAL FUNCTION LOGMGM(IERR)
C
C       Set and check limits for multijet mass
C
C       Note we use the convention that not setting an upper limit
C       gives a fixed variable, even though that currently is not
C       implemented in N-jet phase space.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
+CDE,MGLIMS
C
      REAL UNDEF
      INTEGER IERR
      DATA UNDEF/-.9E9/
C
      LOGMGM=.TRUE.
C
      IF(EHMGMN.LT.UNDEF.OR.EHMGMX.LT.UNDEF) THEN
        LOGMGM=.FALSE.
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGMGY.
      LOGICAL FUNCTION LOGMGY(IERR)
C
C       Set and check limits for dijet masses.
C
C       Note we use the convention that not setting an upper limit
C       gives a fixed variable, even though that currently is not
C       implemented in N-jet phase space.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
+CDE,MGLIMS
C
      REAL UNDEF
      INTEGER IERR
      DATA UNDEF/-.9E9/
C
      LOGMGY=.TRUE.
C
C          Attempt to fix YHMG
C
      IF(YHMGMN.GT.UNDEF.AND.YHMGMX.LT.UNDEF) THEN
        LOGMGY=.FALSE.
        RETURN
      ENDIF
C
C          No limits
C
      IF(EHMGMN.LT.0.OR.EHMGMX.LT.0) THEN
        LOGMGY=.FALSE.
        RETURN
      ENDIF
      IF(YHMGMN.LT.UNDEF) THEN
        YHMGMX=LOG(ECM/EHMGMN)
        YHMGMN=-YHMGMX
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGMIJ.
      LOGICAL FUNCTION LOGMIJ(IERR)
C
C       Set and check limits for dijet masses.
C
C       Note we use the convention that not setting an upper limit
C       gives a fixed variable, even though that currently is not
C       implemented in N-jet phase space.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
+CDE,MGLIMS
C
      REAL AMLOW,UNDEF
      INTEGER I,J,IERR
      DATA AMLOW/1.0/
      DATA UNDEF/-.9E9/
C
      LOGMIJ=.TRUE.
C
      DO 100 I=1,MXLIM
        DO 101 J=I+1,MXLIM
          FIXMIJ(I,J)=.FALSE.
          FIXMIJ(J,I)=.FALSE.
          IF(AMIJMN(I,J).LT.UNDEF.AND.AMIJMX(I,J).LT.UNDEF) THEN
            AMIJMX(I,J)=ECM
            AMIJMX(J,I)=ECM
          ENDIF
          IF(AMIJMX(I,J).GT.ECM) THEN
            AMIJMX(I,J)=ECM
            AMIJMX(J,I)=ECM
          ENDIF
          IF(AMIJMX(I,J).LT.UNDEF) THEN
            AMIJMX(I,J)=AMIJMN(I,J)
            FIXMIJ(I,J)=.TRUE.
            AMIJMX(J,I)=AMIJMN(I,J)
            FIXMIJ(J,I)=.TRUE.
          ENDIF
          IF(AMIJMN(I,J).LT.UNDEF) THEN
            AMIJMN(I,J)=AMLOW
            AMIJMN(J,I)=AMLOW
          ENDIF
101     CONTINUE
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,LOGP.
      LOGICAL FUNCTION LOGP(IERR)
C
C       SET AND CHECK LIMITS FOR JET MOMENTA
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA PLOW/1.0/
      DATA UNDEF/-.9E9/
C
      LOGP=.TRUE.
      DO 10 I=1,NJET
      FIXP(I)=.FALSE.
      IF(PMIN(I).LT.UNDEF.AND.PMAX(I).LT.UNDEF)  PMAX(I)=HALFE
      IF(PMAX(I).GT.HALFE) PMAX(I)=HALFE
      IF(PMAX(I).LT.UNDEF) FIXP(I)=.TRUE.
      IF(PMIN(I).LT.UNDEF) PMIN(I)=PLOW
      IF(FIXP(I)) THEN
        PMAX(I)=PMIN(I)
        P(I)=PMIN(I)
      ENDIF
      IF(KEYS(3).AND.I.EQ.3.AND.QTMIN.GT.0) PMIN(I)=QTMIN
   10 CONTINUE
C
      RETURN
      END
+EOD
+DECK,LOGPHI.
      LOGICAL FUNCTION LOGPHI(IERR,DELPH)
C
C        SET AND CHECK LIMITS FOR JET PHI
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DIMENSION DELPH(3)
      DATA UNDEF/-.9E9/
C
      LOGPHI=.TRUE.
C
C
      DO 50 I=1,NJET
      FIXPHI(I)=.FALSE.
C
      IF(PHIMAX(I).LT.UNDEF.AND.PHIMIN(I).LT.UNDEF) THEN
        PHIMIN(I)=0.
        PHIMAX(I)=2.*PI
        DELPH(I)=PHIMAX(I)
      ELSE
        IF(PHIMAX(I).LT.UNDEF) FIXPHI(I)=.TRUE.
C
        IF(FIXPHI(I)) THEN
          PHI(I)=PHIMIN(I)
          PHIMAX(I)=PHIMIN(I)
          IF(KEYS(3).AND.I.LT.3) THEN
            LOGPHI=.FALSE.
            CALL LOGERR(105,I,IERR)
          ENDIF
          IF(I.EQ.2) THEN
            FIXPHI(1)=.TRUE.
            PHIMIN(1)=PHIMIN(2)
            PHIMAX(1)=PHIMIN(1)
          ENDIF
        ENDIF
C
        DELPH(I)=PHIMAX(I)-PHIMIN(I)
C
        IF(DELPH(I).GT.2.*PI.OR.DELPH(I).LT.0) THEN
          LOGPHI=.FALSE.
          CALL LOGERR(8,I,IERR)
        ENDIF
C
      ENDIF
C
   50 CONTINUE
C
C
      IF(KEYS(1).AND.DELPH(1).GT.DELPH(2)) THEN
        PHIMIN(1)=PHIMIN(2)+PI
        PHIMAX(1)=PHIMIN(1)+DELPH(2)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGPHW.
      LOGICAL FUNCTION LOGPHW(IERR,DELPH)
C
C       SET AND CHECK LIMITS FOR W(Z0) PHI
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DIMENSION DELPH(3)
      DATA UNDEF/-.9E9/
C
      LOGPHW=.TRUE.
      FIXPHW=.FALSE.
C
      IF(FIXPHI(3)) THEN
          FIXPHW=.TRUE.
          PHIW=AMOD(PHI(3)+PI,2.*PI)
      ELSEIF(PHWMIN.LT.UNDEF.AND.PHWMAX.LT.UNDEF) THEN
          PHWMIN=0.
          PHWMAX=2.*PI
      ELSEIF(PHWMAX.LT.UNDEF) THEN
          FIXPHW=.TRUE.
          PHW=PHWMIN
          FIXPHI(3)=.TRUE.
          PHWMAX=PHWMIN
          PHI(3)=PHIW+PI
          PHIMIN(3)=PHIW
          PHIMAX(3)=PHIW
      ENDIF
C
      DELPHW=PHWMAX-PHWMIN
C
      IF(DELPHW.LT.0.OR.DELPHW.GT.2.*PI) THEN
        CALL LOGERR(110,1,IERR)
        LOGPHW=.FALSE.
      ENDIF
C
      IF(DELPHW.LE.DELPH(3)) THEN
        PHIMIN(3)=PHWMIN+PI
        PHIMAX(3)=PHIMIN(3)+DELPHW
      ELSE
        PHWMIN=PHIMIN(3)+PI
        PHWMAX=PHWMIN+DELPH(3)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGPT.
      LOGICAL FUNCTION LOGPT(IERR)
C
C       SET AND CHECK LIMITS FOR JET PT
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA PTLOW/1.0/
      DATA UNDEF/-.9E9/
C
      LOGPT=.TRUE.
      DO 20 I=1,NJET
      FIXPT(I)=.FALSE.
C
      IF(PTMIN(I).LT.UNDEF.AND.PTMAX(I).LT.UNDEF) THEN
        PTMAX(I)=PMAX(I)
        PTMIN(I)=PTLOW
        IF(KEYS(3).AND.I.EQ.3.AND.QTMIN.GT.0.) PTMIN(I)=QTMIN
        IF(PMIN(I).LT.PTMIN(I)) PMIN(I)=PTMIN(I)
      ELSEIF(PTMAX(I).LT.UNDEF) THEN
        FIXPT(I)=.TRUE.
        PTMAX(I)=PTMIN(I)
      ELSEIF(PTMIN(I).LT.UNDEF) THEN
        PTMIN(I)=PTLOW
        IF(KEYS(3).AND.I.EQ.3.AND.QTMIN.GT.0.) PTMIN(I)=QTMIN
      ENDIF
C
      IF(FIXPT(I)) PTMAX(I)=PTMIN(I)
      IF(FIXPT(I)) PT(I)=PTMIN(I)
      IF(PTMAX(I).GT.PMAX(I)) PTMAX(I)=PMAX(I)
      IF(PMIN(I).LT.PTMIN(I)) PMIN(I)=PTMIN(I)
C
   20 CONTINUE
C
      RETURN
      END
+EOD
+DECK,LOGQM.
      LOGICAL FUNCTION LOGQM(IERR)
C
C     Set and check limits for gamma*/W/Z0/Higgs mass range
C     Ver 7.14: Use HMASS+-5*HGAM for MSSM default range
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
+CDE,HCON
+CDE,XMSSM
C
      REAL UNDEF
      INTEGER IERR
      DATA UNDEF/-.9E9/
C
      LOGQM=.TRUE.
      FIXQM=.FALSE.
      IF(QMIN.LT.UNDEF.AND.QMAX.LT.UNDEF) THEN
        IF(KEYS(7).AND.GOMSSM) THEN
C          For MSSM Higgs, set default limits around Higgs
          QMAX=HMASS+5*HGAM
          QMIN=HMASS-5*HGAM
        ELSE
C          Set default QMW limits if none were set.
          QMAX=0.2*ECM
          QMIN=0.05*ECM
        ENDIF
        CALL LOGERR(0,1,IERR)
      ENDIF
      IF(QMAX.LT.UNDEF) FIXQM=.TRUE.
      IF(FIXQM) THEN
        QMW=QMIN
        QMAX=QMIN
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGQT.
      LOGICAL FUNCTION LOGQT(IERR)
C
C      SET AND CHECK W(Z0) PT RANGE
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA UNDEF/-.9E9/
C
      LOGQT=.TRUE.
      FIXQT=.FALSE.
      IF(QTMIN.LT.UNDEF.AND.QTMAX.LT.UNDEF) THEN
        QTMAX=PTMAX(3)
        QTMIN=PTMIN(3)
C          SET DEFAULT QTW LIMITS IF NONE WERE SET
        IF(QTMAX.GT.0.99*HALFE) THEN
          NJET=2
          QTMIN=0.
          QTMAX=0.
          QTW=0.
          STDDY=.TRUE.
          FIXQT=.TRUE.
          PTMIN(3)=0.
          PTMAX(3)=0.
          FIXPT(3)=.TRUE.
          CALL LOGERR(0,1,IERR)
        ENDIF
      ELSEIF(FIXPT(3)) THEN
        QTW=PT(3)
        QTMIN=PTMIN(3)
        QTMAX=QTMIN
        FIXQT=.TRUE.
      ELSEIF(QTMAX.LT.UNDEF) THEN
        FIXQT=.TRUE.
        QTW=QTMIN
        QTMAX=QTMIN
        FIXPT(3)=.TRUE.
        PT(3)=QTW
        PTMIN(3)=QTMIN
        PTMAX(3)=QTMAX
      ELSE
        IF(QTMAX.LT.PTMAX(3)) PTMAX(3)=QTMAX
        IF(QTMIN.GT.PTMIN(3)) PTMIN(3)=QTMIN
        IF(QTMAX.GT.PTMAX(3)) QTMAX=PTMAX(3)
        IF(QTMIN.LT.PTMIN(3)) QTMIN=PTMIN(3)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGTHW.
      LOGICAL FUNCTION LOGTHW(IERR)
C
C        SET AND CHECK THETA LIMITS FOR W(Z0)
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA UNDEF/-.9E9/
C
C            INVERSE HYPERBOLIC COSINE FUNCTION
      ACOSH(X)=ALOG(X+SQRT(X**2-1.0))
C            INVERSE HYPERBOLIC SINE FUNCTION
      ASINH(X)=ALOG(X+SQRT(X**2+1.0))
C
      HALFPI=PI/2.
      LOGTHW=.TRUE.
C
      IF(THWMIN.LT.UNDEF.AND.THWMAX.LT.UNDEF) THEN
          THWMIN=2.*ATAN(EXP(-YWMAX))
          THWMAX=2.*ATAN(EXP(-YWMIN))
      ELSEIF(THWMIN.GT.UNDEF) THEN
        IF(THWMAX.GT.UNDEF) THEN
          LOGTHW=.FALSE.
          CALL LOGERR(113,1,IERR)
        ELSE
          TAMIN=TAN(THWMIN)
          TAMAX=TAN(THWMAX)
          IF(THWMIN.LT.HALFPI)
     1    YWMX=ASINH(QTMAX/SQRT(QTMAX**2+QMIN**2)/TAMIN)
          IF(THWMIN.GE.HALFPI)
     1    YWMX=ASINH(QTMIN/SQRT(QTMIN**2+QMAX**2)/TAMIN)
          IF(THWMAX.GT.HALFPI)
     1    YWMN=ASINH(QTMAX/SQRT(QTMAX**2+QMIN**2)/TAMAX)
          IF(THWMAX.LT.HALFPI)
     1    YWMN=ASINH(QTMIN/SQRT(QTMIN**2+QMAX**2)/TAMAX)
          IF(YWMIN.LT.YWMN) YWMIN=YWMN
          IF(YWMAX.GT.YWMX) YWMAX=YWMX
          IF(FIXYW.AND.(YW.LT.YWMIN.OR.YW.GT.YWMAX)) THEN
            CALL LOGERR(102,1,IERR)
            LOGTHW=.FALSE.
          ENDIF
        ENDIF
      ENDIF
C
      IF(YWMIN.LT.0) THWMAX=ATAN2(QTMIN,SQRT(QTMIN**2+QMAX**2)*
     1              SINH(YWMIN))
      IF(YWMIN.GE.0) THWMAX=ATAN2(QTMAX,SQRT(QTMAX**2+QMIN**2)*
     1               SINH(YWMIN))
      IF(YWMAX.GE.0) THWMIN=ATAN2(QTMIN,SQRT(QTMIN**2+QMAX**2)*
     U               SINH(YWMAX))
      IF(YWMAX.LT.0) THWMIN=ATAN2(QTMAX,SQRT(QTMAX**2+QMIN**2)*
     1               SINH(YWMAX))
C
      RETURN
      END
+EOD
+DECK,LOGX.
      LOGICAL FUNCTION LOGX(IERR)
C
C         SET AND CHECK LIMITS FOR JET FEYNMAN X
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA UNDEF/-.9E9/
C
      HALFPI=PI/2.
      LOGX=.TRUE.
C
      DO 40 I=1,NJET
      FIXXJ(I)=.FALSE.
      IF(FIXYJ(I).AND.(FIXP(I).OR.FIXPT(I)))FIXXJ(I)=.TRUE.
      IF(FIXXJ(I)) GOTO 40
C
      IF(XJMIN(I).LT.UNDEF.AND.XJMAX(I).LT.UNDEF) THEN
        XJMAX(I)=1.0
        XJMIN(I)=-1.0
      ENDIF
C
      IF(XJMAX(I).LT.UNDEF) FIXXJ(I)=.TRUE.
      IF(FIXXJ(I)) XJMAX(I)=XJMIN(I)
C
      IF(.NOT.FIXXJ(I)) THEN
        IF(THMIN(I).LT.HALFPI) X1=PMAX(I)*COS(THMIN(I))/HALFE
        IF(THMIN(I).GE.HALFPI) X1=PMIN(I)*COS(THMIN(I))/HALFE
        IF(THMAX(I).GT.HALFPI) X2=PMAX(I)*COS(THMAX(I))/HALFE
        IF(THMAX(I).LT.HALFPI) X2=PMIN(I)*COS(THMAX(I))/HALFE
        IF(X1.LT.XJMAX(I)) XJMAX(I)=X1
        IF(X2.GT.XJMIN(I)) XJMIN(I)=X2
      ELSE
C
        XJ(I)=XJMIN(I)
C
        IF(FIXP(I)) THEN
          CTH(I)=XJ(I)*HALFE/P(I)
          IF(ABS(CTH(I)).LE.1.0) THEN
            STH(I)=SQRT(1.-CTH(I)**2)
            TH(I)=ATAN2(STH(I),CTH(I))
            YJ(I)=-ALOG(TAN(TH(I)/2.))
            FIXYJ(I)=.TRUE.
            PT(I)=P(I)*STH(I)
            FIXPT(I)=.TRUE.
            YJMIN(I)=YJ(I)
            YJMAX(I)=YJ(I)
            PTMIN(I)=PT(I)
            PTMAX(I)=PT(I)
          ELSE
            LOGX=.FALSE.
            CALL LOGERR(5,I,IERR)
          ENDIF
        ENDIF
C
        IF(FIXPT(I)) THEN
          TH(I)=ATAN(PT(I)/XJ(I)/HALFE)
          FIXYJ(I)=.TRUE.
          YJ(I)=-ALOG(TAN(TH(I)/2.))
          CTH(I)=COS(TH(I))
          STH(I)=SIN(TH(I))
          P(I)=PT(I)/STH(I)
          FIXP(I)=.TRUE.
          YJMIN(I)=YJ(I)
          YJMAX(I)=YJ(I)
          PMAX(I)=P(I)
          PMIN(I)=P(I)
        ENDIF
C
        IF(FIXYJ(I)) THEN
          FIXPT(I)=.TRUE.
          P(I)=XJ(I)*HALFE/CTH(I)
          PT(I)=P(I)*STH(I)
          FIXP(I)=.TRUE.
          PTMIN(I)=PT(I)
          PTMAX(I)=PT(I)
          PMAX(I)=P(I)
          PMIN(I)=P(I)
        ENDIF
C
      ENDIF
C
   40 CONTINUE
C
      RETURN
      END
+EOD
+DECK,LOGXW.
      LOGICAL FUNCTION LOGXW(IERR)
C
C       SET AND CHECK X LIMITS FOR W(Z0)
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA UNDEF/-.9E9/
C
      LOGXW=.TRUE.
      FIXXW=.FALSE.
C
      IF(XWMIN.LT.UNDEF.AND.XWMAX.LT.UNDEF) THEN
        XWMIN=-1.0
        XWMAX=1.0
      ELSEIF(XWMAX.GT.UNDEF) THEN
        FIXXW=.TRUE.
        XW=XWMIN
        XWMAX=XW
C            IF XW=0 THEN YW=0
        IF(XW.NE.0) THEN
          FIXYW=.TRUE.
          YW=0
          YWMIN=0
          YWMAX=0
        ENDIF
      ENDIF
C
C            IF YW=0 THAN XW=0
      IF(YW.EQ.0) THEN
        FIXXW=.TRUE.
        XW=0
        XWMAX=0
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LOGYTH.
      LOGICAL FUNCTION LOGYTH(IERR)
C
C       SET AND CHECK LIMITS FOR JET Y AND THETA
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      DATA UNDEF/-.9E9/
C
C            INVERSE HYPERBOLIC COSINE FUNCTION
      ACOSH(X)=ALOG(X+SQRT(X**2-1.0))
C            INVERSE HYPERBOLIC SINE FUNCTION
      ASINH(X)=ALOG(X+SQRT(X**2+1.0))
C
      HALFPI=PI/2.
      LOGYTH=.TRUE.
C
      DO 30 I=1,NJET
      FIXYJ(I)=.FALSE.
C
      IF(FIXP(I).AND.FIXPT(I)) THEN
        STH(I)=PT(I)/P(I)
        CTHS(1,I)=SQRT(1.-STH(I)**2)
        CTHS(2,I)=-CTHS(1,I)
        THS(1,I)=ATAN2(STH(I),CTHS(1,I))
        THS(2,I)=ATAN2(STH(I),CTHS(2,I))
        YJS(1,I)=-ALOG(TAN(THS(1,I)/2.))
        YJS(2,I)=-ALOG(TAN(THS(2,I)/2.))
        XJS(1,I)=P(I)*CTHS(1,I)/HALFE
        XJS(2,I)=P(I)*CTHS(2,I)/HALFE
        YJMAX(I)=YJS(2,I)
        THMAX(I)=THS(1,I)
        THMIN(I)=THS(2,I)
        IF(YJMIN(I).EQ.YJMAX(I)) FIXYJ(I)=.TRUE.
      ENDIF
C
C
      IF(YJMIN(I).LT.UNDEF.AND.YJMAX(I).LT.UNDEF) THEN
C
        IF(THMIN(I).LT.UNDEF.AND.THMAX(I).LT.UNDEF) THEN
          YJMAX(I)=ACOSH(HALFE/PTMIN(I))
          YJMIN(I)=-YJMAX(I)
          THMIN(I)=2.*ATAN(EXP(-YJMAX(I)))
          THMAX(I)=2.*ATAN(EXP(-YJMIN(I)))
        ENDIF
C
        IF(THMAX(I).LT.UNDEF) FIXYJ(I)=.TRUE.
        IF(THMIN(I).LT.UNDEF) THMIN(I)=.001
        IF(FIXYJ(I)) THMAX(I)=THMIN(I)
        YJMIN(I)=-ALOG(TAN(THMAX(I)/2.))
        YJMAX(I)=-ALOG(TAN(THMIN(I)/2.))
        THMIN(I)=2.*ATAN(EXP(-YJMAX(I)))
        THMAX(I)=2.*ATAN(EXP(-YJMIN(I)))
      ENDIF
C
C
      IF(YJMAX(I).LT.UNDEF) FIXYJ(I)=.TRUE.
      IF(YJMIN(I).LT.UNDEF) YJMIN(I)=-YJMAX(I)
      IF(FIXYJ(I)) YJMAX(I)=YJMIN(I)
      THMIN(I)=2.*ATAN(EXP(-YJMAX(I)))
      THMAX(I)=2.*ATAN(EXP(-YJMIN(I)))
C
      IF(FIXYJ(I)) THEN
        YJ(I)=YJMIN(I)
        TH(I)=THMIN(I)
        STH(I)=SIN(TH(I))
        CTH(I)=COS(TH(I))
        IF(FIXPT(I)) P(I)=PT(I)/STH(I)
        IF(FIXP(I)) PT(I)=P(I)*STH(I)
C
        IF((FIXP(I).OR.FIXPT(I))) THEN
          XJ(I)=P(I)*CTH(I)/HALFE
          XJMIN(I)=XJ(I)
          XJMAX(I)=XJ(I)
        ENDIF
C
      ENDIF
C
C          CHECK PT LIMITS WITH P AND THETA LIMITS
      IF(.NOT.FIXPT(I)) THEN
        THETA1=AMIN1(THMIN(I),PI-THMAX(I))
        THETA2=HALFPI
        IF(THMAX(I).LT.HALFPI) THETA2=THMAX(I)
        IF(THMIN(I).GT.HALFPI) THETA2=THMIN(I)
        PT1=PMIN(I)*SIN(THETA1)
        PTMIN(I)=AMAX1(PTMIN(I),PT1)
        PT2=PMAX(I)*SIN(THETA2)
        PTMAX(I)=AMIN1(PTMAX(I),PT2)
      ENDIF
C
   30 CONTINUE
C
      RETURN
      END
+EOD
+DECK,LOGYW.
      LOGICAL FUNCTION LOGYW(IERR)
C
C       SET AND CHECK Y LIMITS FOR W(Z0)
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETPAR
+CDE,CONST
+CDE,DYLIM
+CDE,KEYS
+CDE,Q1Q2
      LOGICAL COMB(2)
      DATA UNDEF/-.9E9/
C
C            INVERSE HYPERBOLIC COSINE FUNCTION
      ACOSH(X)=ALOG(X+SQRT(X**2-1.0))
C            INVERSE HYPERBOLIC SINE FUNCTION
      ASINH(X)=ALOG(X+SQRT(X**2+1.0))
      YW=1.0
      LOGYW=.TRUE.
      FIXYW=.FALSE.
C
      IF(YWMIN.LT.UNDEF.AND.YWMAX.LT.UNDEF) THEN
        YWMAX=ACOSH(HALFE/SQRT(QTMIN**2+QMIN**2))
        YWMIN=-YWMAX
      ENDIF
C
      IF(YWMAX.LT.UNDEF) THEN
        FIXYW=.TRUE.
        YW=YWMIN
        YWMAX=YWMIN
      ENDIF
C
      YWMX=ACOSH(HALFE/SQRT(QTMIN**2+QMIN**2))
      YWMN=-YWMX
      COMB(1)=YWMX.LT.YWMAX
      COMB(2)=YWMN.GT.YWMIN
C
      IF(FIXYW.AND.(COMB(1).OR.COMB(2))) THEN
        LOGYW=.FALSE.
        CALL LOGERR(102,1,IERR)
      ENDIF
C
      IF(.NOT.FIXYW) THEN
        IF(COMB(1)) YWMAX=YWMX
        IF(COMB(2)) YWMIN=YWMN
      ENDIF
C
      RETURN
      END
+EOD
+DECK,LSTSQ.
      SUBROUTINE LSTSQ(X,Y,NPT,A,B)
C
C          DO LEAST SQUARE FIT TO A STRAIGHT LINE Y=A+B*X
C
+CDE,ITAPES
      DIMENSION X(NPT),Y(NPT)
      SUM1=0
      SUM2=0
      SUM3=0
      SUM4=0
      DO 1 I=1,NPT
      SUM1=SUM1+X(I)
      SUM2=SUM2+Y(I)
      SUM3=SUM3+X(I)**2
      SUM4=SUM4+X(I)*Y(I)
    1 CONTINUE
      B=(SUM2*SUM1-SUM4*NPT)/(SUM1**2-SUM3*NPT)
      A=(SUM2-B*SUM1)/NPT
      RETURN
      END
+EOD
+DECK,MBIAS.
      SUBROUTINE MBIAS
C
C          Generate minbias event or beam jets for high-pt event using
C          parameters set in MBSET:
C
C          (1) Select number NPOM of cut pomerons -- cf cut Reggeon
C              field theory of Abramovskii, Kanchelli, and Gribov.
C          (2) Generate xf for leading baryons including 1/(1-xf)
C              diffractive term and guessed NPOM dependence,
C              F(XF)=(1-XF)**(A+B/NPOM)
C          (3) Select xf for each half of each Pomeron. then fragment
C              each half Pomeron into mesons and baryons independently
C              in the Pomeron-Pomeron center of mass. This avoids
C              making xf=0 a singular point.
C
C          Note that multiple cut Pomerons give approximate KNO scaling.
C          The only short-range correlations are from resonances.
C
C          Ver. 7.09: Add traps on free loops and IMPLICIT NONE.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES.
+CDE,KEYS.
+CDE,MBGEN.
+CDE,PRIMAR.
+CDE,JETPAR.
+CDE,CONST.
+CDE,PARTCL.
+CDE,MBPAR.
C
      DIMENSION IFL(3),IFLEXC(2),PXEXC(2),PYEXC(2),SIGN(2)
      DIMENSION PSUM(5)
      DIMENSION LDIFFR(2)
      LOGICAL LDIFFR
      REAL RANF,AMASS
      REAL RND,XX,XSUM,P0,PPOM,PXEXC,PSUM,SIGN,PYEXC,GAM,BETA,X,
     $AM,PPLUS,EPSDIF,PEND0,TRY,PX,PY,PX2,PY2,QMINUS,PZ,QPLUS,PT1,
     $PHI1,XBGEN,PT2,PHI2,PX1,PY1,AMT2
      INTEGER ID1,ID2,IFL1,IFL2,IMOD1,IMOD2,ITWIST,IPOM,LOOP,NFIRST,
     $ID3,IFLEXC,IFL,I,NP2,IP,NP1,IFAIL,NPTLV1,IDHAD,IB,NEW,JSPIN,
     $INDEX,NBEGIN,IPASS,MXPASS,N,IDIFF,IPASSB,IFLNEW,ISWAP
      DATA SIGN/1.,-1./,PEND0/.14/
      DATA PSUM/5*0./
      DATA MXPASS/200/
C
C          Start
      NBEGIN=NPTCL+1
      IPASS=1
      IPASSB=1
C
C          Select number of cut Pomerons.
C
1     CONTINUE
      TRY=RANF()
      DO 10 N=MNPOM,MXPOM
        NPOM=N
        IF(POMGEN(N).GT.TRY) GO TO 20
10    CONTINUE
20    CONTINUE
C
C          Decide if diffractive event
      IF(RANF().LT.PDIFFR) THEN
        IDIFF=INT(1.99999*RANF())+1
        LDIFFR(IDIFF)=.TRUE.
        LDIFFR(3-IDIFF)=.FALSE.
      ELSE
        LDIFFR(1)=.FALSE.
        LDIFFR(2)=.FALSE.
      ENDIF
C
C          Generate leading baryons.
C
      DO 100 IB=1,2
        PPLUS=2.*PBEAM(IB)
C
C          Special treatment for diffractive beam.
        IF(LDIFFR(IB)) THEN
          IDHAD=IDIN(IB)
          AM=AMASS(IDHAD)
          CALL FLAVOR(IDIN(IB),IFL(1),IFL(2),IFL(3),JSPIN,INDEX)
          NEW=INT(3.*RANF())+1
          IFLEXC(1)=+IFL(NEW)
          IFLEXC(2)=-IFL(NEW)
          EPSDIF=2./SCM
          DXBARY(IB)=EPSDIF**RANF()
          XBARY(IB)=1.-DXBARY(IB)
          GO TO 115
        ENDIF
C
C          If not diffractive, construct IDENT of leading baryon
        CALL FLAVOR(IDIN(IB),IFL(1),IFL(2),IFL(3),JSPIN,INDEX)
        NEW=INT(3.*RANF())+1
        IFLNEW=ISIGN(INT(RANF()/PUD0)+1,IDIN(IB))
        IFLEXC(1)=IFL(NEW)
        IFLEXC(2)=-IFLNEW
        IFL(NEW)=IFLNEW
        IF(IABS(IFL(1)).GT.IABS(IFL(2))) THEN
          ISWAP=IFL(1)
          IFL(1)=IFL(2)
          IFL(2)=ISWAP
        ENDIF
        IF(IABS(IFL(2)).GT.IABS(IFL(3))) THEN
          ISWAP=IFL(2)
          IFL(2)=IFL(3)
          IFL(3)=ISWAP
        ENDIF
        IF(IABS(IFL(1)).GT.IABS(IFL(2))) THEN
          ISWAP=IFL(1)
          IFL(1)=IFL(2)
          IFL(2)=ISWAP
        ENDIF
        JSPIN=1
        IF(IFL(1).EQ.IFL(2).AND.IFL(2).EQ.IFL(3)) THEN
          JSPIN=1
        ELSE
          JSPIN=INT(RANF()+PJSPN)
        ENDIF
        IF(JSPIN.EQ.0.AND.IFL(1).NE.IFL(2).AND.IFL(2).NE.IFL(3)) THEN
          IF(RANF().GT.PISPN) THEN
            ISWAP=IFL(1)
            IFL(1)=IFL(2)
            IFL(2)=ISWAP
          ENDIF
        ENDIF
        IDHAD=1000*IABS(IFL(1))+100*IABS(IFL(2))+10*IABS(IFL(3))+JSPIN
        IDHAD=ISIGN(IDHAD,IDIN(IB))
        AM=AMASS(IDHAD)
C
C          Select xf for nondiffractive baryon, flat for NPOM=1 and
C          like mesons for NPOM=infinity.
110     XBGEN=XGEN0(2)*(1.-1./NPOM)
        DXBARY(IB)=RANF()**(1./(XBGEN+1.))
        XBARY(IB)=1.-DXBARY(IB)
C
C          Select transverse momentum of baryon
115     CALL GETPT(PT1,SIGQT0)
        PHI1=2.*PI*RANF()
        PX1=PT1*COS(PHI1)
        PY1=PT1*SIN(PHI1)
        PXEXC(1)=PX1
        PYEXC(1)=PY1
        CALL GETPT(PT2,SIGQT0)
        PHI2=2.*PI*RANF()
        PX2=PT2*COS(PHI2)
        PY2=PT2*SIN(PHI2)
        PXEXC(2)=PX2
        PYEXC(2)=PY2
        PX=-PX1-PX2
        PY=-PY1-PY2
        AMT2=PX**2+PY**2+AM**2
C
        QPLUS=XBARY(IB)*PPLUS
        QPLUS=AMAX1(QPLUS,1.E-6)
        QMINUS=AMT2/QPLUS
        PZ=.5*(QPLUS-QMINUS)
        P0=.5*(QPLUS+QMINUS)
C
C          Add baryon to /PARTCL/ if PZ>0.
        IF(NPTCL.GE.MXPTCL) GO TO 9999
        IF(PZ.GE.0.) THEN
          NPTCL=NPTCL+1
          PPTCL(1,NPTCL)=PX
          PPTCL(2,NPTCL)=PY
          PPTCL(3,NPTCL)=PZ*SIGN(IB)
          PPTCL(4,NPTCL)=P0
          PPTCL(5,NPTCL)=AM
          IORIG(NPTCL)=0
          IDCAY(NPTCL)=0
          IDENT(NPTCL)=IDHAD
        ELSE
          IPASSB=IPASSB+1
          IF(IPASSB.LT.MXPASS) GO TO 110
C          Just give up if it fails MXPASS times
          WRITE(ITLIS,998)
998       FORMAT(//5X,'ERROR IN MBIAS ... COULD NOT MAKE BARYON')
          XBARY(IB)=0.
          DXBARY(IB)=1.
        ENDIF
C
C          Having accepted baryon, set up XPOM array for cut Pomerons,
C          rescaling to 1.-XBARY(IB).
        XSUM=0.
        DO 120 N=1,NPOM
          XX=RANF()
          XPOM(N,IB)=XX
          XSUM=XSUM+XX
120     CONTINUE
        XSUM=1./XSUM
        DO 130 N=1,NPOM
          XPOM(N,IB)=XSUM*XPOM(N,IB)*DXBARY(IB)
130     CONTINUE
100   CONTINUE
C
C          Fragment each Pomeron into mesons and baryon pairs in the
C          Pomeron-Pomeron center of mass.
C
      DO 1000 IB=1,2
        DO 2000 IPOM=1,NPOM
          PPOM=SQRT(PBEAM(1)*XPOM(IPOM,1)*PBEAM(2)*XPOM(IPOM,2))
          PPLUS=2.*PPOM
          NFIRST=NPTCL+1
          LOOP=0
C
200       CONTINUE
          ITWIST=INT(1.99999*RANF())+1
          LOOP=LOOP+1
C
C          Select new quark or diquark. Old diquark implies new quark.
C          Old quark implies new diquark with probability PBARY0.
          IFL1=IFLEXC(ITWIST)
          IF(MOD(IFL1,100).EQ.0) THEN
            IFL2=ISIGN(INT(RANF()/PUD0)+1,+IFL1)
          ELSEIF(RANF().GT.PBARY0) THEN
            IFL2=ISIGN(INT(RANF()/PUD0)+1,-IFL1)
          ELSE
            ID1=INT(RANF()/PUD0)+1
            ID2=INT(RANF()/PUD0)+1
            IF(IABS(ID1).GT.IABS(ID2)) THEN
              ISWAP=ID1
              ID1=ID2
              ID2=ISWAP
            ENDIF
            IFL2=ISIGN(1000*ID1+100*ID2,IFL1)
          ENDIF
          IFLEXC(ITWIST)=-IFL2
C          Construct meson from quark+antiquark. Else, construct baryon
C          IDENT from quark+diquark.
          IMOD1=MOD(IFL1,100)
          IMOD2=MOD(IFL2,100)
          IF(IMOD1.NE.0.AND.IMOD2.NE.0) THEN
            JSPIN=INT(RANF()+PJSPN)
            ID1=IFL1
            ID2=IFL2
            IF(ID1+ID2.EQ.0) THEN
              RND=RANF()
              ID1=IABS(ID1)
              ID1=INT(PMIX01(ID1,JSPIN+1)+RND)
     $        +INT(PMIX02(ID1,JSPIN+1)+RND)+1
              ID2=-ID1
            ELSEIF(IABS(ID1).GT.IABS(ID2)) THEN
              ISWAP=ID1
              ID1=ID2
              ID2=ISWAP
            ENDIF
            IDHAD=ISIGN(100*IABS(ID1)+10*IABS(ID2)+JSPIN,ID1)
          ELSE
            IF(IMOD1.EQ.0) THEN
              ID3=MOD(IFL1/100,10)
              ID2=IFL1/1000
              ID1=IFL2
            ELSE
              ID3=MOD(IFL2/100,10)
              ID2=IFL2/1000
              ID1=IFL1
            ENDIF
            IF(IABS(ID1).GT.IABS(ID2)) THEN
              ISWAP=ID1
              ID1=ID2
              ID2=ISWAP
            ENDIF
            IF(IABS(ID2).GT.IABS(ID3)) THEN
              ISWAP=ID2
              ID2=ID3
              ID3=ISWAP
            ENDIF
            IF(IABS(ID1).GT.IABS(ID2)) THEN
              ISWAP=ID1
              ID1=ID2
              ID2=ISWAP
            ENDIF
            IF(ID1.EQ.ID2.AND.ID2.EQ.ID3) THEN
              JSPIN=1
            ELSE
              JSPIN=INT(RANF()+PJSPN)
            ENDIF
            IF(JSPIN.EQ.0.AND.ID1.NE.ID2.AND.ID2.NE.ID3) THEN
              IF(RANF().LT.PISPN) THEN
                ISWAP=ID1
                ID1=ID2
                ID2=ISWAP
              ENDIF
            ENDIF
            IDHAD=1000*IABS(ID1)+100*IABS(ID2)+10*IABS(ID3)+JSPIN
            IDHAD=ISIGN(IDHAD,IFL1)
          ENDIF
C
          AM=AMASS(IDHAD)
          PX1=PXEXC(ITWIST)
          PY1=PYEXC(ITWIST)
          CALL GETPT(PT2,SIGQT0)
          PHI2=2.*PI*RANF()
          PX2=PT2*COS(PHI2)
          PY2=PT2*SIN(PHI2)
          PXEXC(ITWIST)=PX2
          PYEXC(ITWIST)=PY2
          PX=PX1-PX2
          PY=PY1-PY2
          AMT2=PX**2+PY**2+AM**2
C
C          Select x -- same distribution for all particles.
          X=RANF()
          IF(RANF().LT.XGEN0(1)) X=1.-X**(1./(XGEN0(2)+1.))
          QPLUS=X*PPLUS
          QPLUS=AMAX1(QPLUS,1.E-6)
          QMINUS=AMT2/QPLUS
          P0=.5*(QPLUS+QMINUS)
          PZ=.5*(QPLUS-QMINUS)
C
C          Add particle to /PARTCL/ if PZ>0.
          IF(NPTCL.GE.MXPTCL) GO TO 9999
          IF(PZ.GE.0.) THEN
            NPTCL=NPTCL+1
            PPTCL(1,NPTCL)=PX
            PPTCL(2,NPTCL)=PY
            PPTCL(3,NPTCL)=PZ*SIGN(IB)
            PPTCL(4,NPTCL)=P0
            PPTCL(5,NPTCL)=AM
            IORIG(NPTCL)=0
            IDCAY(NPTCL)=0
            IDENT(NPTCL)=IDHAD
          ENDIF
C
C          Continue if sufficient pplus
          PPLUS=(1.-X)*PPLUS
          IF(PPLUS.GT.PEND0.AND.LOOP.LT.MXPTCL) GO TO 200
C
C          Boost hadrons to lab frame.
          IF(NPTCL.LT.NFIRST) GO TO 2000
          BETA=(XPOM(IPOM,1)*PBEAM(1)-XPOM(IPOM,2)*PBEAM(2))/(2.*PPOM)
          GAM=(XPOM(IPOM,1)*PBEAM(1)+XPOM(IPOM,2)*PBEAM(2))/(2.*PPOM)
          DO 400 IP=NFIRST,NPTCL
            P0=GAM*PPTCL(4,IP)+BETA*PPTCL(3,IP)
            PZ=BETA*PPTCL(4,IP)+GAM*PPTCL(3,IP)
            PPTCL(3,IP)=PZ
            PPTCL(4,IP)=P0
400       CONTINUE
C
2000    CONTINUE
1000  CONTINUE
C
C          Rescale hadron momenta for correct four-momentum.
C
      NPTLV1=NPTCL
      IF(KEYS(4)) THEN
        PSUM(4)=ECM
        PSUM(5)=ECM
        CALL RESCAL(NBEGIN,NPTLV1,PSUM,IFAIL)
      ELSE
        CALL RESCAL(NBEGIN,NPTLV1,PBEAMS,IFAIL)
      ENDIF
      IF(IFAIL.NE.0.AND.IPASS.LT.MXPASS) THEN
        IPASS=IPASS+1
        NPTCL=NBEGIN-1
        GO TO 1
      ENDIF
C
C          Decay hadrons
C
      NP1=NBEGIN
500   NP2=NPTCL
      DO 510 I=NP1,NP2
      CALL DECAY(I)
510   CONTINUE
      NP1=NP2+1
      IF(NP1.LE.NPTCL) GO TO 500
      RETURN
C
9999  CALL PRTEVT(0)
      WRITE(ITLIS,999) NPTCL
999   FORMAT(//5X,'ERROR IN MBIAS...NPTCL >',I5)
      RETURN
      END
+EOD
+DECK,MBSET.
      SUBROUTINE MBSET
C
C          SET PARAMETERS FOR GENERATING MINBIAS EVENTS OR BEAM JETS,
C          ALLOWING DIFFERENT PARAMETERS FOR TWO CASES.
C
+CDE,ITAPES
+CDE,MBPAR
+CDE,MBGEN
+CDE,PRIMAR
+CDE,TOTALS
+CDE,KEYS
C
C
C          DN/DY INCREASES WITH LOG(S). INCLUDED IN SPLITTING FUNCTION
C          BECAUSE AVERAGE MULTIPLICITY COMES FROM SINGLE CHAIN GRAPH.
      XGEN0(1)=.9
      XGEN0(2)=1.+0.35*ALOG(ECM/60.)
C
C          POMWT ARE (RELATIVE) PROBABILITIES FOR N CUT POMERONS.
C          PDIFFR IS DIFFRACTIVE PROBABILITY.
C          SIGQT0 IS MEAN PT.
      IF(KEYS(4)) THEN
        PDIFFR=.15
        SIGQT0=.35
        PSUM=0.
        DO 100 I=1,LIMPOM
        POMWT(I)=(1.+4.*I**2)*EXP(-1.8*I)
        PSUM=PSUM+POMWT(I)
100     CONTINUE
      ELSE
        PDIFFR=0.
        SIGQT0=.45
        PSUM=0.
        DO 110 I=1,LIMPOM
        POMWT(I)=(1.+4.*I**2)*EXP(-1.8*I)
        PSUM=PSUM+POMWT(I)
110     CONTINUE
        POMWT(1)=.1*POMWT(1)
        POMWT(2)=.2*POMWT(2)
        POMWT(3)=.5*POMWT(3)
      ENDIF
C
C          RENORMALIZE POMWT.
      PSUM=1./PSUM
      DO 200 I=1,LIMPOM
      POMWT(I)=PSUM*POMWT(I)
200   CONTINUE
      PSUM=0.
      DO 210 I=MNPOM,MXPOM
      PSUM=PSUM+POMWT(I)
210   CONTINUE
C
C          POMGEN IS USED TO SELECT NUMBER OF POMERONS.
      PGEN=0.
      PSUM=1./PSUM
      DO 300 I=1,LIMPOM
      POMGEN(I)=0.
300   CONTINUE
      DO 310 I=MNPOM,MXPOM
      PGEN=PGEN+PSUM*POMWT(I)
      POMGEN(I)=PGEN
310   CONTINUE
      POMGEN(MXPOM)=1.
C
C          SET /TOTALS/ FOR MINBIAS EVENTS USING LOG**2(S) FIT TO
C          TOTAL CROSS SECTION.
      IF(KEYS(4)) THEN
        SIGTOT=25.65*(1.+.0102*ALOG(SCM/1.76)**2)
        SIGTOT=PSUM*SIGTOT
        NKINPT=NEVENT
        SUMWT=SIGTOT*NKINPT
      ENDIF
C
      RETURN
      END
+EOD
+DECK,MGINIT
      SUBROUTINE MGINIT
C
C          Initialize common blocks for MadGraph code in ISAJET
C          Note the QCD coupling constant is g=1.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ITAPES
+CDE,SSTYPE
+CDE,MGCOMS
C
      INTEGER I
      REAL AMGMW
      REAL*8 SW2
C
C          Fermion masses and widths
C
      FMASS(1) = AMGMW(IDE,1)
      FMASS(2) = 0D0
      FMASS(3) = AMGMW(IDUP,1)
      FMASS(4) = AMGMW(IDDN,1)
      FMASS(5) = AMGMW(IDMU,1)
      FMASS(6) = 0D0
      FMASS(7) = AMGMW(IDCH,1)
      FMASS(8) = AMGMW(IDST,1)
      FMASS(9) = AMGMW(IDTAU,1)
      FMASS(10)= 0D0
      FMASS(11)= AMGMW(IDTP,1)
      FMASS(12)= AMGMW(IDBT,1)
      DO 100 I=1,12
        FWIDTH(I)=0D0
100   CONTINUE
C
C          Boson masses and widths
C
      AMASS=0D0
      AWIDTH=0D0
      WMASS=AMGMW(IDW,1)
      WWIDTH=AMGMW(IDW,2)
      ZMASS=AMGMW(IDZ,1)
      ZWIDTH=AMGMW(IDZ,2)
      HMASS=AMGMW(IDH,1)
      HWIDTH=AMGMW(IDH,2)
      SW2=AMGMW(1,3)
C
C          Calls to Helas routines to set couplings
C
      CALL COUP1X(SW2,GW,GWWA,GWWZ)
      CALL COUP2X(SW2,GAL,GAU,GAD,GWF,GZN,GZL,GZU,GZD,G1)
      CALL COUP3X(SW2,ZMASS,HMASS,GWWH,GZZH,GHHH,GWWHH,GZZHH,GHHHH)
      DO 110 I=1,12
         CALL COUP4X(SW2,ZMASS,FMASS(I),GCHF(1,I))
110   CONTINUE
C
C          QCD couplings
C
      G = 1D0
      GG(1)=-G
      GG(2)=-G
      RETURN
      END
+EOD
+DECK,MULJET
      SUBROUTINE MULJET(WT)
C
C          Using masses from /MGKIN/, generate NJET<=MXJETS body phase 
C          space point satisfying cuts:
C          (1) Generate kinematic point using successive 2-body decays
C              with Jacobean
C              dPhi_N(p1...pN) = dQ1 p1/(4*pi) dPhi_(N-1)(q1...pN)
C          (2) Apply individual jet cuts from /JETLIM/ and dijet
C              cuts from /MGLIMS/ to ensure IR-safe cross section.
C          (3) Return weight WT or 0 if outside limits. 
C
C          Note that WT contains various constant factors that were 
C          dropped in DECAY:
C            1/(2*SHMG) Jacobean
C            Jacobean for dQ = (EHMG-SUM)*dRANF
C            Factors of 4pi
C
C          MadGraph/Helas notation: 
C          PJETS8(0:3,1:2) = initial momenta
C          PJETS8(0:3,3:NJET+2) = final momenta
C          Note: ANSI extensions, e.g. REAL*8 P(0:3) are required for 
C          compatibility with Helas and MadGraph. :-(
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,MGLIMS
+CDE,PJETS
+CDE,MGKIN
+CDE,PRIMAR
C
C          Local variables; MXJETS defined in /PJETS/
C
      REAL*8 PGEN(0:3,MXJETS),AMGEN(MXJETS),RND(MXJETS)
      REAL*8 SHMG,EHMG,YHMG,SUM,SUM1,RNEW,WT,QCM,PI,
     $U(3),PHI,BETA(3),GAMMA,BP,PTI,PPI,YI,XJI,PHII,AMIJ
      REAL*8 CYHMG,SYHMG,E1,E2,P12,DELTAQ
      REAL*8 PCM,A,B,C
      INTEGER NJET1,I,JJ1,NTRY,J,JSAVE,II,K
      REAL RANF
C
C          Function definition
C
      PCM(A,B,C)=SQRT((A-B-C)*(A+B+C)*(A-B+C)*(A+B-C))/(2.*A)
C
C
C          Generate COM mass and rapidity
C
      PI=4.D0*DATAN(1.D0)
100   CONTINUE
      SHMG=EHMGMN**2+(EHMGMX**2-EHMGMN**2)*RANF()
      EHMG=SQRT(SHMG)
      YHMG=YHMGMN+(YHMGMX-YHMGMN)*RANF()
      IF(EHMG*EXP(ABS(YHMG)).GT.ECM) GO TO 999
      IF(EHMG.LT.AMJET8(1)+AMJET8(2)) GO TO 999
      CYHMG=DCOSH(YHMG)
      SYHMG=SINH(YHMG)
      AMGEN(1)=EHMG
      PGEN(1,1)=0
      PGEN(2,1)=0
      PGEN(3,1)=EHMG*SYHMG
      PGEN(0,1)=EHMG*CYHMG
      E1=(EHMG**2+AMJET8(1)**2-AMJET8(2)**2)/(2*EHMG)
      E2=(EHMG**2-AMJET8(1)**2+AMJET8(2)**2)/(2*EHMG)
      P12=PCM(EHMG,AMJET8(1),AMJET8(2))
C          Initial momenta
      PJETS8(1,1)=0
      PJETS8(2,1)=0
      PJETS8(3,1)=SYHMG*E1+CYHMG*P12
      PJETS8(0,1)=CYHMG*E1+SYHMG*P12
      PJETS8(1,2)=0
      PJETS8(2,2)=0
      PJETS8(3,2)=SYHMG*E1-CYHMG*P12
      PJETS8(0,2)=CYHMG*E1-SYHMG*P12
C
      NJET1=NJET-1
      SUM=0
      DO 110 I=1,NJET
        SUM=SUM+AMJET8(I+2)
110   CONTINUE
      IF(SUM.GE.EHMG) GO TO 999
      DELTAQ=EHMG-SUM
C
C          Generate masses for uniform NJET-body phase space.
C
      NTRY=0
200   CONTINUE
      NTRY=NTRY+1
      IF(NTRY.GT.NTRIES) THEN
        WRITE(ITLIS,9999) NTRY
9999    FORMAT(//2X,'ERROR IN MULJET ... NTRY = ',I8)
        STOP99
      ENDIF
      RND(1)=1
      DO 210 I=2,NJET1
        RNEW=RANF()
        DO 220 JJ1=1,I-1
          J=I-JJ1
          JSAVE=J+1
          IF(RNEW.LE.RND(J)) GO TO 210
          RND(JSAVE)=RND(J)
220     CONTINUE
210   RND(JSAVE)=RNEW
      RND(NJET)=0
C          Jacobean for d(shmg)d(yhmg) and overall 1/(2*shmg)
      WT=(EHMGMX**2-EHMGMN**2)*(YHMGMX-YHMGMN)/(2*SHMG)
      SUM1=SUM
      DO 230 I=2,NJET
        SUM1=SUM1-AMJET8(I-1+2)
        AMGEN(I)=SUM1+RND(I)*(AMGEN(1)-SUM)
        IF(AMGEN(I-1).LE.AMGEN(I)+AMJET8(I-1+2)) GO TO 200
C          Jacobean for sigma_n -> sigma_n-1
        WT=WT*PCM(AMGEN(I-1),AMGEN(I),AMJET8(I-1+2))*DELTAQ/(4*PI**2)
230   CONTINUE
C          Jacobean for final 2-body decay differs by this factor
      WT=WT*PI/(DELTAQ*EHMG)
C
C          Carry out 2-body decays
C
      DO 310 I=1,NJET1
        QCM=PCM(AMGEN(I),AMGEN(I+1),AMJET8(I+2))
        U(3)=2.*RANF()-1
        PHI=2*PI*RANF()
        U(1)=SQRT(1-U(3)**2)*COS(PHI)
        U(2)=SQRT(1-U(3)**2)*SIN(PHI)
        DO 320 J=1,3
          PJETS8(J,I+2)=QCM*U(J)
          PGEN(J,I+1)=-PJETS8(J,I+2)
320     CONTINUE
        PJETS8(0,I+2)=SQRT(QCM**2+AMJET8(I+2)**2)
        PGEN(0,I+1)=SQRT(QCM**2+AMGEN(I+1)**2)
310   CONTINUE
C
      DO 330 J=0,3
        PJETS8(J,NJET+2)=PGEN(J,NJET)
330   CONTINUE
C
C          Boost PGEN frames to lab frame.
C
      DO 400 II=1,NJET1
        I=NJET-II
        DO 410 J=1,3
          BETA(J)=PGEN(J,I)/PGEN(0,I)
410     CONTINUE
        GAMMA=PGEN(0,I)/AMGEN(I)
        DO 420 K=I,NJET
          BP=BETA(1)*PJETS8(1,K+2)+BETA(2)*PJETS8(2,K+2)+
     $    BETA(3)*PJETS8(3,K+2)
          DO 430 J=1,3
            PJETS8(J,K+2)=PJETS8(J,K+2)+GAMMA*BETA(J)*(PJETS8(0,K+2)
     $      +BP*GAMMA/(GAMMA+1.))
430       CONTINUE
          PJETS8(0,K+2)=GAMMA*(PJETS8(0,K+2)+BP)
420     CONTINUE
400   CONTINUE
C
C          Check limits
C
      DO 500 I=1,NJET
        PTI=SQRT(PJETS8(1,I+2)**2+PJETS8(2,I+2)**2)
        IF(PTI.LE.PTMIN(I).OR.PTI.GE.PTMAX(I)) GO TO 999
        PPI=SQRT(PTI**2+PJETS8(3,I+2)**2)
        IF(PPI.LE.PMIN(I).OR.PPI.GE.PMAX(I)) GO TO 999
        XJI=PJETS8(3,I+2)/PPI
        IF(XJI.LE.XJMIN(I).OR.XJI.GE.XJMAX(I)) GO TO 999
        PHII=ATAN2(PJETS8(2,I+2),PJETS8(1,I+2))
        IF(PHII.LT.0) PHII=PHII+2*PI
        IF(PHII.LE.PHIMIN(I).OR.PHII.GE.PHIMAX(I)) GO TO 999
        YI=-LOG(TAN(ACOS(XJI)/2))
        IF(YI.LE.YJMIN(I).OR.YI.GE.YJMAX(I)) GO TO 999
500   CONTINUE
C
      DO 510 I=1,NJET
        DO 520 J=I+1,NJET
          AMIJ=(PJETS8(0,I+2)+PJETS8(0,J+2))**2
     $        -(PJETS8(1,I+2)+PJETS8(1,J+2))**2
     $        -(PJETS8(2,I+2)+PJETS8(2,J+2))**2
     $        -(PJETS8(3,I+2)+PJETS8(3,J+2))**2
          AMIJ=SIGN(SQRT(ABS(AMIJ)),AMIJ)
          IF(AMIJ.LE.AMIJMN(I,J).OR.AMIJ.GE.AMIJMX(I,J)) GO TO 999
520     CONTINUE
510   CONTINUE
C
      RETURN
C
999   WT=0
      RETURN
      END
+EOD
+DECK,NOGOOD.
      LOGICAL FUNCTION NOGOOD(KK)
C
C          Insure proper distribution and check kinematics.
C          Select jet types.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,KEYS
+CDE,WCON
+CDE,CONST
+CDE,WSIG
+CDE,WGEN
+CDE,DYLIM
+CDE,JETLIM
+CDE,JETPAR
+CDE,JETSIG
+CDE,PTPAR
+CDE,HCON
+CDE,XMSSM
C
      REAL RANF,SIGINV,SUM,TRY,BRANCH
      INTEGER KK,I,II,K,IFL
C
      NOGOOD=.TRUE.
      GO TO (1,2,3,4,5,6),KK
C
C          TWOJET, SUPERSYM, WPAIR or PHOTON events
C
1     CONTINUE
      IF(KEYS(1)) THEN
        CALL SIGQCD
      ELSEIF(KEYS(5)) THEN
        CALL SIGSSY
      ELSEIF(KEYS(6)) THEN
        CALL SIGWW
      ELSEIF(KEYS(8)) THEN
        CALL SIGGAM
      ELSEIF(KEYS(10)) THEN
        CALL SIGWH
      ENDIF
      IF(SIGMA.LE.0) RETURN
      IF(SIGMAX*RANF().GT.SIGMA) RETURN
      NOGOOD=.FALSE.
      SIGINV=1./SIGMA
      SUM=0.
      TRY=RANF()
      DO 100 I=1,NSIGS
        SUM=SUM+SIGS(I)*SIGINV
        IF(SUM.LT.TRY) GO TO 100
C          Find reaction
        ISIGS=I
        SIGEVT=SIGS(ISIGS)
        II=INOUT(I)
        DO 110 K=1,2
        INITYP(K)=MOD(II,IOPAK)
110     II=II/IOPAK
        DO 120 K=1,2
        JETTYP(K)=MOD(II,IOPAK)
120     II=II/IOPAK
        RETURN
100   CONTINUE
      RETURN
C
C          DRELLYAN events--test of SIGDY
C
2     CONTINUE
      IF(KEYS(3)) THEN
        CALL SIGDY
      ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN
        CALL SIGH
      ELSEIF(KEYS(7).AND.GOMSSM) THEN
        CALL SIGHSS
      ELSEIF(KEYS(9)) THEN
        CALL SIGTC
      ELSEIF(KEYS(11)) THEN
        CALL SIGKKG
      ENDIF
      IF(SIGMA.LE.0.) RETURN
      IF(SIGSL(KSEL)*RANF().GT.SIGMA) RETURN
      NOGOOD=.FALSE.
      SIGINV=1./SIGMA
      SUM=0.
      TRY=RANF()
C          Find reaction.
      DO 200 I=1,NSIGS
        SUM=SUM+SIGS(I)*SIGINV
        IF(SUM.LT.TRY) GO TO 200
        ISIGS=I
        SIGEVT=SIGS(ISIGS)
        GO TO 210
200   CONTINUE
C          Unpack INOUT to find JETTYP and INITYP
210   IF(KEYS(3).OR.KEYS(11)) THEN
        II=INOUT(I)
        DO 220 K=1,2
        INITYP(K)=MOD(II,IOPAK)
220     II=II/IOPAK
        JWTYP=MOD(II,IOPAK)
        II=II/IOPAK
        JETTYP(3)=MOD(II,IOPAK)
      ELSEIF(KEYS(7).OR.KEYS(9)) THEN
        II=INOUT(ISIGS)
        DO 230 I=1,2
        INITYP(I)=MOD(II,IOPAK)
230     II=II/IOPAK
        DO 240 I=1,2
        JETTYP(I)=MOD(II,IOPAK)
240     II=II/IOPAK
      ENDIF
      RETURN
C
C          DRELLYAN events--test of SIGDY2
C
3     CONTINUE
      IF(KEYS(3)) THEN
        CALL SIGDY2
        IFL=JETTYP(1)/2
        BRANCH=(AQ(IFL,JWTYP)**2+BQ(IFL,JWTYP)**2)/COUT(JWTYP)
      ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN
        CALL SIGH2
        BRANCH=1.
      ELSEIF(KEYS(7).AND.GOMSSM) THEN
        SIGLLQ=SIGMA/(4*PI)
        NOGOOD=.FALSE.
        RETURN
      ELSEIF(KEYS(9)) THEN
        CALL SIGTC2
        BRANCH=1.
      ENDIF
      IF(SIGLLQ.GT.SIGS(ISIGS)*BRANCH*3.*RANF()/(4.*PI))
     1NOGOOD=.FALSE.
      RETURN
C
C          DRELLYAN events--test of kinematics
C
4     CONTINUE
      DO 400 I=1,2
        IF(P(I).LT.PMIN(I).OR.P(I).GT.PMAX(I)) GO TO 410
        IF(PT(I).LT.PTMIN(I).OR.PT(I).GT.PTMAX(I)) GO TO 410
        IF(YJ(I).LT.YJMIN(I).OR.YJ(I).GT.YJMAX(I)) GO TO 410
        IF(PHI(I).LT.PHIMIN(I).OR.PHI(I).GT.PHIMAX(I)) GO TO 410
400   CONTINUE
      NOGOOD=.FALSE.
410   RETURN
C
5     CONTINUE
6     CONTINUE
      RETURN
C
      END
+EOD
+DECK,ORDECR.
      SUBROUTINE ORDECR(IA,IB,N)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : 
C-        return an ordered array (by size of absolute values)
C-        Warning: input array is destroyed
C-
C-   Inputs  : 
C-   IA(N) = input array
C-   Outputs : 
C-   IB(N) = output ordered array
C-
C-   Created   9-MAY-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
      INTEGER IA(*),IB(*),N,I,J,JSEL
C----------------------------------------------------------------------
      DO 2 I=1,N
        JSEL=0
        IB(I)=0
        DO 1 J=1,N
          IF(IABS(IA(J)).GT.IABS(IB(I))) THEN
            IB(I)=IA(J)
            JSEL=J
          ENDIF
    1   CONTINUE
        IF(JSEL.GT.0) IA(JSEL)=0
    2 CONTINUE
  999 RETURN
      END
+EOD
+DECK,ORDER.
      SUBROUTINE ORDER(ID,MODEIN,MODOUT,MEOUT,LPRT)
C
C          Search for mode MODEIN of particle ID in standard /DKYTAB/.
C          If found, return MODOUT = standard order and MEOUT=MELEM.
C          Otherwise return MODOUT = MODEIN and MEOUT=0.
C          If ID<0, use antiparticles instead.
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
C
+CDE,ITAPES
+CDE,DKYTAB
+CDE,FORCE
C
      INTEGER ID,MODEIN(5),MODOUT(5),MODTST(5)
      INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,LOOK0,IUSE(5),ISAME,I,J,
     $NADD,NADDI,K,K1,K2,IDANTI,MEOUT
      LOGICAL LPRT
C
C          Find standard starting point
C
      CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX)
      ISAME=0
      IF(LOOK(INDEX).GT.0) THEN
        LOOK0=LOOK(INDEX)
      ELSEIF(LOOK(INDEX).LT.0) THEN
        LOOK0=LOOKST(-LOOK(INDEX))
      ELSE
        GO TO 300
      ENDIF
C
C          Find NADD
C
      DO 100 I=1,5
100   IF(MODEIN(I).NE.0) NADD=I
C
C          If ID<0, compare antiparticles
C
      IF(ID.GE.0) THEN
        DO 110 K=1,NADD
110     MODTST(K)=MODEIN(K)
      ELSE
        DO 120 K=1,NADD
120     MODTST(K)=IDANTI(MODEIN(K))
      ENDIF
C
C          Scan all modes starting at LOOK0. Check for correct NADD.
C          Then check that particles match in arbitrary order.
C
      IF(LOOK0.LE.0) GO TO 300
      DO 200 I=LOOK0,MXDKY
        DO 210 K=1,5
210     IF(MODE(K,I).NE.0) NADDI=K
        IF(NADDI.EQ.NADD) THEN
          DO 220 K=1,5
220       IUSE(K)=0
C
          DO 230 K1=1,NADD
            DO 240 K2=1,NADD
              IF(MODTST(K1).EQ.MODE(K2,I).AND.IUSE(K2).EQ.0) THEN
                IUSE(K2)=K1
                GO TO 230
              ENDIF
240         CONTINUE
            GO TO 201
230       CONTINUE
C
          ISAME=I
          GO TO 300
        ENDIF
201     IF(CBR(I).GE.1.) THEN
          ISAME=0
          GO TO 300
        ENDIF
200   CONTINUE
      STOP 99
C
C          Return matching mode or original mode.
C
300   IF(ISAME.EQ.0) THEN
        IF(LPRT) WRITE(ITLIS,3001)
3001    FORMAT(' ***** WARNING: NONSTANDARD MODE')
        DO 310 K=1,5
310     MODOUT(K)=MODEIN(K)
        MEOUT=0
      ELSEIF(ID.GT.0) THEN
        DO 320 K=1,5
320     MODOUT(K)=MODE(K,ISAME)
        MEOUT=MELEM(ISAME)
      ELSE
        DO 330 K=1,5
330     MODOUT(K)=IDANTI(MODE(K,ISAME))
        MEOUT=MELEM(ISAME)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,PRTEVT.
      SUBROUTINE PRTEVT(IPRT)
C
C          PRINT THE EVENT STORED IN /PJETS/, /JETSET/, AND /PARTCL/
C          IF IPRT IS SELECTED BY NEVPRT AND NJUMP.
C          IPRT=0 ALWAYS PRINTS EVENT
C          IPRT<0 PRINTS ONLY JET PARAMETERS
C
+CDE,ITAPES
+CDE,MBGEN
+CDE,PJETS
+CDE,PINITS
+CDE,JETSET
+CDE,IDRUN
+CDE,JETSIG
+CDE,KEYS
+CDE,JETPAR
+CDE,LSTPRT
+CDE,PARTCL
+CDE,PRIMAR
+CDE,PRTOUT
+CDE,WSIG
+CDE,SEED.
C
C          LABELS ARE CHARACTER*8
      CHARACTER*8 LABEL,LW,LJET,LPTCL
      INTEGER N0J
      INTEGER LUX,LUXINT,LUXK1,LUXK2
C
C          DECIDE WHETHER TO PRINT
      IF(IPRT.GT.NJUMP*NEVPRT) THEN
        IF(NJUMP.GT.0) THEN
+SELF,IF=NORANLUX
          IF(MOD(IPRT,NJUMP).EQ.0) WRITE(ITLIS,5) IDG,IEVT,XSEED
5         FORMAT(/6X,'RUN ID',2I10,5X,'EVENT NO',I8,5X,'SEED',2X,A24)
+SELF,IF=RANLUX
          CALL RLUXAT(LUX,LUXINT,LUXK1,LUXK2)
          IF(MOD(IPRT,NJUMP).EQ.0) WRITE(ITLIS,5) IDG,IEVT,LUXINT,
     $    LUXK1,LUXK2
5         FORMAT(/6X,'RUN ID',2I10,5X,'EVENT NO',I8,5X,'RANLUX SEEDS',
     $    3I12)
+SELF
        ENDIF
        RETURN
      ENDIF
      IF(IPRT.GT.1.AND.MOD(IPRT,NJUMP).NE.0) RETURN
      IF(IEVT.EQ.LSTPRT) RETURN
      PI=4.*ATAN(1.)
      LSTPRT=IEVT
C          PRINT EVENT NUMBER
+SELF,IF=NORANLUX
      WRITE(ITLIS,10) IDG,IEVT,XSEED
10    FORMAT('1',5X,'RUN ID',2I10.6,5X,'EVENT NO',I8,5X,'SEED',2X,A24)
+SELF,IF=RANLUX
          CALL RLUXAT(LUX,LUXINT,LUXK1,LUXK2)
          WRITE(ITLIS,10) IDG,IEVT,LUXINT,LUXK1,LUXK2
10        FORMAT(/6X,'RUN ID',2I10,5X,'EVENT NO',I8,5X,'RANLUX SEEDS',
     $    3I12)
+SELF
C
C          PRINT JET PARAMETERS
      IF(NJET.EQ.0) GO TO 300
      WRITE(ITLIS,20)
20    FORMAT(//20X,'JET PARAMETERS'//3X,'JET',4X,'TYPE ',
     18X,'PX',8X,'PY',8X,'PZ',8X,'P0',8X,'PT',
     25X,'THETA',7X,'PHI',9X,'X',9X,'Y')
      IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN
        LW=LABEL(IDENTW)
        WRITE(ITLIS,31) LW,(QWJET(K),K=1,4),QTW,THW,PHIW,XW,YW
31      FORMAT(5X,'-',4X,A5,5F10.2,4F10.4)
      ENDIF
      IF(KEYS(11)) THEN
        N0J=3
      ELSE
        N0J=1
      ENDIF
      DO 100 I=N0J,NJET
      LJET=LABEL(IDJETS(I))
      WRITE(ITLIS,30) I,LJET,(PJETS(K,I),K=1,4),PT(I),TH(I),PHI(I),
     $XJ(I),YJ(I)
30    FORMAT(1X,I5,4X,A5,5F10.2,4F10.4)
100   CONTINUE
C          PRINT WPAIR DECAY PARAMETERS
      IF(KEYS(6).OR.KEYS(7).OR.KEYS(10)) THEN
        IF(NPAIR.NE.0) THEN
          WRITE(ITLIS,101)
101       FORMAT(//20X,'WPAIR DECAY PARAMETERS'//3X,'JET',4X,'TYPE ',
     $    8X,'PX',8X,'PY',8X,'PZ',8X,'P0',8X,'PT',
     $    5X,'THETA',7X,'PHI',9X,'X',9X,'Y')
          DO 102 I=1,NPAIR
          JET=JPAIR(I)
          LJET=LABEL(IDPAIR(I))
          PTPRT=SQRT(PPAIR(1,I)**2+PPAIR(2,I)**2)
          THPRT=ACOS(PPAIR(3,I)/SQRT(PTPRT**2+PPAIR(3,I)**2))
          PHIPRT=ATAN2(PPAIR(2,I),PPAIR(1,I))
          XPRT=2*PPAIR(3,I)/ECM
          YPRT=-ALOG(TAN(THPRT/2.))
          WRITE(ITLIS,30) JET,LJET,(PPAIR(K,I),K=1,4),
     $    PTPRT,THPRT,PHIPRT,XPRT,YPRT
102       CONTINUE
        ENDIF
      ENDIF
      IF(IPRT.LT.0) RETURN
C
C          PRINT JET CROSS SECTIONS
201   CONTINUE
      IF(KEYS(1).OR.KEYS(5).OR.KEYS(6).OR.KEYS(10)) THEN
        WRITE(ITLIS,39) SIGEVT
39      FORMAT(//5X,'D(SIGMA)/D(PT**2)D(Y1)D(Y2) = ',E12.4)
      ENDIF
      IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN
        IF(NJET.EQ.3) THEN
          WRITE(ITLIS,38) LW,QMW,SIGEVT,SIGLLQ
38      FORMAT(//5X,'MASS OF ',A8,' = ',F10.3//
     C    5X,'D(SIGMA)/D(Q**2)D(QT**2)D(YW)D(YJ) = ',E12.4/
     C    5X,'D(SIGMA)/D(Q**2)D(QT**2)D(YW)D(YJ)D(OMEGA) = ',E12.4)
        ELSE
          WRITE(ITLIS,37) LW,QMW,SIGEVT,SIGLLQ
37      FORMAT(//5X,'MASS OF ',A8,' = ',F10.3//
     1    5X,'D(SIGMA)/D(Q**2)D(YW) =',E12.4/
     2    5X,'D(SIGMA)/D(Q**2)D(YW)D(OMEGA) =',E12.4)
        ENDIF
      ENDIF
      IF(KEYS(2)) THEN
        WRITE(ITLIS,32) SIGEVT
32      FORMAT(//5X,'D(SIGMA)/D(COS THETA) = ',E12.4)
      ENDIF
C
C          PRINT /JETSET/ PARAMETERS
      IF(KEYS(4)) GO TO 300
      IF(NJSET.EQ.0) GO TO 300
      WRITE(ITLIS,70)
70    FORMAT(//20X,'PARTON CASCADE PARAMETERS'//
     C  6X,'I',3X,'JET',4X,'ORIG',4X,'TYPE',9X,'DECAY',
     C  8X,'PX',8X,'PY',8X,'PZ',8X,'P0',6X,'MASS')
      DO 310 I=1,NJSET
      JET=JORIG(I)/JPACK
      I1=MOD(JORIG(I),JPACK)
      JTLV1=JTYPE(I)
      LJET=LABEL(JTLV1)
      J1=JDCAY(I)/JPACK
      J2=MOD(JDCAY(I),JPACK)
      IF(JDCAY(I).EQ.0) THEN
        WRITE(ITLIS,71) I,JET,I1,LJET,(PJSET(K,I),K=1,5)
71      FORMAT(1X,I6,I6,I8,4X,A5,8X,'FINAL',5F10.2)
      ELSEIF(J1.NE.J2) THEN
        WRITE(ITLIS,72) I,JET,I1,LJET,J1,J2,(PJSET(K,I),K=1,5)
72      FORMAT(1X,I6,I6,I8,4X,A5,4X,I4,'-',I4,5F10.2)
      ELSE
        WRITE(ITLIS,73) I,JET,I1,LJET,(PJSET(K,I),K=1,5)
73      FORMAT(1X,I6,I6,I8,4X,A5,6X,'INITIAL',5F10.2)
      ENDIF
310   CONTINUE
C
C          PRINT HADRON PARAMETERS
300   IF(NPTCL.EQ.0) RETURN
      IF(.NOT.KEYS(2)) WRITE(ITLIS,45) NPOM
45    FORMAT(//' NUMBER OF POMERONS =',I5)
      WRITE(ITLIS,40)
40    FORMAT(//20X,'HADRON PARAMETERS'//7X,'I',3X,'JET',5X,'ORIG'
     C  ,4X,'TYPE',11X,'DECAY',8X,'PX',8X,'PY',8X,'PZ',8X,'P0'
     C  ,8X,'PT',5X,'THETA',7X,'PHI')
      DO 200 I=1,NPTCL
      I1=IABS(IORIG(I))
      JET=I1/IPACK
      I1=I1-IPACK*JET
      I1=ISIGN(I1,IORIG(I))
      IDLV1=IDENT(I)
      LPTCL=LABEL(IDLV1)
      J1=IDCAY(I)/IPACK
      J2=MOD(IDCAY(I),IPACK)
      PTHAD=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2)
      PHAD=SQRT(PPTCL(3,I)**2+PTHAD**2)
      PHIHAD=ATAN2(PPTCL(2,I),PPTCL(1,I))
      IF(PHIHAD.LT.0.) PHIHAD=2.*PI+PHIHAD
      THHAD=ACOS(PPTCL(3,I)/PHAD)
      IF(IDCAY(I).EQ.0) THEN
        WRITE(ITLIS,50) I,JET,I1,LPTCL,(PPTCL(K,I),K=1,4),PTHAD,THHAD,
     $  PHIHAD
50      FORMAT(1X,I7,I6,I9,4X,A5,9X,'STABLE',5F10.2,2F10.4)
      ELSE
        WRITE(ITLIS,60) I,JET,I1,LPTCL,J1,J2,(PPTCL(K,I),K=1,4),
     $  PTHAD,THHAD,PHIHAD
60      FORMAT(1X,I7,I6,I9,4X,A5,4X,I5,'-',I5,5F10.2,2F10.4)
      ENDIF
200   CONTINUE
      RETURN
      END
+EOD
+DECK,PRTLIM.
      SUBROUTINE PRTLIM
C
C          Print initial conditions and limits for generating jets
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,FORCE
+CDE,MBGEN
+CDE,QCDPAR
+CDE,QLMASS
+CDE,WCON
+CDE,JETPAR
+CDE,KEYS
+CDE,KKGRAV
+CDE,FRGPAR
+CDE,NODCAY
+CDE,PRTOUT
+CDE,SEED
+CDE,TYPES
+CDE,Q1Q2
+CDE,JETLIM
+CDE,PRIMAR
+CDE,PTPAR
+CDE,IDRUN
+CDE,DYLIM
+CDE,HCON
+CDE,ISLOOP
+CDE,XMSSM
+CDE,LUXPAR
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SSPAR
+CDE,SUGNU
C
      INTEGER I,J,II,K,NPRT,I1,I2,I3,J1,INDEX,IQ,KK,KKK,NN,N0J
      REAL AMASS
      CHARACTER*8 LSTRUC(10),LMODE(5),STUF(6),IDFMT(2)
      CHARACTER*8 WTITL(4)
      CHARACTER*8 LABEL,L0
      CHARACTER*8 BLANK
      CHARACTER*40 V,VISAJE
      REAL AM(6),AML(6)
      INTEGER NPRSS
      PARAMETER (NPRSS=32)
      INTEGER IDPRSS(NPRSS)
      REAL AMPRSS(NPRSS)
      CHARACTER*8 LPRSS(NPRSS)
      REAL ALEMI,AS,TANBQ,PI,MU,B,HIGFRZ
C
      DATA LSTRUC/'OWENS','BAIER','EICHTEN','DUKE','CTEQ2L','CTEQ3L',
     $'CTEQ5L','???','???','???'/
      DATA WTITL/'GM','W+','W-','Z0'/
      DATA BLANK/' '/
      DATA IDPRSS/21,22,23,24,25,26,41,42,43,44,45,46,
     $31,32,33,34,35,36,52,54,56,
     $29,30,40,50,60,39,49,82,83,84,86/
C
C          Print version
      PI=4.*ATAN(1.)
      V=VISAJE()
      WRITE(ITLIS,1000) V
1000  FORMAT('1',44('*')/' *',42X,'*'/
     C  ' * ',A40,' *'/
     C  ' *',42X,'*'/' ',44('*')/)
C
C          Print title, reaction, energy, number, run id
      WRITE(ITLIS,1010) TITLE
1010  FORMAT(/11X,10A8)
      WRITE(ITLIS,1020) NJET
1020  FORMAT(/2X,'NUMBER OF JETS TO BE GENERATED PER EVENT',I3)
      DO 100 I=1,2
        IDFMT(I)=LABEL(IDIN(I))
100   CONTINUE
      WRITE(ITLIS,1030) IDFMT(1),IDFMT(2),ECM
1030  FORMAT(/2X,A8,' ON ',A8,' AT COM ENERGY',E15.4)
      WRITE(ITLIS,1040) REAC,NEVENT
1040  FORMAT(/2X,'NUMBER OF ',A8,' EVENTS TO BE GENERATED',I10)
      IF(NEVPRT.GT.0) WRITE(ITLIS,1050) NEVPRT,NJUMP
1050  FORMAT(/2X,'PRINT A MAXIMUM OF ',I6,
     C  ' EVENTS SKIPPING ',I6,' EVENTS AT A TIME')
      WRITE(ITLIS,1060) IDG
1060  FORMAT(/2X,'RUN ID   ',2I10.6)
C
C          Print W/Higgs parameters
C
      IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN
        IF(KEYS(3)) THEN
          II=0
          DO 200 I=1,4
            IF(.NOT.GODY(I)) GOTO 200
            II=II+1
            STUF(II)=WTITL(I)
200       CONTINUE
        ELSEIF(KEYS(11)) THEN
          II=1
          STUF(II)='GRAV'
        ELSE
          II=1
          STUF(II)='HIGGS'
          IF(IHTYPE.EQ.82) STUF(II)='HL0'
          IF(IHTYPE.EQ.83) STUF(II)='HH0'
          IF(IHTYPE.EQ.84) STUF(II)='HA0'
        ENDIF
        WRITE(ITLIS,2000) (STUF(K),K=1,II)
2000    FORMAT(//10X,'PARAMETERS FOR',4(2X,A8))
        WRITE(ITLIS,2010) QMIN,QMAX
2010    FORMAT(' MASS LIMITS',15X,2E15.4)
        WRITE(ITLIS,3020) QTMIN,QTMAX
        WRITE(ITLIS,3030) THWMIN,THWMAX
        WRITE(ITLIS,3040) PHWMIN,PHWMAX
        WRITE(ITLIS,3050) YWMIN,YWMAX
        WRITE(ITLIS,3060) XWMIN,XWMAX
        NPRT=0
        IF(FIXQT) THEN
          NPRT=NPRT+1
          STUF(NPRT)='QTW     '
        ENDIF
        IF(FIXQM) THEN
          NPRT=NPRT+1
          STUF(NPRT)='QMW     '
        ENDIF
        IF(FIXYW) THEN
          NPRT=NPRT+1
          STUF(NPRT)='YW      '
        ENDIF
        IF(FIXXW) THEN
          NPRT=NPRT+1
          STUF(NPRT)='XW      '
        ENDIF
        IF(FIXPHW) THEN
          NPRT=NPRT+1
          STUF(NPRT)='PHW     '
        ENDIF
        IF(NPRT.NE.0) WRITE(ITLIS,2070) (STUF(K),K=1,NPRT)
      ENDIF
C
C          Print jet parameters
C
      DO 300 I=1,6
300   STUF(I)=BLANK
      IF(KEYS(11)) THEN
        N0J=3
      ELSE
        N0J=1
      ENDIF
      DO 310 I=N0J,NJET
        NPRT=0
        WRITE(ITLIS,3000) I
3000    FORMAT(//10X,'JET NO.',I3,/)
        WRITE(ITLIS,3010) PMIN(I),PMAX(I)
3010    FORMAT(' MOMENTUM LIMITS',11X,2E15.4)
        WRITE(ITLIS,3020) PTMIN(I),PTMAX(I)
3020    FORMAT(' TRANSVERSE MOMENTUM LIMITS',2E15.4)
        WRITE(ITLIS,3030) THMIN(I),THMAX(I)
3030    FORMAT(' THETA LIMITS',14X,2E15.4)
        WRITE(ITLIS,3040) PHIMIN(I),PHIMAX(I)
3040    FORMAT(' PHI LIMITS',16X,2E15.4)
        WRITE(ITLIS,3050) YJMIN(I),YJMAX(I)
3050    FORMAT(' RAPIDITY (Y) LIMITS',7X,2E15.4)
        WRITE(ITLIS,3060) XJMIN(I),XJMAX(I)
3060    FORMAT(' FEYNMAN X LIMITS',10X,2E15.4)
        IF(.NOT.GOALL(I)) WRITE(ITLIS,3070) (JETYP(K,I),K=1,NJTTYP(I))
3070    FORMAT(' JET TYPE',23X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
        IF((KEYS(6).OR.KEYS(7)).AND..NOT.ALLWW(I))
     $  WRITE(ITLIS,3080) (WWTYP(K,I),K=1,NWWTYP(I))
3080    FORMAT(' DECAY MODES',20X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
        IF(FIXP(I)) THEN
          NPRT=NPRT+1
          STUF(NPRT)='P       '
        ENDIF
        IF(FIXPT(I)) THEN
          NPRT=NPRT+1
          STUF(NPRT)='PT      '
        ENDIF
        IF(FIXYJ(I)) THEN
          NPRT=NPRT+1
          STUF(NPRT)='TH      '
          NPRT=NPRT+1
          STUF(NPRT)='Y      '
        ENDIF
        IF(FIXPHI(I)) THEN
          NPRT=NPRT+1
          STUF(NPRT)='PHI     '
        ENDIF
        IF(FIXXJ(I)) THEN
          NPRT=NPRT+1
          STUF(NPRT)='X       '
        ENDIF
        IF(NPRT.EQ.0) GOTO 310
        WRITE(ITLIS,2070) (STUF(K),K=1,NPRT)
2070    FORMAT(/5X,'FOLLOWING PARAMETERS HAVE BEEN FIXED ',6A8)
310   CONTINUE
C
C          Print structure functions, QCD parameters, W parameters,
C          and other parameters changed from their default values.
C
      IF(KEYS(1).OR.KEYS(3).OR.KEYS(5).OR.KEYS(6).OR.KEYS(7)
     $.OR.KEYS(8).OR.KEYS(9).OR.KEYS(11).OR.KEYS(12)) THEN
        IF(ISTRUC.GT.0) THEN
          WRITE(ITLIS,4000) LSTRUC(ISTRUC)
4000      FORMAT(//1X,A8,' STRUCTURE FUNCTIONS')
        ELSEIF(ISTRUC.EQ.-999) THEN
          WRITE(ITLIS,4001)
4001      FORMAT(//1X,' PDFLIB STRUCTURE FUNCTIONS')
        ENDIF
      ENDIF
      WRITE(ITLIS,4010) ALAM,CUTJET
4010  FORMAT(//' QCD LAMBDA =',F10.4,10X,'JET CUTOFF MASS =',F10.3)
      WRITE(ITLIS,4020) AMLEP(6),AMLEP(7),AMLEP(8)
4020  FORMAT(/' HEAVY QUARK MASSES =',3F8.2)
      IF(LOC(36).NE.0) THEN
        CALL FLAVOR(80,I1,I2,I3,J1,INDEX)
        WRITE(ITLIS,4030) (AMLEP(INDEX+K),K=1,9)
4030    FORMAT(/' HIGGS MASSES =',6F8.2/15X,3F8.2)
      ENDIF
C
C          Supersymmetry
C
      IF(KEYS(5).AND..NOT.GOMSSM) THEN
        DO 410 IQ=1,6
          AM(IQ)=AMASS(20+IQ)
          AML(IQ)=AMASS(30+IQ)
410     CONTINUE
        WRITE(ITLIS,4040) (AM(KK),KK=1,6)
4040    FORMAT(//' SQUARK  MASSES ',7F9.2)
        WRITE(ITLIS,4050) (AML(KK),KK=1,6)
4050    FORMAT(' SLEPTON MASSES ',7F9.2)
        AM(1)=AMASS(29)
        AM(2)=AMASS(30)
        AM(3)=AMASS(39)
        AM(4)=AMASS(40)
        WRITE(ITLIS,4060) (AM(KK),KK=1,4)
4060    FORMAT(' GAUGINO MASSES (WITH SIGNS) ',7F9.2)
        IF(LOC(44).NE.0) WRITE(ITLIS,4070) XGENSS(9),
     $  (XGENSS(KK),KK=1,8) 
4070    FORMAT(/' FRAG. PARAM. XGENSS = ',9F8.3)
      ENDIF
C
C          MSSM model, including SUGRA, GMSB, AMSB
C
      IF(GOMSSM) THEN
C          Print masses
        DO 420 I=1,NPRSS
          LPRSS(I)=LABEL(IDPRSS(I))
          AMPRSS(I)=AMASS(IDPRSS(I))
420     CONTINUE
        WRITE(ITLIS,4100) (LPRSS(I),AMPRSS(I),I=1,NPRSS)
4100    FORMAT(/' MSSM MASSES (WITHOUT SIGNS):'/
     $  10(' M(',A5,') = ',F10.3,5X,'M(',A5,') = ',F10.3,
     $  5X,'M(',A5,') = ',F10.3/),
     $  ' M(',A5,') = ',F10.3,5X,'M(',A5,') = ',F10.3)
C
        IF(.NOT.(GOSUG.OR.GOGMSB.OR.GOAMSB)) THEN
C          If weak-scale MSSM, just print other inputs
          WRITE(ITLIS,4110) XTBSS,XMUSS,XATSS
4110      FORMAT(/' OTHER MSSM PARAMETERS:'/
     $    ' TAN(BETA) = ',F10.3,5X,'MU = ',F10.3,5X,'A_t = ',F10.3)
        ELSE
C          SUGRA, GMSB, or AMSB model
C          Printout copied from SUGPRT in ISASUGRA
          ALEMI=4*PI/GSS(2)**2/SIN2W
          AS=GSS(3)**2/4./PI
          TANBQ=VUQ/VDQ
          WRITE(ITLIS,4120) ALEMI,SIN2W,AS
4120      FORMAT(/' 1/ALPHAEM  =',F8.2,2X,
     $    '   SIN**2(THETAW) =',F7.4,1X,'   ALPHAS    =  ',F5.3)
          WRITE(ITLIS,4121) GSS(7),GSS(8),GSS(9)
4121      FORMAT(' M1         =',F8.2,2X,
     $    '   M2             =',F8.2,'   M3        =',F8.2)
          CALL GETPAS(MU,B,HIGFRZ)
          WRITE(ITLIS,4122) MU,B,HIGFRZ
4122      FORMAT(' MU(Q)      =',F8.2,2X,
     $    '   B(Q)           =',F8.2,'   Q         =',F8.2)
          WRITE(ITLIS,4123) GSS(13),GSS(14),TANBQ
4123      FORMAT(' M**2(H1)   =',E10.3,'   M**2(H2)       =',E10.3,
     $    ' TANBQ     =   ',F6.3)
C
          WRITE(ITLIS,4130) THETAT,THETAB,THETAL,ALFAH
4130       FORMAT(/,' theta_t=',F9.4,'   theta_b=',F9.4,
     $     '   theta_l=',F9.4,'   alpha_h=',F9.4)
C
          WRITE(ITLIS,4140) AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS
4140      FORMAT(/' NEUTRALINO MASSES (SIGNED) =',4F10.3)
          DO 4150 J=1,4
            WRITE(ITLIS,4151) J,(ZMIXSS(K,J),K=1,4)
4151        FORMAT(' EIGENVECTOR ',I1,'       =',4F10.5)
4150      CONTINUE
          WRITE(ITLIS,4160) AMW1SS,AMW2SS
4160      FORMAT(/' CHARGINO MASSES (SIGNED)  =',2F10.3)
          WRITE(ITLIS,4161) GAMMAL,GAMMAR
4161      FORMAT(' GAMMAL, GAMMAR             =',2F10.5/)
        ENDIF
      ENDIF
C
C          Other parameters
C
      IF(LOC(30).NE.0) WRITE(ITLIS,4200) XGEN
4200  FORMAT(/' FRAGMENTATION PARAMETER XGEN =',6F8.3)
      IF(LOC(31).NE.0) WRITE(ITLIS,4210) SIGQT
4210  FORMAT(/' FRAGMENTATION PARAMETER SIGQT =',F8.3)
      IF(KEYS(2).OR.KEYS(3).OR.KEYS(6).OR.KEYS(7)) THEN
        WRITE(ITLIS,4220) SIN2W,WMASS(2),WMASS(4),WGAM(2),WGAM(4)
4220    FORMAT(//' WEINBERG MODEL',5X,'SIN**2(THETA-W)=',F8.4/
     $  ' MASSES = ',F8.2,',',F8.2,'   WIDTHS = ',F8.3,',',F8.3)
      ENDIF
      IF(KEYS(3)) THEN
        IF(.NOT.STDDY) WRITE(ITLIS,4230) CUTOFF,CUTPOW
4230    FORMAT(/' CUTOFF FUNCTION IS QT**2=',E11.4,'*Q**',E11.4)
        IF(LOC(50).NE.0) WRITE(ITLIS,4240) WFUDGE
4240    FORMAT(/' W fudge factor (WFUDGE) = ',F8.3)
      ENDIF
      IF(KEYS(7)) THEN
        WRITE(ITLIS,4250) HMASS,HGAM
4250    FORMAT(/' HIGGS MASS = ',F8.2,'  WIDTH = ',F8.3)
      ENDIF
+SELF,IF=NORANLUX
      WRITE(ITLIS,4260) XSEED
4260  FORMAT(/' SEED FOR RANDOM NUMBER GENERATOR = ',A24)
+SELF,IF=RANLUX
      WRITE(ITLIS,4260) LUX
4260  FORMAT(/' RANDOM NUMBER GENERATOR IS RANLUX, LUX=',I5)
      IF(LUXGO) CALL RLUXGO(LUX,LUXINT,LUXK1,LUXK2)
      LUXGO=.FALSE.
+SELF
      IF(LOC(13).NE.0) WRITE(ITLIS,4270) FRPAR
4270  FORMAT(//'  FRAGMENTATION PARAMETERS ',8E11.3,2(/,26X,8E11.3))
      IF(LOC(34).NE.0) WRITE(ITLIS,4280) MNPOM,MXPOM
4280  FORMAT(//'  NUMBER OF POMERONS =',I4,' TO',I4)
C
C          Print KKG parameters
      IF(KEYS(11)) THEN
        WRITE(ITLIS,4291) NEXTRAD
        WRITE(ITLIS,4292) MASSD
        WRITE(ITLIS,4296) SURFD
        WRITE(ITLIS,4295) KKGSD
        WRITE(ITLIS,4297) UVCUT
4291    FORMAT(//' NB EXTRA-DIMENSIONS',7X,I4)
4292    FORMAT(' SCALE M_D',15X,E15.4)
4295    FORMAT(' KKGSD FACTOR',12X,E15.4)
4296    FORMAT(' SD SURFACE',14X,E15.4)
4297    FORMAT(' UV CUTOFF',17X,I4)
      ENDIF
C
C          Decay switches
C
      IF(LOC(46).NE.0) THEN
        WRITE(ITLIS,4300)
4300    FORMAT(//'  SECONDARY W DECAY MODES:')
        NN=MAX0(NWMODE(1),1)
        WRITE(ITLIS,4310) (WMODES(KKK,1),KKK=1,NN)
4310    FORMAT('  W+ --> '
     $  ,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
        NN=MAX0(NWMODE(2),1)
        WRITE(ITLIS,4320) (WMODES(KKK,2),KKK=1,NN)
4320    FORMAT('  W- --> '
     $  ,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
        WRITE(ITLIS,4330) (WMODES(KKK,3),KKK=1,NN)
4330    FORMAT('  Z0 --> '
     $  ,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8,1X,A8)
      ENDIF
C
      IF(NODCAY) WRITE(ITLIS,4400)
4400  FORMAT(//'  NO DECAYS OF HADRONS WILL BE GENERATED')
      IF(NOETA) WRITE(ITLIS,4410)
4410  FORMAT(//'  NO DECAYS OF ETAS WILL BE GENERATED')
      IF(NOPI0) WRITE(ITLIS,4420)
4420  FORMAT(//'  NO DECAYS OF PI0S WILL BE GENERATED')
      IF(NONUNU) WRITE(ITLIS,4430)
4430  FORMAT(//'  NO DECAYS Z0---->NU+NU WILL BE GENERATED')
      IF(NOEVOL) WRITE(ITLIS,4440)
4440  FORMAT(//'  NO QCD JET EVOLUTION WILL BE DONE')
      IF(NOHADR) WRITE(ITLIS,4450)
4450  FORMAT(//'  NO JET HADRONIZATION WILL BE DONE')
      IF(GOGMSB.AND.NOGRAV) WRITE(ITLIS,4460)
4460  FORMAT(//'  NO GRAVITINO DECAYS WILL BE GENERATED')
C
C          Print forced decay modes and M.E. flag
C
      IF(NFORCE.NE.0) THEN
        WRITE(ITLIS,4500)
4500    FORMAT(//7X,'FORCED DECAY MODES (MATRIX ELEMENT FLAGS)'/
     $  2X,'PART',6X,'DECAY MODE')
        DO 450 I=1,NFORCE
          IF(IFORCE(I).EQ.0) GOTO 450
          L0=LABEL(IFORCE(I))
          DO 451 K=1,5
            LMODE(K)=BLANK
            IF(MFORCE(K,I).EQ.0) GO TO 451
            LMODE(K)=LABEL(MFORCE(K,I))
451       CONTINUE
          WRITE(ITLIS,4510) L0,(LMODE(K),K=1,5),MEFORC(I)
4510      FORMAT(2X,6A10,'(M.E. =',I5,')')
450     CONTINUE
      ENDIF
C
C          Print multiple evolution/fragmentation information
C
      IF(NEVOLV.NE.1.OR.NFRGMN.NE.1) THEN
        WRITE(ITLIS,4600) NEVOLV,NFRGMN
4600    FORMAT(//,
     $  '  MULTIPLE EVOLUTION AND FRAGMENTATION VERSION'/
     $  '  EVENTS WILL BE EVOLVED',I6,' TIMES'/
     $  '  AND FRAGMENTED        ',I6,' TIMES'/)
      ENDIF
C
      RETURN
      END
      SUBROUTINE GETPAS(XMU,XB,XHGFRZ)
C          Get parameters from SUGPAS to avoid name clashes
+CDE,SUGPAS
      XMU=MU
      XB=B
      XHGFRZ=HIGFRZ
      RETURN
      END
+EOD
+DECK,PTFUN.
      SUBROUTINE PTFUN
C
C          Calculate an envelope
C          D(SIGMA)/D(PT**2)D(Y1)D(Y2) < PTFUN1*PT**PTFUN2
C          used to generate initial PT values.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,KEYS
+CDE,CONST
+CDE,JETLIM
+CDE,PTPAR
+CDE,JETPAR
+CDE,JETSIG
C
      REAL PCPY(24)
      EQUIVALENCE(P(1),PCPY(1))
      REAL PTS(51),SIGSAV(51),STOR(24),DPT,DPTMIN,A,B,DEVMAX,DEV
      REAL DY1,DY2,B1
      INTEGER I,NPT,NDIV1,NDIV2,I1,I2
C
      DATA DPTMIN/0.2/
C
C          Initialize
      DO 89 I=1,24
   89 STOR(I)=PCPY(I)
      YJ(1)=0
      YJ(2)=0
      TH(1)=PI/2.
      TH(2)=PI/2.
      STH(1)=1.
      STH(2)=1.
      CTH(1)=0.
      CTH(2)=0.
      PHI(1)=0.
      PHI(2)=PI
      IF(FIXPT(1).OR.FIXPT(2)) GOTO 300
      DPT=(PTMAX(1)-PTMIN(1))/25.
      IF(DPT.LT.DPTMIN) DPT=DPTMIN
      NPT=(PTMAX(1)-PTMIN(1))/DPT+1
      IF(NPT.GT.51) NPT=50
      IF(NPT.LE.1) NPT=2
C
C          Calculate sigma vs PT at Y1=Y2=0
      DO 100 I=1,NPT
        PT(1)=PTMIN(1)+DPT*(I-1)
        PT(2)=PT(1)
        P(1)=PT(1)
        P(2)=PT(2)
        IF(KEYS(1)) THEN
          CALL SIGQCD
        ELSEIF(KEYS(5)) THEN
          CALL SIGSSY
        ELSEIF(KEYS(6)) THEN
          CALL SIGWW
        ELSEIF(KEYS(8)) THEN
          CALL SIGGAM
        ELSEIF(KEYS(10)) THEN
          CALL SIGWH
        ENDIF
        IF(SIGMA.EQ.0.) GO TO 9999
        SIGSAV(I)=ALOG(SIGMA)
        PTS(I)=ALOG(PT(1))
  100 CONTINUE
C
C          Fit to power and shift to get envelope
C
      CALL LSTSQ(PTS,SIGSAV,NPT,A,B)
      DEVMAX=0.
      DO 101 I=1,NPT
        DEV=SIGSAV(I)-A-B*PTS(I)
        IF(DEV.GT.DEVMAX) DEVMAX=DEV
  101 CONTINUE
C
C        Scan in Y1, Y2 for 3 PT values
C
      DO 104 I=1,3
        IF(I.EQ.1) PT(1)=PTMIN(1)
        IF(I.EQ.2) PT(1)=(PTMIN(1)+PTMAX(1))/2.
        IF(I.EQ.3) PT(1)=PTMAX(1)
        PT(2)=PT(1)
        NDIV1=YJMAX(1)-YJMIN(1) 
        IF(NDIV1.GT.20) NDIV1=20
        NDIV2=YJMAX(2)-YJMIN(2) 
        IF(NDIV2.GT.20) NDIV2=20
        IF(NDIV1.LE.1) NDIV1=2
        IF(NDIV2.LE.1) NDIV2=2
        DY1=(YJMAX(1)-YJMIN(1))/(NDIV1-1)
        DY2=(YJMAX(2)-YJMIN(2))/(NDIV2-1)
        IF(FIXYJ(1)) NDIV1=1
        IF(FIXYJ(2)) NDIV2=1
C
        DO 103 I1=1,NDIV1
          YJ(1)=YJMIN(1)+(I1-1)*DY1
          CTH(1)=TANH(YJ(1))
          STH(1)=SQRT(1.-CTH(1)**2)
          IF(STH(1).EQ.0) GOTO 103
          TH(1)=ACOS(CTH(1))
          P(1)=PT(1)/STH(1)
C
          DO 102 I2=1,NDIV2
            YJ(2)=YJMIN(2)+(I2-1)*DY2
            CTH(2)=TANH(YJ(2))
            STH(2)=SQRT(1.-CTH(2)**2)
            IF(STH(2).EQ.0) GOTO 103
            TH(2)=ACOS(CTH(2))
            P(2)=PT(2)/STH(2)
            IF(KEYS(1)) THEN
              CALL SIGQCD
            ELSEIF(KEYS(5)) THEN
              CALL SIGSSY
            ELSEIF(KEYS(6)) THEN
              CALL SIGWW
            ELSEIF(KEYS(8)) THEN
              CALL SIGGAM
            ELSEIF(KEYS(10)) THEN
              CALL SIGWH
            ENDIF
            IF(SIGMA.EQ.0.) GO TO 102
            DEV=ALOG(SIGMA)-A-B*ALOG(PT(1))
            IF(DEV.GT.DEVMAX) DEVMAX=DEV
  102     CONTINUE
  103   CONTINUE
  104 CONTINUE
C
      A=A+DEVMAX
      B1=B+2.
      PTFUN1=EXP(A)
      PTFUN2=B
C
C          Use envelope to generate initial PT values
C
      PTGEN1=PTMIN(1)**B1
      PTGEN2=PTMAX(1)**B1-PTGEN1
      PTGEN3=1./B1
      DO 109 I=1,24
  109 PCPY(I)=STOR(I)
C
C          Write envelope parameters on listing
C
      WRITE(ITLIS,200) PTFUN1,PTFUN2,PTGEN1,PTGEN2,PTGEN3
200   FORMAT(//10X,'FIT AT Y1=Y2=0 IS D(SIGMA)/D(PT**2)D(Y1)D(Y2)='
     C  ,E11.5,'*PT**(',E11.5,')'//
     C  10X,'PT FIRST GENERATED BY PT=(',E11.5,'+',E11.5,'*RANF)**(',
     C  E11.5,')')
C
      RETURN
C
C          Fixed PT
C
  300 CONTINUE
      IF(FIXPT(1)) PT(2)=PT(1)
      IF(FIXPT(2)) PT(1)=PT(2)
      P(1)=PT(1)
      P(2)=PT(2)
      IF(KEYS(1)) THEN
        CALL SIGQCD
      ELSEIF(KEYS(5)) THEN
        CALL SIGSSY
      ELSEIF(KEYS(6)) THEN
        CALL SIGWW
      ELSEIF(KEYS(8)) THEN
        CALL SIGGAM
      ELSEIF(KEYS(10)) THEN
        CALL SIGWH
      ENDIF
      SIGMAX=SIGMA
      DO 301 I=1,24
301   PCPY(I)=STOR(I)
C
      RETURN
C
C          Fit fails if SIGMA=0 in specified range
9999  WRITE(ITLIS,1010) PT(1)
1010  FORMAT(//' ERROR IN PTFUN...SIGMA=0 FOR PT = ',E12.4/
     1' CHECK YOUR LIMITS.')
      STOP 99
      END
+EOD
+DECK,QCDINI
      SUBROUTINE QCDINI(JIN1,JIN2)
C
C          GENERATE INITIAL-STATE QCD CASCADE USING BACKWARDS
C          EVOLUTION OF GOTTSCHALK AND OF SJOSTRAND.
C
C          IF QCDINI FAILS WHEN ATTEMPTING TO FORCE GL-->QK+QB FOR
C          HEAVY QUARKS, THEN RETURN NJSET=-1.
C
C          VER. 6.40: TRAP W1LIM > 0 TO PREVENT ROUNDING ERRORS.
C
+CDE,ITAPES
+CDE,IDRUN
+CDE,PINITS
+CDE,JETPAR
+CDE,QCDPAR
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,CONST
+CDE,PRIMAR
+CDE,KEYS
C
      DIMENSION BOOST1(5),BOOST2(5),B2B1(5),DBL1(5),DBL2(5)
      DIMENSION FXOLD(2),FXNEW(2)
      DIMENSION PJKEEP(5,12),JINS(2),JLIST(16),PFKEEP(5)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION DBL1,DBL2,DBLM
+SELF.
C
C          CONVERT IDENT+7 TO JETTYP
      DATA JLIST/13,11,9,7,5,3,0,2,4,6,8,10,12,0,0,1/
      ALAMF(A,B,C)=SQRT((A-B-C)**2-4.*B*C)
C
C          INITIALIZE
C
      JINS(1)=JIN1
      JINS(2)=JIN2
      DO 97 K=1,4
97    PFKEEP(K)=PJSET(K,JIN1)+PJSET(K,JIN2)
C          EXCEPT FOR HIGGS, PFKEEP**2=SHAT
      IF(KEYS(7).OR.KEYS(9)) THEN
        S1KEEP=PFKEEP(4)**2-PFKEEP(1)**2-PFKEEP(2)**2-PFKEEP(3)**2
        PFKEEP(5)=SQRT(S1KEEP)
        PPKEEP=PFKEEP(4)+PFKEEP(3)
        PMKEEP=PFKEEP(4)-PFKEEP(3)
      ELSE
        S1KEEP=SHAT
        PFKEEP(5)=SQRT(S1KEEP)
        IF(PFKEEP(3).GT.0.) THEN
          PPKEEP=PFKEEP(4)+PFKEEP(3)
          PMKEEP=(S1KEEP+PFKEEP(1)**2+PFKEEP(2)**2)/PPKEEP
        ELSE
          PMKEEP=PFKEEP(4)-PFKEEP(3)
          PPKEEP=(S1KEEP+PFKEEP(1)**2+PFKEEP(2)**2)/PMKEEP
        ENDIF
        PFKEEP(4)=.5*(PPKEEP+PMKEEP)
        PFKEEP(3)=.5*(PPKEEP-PMKEEP)
      ENDIF
      DO 98 I=1,NJSET
      DO 98 K=1,5
98    PJKEEP(K,I)=PJSET(K,I)
      NJKEEP=NJSET
      NPASS=0
      NPASS1=0
C
1     CONTINUE
      NPASS1=NPASS1+1
      IF(NPASS1.GT.100) GO TO 9999
      NJSET=NJKEEP
      DO 99 I=1,NJSET
      DO 99 K=1,5
99    PJSET(K,I)=PJKEEP(K,I)
C
      DO 100 K=1,5
100   PFINAL(K)=PFKEEP(K)
      S1=S1KEEP
      PTOTPL=PPKEEP
      PTOTMN=PMKEEP
      TCUT=CUTJET**2
      DO 101 I=1,2
      JI=JINS(I)
      XOLD=(PJSET(4,JI)+ABS(PJSET(3,JI)))/ECM
      JT=JLIST(JTYPE(JI)+7)
      FXOLD(I)=STRUC(XOLD,QSQ,JT,IDIN(I))
101   CONTINUE
C
C          DO FIRST EVOLUTION
      DO 110 I=1,2
      SGN=3-2*I
      JET=10+I
      JI=JINS(I)
      ZMIN=(PJSET(4,JI)+ABS(PJSET(3,JI)))/ECM
      ZMAX=1./(1.+TCUT/S1)
C          DZMAX=1.-ZMAX
      DZMAX=ZMAX*TCUT/S1
      IF(ZMIN.GE.ZMAX) ZMIN=.5*ZMAX
      CALL QCDINT(JI)
      JVIR(I)=JI
110   CONTINUE
C
C          SOLVE INITIAL KINEMATICS
      AM1SQ=PJSET(5,JVIR(1))**2*SIGN(1.,PJSET(5,JVIR(1)))
      AM2SQ=PJSET(5,JVIR(2))**2*SIGN(1.,PJSET(5,JVIR(2)))
      P1PL=(S1+AM1SQ-AM2SQ+ALAMF(S1,AM1SQ,AM2SQ))/(2.*PTOTMN)
      P1MN=AM1SQ/P1PL
      P2MN=(S1+AM2SQ-AM1SQ+ALAMF(S1,AM1SQ,AM2SQ))/(2.*PTOTPL)
      P2PL=AM2SQ/P2MN
      PJSET(3,JVIR(1))=.5*(P1PL-P1MN)
      PJSET(4,JVIR(1))=.5*(P1PL+P1MN)
      PJSET(3,JVIR(2))=.5*(P2PL-P2MN)
      PJSET(4,JVIR(2))=.5*(P2PL+P2MN)
C
C          TEST WHETHER NEW MASS IS PLAUSIBLE
      DO 111 I=1,2
      JI=JINS(I)
      XNEW=(PJSET(4,JI)+ABS(PJSET(3,JI)))/ECM
      IF(XNEW.GE.1.) THEN
        FXNEW(I)=0.
      ELSE
        JT=JLIST(JTYPE(JI)+7)
        FXNEW(I)=STRUC(XNEW,QSQ,JT,IDIN(I))
      ENDIF
111   CONTINUE
      DO 112 I=1,2
      IF(FXNEW(I).LT.FXOLD(I)*RANF()) GO TO 1
112   CONTINUE
C
C          FIND JVIR (SPACE-LIKE PARTON) WITH LARGER (-MASS) FOR NEXT
C          BRANCHING.
10    IF(JDCAY(JVIR(1)).GE.0.AND.JDCAY(JVIR(2)).GE.0) RETURN
      NPASS=NPASS+1
      IF(NPASS.GT.20*NJSET) GO TO 9999
      IF(-PJSET(5,JVIR(1)).GE.-PJSET(5,JVIR(2))) THEN
        IVIR=JVIR(1)
        IVIR2=JVIR(2)
        SGN=+1.
        JET=11
      ELSE
        IVIR=JVIR(2)
        IVIR2=JVIR(1)
        SGN=-1.
        JET=12
      ENDIF
C
      T1=PJSET(5,IVIR)**2
      ZMIN=(PJSET(4,IVIR)+SGN*PJSET(3,IVIR))/ECM
      ZMAX=1./(1.+T1/S1)
      DZMAX=ZMAX*T1/S1
      IF(ZMIN.GE.ZMAX) GO TO 1
C
C          GENERATE Z AND NEW PARTONS.
C          NEWV=SPACELIKE, NEWF=TIMELIKE.
      NEWV=NJSET+1
      NEWF=NJSET+2
      CALL QCDINZ(IVIR)
C
C          IF Z FAILS (BECAUSE OF STRUCTURE FUNCTION) SET NEWV=IVIR,
C          NEWF=NULL AND RE-SOLVE KINEMATICS.
15    IF(.NOT.ZGOOD) THEN
        CALL QCDINT(IVIR)
C
        PP1PL=PJSET(4,IVIR2)+PJSET(3,IVIR2)
        PP1MN=PJSET(4,IVIR2)-PJSET(3,IVIR2)
        AMSQ=PJSET(5,IVIR)**2*SIGN(1.,PJSET(5,IVIR))
        AMPSQ=PJSET(5,IVIR2)**2*SIGN(1.,PJSET(5,IVIR2))
        IF(SGN.GT.0) THEN
          P2PL=(S1-AMSQ-AMPSQ+ALAMF(S1,AMSQ,AMPSQ))/(2.*PP1MN)
          P2MN=AMSQ/P2PL
        ELSE
          P2MN=(S1-AMSQ-AMPSQ+ALAMF(S1,AMSQ,AMPSQ))/(2.*PP1PL)
          P2PL=AMSQ/P2MN
        ENDIF
        PJSET(3,IVIR)=.5*(P2PL-P2MN)
        PJSET(4,IVIR)=.5*(P2PL+P2MN)
C
        NEWV=IVIR
        DO 120 K=1,5
120     PJSET(K,NEWF)=0.
        GO TO 30
      ENDIF
C
C          EVOLVE NEW SPACELIKE PARTON.
      PJSET(5,NEWV)=PJSET(5,IVIR)
      S2=S1/ZZC(IVIR)
      ZMIN=ZMIN/ZZC(IVIR)
      ZMAX=1./(1.+TCUT/S2)
      DZMAX=ZMAX*TCUT/S2
      IF(ZMIN.GE.ZMAX) GO TO 1
      CALL QCDINT(NEWV)
C
C          CALCULATE APPROXIMATE MASS LIMIT AND DO TIMELIKE EVOLUTION.
C          VER. 6.40: TRAP W1LIM < 0 FROM ROUNDING ERRORS.
      W1LIM=T1*(1./(ZZC(IVIR)*(1.+T1/S1))-1.)
      W1LIM=AMIN1(W1LIM,T1)
      PJSET(5,NEWF)=SQRT(ABS(W1LIM))
      JDCAY(NEWF)=-1
20    CALL QCDT(NEWF)
C
C          SOLVE KINEMATICS USING +(PL) AND -(MN) COMPONENTS FOR
C          PJSET(K,NEWV)+PJSET(K,IVIR2)-->PJSET(K,NEWF)+PFINAL
C          STEP 1: SOLVE FOR P2=PJSET(K,NEWV)
      PP1PL=PJSET(4,IVIR2)+PJSET(3,IVIR2)
      PP1MN=PJSET(4,IVIR2)-PJSET(3,IVIR2)
      AMSQ=PJSET(5,NEWV)**2*SIGN(1.,PJSET(5,NEWV))
      AMPSQ=PJSET(5,IVIR2)**2*SIGN(1.,PJSET(5,IVIR2))
      W1=PJSET(5,NEWF)**2
      IF(SGN.GT.0) THEN
        P2PL=(S2-AMSQ-AMPSQ+ALAMF(S2,AMSQ,AMPSQ))/(2.*PP1MN)
        P2MN=AMSQ/P2PL
      ELSE
        P2MN=(S2-AMSQ-AMPSQ+ALAMF(S2,AMSQ,AMPSQ))/(2.*PP1PL)
        P2PL=AMSQ/P2MN
      ENDIF
C
C          STEP 2: SOLVE FOR Q1(K)=PJSET(K,IVIR)
      DEN=P2PL*PP1MN-P2MN*PP1PL
      Q1PL=(+P2PL*(S1+T1-AMPSQ)+PP1PL*(W1+T1-AMSQ))/DEN
      Q1MN=(-P2MN*(S1+T1-AMPSQ)-PP1MN*(W1+T1-AMSQ))/DEN
      WPL=P2PL-Q1PL
      WMN=P2MN-Q1MN
C          CALCULATE TRANSVERSE MOMENTUM AND REJECT IF UNPHYSICAL.
      Q1TR2=T1+Q1PL*Q1MN
      IF(Q1TR2.LT.0.) THEN
        IF(JDCAY(NEWF).EQ.-1) GO TO 20
        ZGOOD=.FALSE.
        GO TO 15
      ENDIF
C
C          DO ONE TIMELIKE BRANCHING TO INSURE CORRECT MASS. MUST FIRST
C          SHIFT NJSET TO PUT DECAY PRODUCTS IN CORRECT PLACE.
      IF(JDCAY(NEWF).EQ.-1) THEN
        NJSET=NJSET+2
        CALL QCDZ(NEWF)
        NJSET=NJSET-2
        Z1=ZZC(NEWF)
        E0=.5*(WPL+WMN)
        P0=SQRT(.25*(WPL-WMN)**2+Q1TR2)
        WM0=PJSET(5,NEWF)
        ZLIM=AMAX1((WM0/(E0+P0))**2,CUTJET/(E0+P0))
        IF(Z1.LE.ZLIM.OR.Z1.GE.1.-ZLIM) GO TO 20
        NEWF1=NEWF+1
        NEWF2=NEWF+2
        JDCAY(NEWF)=NEWF1*JPACK+NEWF2
        CALL QCDT(NEWF1)
        CALL QCDT(NEWF2)
        JORIG(NEWF1)=JPACK*JET+NEWF
        JORIG(NEWF2)=JORIG(NEWF1)
        DO 130 K=1,4
        PJSET(K,NEWF1)=0.
130     PJSET(K,NEWF2)=0.
      ENDIF
C
C          GOOD BRANCHING!
      PHIQ1=2.*PI*RANF()
      Q1TR=SQRT(Q1TR2)

      Q1X=Q1TR*COS(PHIQ1)
      Q1Y=Q1TR*SIN(PHIQ1)
C
      PJSET(1,IVIR)=Q1X
      PJSET(2,IVIR)=Q1Y
      PJSET(3,IVIR)=.5*(Q1PL-Q1MN)
      PJSET(4,IVIR)=.5*(Q1PL+Q1MN)
      JDCAY(IVIR)=JPACK*NEWV+NEWF
C
      PJSET(1,NEWV)=0.
      PJSET(2,NEWV)=0.
      PJSET(3,NEWV)=.5*(P2PL-P2MN)
      PJSET(4,NEWV)=.5*(P2PL+P2MN)
      JORIG(NEWV)=JPACK*JET+IVIR
C
      PJSET(1,NEWF)=-Q1X
      PJSET(2,NEWF)=-Q1Y
      PJSET(3,NEWF)=.5*(WPL-WMN)
      PJSET(4,NEWF)=.5*(WPL+WMN)
      JORIG(NEWF)=JPACK*JET+IVIR
C
C          BOOST ALL FINAL VECTORS (EXCEPT NEW ONES) AND RECALCULATE
C          VIRTUAL MOMENTA.  BOOST IS DETERMINED BY DIFFERENCE OF
C          NEW AND OLD TOTAL FINAL MOMENTA, B2B1=BOOST2-BOOST1.
C
30    CONTINUE
      DO 201 K=1,4
201   BOOST1(K)=PFINAL(K)
      BMASS=PFINAL(5)
      DO 202 K=1,4
202   BOOST2(K)=PJSET(K,NEWV)+PJSET(K,IVIR2)-PJSET(K,NEWF)
C
C          PARAMETERS FOR COMBINED BOOSTS.
+SELF,IF=SINGLE.
      BDOTB=BOOST1(4)*BOOST2(4)-BOOST1(1)*BOOST2(1)-BOOST1(2)*BOOST2(2)
     $-BOOST1(3)*BOOST2(3)
      DO 203 K=1,4
203   B2B1(K)=BOOST2(K)-BOOST1(K)
+SELF,IF=DOUBLE.
C          DOUBLE PRECISION FOR 32-BIT MACHINES USING 3-VECTORS AND MASS
C          AS EXACT.
      DO 204 K=1,3
      DBL1(K)=BOOST1(K)
204   DBL2(K)=BOOST2(K)
      DBLM=BMASS
      DBL1(4)=DSQRT(DBL1(1)**2+DBL1(2)**2+DBL1(3)**2+DBLM**2)
      DBL2(4)=DSQRT(DBL2(1)**2+DBL2(2)**2+DBL2(3)**2+DBLM**2)
      BDOTB=DBL1(4)*DBL2(4)-DBL1(1)*DBL2(1)-DBL1(2)*DBL2(2)
     $-DBL1(3)*DBL2(3)
      DO 205 K=1,4
205   B2B1(K)=DBL2(K)-DBL1(K)
+SELF.
      B44=BDOTB/BMASS**2
      BI41=1./BMASS
      BI42=(BDOTB-BMASS**2-B2B1(4)*BMASS)/(BMASS**2*(BOOST2(4)+BMASS))
      B4K1=BI41
      B4K2=(BMASS**2-BDOTB-B2B1(4)*BMASS)/(BMASS**2*(BOOST1(4)+BMASS))
      BIK1=-1./(BMASS*(BOOST1(4)+BMASS))
      BIK2=1./(BMASS*(BOOST2(4)+BMASS))
      BIK3=(BMASS**2-BDOTB)/(BMASS**2*(BOOST1(4)+BMASS)
     $*(BOOST2(4)+BMASS))
C
C          BOOST FINAL JETS
      DO 210 J=1,NJSET
      IF(J.EQ.IVIR.OR.J.EQ.IVIR2) GO TO 210
      IF(PJSET(5,J).LT.0.) GO TO 210
      IF(JDCAY(J).EQ.-1) GO TO 210
      BP1=0.
      BP21=0.
      DO 215 K=1,3
      BP1=BP1+BOOST1(K)*PJSET(K,J)
215   BP21=BP21+B2B1(K)*PJSET(K,J)
      DO 220 K=1,3
220   PJSET(K,J)=PJSET(K,J)
     $+(B2B1(K)*BI41+BOOST2(K)*BI42)*PJSET(4,J)
     $+B2B1(K)*BP1*BIK1+BOOST2(K)*BP21*BIK2+BOOST2(K)*BP1*BIK3
      PJSET(4,J)=B44*PJSET(4,J)+BP21*B4K1+BP1*B4K2
210   CONTINUE
C
C          SET PFINAL TO BOOST2
      DO 230 K=1,4
230   PFINAL(K)=BOOST2(K)
      PFINAL(5)=BMASS
C
C          RESET REMAINING VECTORS
      DO 240 J=NJSET,1,-1
      IF(J.EQ.IVIR.OR.J.EQ.IVIR2) GO TO 240
      IF(PJSET(5,J).GE.0.) GO TO 240
      JX1=JDCAY(J)/JPACK
      JX2=JDCAY(J)-JPACK*JX1
      DO 250 K=1,4
      PJSET(K,J)=PJSET(K,JX1)-PJSET(K,JX2)
250   DBL1(K)=PJSET(K,J)
+SELF,IF=SINGLE.
      AMJ=SQRT(ABS(DBL1(4)**2-DBL1(1)**2-DBL1(2)**2-DBL1(3)**2))
+SELF,IF=DOUBLE.
      AMJ=DSQRT(ABS(DBL1(4)**2-DBL1(1)**2-DBL1(2)**2-DBL1(3)**2))
+SELF.
      PJSET(5,J)=-AMJ
240   CONTINUE
C
C          RESET PFINAL, ETC.
+SELF,IF=SINGLE.
      DO 300 K=1,4
300   PFINAL(K)=PFINAL(K)+PJSET(K,NEWF)
      S1=PFINAL(4)**2-PFINAL(1)**2-PFINAL(2)**2-PFINAL(3)**2
      IF(S1.LT.0.) GO TO 9999
      PFINAL(5)=SQRT(S1)
      PTOTPL=PJSET(4,NEWV)+PJSET(3,NEWV)+PJSET(4,IVIR2)+PJSET(3,IVIR2)
      PTOTMN=PJSET(4,NEWV)-PJSET(3,NEWV)+PJSET(4,IVIR2)-PJSET(3,IVIR2)
+SELF,IF=DOUBLE.
C          NEED DOUBLE PRECISION ON 32-BIT MACHINES
      CALL DBLVEC(PFINAL,DBL1)
      CALL DBLVEC(PJSET(1,NEWF),DBL2)
      DO 300 K=1,4
      DBL1(K)=DBL1(K)+DBL2(K)
300   PFINAL(K)=DBL1(K)
      S1=DBL1(4)**2-DBL1(1)**2-DBL1(2)**2-DBL1(3)**2
      PFINAL(5)=SQRT(S1)
      IF(S1.LT.0.) GO TO 9999
      PFINAL(5)=SQRT(S1)
      PTOTPL=PJSET(4,NEWV)+PJSET(3,NEWV)+PJSET(4,IVIR2)+PJSET(3,IVIR2)
      PTOTMN=PJSET(4,NEWV)-PJSET(3,NEWV)+PJSET(4,IVIR2)-PJSET(3,IVIR2)
+SELF.
C
C          SET NJSET AND POINTERS IF Z WAS GOOD
      IF(.NOT.ZGOOD) GO TO 10
      NJSET=NJSET+2
      IF(JDCAY(NEWF).GT.0) NJSET=NJSET+2
      JVIR(JET-10)=NEWV
      GO TO 10
C          ERROR -- DISCARD EVENT.
9999  CONTINUE
      WRITE(ITLIS,9998) IEVT
9998  FORMAT(/' ***** ERROR IN QCDINI ... EVENT',I8,' DISCARDED *****')
      NJSET=-1
      RETURN
      END
+EOD
+DECK,QCDINT
      SUBROUTINE QCDINT(J0)
C
C          AUXILIARY ROUTINE FOR QCDINI.  GENERATE A NEW MASS FOR
C          SPACELIKE PARTON J0.
C
+CDE,ITAPES
+CDE,JETSET
+CDE,JWORK
+CDE,JWORK2
+CDE,QCDPAR
+CDE,PRIMAR
C
      DIMENSION GAMS(13),FX0S(13)
      DATA CA/3./,CF/1.333333333/
C
C          FUNCTIONS -- USE DZMAX FOR PRECISION
      GQQ(Z,DZ)=CF*(-2.*ALOG(DZ)+Z*(-1.-.5*Z))
      GQG(Z)=CF*(+2.*ALOG(Z)+Z*(-2.+.5*Z))
      GGQ(Z)=(Z**3-(1.-Z)**3)/6.
      GGG(Z,DZ)=2.*CA*(ALOG(Z/DZ)+Z*(-2.+Z*(.5-Z/3.)))
      GBQQ(RZ,DZ)=CF*(2.*ALOG((1.+RZ)**2/DZ)+RZ*(-2.-2./3.*RZ**2))
      GBQG(RZ)=CF*(-4./RZ+RZ*(-4.+2./3.*RZ**2))
C
      GLFORC(JET-10)=.FALSE.
      IDABS=IABS(JTYPE(J0))
      IF(JTYPE(J0).EQ.9) THEN
        ITYP=1
      ELSEIF(JTYPE(J0).GT.0) THEN
        ITYP=2*IDABS
      ELSE
        ITYP=2.*IDABS+1
      ENDIF
      IBEAM=JET-10
      AM0=ABS(PJSET(5,J0))
1     T0=AM0**2
      X0=ZMIN
      ANF=3
      DO 110 I=4,6
      AMQ2=AMASS(I)**2
110   ANF=ANF+T0/(AMQ2+T0)
      B0=11.-2.*ANF/3.
C
C          SET UP ANOMALOUS DIMENSIONS. ALSO USE THESE TO DETERMINE TYPE
C          OF INCOMING PARTON (TO BE USED IN QCDINZ).
C
C          GLUON
      IF(IDABS.EQ.9) THEN
        AMQ=0.
        GAMG=GGG(ZMAX,DZMAX)-GGG(ZMIN,1.-ZMIN)
        GAMS(1)=GAMG
        FX0=STRUC(X0,T0,1,IDIN(IBEAM))
        FX0S(1)=FX0
        GAMFAC=(GBQG(SQRT(ZMAX))-GBQG(SQRT(ZMIN)))/FX0
        GAMQ=0.
        DO 210 IQ=2,13
        FX0S(IQ)=STRUC(X0,T0,IQ,IDIN(IBEAM))
        GAMS(IQ)=GAMFAC*FX0S(IQ)
210     GAMQ=GAMQ+GAMS(IQ)
        GAM=GAMG+GAMQ
        AM1=CUTJET
C
        TRY=RANF()
        SUM=0.
        DO 220 IQ=1,13
        SUM=SUM+GAMS(IQ)/GAM
        IF(SUM.LT.TRY) GO TO 220
        JIN(J0)=IQ
        FXTEST(J0)=FX0S(IQ)
        GO TO 300
220     CONTINUE
C
C          LIGHT QUARK
      ELSEIF(IDABS.LE.3) THEN
        AMQ=AMASS(IDABS)
        GAMQ=GBQQ(SQRT(ZMAX),DZMAX)-GBQQ(SQRT(ZMIN),1.-ZMIN)
        FX0=STRUC(X0,T0,ITYP,IDIN(IBEAM))
        FXG=STRUC(X0,T0,1,IDIN(IBEAM))
        GAMFAC=FXG/FX0
        GAMG=GAMFAC*(GGQ(ZMAX)-GGQ(ZMIN))
        GAM=GAMQ+GAMG
        AM1=AMQ+CUTJET
C
        IF(GAMQ/GAM.GT.RANF()) THEN
          JIN(J0)=ITYP
          FXTEST(J0)=FX0
        ELSE
          JIN(J0)=1
          FXTEST(J0)=FXG
        ENDIF
C
C          HEAVY QUARK -- SPECIAL TREATMENT NEEDED TO ALWAYS FORCE
C          GL-->QK+QB BEFORE END OF EVOLUTION.
C          USE SMALLER MASS FOR FORCED DECAYS TO PREVENT INFINITE LOOP.
      ELSE
        AMQ=AMASS(IDABS)
        THRESH=4.*AMQ**2*X0/(1.-X0)
        THRESH=(SQRT(THRESH)+CUTJET)**2
        IF(STRUC(X0,T0,ITYP,IDIN(IBEAM)).LE.0..OR.
     $  T0.LE.THRESH) THEN
          PJSET(5,J0)=-AM0*SQRT(RANF())-ALAM
          GLFORC(JET-10)=.TRUE.
          JDCAY(J0)=-2
          JIN(J0)=1
          FXTEST(J0)=1.
          RETURN
        ENDIF
        T1=SQRT(T0*THRESH)
230     AM1=SQRT(T1)
        FX0=STRUC(X0,T1,ITYP,IDIN(IBEAM))
        IF(FX0.LE.0.) THEN
          T1=SQRT(T1*T0)
          GO TO 230
        ENDIF
        FXG=STRUC(X0,T1,1,IDIN(IBEAM))
        GAMFAC=FXG/FX0
        GAMQ=GQQ(ZMAX,DZMAX)-GQQ(ZMIN,1.-ZMIN)
        GAMG=GAMFAC*(GGQ(ZMAX)-GGQ(ZMIN))
        GAM=GAMQ+GAMG
C
        IF(GAMQ/GAM.GT.RANF()) THEN
          JIN(J0)=ITYP
          FXTEST(J0)=FX0
        ELSE
          JIN(J0)=1
          FXTEST(J0)=FXG
        ENDIF
      ENDIF
C
C          LEADING-LOG MASS GENERATION.
C
300   GB=2.*GAM/B0
      IF(AM1.GT.ALAM.AND.AM0.GT.ALAM) THEN
        PROBL=GB*ALOG(ALOG(AM1/ALAM)/ALOG(AM0/ALAM))
      ELSE
        PROBL=0.
      ENDIF
      IF(PROBL.GT.0.) THEN
        PROB=1.
      ELSEIF(PROBL.GT.-50.) THEN
        PROB=EXP(PROBL)
      ELSE
        PROB=0.
      ENDIF
      IF(PROB.GT.RANF()) THEN
        IF(IDABS.LE.3.OR.IDABS.EQ.9) THEN
          PJSET(5,J0)=AMQ
          JDCAY(J0)=JPACK*J0+J0
          RETURN
        ELSEIF(AM0.LT.AM1+CUTJET) THEN
          PJSET(5,J0)=-SQRT(T0)
          GLFORC(JET-10)=.TRUE.
          JDCAY(J0)=-2
          JIN(J0)=1
          FXTEST(J0)=1
          RETURN
        ELSE
          AM0=AM1
          GO TO 1
        ENDIF
      ELSE
        POW=(1.-(1.-PROB)*RANF())**(1./GB)
        AMNEW=ALAM*(AM0/ALAM)**POW
        IF(AMNEW.GE.AM1) THEN
          PJSET(5,J0)=-AMNEW
          JDCAY(J0)=-2
          RETURN
        ELSEIF(IDABS.LE.3.OR.IDABS.EQ.9) THEN
          PJSET(5,J0)=AMQ
          JDCAY(J0)=JPACK*J0+J0
          RETURN
        ELSEIF(AM0.LT.AM1+CUTJET) THEN
          PJSET(5,J0)=-AM0*SQRT(RANF())-ALAM
          GLFORC(JET-10)=.TRUE.
          JDCAY(J0)=-2
          JIN(J0)=1
          FXTEST(J0)=1
          RETURN
        ELSE
          AM0=AM1
          GO TO 1
        ENDIF
      ENDIF
      END
+EOD
+DECK,QCDINZ.
      SUBROUTINE QCDINZ(J0)
C
C          AUXILIARY ROUTINE FOR QCDINI. GENERATE A Z AND TWO DAUGHTER
C          PARTONS FOR SPACELIKE PARTON J0.
C
+CDE,ITAPES
+CDE,JETSET.
+CDE,JWORK.
+CDE,JWORK2.
+CDE,QCDPAR.
+CDE,PRIMAR
C
      DATA CA/3./,CF/1.333333333/
C          FUNCTIONS.
      PQQ(Z)=CF*(1.+Z**2)/(1.-Z)
      PQG(Z)=CF*(1.+(1.-Z)**2)/Z
      PGQ(Z)=.5*(Z**2+(1.-Z)**2)
      PGG(Z)=2.*CA*(1.-Z*(1.-Z))**2/(Z*(1.-Z))
C
C          INITIALIZE
      IDABS=IABS(JTYPE(J0))
      AM0=ABS(PJSET(5,J0))
      T0=AM0**2
      JIN0=JIN(J0)
      X0=(PJSET(4,J0)+SGN*PJSET(3,J0))/ECM
      ZGOOD=.FALSE.
      IF(ZMIN.GE.ZMAX) RETURN
C
C          SELECT BRANCHING AND GENERATE Z ACCORDING TO ALTARELLI-PARISI
C          FUNCTIONS.  THEN CHECK WITH STRUCTURE FUNCTIONS
C
C          GLUON
C
      IF(IDABS.EQ.9) THEN
C
C          GL->GL+GL
        IF(JIN0.EQ.1) THEN
110       ZGEN=DZMAX/ZMAX*(ZMAX*(1.-ZMIN)/(ZMIN*DZMAX))**RANF()
          Z=1./(1.+ZGEN)
          DZ=ZGEN/(1.+ZGEN)
          GZ=2.*CA/(Z*DZ)
          PGGZ=2.*CA*(1.-Z*(1.-Z))**2/(Z*DZ)
          IF(PGGZ.LT.GZ*RANF()) GO TO 110
          JTYPE(NJSET+1)=9
          JTYPE(NJSET+2)=9
          ZZC(J0)=Z
C
          X1=X0/Z
          FX1=STRUC(X1,T0,1,IDIN(JET-10))
          FX0=FXTEST(J0)
          IF(FX1/FX0.GT.RANF()) ZGOOD=.TRUE.
C
C          QK->GL+QK
        ELSE
120       RZMAX=SQRT(ZMAX)
          RZMIN=SQRT(ZMIN)
          ZGEN=1./RZMAX-RANF()*(1./RZMAX-1./RZMIN)
          Z=1./ZGEN**2
          RZ=SQRT(Z)
          GZ=2.*CF/RZ**3
          IF(PQG(Z)/RZ.LT.GZ*RANF()) GO TO 120
          IFL=JIN0/2
          IF(JIN0.NE.2*IFL) IFL=-IFL
          JTYPE(NJSET+1)=IFL
          JTYPE(NJSET+2)=IFL
          ZZC(J0)=Z
C
          X1=X0/Z
          FX1=STRUC(X1,T0,JIN0,IDIN(JET-10))
          FX0=FXTEST(J0)
          IF(RZ*FX1/FX0.GT.RANF()) ZGOOD=.TRUE.
        ENDIF
C
C          QUARK
C
      ELSE
C
C          GL->QK+QB
        IF(JIN0.EQ.1) THEN
130       Z=ZMIN+(ZMAX-ZMIN)*RANF()
          IF(PGQ(Z).LT..5*RANF()) GO TO 130
          JTYPE(NJSET+1)=9
          JTYPE(NJSET+2)=-JTYPE(J0)
          ZZC(J0)=Z
C
          X1=X0/Z
          FX1=STRUC(X1,T0,1,IDIN(JET-10))
          FX0=FXTEST(J0)
          IF(FX1/FX0.GT.RANF().OR.GLFORC(JET-10)) ZGOOD=.TRUE.
C
C          QK->QK+GL
        ELSE
140       DZ=DZMAX*((1.-ZMIN)/DZMAX)**RANF()
          Z=1.-DZ
          GZ=2.*CF/DZ
          RZ=1.
          IF(IDABS.LE.3) RZ=SQRT(Z)
          PQQZ=CF*(1.+Z**2)/DZ
          IF(PQQZ/RZ.LT.GZ*RANF()) GO TO 140
          JTYPE(NJSET+1)=JTYPE(J0)
          JTYPE(NJSET+2)=9
          ZZC(J0)=Z
C
          X1=X0/Z
          FX1=STRUC(X1,T0,JIN0,IDIN(JET-10))
          FX0=FXTEST(J0)
          IF(RZ*FX1/FX0.GT.RANF()) ZGOOD=.TRUE.
        ENDIF
      ENDIF
      JMATCH(NJSET+1)=0
      JMATCH(NJSET+2)=0
      RETURN
      END
+EOD
+DECK,QCDJET.
      SUBROUTINE QCDJET(NJMIN)
C
C          Carry out final state QCD jet evolution using the algorithm
C          of Fox and Wolfram.  Evolve each parton in T with fixed ZC
C          and iterate as follows--
C
C          (0) Evolve initial partons.
C          (1) Pick I and find matching J>I.
C          (2) Solve kinematics.
C          (3) For K=I,J, generate Z(K) and evolve T(K1), T(K2).  If no
C              good, evolve T(K). Otherwise, add K1 and K2 to /JETSET/.
C          (4) If I or J no good, then (2).
C          (5) Then (1).
C
C          Use Z=(E+P)/(E0+P0) and a large TCUT.
C          JMATCH(J1)=J2 if J1 and J2 match.
C          JMATCH(J)=JPACK*J1+J2 if J1,...,J2 match. Used for multiple
C          initial partons.
C          JMATCH(J)=0 for initial jet partons
C
C          Include W+- and Z0 radiation.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,PARTCL
+CDE,QCDPAR
+CDE,JETSET
+CDE,JWORK
+CDE,CONST
C
      INTEGER J,NJMIN,JPRNT,JI1,JI2,NJI,JI,NJ1,NJ2,L,K,NPTLV1,IFAIL,J0
      REAL AM0,AM1,AM2,RANF,AMSUM,PCM2,POLD2,RATIO,PSUM,P12CM,E0,P0,Z1,
     $E1MAX,P1MAX,ZMAX,E1MIN,P1MIN,ZMIN,ZEP,E1,P1,CTHCMZ,Z2,E2MAX,P2MAX,
     $E2MIN,P2MIN,P2,E2,CTHCM,STHCM,PHICM,CPHICM,SPHICM,PT0,CTH0,STH0,
     $CPHI0,SPHI0,SGN,BP,ZLIM,ZLIM1
      DIMENSION PSUM(5)
      DATA PSUM/5*0./
C
C          (0) Evolve initial parton masses.
C
      DO 100 J=NJMIN,NJSET
        J1=J
        J2=JMATCH(J)
        IF(J2.GT.JPACK) GO TO 150
        IF(J2.LE.J1) GO TO 100
C          Two partons
        IF(JDCAY(J1).EQ.-1) CALL QCDT(J1)
        IF(JDCAY(J2).EQ.-1) CALL QCDT(J2)
        JPRNT=MOD(JORIG(J),JPACK)
        IF(JPRNT.EQ.0) THEN
          AM0=PJSET(4,J1)+PJSET(4,J2)
        ELSE
          AM0=PJSET(5,JPRNT)
        ENDIF
110     AM1=PJSET(5,J1)
        AM2=PJSET(5,J2)
        IF(AM0.LE.AM1+AM2) THEN
          J3=J1
          IF(RANF().GT..5) J3=J2
          IF(JDCAY(J3).EQ.-1) CALL QCDT(J3)
          GO TO 110
        ENDIF
        GO TO 100
C          More than two partons
150     JI1=JMATCH(J)/JPACK
        IF(J.NE.JI1) GO TO 100
        JI2=JMATCH(J)-JPACK*JI1
        NJI=JI2-JI1+1
        AM0=0.
        AMSUM=0.
        DO 160 JI=JI1,JI2
          IF(JDCAY(JI).EQ.-1) CALL QCDT(JI)
          AM0=AM0+PJSET(4,JI)
          AMSUM=AMSUM+PJSET(5,JI)
160     CONTINUE
170     IF(AM0.LT.AMSUM) THEN
          J3=NJI*RANF()+JI1
          AMSUM=AMSUM-PJSET(5,J3)
          IF(JDCAY(J3).EQ.-1) CALL QCDT(J3)
          AMSUM=AMSUM+PJSET(5,J3)
          GO TO 170
        ENDIF
100   CONTINUE
C
C          (1) Loop over active partons
C
      NJ1=NJMIN
1     NJ2=NJSET
      DO 200 J=NJ1,NJ2
        J1=J
        J2=JMATCH(J1)
        NJI=2
        IF(J2.LE.J1) GO TO 200
C
C          (2) Solve kinematics.
C
C          Initial partons--keep directions fixed.
210     IF(MOD(JORIG(J),JPACK).NE.0) GO TO 230
        IF(JMATCH(J).GT.JPACK) GO TO 400
        AM0=PJSET(4,J1)+PJSET(4,J2)
        AM1=PJSET(5,J1)
        AM2=PJSET(5,J2)
        PJSET(4,J1)=(AM0**2+AM1**2-AM2**2)/(2*AM0)
        PJSET(4,J2)=(AM0**2+AM2**2-AM1**2)/(2*AM0)
        PCM2=((AM0**2-AM1**2-AM2**2)**2-(2*AM1*AM2)**2)/(4*AM0**2)
        DO 220 L=1,2
          POLD2=PJSET(1,JJ(L))**2+PJSET(2,JJ(L))**2+PJSET(3,JJ(L))**2
          RATIO=SQRT(PCM2/POLD2)
          DO 225 K=1,3
225       PJSET(K,JJ(L))=RATIO*PJSET(K,JJ(L))
220     CONTINUE
        GO TO 300
C
C          NJI.LE.5 initial partons
400     CONTINUE
        JI1=JMATCH(J)/JPACK
        IF(J.NE.JI1) GO TO 200
        JI2=JMATCH(J)-JPACK*JI1
        NJI=JI2-JI1+1
        AM0=0.
        DO 410 JI=JI1,JI2
          AM0=AM0+PJSET(4,JI)
          JJ(JI-JI1+1)=JI
          PJSET(4,JI)=SQRT(PJSET(1,JI)**2+PJSET(2,JI)**2+PJSET(3,JI)**2
     1    +PJSET(5,JI)**2)
          DO 420 K=1,5
420       PPTCL(K,NPTCL+JI-JI1+1)=PJSET(K,JI)
410     CONTINUE
        PSUM(4)=AM0
        PSUM(5)=PSUM(4)
        NPTLV1=NPTCL
        CALL RESCAL(NPTLV1+1,NPTLV1+NJI,PSUM,IFAIL)
        DO 430 JI=JI1,JI2
        DO 430 K=1,5
          PJSET(K,JI)=PPTCL(K,NPTCL+JI-JI1+1)
430     CONTINUE
        GO TO 300
C
C          Solve kinematics for general partons.
C
230     J0=MOD(JORIG(J),JPACK)
        AM0=PJSET(5,J0)
        AM1=PJSET(5,J1)
        AM2=PJSET(5,J2)
        E1CM=(AM0**2+AM1**2-AM2**2)/(2*AM0)
        E2CM=(AM0**2+AM2**2-AM1**2)/(2*AM0)
        P12CM=SQRT((AM0**2-AM1**2-AM2**2)**2-(2*AM1*AM2)**2)/(2*AM0)
        NJI=2
C          Determine E1, P1, and COS(THCM) from Z(J0).
C          Occasionally COS(TH)>1.  If so then reset Z.
        E0=PJSET(4,J0)
        P0=SQRT(PJSET(1,J0)**2+PJSET(2,J0)**2+PJSET(3,J0)**2)
        Z1=ZZC(J0)
        IF(Z1.GT.0.5) THEN
          E1MAX=(E0*E1CM+P0*P12CM)/AM0
          P1MAX=(P0*E1CM+E0*P12CM)/AM0
          ZMAX=(E1MAX+P1MAX)/(E0+P0)
          E1MIN=(E0*E1CM-P0*P12CM)/AM0
          P1MIN=(P0*E1CM-E0*P12CM)/AM0
          P1MIN=ABS(P1MIN)
          ZMIN=(E1MIN+P1MIN)/(E0+P0)
          IF(Z1.LT.ZMIN.OR.Z1.GT.ZMAX) Z1=ZMIN+Z1*(ZMAX-ZMIN)
          ZZC(J0)=Z1
          ZEP=Z1*(E0+P0)
          P1=(ZEP**2-AM1**2)/(2.*ZEP)
          E1=(ZEP**2+AM1**2)/(2.*ZEP)
          CTHCM=(E1*AM0-E0*E1CM)/(P0*P12CM)
        ELSE
          Z2=1.-Z1
          E2MAX=(E0*E2CM+P0*P12CM)/AM0
          P2MAX=(P0*E2CM+E0*P12CM)/AM0
          ZMAX=(E2MAX+P2MAX)/(E0+P0)
          E2MIN=(E0*E2CM-P0*P12CM)/AM0
          P2MIN=(P0*E2CM-E0*P12CM)/AM0
          P2MIN=ABS(P2MIN)
          ZMIN=(E2MIN+P2MIN)/(E0+P0)
          IF(Z2.LT.ZMIN.OR.Z2.GT.ZMAX) Z2=ZMIN+Z2*(ZMAX-ZMIN)
          ZZC(J0)=Z2
          ZEP=Z2*(E0+P0)
          P2=(ZEP**2-AM2**2)/(2.*ZEP)
          E2=(ZEP**2+AM2**2)/(2.*ZEP)
          CTHCM=-(E2*AM0-E0*E2CM)/(P0*P12CM)
        ENDIF
C          Avoid disaster
        IF(ABS(CTHCM).GT.1.) CTHCM=SIGN(RANF(),CTHCM)
        STHCM=SQRT(1.-CTHCM**2)
        PHICM=2*PI*RANF()
        CPHICM=COS(PHICM)
        SPHICM=SIN(PHICM)
C
C          Construct cm momenta.
        PT0=SQRT(PJSET(1,J0)**2+PJSET(2,J0)**2)
        CTH0=PJSET(3,J0)/P0
        STH0=PT0/P0
        CPHI0=PJSET(1,J0)/PT0
        SPHI0=PJSET(2,J0)/PT0
        P1CM(1)=P12CM*(CPHI0*(CTH0*CPHICM*STHCM+STH0*CTHCM)
     1  -SPHI0*SPHICM*STHCM)
        P1CM(2)=P12CM*(SPHI0*(CTH0*CPHICM*STHCM+STH0*CTHCM)
     1  +CPHI0*SPHICM*STHCM)
        P1CM(3)=P12CM*(-STH0*CPHICM*STHCM+CTH0*CTHCM)
C          Boost with P0 to get lab momenta
        DO 240 L=1,2
          SGN=3-2*L
          BP=0
          DO 241 K=1,3
241       BP=BP+PJSET(K,J0)*SGN*P1CM(K)
          BP=BP/AM0
          PJSET(4,JJ(L))=PJSET(4,J0)*EE(L)/PJSET(5,J0)+BP
          DO 242 K=1,3
242       PJSET(K,JJ(L))=SGN*P1CM(K)+PJSET(K,J0)*EE(L)/PJSET(5,J0)
     1    +PJSET(K,J0)*BP/(PJSET(4,J0)+PJSET(5,J0))
240     CONTINUE
C
C          (3) Pick Z and decay partons. Check.
C
300     CONTINUE
        TNEW=.FALSE.
        DO 310 L=1,NJI
          IF(JDCAY(JJ(L)).GE.0) GO TO 310
          IF(NJSET+2.GT.MXJSET) GO TO 9999
          CALL QCDZ(JJ(L))
          CALL QCDT(NJSET+1)
          CALL QCDT(NJSET+2)
C
C          Check whether masses allowed.
          AM0=PJSET(5,JJ(L))
          AM1=PJSET(5,NJSET+1)
          AM2=PJSET(5,NJSET+2)
          IF(AM1+AM2.GE.AM0) GO TO 320
C
C          Check whether Z allowed.
          E1CM=(AM0**2+AM1**2-AM2**2)/(2*AM0)
          E2CM=(AM0**2+AM2**2-AM1**2)/(2.*AM0)
          P12CM=SQRT((AM0**2-AM1**2-AM2**2)**2-(2*AM1*AM2)**2)/(2*AM0)
          E0=PJSET(4,JJ(L))
          P0=SQRT(PJSET(1,JJ(L))**2+PJSET(2,JJ(L))**2+PJSET(3,JJ(L))**2)
          IF(ZZC(JJ(L)).GT.0.5) THEN
            ZEP=ZZC(JJ(L))*(E0+P0)
            P1=(ZEP**2-AM1**2)/(2.*ZEP)
            E1=(ZEP**2+AM1**2)/(2.*ZEP)
            CTHCM=(E1*AM0-E0*E1CM)/(P0*P12CM)
            IF((ABS(CTHCM).GE.1..OR.P1.LE.0.).AND.IABS(JTYPE(JJ(L)))
     $      .LT.80) GO TO 320
          ELSE
            ZEP=(1.-ZZC(JJ(L)))*(E0+P0)
            P2=(ZEP**2-AM2**2)/(2.*ZEP)
            E2=(ZEP**2+AM2**2)/(2.*ZEP)
            CTHCM=-(E2*AM0-E0*E2CM)/(P0*P12CM)
            IF((ABS(CTHCM).GE.1..OR.P2.LE.0.).AND.IABS(JTYPE(JJ(L)))
     $      .LT.80) GO TO 320
          ENDIF
C
C          Require Z and 1-Z within kinematic limits.
C
          ZLIM=(AM0/(E0+P0))**2
          ZLIM1=CUTJET/(E0+P0)
          ZLIM=AMAX1(ZLIM,ZLIM1)
          IF((ZZC(JJ(L)).GT.ZLIM.AND.ZZC(JJ(L)).LT.(1.-ZLIM)).OR.
     $    IABS(JTYPE(JJ(L))).GE.80) THEN
C          Add new partons to /JETSET/.
            JDCAY(JJ(L))=JPACK*(NJSET+1)+(NJSET+2)
            NJSET=NJSET+2
            GO TO 310
          ENDIF
C          Discard partons and evolve JJ(L) again.
320       TNEW=.TRUE.
          CALL QCDT(JJ(L))
310     CONTINUE
C
C          (4) Resolve kinematics if any parton mass is changed.
C
        IF(TNEW) GO TO 210
200   CONTINUE
C
C          (5) Iterate entire proceedure.
C
      NJ1=NJ2+1
      IF(NJ1.LE.NJSET) GO TO 1
      RETURN
C
C          Error message
C
9999  CALL PRTEVT(0)
      WRITE(ITLIS,10) NJSET
10    FORMAT(//' ERROR IN QCDJET...NJSET > ',I4)
      RETURN
      END
+EOD
+DECK,QCDT.
      SUBROUTINE QCDT(J)
C
C          Auxiliary routine for QCDJET. Calculate ZC and store in 
C          ZZC(J).  Generate new mass with ZC and store in PJSET(5,J).
C
C          Must include 1/2 symmetry factor in GAMGG. No fix is needed
C          in QCDZ since GAMGG+2*GAMQQ is used as the normalization.
C
C          Include GM, W+, W-, and Z0 radiation.
C
C          Ver 7.20: Anomalous dimensions were coded incorrectly!
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETSET
+CDE,JWORK
+CDE,QCDPAR
+CDE,CONST
+CDE,WCON
+CDE,PRIMAR
C
      REAL AM0,AM1,AM2,AMASS,T0,T1,T2,ZC,B0,GAMEW,GAMQQ,GAMGG,GAM,GAMZC
      REAL AM1W,AM2W,T1W,T2W,TERM,GB,PROB,RANF,RND,POW,AMNEW,AMOLD
      REAL POWEW
      INTEGER J,JTLV1,NF,IQ,JTABS,IW,JT0,JT1,IFL1,I
      INTEGER JWTYPE(4)
      DATA JWTYPE/10,80,-80,90/
C
C          Set ZC = 0 and return for W+- or Z0
C
      JTABS=IABS(JTYPE(J))
      IF(JTABS.GE.80.AND.JTABS.LE.90) THEN
        ZZC(J)=0.
        RETURN
      ENDIF
C
C          Calculate ZC
C
      AM0=PJSET(5,J)
      JTLV1=JTYPE(J)
      AM1=AMASS(JTLV1)+CUTJET
      AM2=CUTJET
      IF(AM1+AM2.GE.AM0) GO TO 300
      T0=AM0**2
      T1=AM1**2
      T2=AM2**2
C          Fix floating point problem
C     ZC=(T0-T1+T2-SQRT((T0-T1-T2)**2-4*T1*T2))/(2*T0)
      ZC=2*T2/(T0-T1+T2+SQRT((T0-T1-T2)**2-4*T1*T2))
      ZZC(J)=ZC
C          Count light fermions
      NF=3
      DO 110 IQ=4,6
      IF(AM0.LT.2*AMASS(IQ)) GO TO 120
      NF=NF+1
110   CONTINUE
120   B0=11.-2.*NF/3.
C
C          Calculate GAMMA(ZC) and GAMEW for quarks
C
      GAMEW=0.
C
C          Initial gluon
      IF(JTABS.EQ.9) THEN
        GAMQQ=(1.-2.*ZC)*(1.-ZC*(1.-ZC))/3.
        GAMGG=12.*ALOG((1.-ZC)/ZC)-9.*(1.-2.*ZC)-6.*GAMQQ
        GAMGG=0.5*GAMGG
        GAM=GAMGG+NF*GAMQQ
C
C          Initial quark
      ELSEIF(JTABS.LT.9) THEN
        GAMZC=2.*ALOG((1-ZC)/ZC)-1.5*(1.-2.*ZC)
        GAM=4./3.*GAMZC
        GAMEW=ALFA/(2.*PI)*AQ(JTABS,1)**2*GAMZC
        IF(AM0.GT.WMASS(4)) THEN
          DO 130 IW=2,4
            JT0=2*IABS(JTYPE(J))
            IF(JTYPE(J).LT.0) JT0=JT0+1
            JT1=MATCH(JT0,IW)
            IF(JT1.EQ.0) GO TO 130
            JT1=MATCH(JT1,4)
            IFL1=JT1/2
            AM1W=AMASS(IFL1)
            AM2W=AMASS(JWTYPE(IW))
            IF(AM1W+AM2W.GE.AM0) GO TO 130
            T1W=AM1W**2
            T2W=AM2W**2
C          Fix floating underflow
C           ZC=(T0-T1W+T2W-SQRT((T0-T1W-T2W)**2-4*T1W*T2W))/(2*T0)
            ZC=2*T2W/(T0-T1W+T2W+SQRT((T0-T1W-T2W)**2-4*T1W*T2W))
            GAMZC=2.*ALOG((1-ZC)/ZC)-1.5*(1.-2.*ZC)
            TERM=(AQ(JTABS,IW)**2+BQ(JTABS,IW)**2)*GAMZC
            GAMEW=GAMEW+ALFA/(2.*PI)*TERM
130       CONTINUE
        ENDIF
C
C          Initial diquark
      ELSEIF(MOD(JTABS,100).EQ.0) THEN
        GAM=8./3.*ALOG((1-ZC)/ZC)-2.*(1.-2.*ZC)
C
C          Initial gluino
      ELSEIF(JTABS.EQ.29) THEN
        GAM=6.*ALOG((1.-ZC)/ZC)-9./2.*(1.-2.*ZC)
C
C          Initial squark
      ELSEIF(JTABS.GT.20.AND.JTABS.LT.29) THEN
        GAM = 8./3.*(ALOG((1.-ZC)/ZC)-(1.-2.*ZC))
      ENDIF
C
C          Generate new mass
C
      GB=2*GAM/B0
      PROB=(ALOG(AM1/ALAM)/ALOG(AM0/ALAM))**GB
      PROB=PROB*(AM1/AM0)**(2.*GAMEW)
      IF(PROB.GT.RANF()) GO TO 300
      RND=RANF()
      POW=(1.-(1.-PROB)*RND)**(1./GB)
      AMNEW=ALAM*(AM0/ALAM)**POW
C          For quark, add effect of GM, W+-, Z0 radiation
      IF(IABS(JTYPE(J)).LT.9) THEN
        DO 200 I=1,NTRIES
          AMOLD=AMNEW
          POWEW=POW/((AMOLD/AM0)**(2.*GAMEW))**(1./GB)
          AMNEW=ALAM*(AM0/ALAM)**POWEW
          IF(ABS(AMNEW-AMOLD).LT.0.001*AMOLD) GO TO 210
200    CONTINUE
      ENDIF
210   IF(AMNEW.LE.AM1) GO TO 300
      PJSET(5,J)=AMNEW
      RETURN
C
C          Final parton -- set mass to physical value
C
300   PJSET(5,J)=AM1-CUTJET
      JDCAY(J)=0
      RETURN
      END
+EOD
+DECK,QCDZ.
      SUBROUTINE QCDZ(J)
C
C          Auxiliary routine for QCDJET.  Generate Z for parton J and 
C          store in ZZC(J). Add possible new partons to /JETSET/.
C
C          Include GM, W+, W-, and Z0 radiation.
C
C          Ver 7.20: Anomalous dimensions were coded incorrectly!
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETSET
+CDE,JWORK
+CDE,QCDPAR
+CDE,WCON
+CDE,CONST
+CDE,Q1Q2
C
      REAL PQQ,PGQ,PQG,PGG,Z,PGSGS,PQSQS,ALFAS,QQ,AM0,ZC,AMASS
      REAL GAMQQ,GAMGG,PROBG,PROBQ,RND,RANF,ZGEN,GZ
      REAL GAMZC,GAMSUM,AM1W,AM2W,T1W,T2W,ZCW,T0,GAMZCW,TERM,SUM
      REAL SUMBR,BRMODE,TRY,HELPL,HELMN,HEL,PZ
      INTEGER NF,J,JTABS,IQ,IFL,IW,JT0,JT1,IFL1,IFL2
      INTEGER IWTYPE,JET,JW,IQ1,IQ2,JPAR,IFLPAR,NJ1,NJ2,IDABS1,IDABS2
      REAL GAMSAV(5),ZCSAV(5),BRANCH(25)
      INTEGER JSAV(5),LISTW(5),LISTJ(25)
      DATA LISTW/9,10,80,-80,90/
      DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/
C
C          Altarelli-Parisi functions.
      PQQ(Z)=4*(1+Z**2)/(3*(1-Z))
      PGQ(Z)=.5*(Z**2+(1-Z)**2)
      PGG(Z)=6*(1-Z*(1-Z))**2/(Z*(1-Z))
      PGSGS(Z)=3.*(1.+Z**2)/(1.-Z)
      PQSQS(Z)=8./3.*Z/(1.-Z)
      ALFAS(QQ)=12.*PI/((33.-2.*NF)*ALOG(QQ/ALAM2))
C
C          Initialize.
C
      AM0=PJSET(5,J)
      ZC=ZZC(J)
      JTABS=IABS(JTYPE(J))
      NF=3
      DO 110 IQ=4,6
        IF(AM0.LT.2*AMASS(IQ)) GO TO 120
        NF=NF+1
110   CONTINUE
120   CONTINUE
      NJ1=NJSET+1
      NJ2=NJSET+2        
C
C          Initial gluon
C
      IF (JTABS.EQ.9) THEN
        GAMQQ=(1-2*ZC)*(1-ZC*(1-ZC))/3.
        GAMGG=12*ALOG((1-ZC)/ZC)-9*(1-2*ZC)-6*GAMQQ
        PROBG=GAMGG/(GAMGG+2*NF*GAMQQ)
        PROBQ=GAMQQ/(GAMGG+2*NF*GAMQQ)
        RND=RANF()
C          GL--->GL+GL
        IF(PROBG.GT.RND) THEN
130       ZGEN=(ZC/(1-ZC))**(1-2*RANF())
          Z=ZGEN/(1.+ZGEN)
          GZ=6./(Z*(1.-Z))
          IF(PGG(Z).LT.GZ*RANF()) GO TO 130
          JTYPE(NJ1)=9
          JTYPE(NJ2)=9
          ZZC(J)=Z
C          GL--->QK+QB
        ELSE 
140       Z=RANF()
          IF(PGQ(Z).LT.0.5*RANF()) GO TO 140
          IFL=(RND-PROBG)/PROBQ+1.
          IF(IFL.GT.NF) IFL=NF-IFL
          JTYPE(NJ1)=IFL
          JTYPE(NJ2)=-IFL
          ZZC(J)=Z
        ENDIF
C
C          Initial quark - may radiate GL, GM, W+-, Z0
C
      ELSEIF(JTABS.LT.9) THEN
C          Gluon
        GAMZC=2.*ALOG((1-ZC)/ZC)-1.5*(1.-2.*ZC)
        GAMSAV(1)=4./3.*ALFAS(AM0**2)*GAMZC
        ZCSAV(1)=ZC
        JSAV(1)=JTYPE(J)
C          Photon
        GAMSAV(2)=ALFA*AQ(JTABS,1)**2*GAMZC
        ZCSAV(2)=ZC
        GAMSUM=GAMSAV(1)+GAMSAV(2)
        JSAV(2)=JTYPE(J)
C          W+- and Z0 
        IF(AM0.GT.WMASS(4)) THEN
          DO 200 IW=2,4
            GAMSAV(IW+1)=0.
            ZCSAV(IW+1)=.5
            JSAV(IW+1)=0
            JT0=2*IABS(JTYPE(J))
            IF(JTYPE(J).LT.0) JT0=JT0+1
            JT1=MATCH(JT0,IW)
            IF(JT1.EQ.0) GO TO 200
            JT1=MATCH(JT1,4)
            IFL1=JT1/2
            AM1W=AMASS(IFL1)
            AM2W=AMASS(LISTW(IW+1))
            IF(AM1W+AM2W.GE.AM0) GO TO 200
            T0=AM0**2
            T1W=AM1W**2
            T2W=AM2W**2
            ZCW=(T0-T1W+T2W-SQRT((T0-T1W-T2W)**2-4*T1W*T2W))/(2*T0)
            GAMZCW=2.*ALOG((1-ZCW)/ZCW)-2.*(1.-2.*ZCW)
            TERM=(AQ(JTABS,IW)**2+BQ(JTABS,IW)**2)*ALFA*GAMZCW
            GAMSAV(IW+1)=TERM
            ZCSAV(IW+1)=ZCW
            JSAV(IW+1)=IFL1*ISIGN(1,JTYPE(J))
            GAMSUM=GAMSUM+TERM
200       CONTINUE
        ELSE
          DO 210 IW=2,4
            GAMSAV(IW+1)=0.
            ZCSAV(IW+1)=.5
            JSAV(IW+1)=0
210       CONTINUE
        ENDIF
C          Select decay mode
        RND=RANF()
        SUM=0.
        DO 220 IW=1,5
          IWTYPE=IW
          SUM=SUM+GAMSAV(IW)/GAMSUM
          IF(RND.LE.SUM) GO TO 230
220     CONTINUE
C          Generate Z
230     CONTINUE
        Z=1-(ZC/(1-ZC))**RANF()*(1-ZC)
        GZ=8./(3.*(1-Z))
        IF(PQQ(Z).LT.GZ*RANF()) GO TO 230
        IF(Z.LT.ZCSAV(IWTYPE).OR.Z.GT.1.-ZCSAV(IWTYPE)) GO TO 230
        JTYPE(NJ1)=JSAV(IWTYPE)
        JTYPE(NJ2)=LISTW(IWTYPE)
        ZZC(J)=Z
C
C          Initial diquark
C
      ELSEIF(MOD(JTABS,100).EQ.0) THEN
300     CONTINUE
        Z=1-(ZC/(1-ZC))**RANF()*(1-ZC)
        GZ=8./(3.*(1-Z))
        IF(PQQ(Z).LT.GZ*RANF()) GO TO 300
        JTYPE(NJ1)=JTYPE(J)
        JTYPE(NJ2)=9
        ZZC(J)=Z
C
C          Initial gluino
C
       ELSEIF (JTABS.EQ.29) THEN
400      Z=1.-(ZC/(1.-ZC))**RANF()*(1.-ZC)
         GZ=6./(1.-Z)
         IF(PGSGS(Z) .LT. GZ*RANF()) GOTO 400
         JTYPE(NJ1)=JTYPE(J)
         JTYPE(NJ2)=9
         ZZC(J)=Z
C
C          Initial squark
C
      ELSEIF(JTABS.GT.20.AND.JTABS.LT.29) THEN
500     CONTINUE
        Z=1-(ZC/(1-ZC))**RANF()*(1-ZC)
        GZ=8./(3.*(1-Z))
        IF(PQSQS(Z).LT.GZ*RANF()) GO TO 500
        JTYPE(NJ1)=JTYPE(J)
        JTYPE(NJ2)=9
        ZZC(J)=Z
C
C          Initial W+, W-, or Z0
C
      ELSEIF(JTABS.EQ.80.OR.JTABS.EQ.90) THEN
C          Select decay mode
        IF(JTYPE(J).EQ.+80) JW=2
        IF(JTYPE(J).EQ.-80) JW=3
        IF(JTYPE(J).EQ.+90) JW=4
        TRY=RANF()
        DO 610 IQ=2,25
        IF(TRY.LT.CUMWBR(IQ,JW-1)) THEN
          IQ1=IQ
          IQ2=MATCH(IQ,JW)
          GO TO 620
        ENDIF
610     CONTINUE
620     JTYPE(NJ1)=LISTJ(IQ1)
        JTYPE(NJ2)=LISTJ(IQ2)
C          Select W helicity
        JPAR=MOD(JORIG(J),JPACK)
        IFLPAR=IABS(JTYPE(JPAR))
        HELPL=(AQ(IFLPAR,JW)-BQ(IFLPAR,JW))**2
        HELMN=(AQ(IFLPAR,JW)+BQ(IFLPAR,JW))**2
        IF(RANF()*(HELPL+HELMN).LT.HELMN) THEN
          HEL=-ISIGN(1,JTYPE(NJ1))
        ELSE
          HEL=+ISIGN(1,JTYPE(NJ1))
        ENDIF
630     Z=RANF()
        PZ=(1.+HEL*(2.*Z-1.))**2
        IF(PZ.LT.4.*RANF()) GO TO 630
        ZZC(J)=Z
      ENDIF
C
C          Set masses and flags.
C
      JET=IABS(JORIG(J))/JPACK
      JORIG(NJ1)=JPACK*JET+J
      JORIG(NJ2)=JPACK*JET+J
      IDABS1=IABS(JTYPE(NJ1))
      IDABS2=IABS(JTYPE(NJ2))
      JMATCH(NJ1)=NJ2
      JMATCH(NJ2)=NJ1
C          JDCAY=-1 implies further decay
      IF(IDABS1.LE.9.OR.(IDABS1.GT.20.AND.IDABS1.LT.30.).OR.
     $MOD(IDABS1,100).EQ.0) THEN
        PJSET(5,NJ1)=Z*AM0
        JDCAY(NJ1)=-1
      ELSEIF(IDABS1.GE.80.OR.IDABS1.LE.90) THEN
        PJSET(5,NJ1)=AMASS(IDABS1)
        JDCAY(NJ1)=-1
      ELSE
        PJSET(5,NJ1)=AMASS(IDABS1)
        JDCAY(NJ1)=0
      ENDIF
      IF(IDABS2.LE.9.OR.(IDABS2.GT.20.AND.IDABS2.LT.30.).OR.
     $MOD(IDABS2,100).EQ.0) THEN
        PJSET(5,NJ2)=(1.-Z)*AM0
        JDCAY(NJ2)=-1
      ELSEIF(IDABS2.EQ.80.OR.IDABS2.EQ.90) THEN
        PJSET(5,NJ2)=AMASS(IDABS2)
        JDCAY(NJ2)=-1
      ELSE
        PJSET(5,NJ2)=AMASS(IDABS2)
        JDCAY(NJ2)=0
      ENDIF
      RETURN
      END
+EOD
+DECK,QFUNC.
      SUBROUTINE QFUNC
C
C          Find approximate QMW and QTW dependence for DRELLYAN.
C          Set up /WGEN/ to generate QMW and QTW. Fit is
C          Non-resonant:
C            SIGMA=ANORM/(Q2/QMAX**2)**QPOW/(PT**2+RNU2)**PTPOW
C          Resonant:
C            SIGMA=ANORM/((Q**2-M**2)**2+M**2*GAM**2)
C          with appropriate M and GAM.
C
C          Ver. 6.23: Remove extension of region 1 under region 2
C                     to avoid discontinuity in d(sigma)/d(M)
C          Ver. 6.40: Scale Q**2 fit by QMAX**2 to avoid underflow
C                     problems. Must also change DRLLYN
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,DYPAR
+CDE,DYLIM
+CDE,JETPAR
+CDE,JETLIM
+CDE,Q1Q2
+CDE,WCON
+CDE,WGEN
+CDE,JETSIG
+CDE,KEYS
+CDE,HCON
+CDE,TCPAR
+CDE,XMSSM
C
      REAL QT2CUT,DPT,QMN,QMX,EM,GAM,DELM,QSTOR,SUMS,DQ,ETAX,ETA,
     $Q2,XI,ALI,SIGSAV,T1,T2,T3,T4,T5,DET,DEVMAX,PTNU,ALPTNU,ALQ2,FIT,
     $DEV,DY3,DYW,SIG00,FACTOR,FAC1,C1,B1,SUM,AL1,QMAX2
      INTEGER NDIV1,NDIV2,K,I,NQS,J,N,NDIV3,NDIV4,IW,I3,II
      DIMENSION SUMS(9)
      DIMENSION QMN(3),QMX(3)
      DIMENSION SIGSAV(20,20)
C
C          QT cutoff function
      QT2CUT(QMW)=CUTOFF*QMW**CUTPOW
C
C          Entry
C
      IF(FIXQM) THEN
        NDIV1=1
      ELSE
        NDIV1=20
      ENDIF
      IF(FIXQT) THEN
        NDIV2=1
      ELSE
        NDIV2=20
      ENDIF
C
      DPT=(PTMAX(3)-PTMIN(3))/NDIV2
      YJ(3)=0
      YW=0.
      CTH(3)=0.
      STH(3)=1.
      IF(GODY(4)) JWTYP=4
      NKL=1
      NKH=1
      QMN(1)=QMIN
      QMX(1)=QMAX
      QMAX2=QMAX**2
C
C          Define resonance region
C
      IF(KEYS(3)) THEN
        IF(JWTYP.EQ.1) GO TO 99
        EM=WMASS(JWTYP)
        GAM=WGAM(JWTYP)
        DELM=20.
      ELSEIF(KEYS(7)) THEN
        EM=HMASS
        GAM=HGAM
        DELM=.201357*EM
        DELM=AMIN1(DELM,1.5*HGAM)
        DELM=AMAX1(DELM,.1*EM)
      ELSEIF(KEYS(9)) THEN
        EM=TCMRHO
        GAM=TCGRHO
        DELM=.201357*EM
        DELM=AMIN1(DELM,1.5*TCGRHO)
        DELM=AMAX1(DELM,.1*EM)
C          No resonance region for KKG
      ELSEIF(KEYS(11)) THEN
        EM=QMAX
        GAM=0.
        DELM=0.
      ENDIF
      EMGAM=EM*GAM
      EMSQ=EM**2
C          Region limits
      QMN(2)=EM-DELM
      QMN(3)=EM+DELM
      QMX(1)=QMN(2)
      QMX(2)=QMN(3)
      NKL=1
      NKH=3
      IF(QMAX.LE.QMN(3)) NKH=2
      IF(QMAX.LE.QMN(2)) NKH=1
      IF(QMIN.GE.QMN(2)) NKL=2
      IF(QMIN.GE.QMN(3)) NKL=3
      QMX(NKH)=QMAX
      QMN(NKL)=QMIN
   99 CONTINUE
C
C            Fit over regions NKL to NKH
C            Region 1 is below resonance
C            Region 2 is inside resonance
C            Region 3 is above resonance
C            FIT=ANORM/(Q2/QMAX**2)**QPOW/(PT**2+RNU2)**PTPOW
C
      DO 100 K=1,3
        ANORM(K)=0.
        PTPOW(K)=0.
        QPOW(K)=0.
        RNU2(K)=QT2CUT(QMIN)
100   CONTINUE
C
C          Loop over regions
C
      DO 200 K=NKL,NKH
        DO 210 I=1,9
210     SUMS(I)=0
        DQ=(QMX(K)-QMN(K))/NDIV1
        NQS=NDIV1
        DO 220 I=1,NDIV2
          PT(3)=PTMIN(3)+(I-1)*DPT
          QTW=PT(3)
          P(3)=PT(3)
          RNU2(K)=QT2CUT(QMN(K))
          ETAX=PT(3)**2+RNU2(K)
          ETA=ALOG(ETAX)
          DO 230 J=1,NQS
            QMW=QMN(K)+(J-1)*DQ
            Q2=QMW*QMW
            XI=ALOG(Q2/QMAX2)
            SUMS(1)=SUMS(1)+XI
            SUMS(2)=SUMS(2)+ETA
            SUMS(5)=SUMS(5)+ETA*ETA
            SUMS(4)=SUMS(4)+XI**2
            SUMS(7)=SUMS(7)+XI*ETA
C            Cross section
            IF(KEYS(3)) THEN
              CALL SIGDY
            ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN
              CALL SIGH
            ELSEIF(KEYS(7).AND.GOMSSM) THEN
              CALL SIGHSS
            ELSEIF(KEYS(9)) THEN
              CALL SIGTC
            ELSEIF(KEYS(11)) THEN
              CALL SIGKKG
            ENDIF
            IF(SIGMA.EQ.0.) GO TO 999
            AL1=ALOG(SIGMA)
            SIGSAV(I,J)=AL1
            IF(K.EQ.2) AL1=AL1+ALOG((Q2-EM**2)**2+EMGAM**2)
            SUMS(3)=SUMS(3)+AL1
            SUMS(8)=SUMS(8)+AL1*XI
            SUMS(9)=SUMS(9)+AL1*ETA
230         CONTINUE
220      CONTINUE
C
C            Find coefficients minimizing chisq
C
        N=NQS*NDIV2
        T1=N*SUMS(7)-SUMS(1)*SUMS(2)
        T2=N*SUMS(5)-SUMS(2)**2
        T3=N*SUMS(4)-SUMS(1)**2
        T4=N*SUMS(8)-SUMS(1)*SUMS(3)
        T5=N*SUMS(9)-SUMS(2)*SUMS(3)
        IF((FIXQM.OR.K.EQ.2).AND.FIXQT) THEN
          PTPOW(K)=0.
          QPOW(K)=0.
        ELSEIF(FIXQT) THEN
          PTPOW(K)=0.
          QPOW(K)=-T4/T3
        ELSEIF(FIXQM.OR.K.EQ.2) THEN
          PTPOW(K)=-T5/T2
          QPOW(K)=0.
        ELSE
          DET=T1**2-T2*T3
          PTPOW(K)=(T5*T3-T4*T1)/DET
          QPOW(K)=(T4*T2-T1*T5)/DET
        ENDIF
        ANORM(K)=(QPOW(K)*SUMS(1)+PTPOW(K)*SUMS(2)+SUMS(3))/N
C
C          Shift fit to obtain envelope for SIGDY
C
        DEVMAX=0.
        DO 240 I=1,NDIV2
          PT(3)=PTMIN(3)+(I-1)*DPT
          PTNU=PT(3)**2+RNU2(K)
          DO 250 J=1,NDIV1
            QMW=QMN(K)+(J-1)*DQ
            Q2=QMW**2
            ALPTNU=ALOG(PTNU)
            ALQ2=ALOG(Q2/QMAX2)
            IF(K.EQ.2) THEN
              FIT=EXP(ANORM(K)-PTPOW(K)*ALPTNU
     $        -ALOG((Q2-EM**2)**2+EMGAM**2))
            ELSE
              FIT=EXP(ANORM(K)-PTPOW(K)*ALPTNU-QPOW(K)*ALQ2)
            ENDIF
            DEV=SIGSAV(I,J)-ALOG(FIT)
            IF(DEV.GT.DEVMAX) DEVMAX=DEV
250       CONTINUE
240     CONTINUE
        ANORM(K)=ANORM(K)+DEVMAX
200   CONTINUE
C
C          Shift fit to obtain envelope in YW
      NDIV3=20
      IF(STDDY) THEN
        NDIV4=1
        DY3=0.
      ELSE
        NDIV4=20
        DY3=(YJMAX(3)-YJMIN(3))/(NDIV4-1)
      ENDIF
      DYW=(YWMAX-YWMIN)/(NDIV3-1)
C
      DO 300 K=NKL,NKH
        QMW=QMN(K)
        Q2=QMW**2
        QTW=QTMIN
        PT(3)=QTW
        P(3)=PT(3)
        YW=0.
        YJ(3)=0.
        CTH(3)=0.
        STH(3)=1.
        IF(KEYS(3)) THEN
          CALL SIGDY
        ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN
          CALL SIGH
        ELSEIF(KEYS(7).AND.GOMSSM) THEN
          CALL SIGHSS
        ELSEIF(KEYS(9)) THEN
          CALL SIGTC
        ELSEIF(KEYS(11)) THEN
          CALL SIGKKG
        ENDIF
        SIG00=SIGMA
        FACTOR=1.
        DO 310 IW=1,NDIV3
          YW=YWMIN+(IW-1)*DYW
          DO 320 I3=1,NDIV4
            IF(.NOT.STDDY) THEN
              YJ(3)=YJMIN(3)+(I3-1)*DY3
              CTH(3)=TANH(YJ(3))
              STH(3)=SQRT(1.-CTH(3)**2)
              IF(STH(3).EQ.0.) GO TO 320
              TH(3)=ACOS(CTH(3))
              P(3)=PT(3)/STH(3)
            ENDIF
            IF(KEYS(3)) THEN
              CALL SIGDY
            ELSEIF(KEYS(7).AND..NOT.GOMSSM) THEN
              CALL SIGH
            ELSEIF(KEYS(7).AND.GOMSSM) THEN
              CALL SIGHSS
            ELSEIF(KEYS(9)) THEN
              CALL SIGTC
            ELSEIF(KEYS(11)) THEN
              CALL SIGKKG
            ENDIF
            FAC1=SIGMA/SIG00
            FACTOR=AMAX1(FACTOR,FAC1)
320       CONTINUE
310     CONTINUE
        ANORM(K)=ALOG(FACTOR)+ANORM(K)
300   CONTINUE
C
C          Set up generating constants for PT**2 and QMW**2
C
      DO 400 K=NKL,NKH
        C1=1.-PTPOW(K)
        PTGN(1,K)=(PTMIN(3)**2+RNU2(K))**C1
        PTGN(2,K)=(PTMAX(3)**2+RNU2(K))**C1-PTGN(1,K)
        PTGN(3,K)=1./C1
        IF(K.EQ.2) THEN
          QGEN(1,2)=ATAN((QMN(2)**2-EMSQ)/EMGAM)
          QGEN(2,2)=ATAN((QMX(2)**2-EMSQ)/EMGAM)-QGEN(1,2)
          QGEN(3,2)=EMGAM
        ELSE
          B1=1.-QPOW(K)
          QGEN(1,K)=(QMN(K)/QMAX)**(2.*B1)
          QGEN(2,K)=(QMX(K)/QMAX)**(2.*B1)-QGEN(1,K)
          QGEN(3,K)=1./B1
        ENDIF
400   CONTINUE
C
      DO 410 K=1,3
410   QSELWT(K)=0.
      SUM=0.
C
      DO 420 K=NKL,NKH
        QSELWT(K)=1.
        IF(.NOT.FIXQT) QSELWT(K)=QSELWT(K)*PTGN(2,K)*PTGN(3,K)
        IF(.NOT.FIXQM) THEN
          IF(K.EQ.2) THEN
            QSELWT(K)=QSELWT(K)*QGEN(2,K)/EMGAM
          ELSE
            QSELWT(K)=QMAX**2*QSELWT(K)*QGEN(2,K)*QGEN(3,K)
          ENDIF
        ENDIF
        QSELWT(K)=EXP(ALOG(QSELWT(K))+ANORM(K))
        SUM=SUM+QSELWT(K)
420   CONTINUE
C
      DO 430 K=1,3
        QSELWT(K)=QSELWT(K)/SUM
430   CONTINUE
C
C          Write fit to output
C
      WRITE(ITLIS,4301)
4301  FORMAT(//10X,' QT AND Q FIRST GENERATED BY--'/)
      DO 440 K=NKL,NKH
        WRITE(ITLIS,4402) K,QMN(K),QMX(K)
4402    FORMAT(//5X,' REGION',I2,5X,E11.4,' < Q < ',E11.5)
        WRITE(ITLIS,4403) (PTGN(II,K),II=1,3),RNU2(K)
4403    FORMAT(/' QT**2 = (',E11.4,' + ',E11.4,' * RANF) ** ',E11.4,
     $  ' - ',E11.4)
        IF(K.NE.2) THEN
          WRITE(ITLIS,4404) QMAX2,(QGEN(II,K),II=1,3)
4404      FORMAT(/' Q**2  = ',E11.4,' * (',E11.4,' + ',E11.4,
     $    ' * RANF) ** ',E11.4)
        ELSE
          WRITE(ITLIS,4505) QGEN(3,K),QGEN(1,K),QGEN(2,K),EMSQ
4505       FORMAT(/' Q**2  = ',E11.4,' * TAN(',E11.4,' + ',E11.4,
     $    ' * RANF) + ',E11.4)
        ENDIF
        WRITE(ITLIS,4506) QSELWT(K)
4506    FORMAT(/' WEIGHT = ',E11.4)
440   CONTINUE
C
C          Set fixed limits if any
C
      IF(FIXQT) THEN
        PTMAX(3)=PTMIN(3)
        PT(3)=PTMIN(3)
        QTW=PT(3)
      ENDIF
      IF(FIXQM) THEN
        QMAX=QMIN
        QMW=QMIN
      ENDIF
      RETURN
C
C          Fit fails if SIGMA=0 in allowed range
C
999   WRITE(ITLIS,9990) QMW,QTW
9990  FORMAT(//' ERROR IN QFUNC...SIGMA=0 FOR QMW = ',E12.4,' , QTW = ',
     1E12.4/' CHECK YOUR LIMITS')
      STOP 99
      END
+EOD
+DECK,RANF,IF=RANFFTN,IF=NORANLUX.
          REAL FUNCTION RANF()
C
C         Kernlib routine G900 in CERN Program Library
C         7.70: Check ranf<1
C
          DOUBLE PRECISION    DRANF,    G900GT,   G900ST
          DOUBLE PRECISION    DS(2),    DM(2),    DSEED
          DOUBLE PRECISION    DX24,     DX48
          DOUBLE PRECISION    DL,       DC,       DU,       DR
          LOGICAL             SINGLE
          DATA      DS     /  1665 1885.D0, 286 8876.D0  /
          DATA      DM     /  1518 4245.D0, 265 1554.D0  /
          DATA      DX24   /  1677 7216.D0  /
          DATA      DX48   /  281 4749 7671 0656.D0  /
          SINGLE  =  .TRUE.
          GOTO 10
          ENTRY DRANF()
          SINGLE  =  .FALSE.
  10      DL  =  DS(1) * DM(1)
          DC  =  DINT(DL/DX24)
          DL  =  DL - DC*DX24
          DU  =  DS(1)*DM(2) + DS(2)*DM(1) + DC
          DS(2)  =  DU - DINT(DU/DX24)*DX24
          DS(1)  =  DL
          DR     =  (DS(2)*DX24 + DS(1)) / DX48
          IF(SINGLE)  THEN
             RANF  =  SNGL(DR)
             IF(RANF.GE.1) GO TO 10
          ELSE
             DRANF  =  DR
          ENDIF
          RETURN
          ENTRY G900GT()
          G900GT  =  DS(2)*DX24 + DS(1)
          RETURN
          ENTRY G900ST(DSEED)
          DS(2)  =  DINT(DSEED/DX24)
          DS(1)  =  DSEED - DS(2)*DX24
          G900ST =  DS(1)
          RETURN
          END
          SUBROUTINE RANGET(SEED)
          DOUBLE PRECISION    SEED,     G900GT,   G900ST,   DUMMY
          SEED  =  G900GT()
          RETURN
          ENTRY RANSET(SEED)
          DUMMY  =  G900ST(SEED)
          RETURN
          END
+EOD.
+DECK,RANFGT,IF=NORANLUX.
      SUBROUTINE RANFGT(SEED)
C
C          Get seed for RANF() in real or double precision SEED.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+SELF,IF=SINGLE
      REAL SEED
+SELF,IF=DOUBLE
      DOUBLE PRECISION SEED
+SELF
+SELF,IF=RANFCALL
      CALL RANGET(SEED)
+SELF,IF=CRAY
      INTEGER ISEED,RANGET,IDUMMY
      ISEED=RANGET(IDUMMY)
      SEED=ISEED
+SELF
      RETURN
      END
+EOD
+DECK,RANFLUX,IF=RANLUX.
      REAL FUNCTION RANF()
C
C          Call RANLUX instead of 48-bit congruental generator RANF
C          Dummy RANFGT/RANFST/RANFMT
C
      DIMENSION X(1)
      CALL RANLUX(X,1)
      RANF=X(1)
      RETURN
      END
C
      SUBROUTINE RANFGT(SEED)
      RETURN
      END
      SUBROUTINE RANFST(SEED)
      DOUBLE PRECISION SEED
      RETURN
      END
      SUBROUTINE RANFMT
      RETURN
      END
+EOD
+DECK,RANFMT,IF=NORANLUX.
      SUBROUTINE RANFMT
C
C          Get RANF seed and translate it to a character variable
C          to ensure exactly the same seed with a formatted read.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SEED.
+SELF,IF=SINGLE
      REAL SEED
+SELF,IF=DOUBLE.
      DOUBLE PRECISION SEED
+SELF.
      CALL RANFGT(SEED)
      WRITE(XSEED,'(E24.15)') SEED
      READ(XSEED,'(E24.15)') SEED
      CALL RANFST(SEED)
      RETURN
      END
+EOD
+DECK,RANFST,IF=NORANLUX.
      SUBROUTINE RANFST(SEED)
C
C          Set seed for RANF() from real or double precision SEED
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+SELF,IF=SINGLE
      REAL SEED
+SELF,IF=DOUBLE
      DOUBLE PRECISION SEED
+SELF
+SELF,IF=RANFCALL
      CALL RANSET(SEED)
+SELF,IF=CRAY
      INTEGER ISEED
      ISEED=SEED
      CALL RANSET(ISEED)
+SELF
      RETURN
      END
+EOD
+DECK,RANLUX,IF=RANLUX
      SUBROUTINE RANLUX(RVEC,LENV)
C         Subtract-and-borrow random number generator proposed by
C         Marsaglia and Zaman, implemented by F. James with the name
C         RCARRY in 1991, and later improved by Martin Luescher
C         in 1993 to produce "Luxury Pseudorandom Numbers".
C     Fortran 77 coded by F. James, 1993
C
C     Modified from 1999 CERN Program Library by F. Paige:
C     CPP call removed (unused)
C     Use ITLIS for output
C
C   LUXURY LEVELS.
C   ------ ------      The available luxury levels are:
C
C  level 0  (p=24): equivalent to the original RCARRY of Marsaglia
C           and Zaman, very long period, but fails many tests.
C  level 1  (p=48): considerable improvement in quality over level 0,
C           now passes the gap test, but still fails spectral test.
C  level 2  (p=97): passes all known tests, but theoretically still
C           defective.
C  level 3  (p=223): DEFAULT VALUE.  Any theoretically possible
C           correlations have very small chance of being observed.
C  level 4  (p=389): highest possible luxury, all 24 bits chaotic.
C
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C!!!  Calling sequences for RANLUX:                                  ++
C!!!      CALL RANLUX (RVEC, LEN)   returns a vector RVEC of LEN     ++
C!!!                   32-bit random floating point numbers between  ++
C!!!                   zero (not included) and one (also not incl.). ++
C!!!      CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from  ++
C!!!               one 32-bit integer INT and sets Luxury Level LUX  ++
C!!!               which is integer between zero and MAXLEV, or if   ++
C!!!               LUX .GT. 24, it sets p=LUX directly.  K1 and K2   ++
C!!!               should be set to zero unless restarting at a break++ 
C!!!               point given by output of RLUXAT (see RLUXAT).     ++
C!!!      CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++
C!!!               which can be used to restart the RANLUX generator ++
C!!!               at the current point by calling RLUXGO.  K1 and K2++
C!!!               specify how many numbers were generated since the ++
C!!!               initialization with LUX and INT.  The restarting  ++
C!!!               skips over  K1+K2*E9   numbers, so it can be long.++
C!!!   A more efficient but less convenient way of restarting is by: ++
C!!!      CALL RLUXIN(ISVEC)    restarts the generator from vector   ++
C!!!                   ISVEC of 25 32-bit integers (see RLUXUT)      ++
C!!!      CALL RLUXUT(ISVEC)    outputs the current values of the 25 ++
C!!!                 32-bit integer seeds, to be used for restarting ++
C!!!      ISVEC must be dimensioned 25 in the calling program        ++
C!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+CDE,ITAPES
C
      DIMENSION RVEC(LENV)
      DIMENSION SEEDS(24), ISEEDS(24), ISDEXT(25)
      PARAMETER (MAXLEV=4, LXDFLT=3)
      DIMENSION NDSKIP(0:MAXLEV)
      DIMENSION NEXT(24)
      PARAMETER (TWOP12=4096., IGIGA=1000000000,JSDFLT=314159265)
      PARAMETER (ITWO24=2**24, ICONS=2147483563)
      SAVE NOTYET, I24, J24, CARRY, SEEDS, TWOM24, TWOM12, LUXLEV
      SAVE NSKIP, NDSKIP, IN24, NEXT, KOUNT, MKOUNT, INSEED
      INTEGER LUXLEV
      LOGICAL NOTYET
      DATA NOTYET, LUXLEV, IN24, KOUNT, MKOUNT /.TRUE., LXDFLT, 0,0,0/
      DATA I24,J24,CARRY/24,10,0./
C                               default
C  Luxury Level   0     1     2   *3*    4
      DATA NDSKIP/0,   24,   73,  199,  365 /
Corresponds to p=24    48    97   223   389
C     time factor 1     2     3     6    10   on slow workstation
C                 1    1.5    2     3     5   on fast mainframe
C
C  NOTYET is .TRUE. if no initialization has been performed yet.
C              Default Initialization by Multiplicative Congruential
      IF (NOTYET) THEN
         NOTYET = .FALSE.
         JSEED = JSDFLT  
         INSEED = JSEED
         WRITE(ITLIS,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ',JSEED
         LUXLEV = LXDFLT
         NSKIP = NDSKIP(LUXLEV)
         LP = NSKIP + 24
         IN24 = 0
         KOUNT = 0
         MKOUNT = 0
         WRITE(ITLIS,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL =  ',
     +        LUXLEV,'      p =',LP
            TWOM24 = 1.
         DO 25 I= 1, 24
            TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
   25    CONTINUE
         TWOM12 = TWOM24 * 4096.
         DO 50 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
   50    CONTINUE
         NEXT(1) = 24
         I24 = 24
         J24 = 10
         CARRY = 0.
         IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
      ENDIF
C
C          The Generator proper: "Subtract-with-borrow",
C          as proposed by Marsaglia and Zaman,
C          Florida State University, March, 1989
C
      DO 100 IVEC= 1, LENV
      UNI = SEEDS(J24) - SEEDS(I24) - CARRY 
      IF (UNI .LT. 0.)  THEN
         UNI = UNI + 1.0
         CARRY = TWOM24
      ELSE
         CARRY = 0.
      ENDIF
      SEEDS(I24) = UNI
      I24 = NEXT(I24)
      J24 = NEXT(J24)
      RVEC(IVEC) = UNI
C  small numbers (with less than 12 "significant" bits) are "padded".
      IF (UNI .LT. TWOM12)  THEN
         RVEC(IVEC) = RVEC(IVEC) + TWOM24*SEEDS(J24)
C        and zero is forbidden in case someone takes a logarithm
         IF (RVEC(IVEC) .EQ. 0.)  RVEC(IVEC) = TWOM24*TWOM24
      ENDIF
C        Skipping to luxury.  As proposed by Martin Luscher.
      IN24 = IN24 + 1
      IF (IN24 .EQ. 24)  THEN
         IN24 = 0
         KOUNT = KOUNT + NSKIP
         DO 90 ISK= 1, NSKIP
         UNI = SEEDS(J24) - SEEDS(I24) - CARRY
         IF (UNI .LT. 0.)  THEN
            UNI = UNI + 1.0
            CARRY = TWOM24
         ELSE
            CARRY = 0.
         ENDIF
         SEEDS(I24) = UNI
         I24 = NEXT(I24)
         J24 = NEXT(J24)
   90    CONTINUE
      ENDIF
  100 CONTINUE
      KOUNT = KOUNT + LENV
      IF (KOUNT .GE. IGIGA)  THEN
         MKOUNT = MKOUNT + 1
         KOUNT = KOUNT - IGIGA
      ENDIF
      RETURN
C
C           Entry to input and float integer seeds from previous run
      ENTRY RLUXIN(ISDEXT)
         NOTYET = .FALSE.
         TWOM24 = 1.
         DO 195 I= 1, 24
         NEXT(I) = I-1
  195    TWOM24 = TWOM24 * 0.5
         NEXT(1) = 24
         TWOM12 = TWOM24 * 4096.
      WRITE(ITLIS,'(A)') 
     $' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:'
      WRITE(ITLIS,'(5X,5I12)') ISDEXT
      DO 200 I= 1, 24
      SEEDS(I) = REAL(ISDEXT(I))*TWOM24
  200 CONTINUE
      CARRY = 0.
      IF (ISDEXT(25) .LT. 0)  CARRY = TWOM24
      ISD = IABS(ISDEXT(25))
      I24 = MOD(ISD,100)
      ISD = ISD/100
      J24 = MOD(ISD,100)
      ISD = ISD/100
      IN24 = MOD(ISD,100)
      ISD = ISD/100
      LUXLEV = ISD
        IF (LUXLEV .LE. MAXLEV) THEN
          NSKIP = NDSKIP(LUXLEV)
          WRITE (ITLIS,'(A,I2)') 
     $    ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ',
     +                         LUXLEV
        ELSE  IF (LUXLEV .GE. 24) THEN
          NSKIP = LUXLEV - 24
          WRITE (ITLIS,'(A,I5)') 
     $    ' RANLUX P-VALUE SET BY RLUXIN TO:',LUXLEV
        ELSE
          NSKIP = NDSKIP(MAXLEV)
          WRITE (ITLIS,'(A,I5)') 
     $    ' RANLUX ILLEGAL LUXURY RLUXIN: ',LUXLEV
          LUXLEV = MAXLEV
        ENDIF
      INSEED = -1
      RETURN
C
C                    Entry to ouput seeds as integers
      ENTRY RLUXUT(ISDEXT)
      DO 300 I= 1, 24
         ISDEXT(I) = INT(SEEDS(I)*TWOP12*TWOP12)
  300 CONTINUE
      ISDEXT(25) = I24 + 100*J24 + 10000*IN24 + 1000000*LUXLEV
      IF (CARRY .GT. 0.)  ISDEXT(25) = -ISDEXT(25)
      RETURN
C
C                    Entry to output the "convenient" restart point
      ENTRY RLUXAT(LOUT,INOUT,K1,K2)
      LOUT = LUXLEV
      INOUT = INSEED
      K1 = KOUNT
      K2 = MKOUNT
      RETURN
C
C                    Entry to initialize from one or three integers
      ENTRY RLUXGO(LUX,INS,K1,K2)
         IF (LUX .LT. 0) THEN
            LUXLEV = LXDFLT
         ELSE IF (LUX .LE. MAXLEV) THEN
            LUXLEV = LUX
         ELSE IF (LUX .LT. 24 .OR. LUX .GT. 2000) THEN
            LUXLEV = MAXLEV
            WRITE (ITLIS,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ',LUX
         ELSE
            LUXLEV = LUX
            DO 310 ILX= 0, MAXLEV
              IF (LUX .EQ. NDSKIP(ILX)+24)  LUXLEV = ILX
  310       CONTINUE
         ENDIF
      IF (LUXLEV .LE. MAXLEV)  THEN
         NSKIP = NDSKIP(LUXLEV)
         WRITE(ITLIS,'(A,I2,A,I4)') 
     $   ' RANLUX LUXURY LEVEL SET BY RLUXGO :',
     +        LUXLEV,'     P=', NSKIP+24
      ELSE
          NSKIP = LUXLEV - 24
          WRITE (ITLIS,'(A,I5)') 
     $    ' RANLUX P-VALUE SET BY RLUXGO TO:',LUXLEV
      ENDIF
      IN24 = 0
      IF (INS .LT. 0)  WRITE (ITLIS,'(A)')   
     +   ' Illegal initialization by RLUXGO, negative input seed'
      IF (INS .GT. 0)  THEN
        JSEED = INS
        WRITE(ITLIS,'(A,3I12)') 
     $  ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS',
     +      JSEED, K1,K2
      ELSE
        JSEED = JSDFLT
        WRITE(ITLIS,'(A)')
     $  ' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED'
      ENDIF
      INSEED = JSEED
      NOTYET = .FALSE.
      TWOM24 = 1.
         DO 325 I= 1, 24
           TWOM24 = TWOM24 * 0.5
         K = JSEED/53668
         JSEED = 40014*(JSEED-K*53668) -K*12211
         IF (JSEED .LT. 0)  JSEED = JSEED+ICONS
         ISEEDS(I) = MOD(JSEED,ITWO24)
  325    CONTINUE
      TWOM12 = TWOM24 * 4096.
         DO 350 I= 1,24
         SEEDS(I) = REAL(ISEEDS(I))*TWOM24
         NEXT(I) = I-1
  350    CONTINUE
      NEXT(1) = 24
      I24 = 24
      J24 = 10
      CARRY = 0.
      IF (SEEDS(24) .EQ. 0.) CARRY = TWOM24
C        If restarting at a break point, skip K1 + IGIGA*K2
C        Note that this is the number of numbers delivered to
C        the user PLUS the number skipped (if luxury .GT. 0).
      KOUNT = K1
      MKOUNT = K2
      IF (K1+K2 .NE. 0)  THEN
        DO 500 IOUTER= 1, K2+1
          INNER = IGIGA
          IF (IOUTER .EQ. K2+1)  INNER = K1
          DO 450 ISK= 1, INNER
            UNI = SEEDS(J24) - SEEDS(I24) - CARRY 
            IF (UNI .LT. 0.)  THEN
               UNI = UNI + 1.0
               CARRY = TWOM24
            ELSE
               CARRY = 0.
            ENDIF
            SEEDS(I24) = UNI
            I24 = NEXT(I24)
            J24 = NEXT(J24)
  450     CONTINUE
  500   CONTINUE
C         Get the right value of IN24 by direct calculation
        IN24 = MOD(KOUNT, NSKIP+24)
        IF (MKOUNT .GT. 0)  THEN
           IZIP = MOD(IGIGA, NSKIP+24)
           IZIP2 = MKOUNT*IZIP + IN24
           IN24 = MOD(IZIP2, NSKIP+24)
        ENDIF
C       Now IN24 had better be between zero and 23 inclusive
        IF (IN24 .GT. 23) THEN
           WRITE (ITLIS,'(A/A,3I11,A,I5)')  
     +    '  Error in RESTARTING with RLUXGO:','  The values', INS,
     +     K1, K2, ' cannot occur at luxury level', LUXLEV
           IN24 = 0
        ENDIF
      ENDIF
      RETURN
      END
+EOD
+DECK,READIN.
      SUBROUTINE READIN(IFL)
C
C       Read in user data and execute SETTYP if appropriate values 
C       are set. IFL return values:
C       IFL = 0       Good parameter set
C       IFL = 1001    Stop
C       IFL > 0       Error. Program will continue reading data but
C                     will exit when END or unrecognizable keyword
C                     is found.
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,MBGEN
+CDE,FORCE
+CDE,DKYTAB
+CDE,QCDPAR
+CDE,EEPAR
+CDE,IDRUN
+CDE,FRGPAR
+CDE,KEYS
+CDE,KKGRAV
+CDE,PRTOUT
+CDE,SEED
+CDE,TYPES
+CDE,PRIMAR
+CDE,JETLIM
+CDE,NODCAY   
+CDE,WCON
+CDE,DYLIM
+CDE,QLMASS
+CDE,Q1Q2
+CDE,JETPAR
+CDE,ISLOOP
+CDE,TCPAR
+CDE,XMSSM
+CDE,SUGNU
+CDE,W50510,T=PASS,IF=PDFLIB
+CDE,W50517,T=PASS,IF=PDFLIB
+CDE,HCON
+CDE,MGLIMS
+CDE,LUXPAR
C
      LOGICAL SETTYP,DUMY
      CHARACTER*8 TTL(10),WORD,LSTRUC,BLANK
      CHARACTER*8 WTYP(4),RDID(2)
      CHARACTER*40 V,VISAJE
      INTEGER NLAP(3,17)
      INTEGER IDANTI,ID,IDB
      INTEGER IFL,I1,I2,I3,J1,I,IKEY,IJ,J,KK,IDABS
      INTEGER IDXQKL,IDXQKR
      INTEGER NSEL,K,KFORCE(5),INDEX,IDG1,IDG2,IDG3,IDG4,IDXLEP
      REAL AMW,AMZ
      CHARACTER*8 HTYPE
      INTEGER JLIM1,JLIM2
      REAL AMLIM1,AMLIM2
+SELF,IF=SINGLE.
      REAL    SEED
+SELF,IF=DOUBLE.
      DOUBLE PRECISION SEED
+SELF.
+SELF,IF=PDFLIB
      CHARACTER*20 PDFPAR(20)
+SELF,IF=PDFLIB,IF=SINGLE
      REAL PDFVAL(20)
      REAL DX,DSCALE,DXPDF(-6:6)
+SELF,IF=PDFLIB,IF=DOUBLE
      DOUBLE PRECISION PDFVAL(20)
      DOUBLE PRECISION DX,DSCALE,DXPDF(-6:6)
+SELF
C
C          Overlapping variable flags.
      DATA NLAP/1,2,3, 1,2,7 ,1,2,8, 1,3,5, 1,3,6, 1,3,7, 1,3,8, 1,5,7,
     X          1,5,8, 1,6,7, 1,6,8, 2,3,7, 2,3,8, 3,5,7, 3,6,7, 3,5,8,
     X          3,6,8/
      DATA BLANK/'        '/
C
C          Entry
      IFL=0
      V=VISAJE()
      WRITE(ITLIS,10) V
10    FORMAT('1',//5X,'*****  ',A40,'  *****')
      WRITE(ITLIS,11)
   11 FORMAT(////30X,' COMMANDS READ BY READIN')
C
C          Read title
C
      READ(ITCOM,1) TTL
    1 FORMAT(10A8)
      WRITE(ITLIS,2) TTL
    2 FORMAT(' ',10A8)
      IF(TTL(1).EQ.'STOP    ') THEN
        IFL=1001
        RETURN
      ENDIF
C
C          Read energy and no. of events
C
      READ(ITCOM,*) ECM,NEVENT,NEVPRT,NJUMP
      WRITE(ITLIS,*) ECM,NEVENT,NEVPRT,NJUMP
C
C          Reset all variables and set process if title is not 'SAME'
C
      IF(TTL(1).NE.'SAME    ') THEN
        DO 20 I=1,10
   20   TITLE(I)=TTL(I)
        CALL RESET
        KEYON=.FALSE.
C          Read reaction
        READ(ITCOM,3) REAC
    3   FORMAT(A8)
        WRITE(ITLIS,4) REAC
   4    FORMAT(1X,A8)
        DO 18 I=1,MXKEYS
18      KEYS(I)=.FALSE.
        KEYON=.FALSE.
C          Set KEYS and NJET
        IF(REAC.EQ.'TWOJET  ') THEN
          KEYS(1)=.TRUE.
          IKEY=1
          NJET=2
        ELSEIF(REAC.EQ.'E+E-    ') THEN
          KEYS(2)=.TRUE.
          IKEY=2
          NJET=2
          IDIN(1)=12
          IDIN(2)=-12
        ELSEIF(REAC.EQ.'DRELLYAN') THEN
          KEYS(3)=.TRUE.
          IKEY=3
          NJET=3
        ELSEIF(REAC.EQ.'MINBIAS ') THEN
          KEYS(4)=.TRUE.
          IKEY=4
          NJET=0
        ELSEIF(REAC.EQ.'SUPERSYM'.OR.REAC.EQ.'SUSY    ') THEN
          KEYS(5)=.TRUE.
          IKEY=5
          NJET=2
        ELSEIF(REAC.EQ.'WPAIR   ') THEN
          KEYS(6)=.TRUE.
          IKEY=6
          NJET=2
        ELSEIF(REAC.EQ.'HIGGS   ') THEN
          KEYS(7)=.TRUE.
          IKEY=7
          NJET=2
        ELSEIF(REAC.EQ.'PHOTON  ') THEN
          KEYS(8)=.TRUE.
          IKEY=8
          NJET=2
        ELSEIF(REAC.EQ.'TCOLOR  ') THEN
          KEYS(9)=.TRUE.
          IKEYS=9
          NJET=2
        ELSEIF(REAC.EQ.'WHIGGS  ') THEN
          KEYS(10)=.TRUE.
          IKEY=10
          NJET=2
        ELSEIF(REAC.EQ.'EXTRADIM') THEN
          KEYS(11)=.TRUE.
          IKEY=11
          NJET=3
        ELSEIF(REAC.EQ.'ZJJ     ') THEN
          KEYS(12)=.TRUE.
          IKEY=12
          NJET=3
        ELSE
          KEYON=.FALSE.
  890     WRITE(ITLIS,1999)
          IFL=9
          RETURN
        ENDIF
      ENDIF
C
      SCM=ECM**2
      HALFE=ECM/2
      NSEL=0
C
C          Read keyword. For each recognized keyword read corresponding
C          variables and set LOC flag.
C
      NSEL=0
100   CONTINUE
      READ(ITCOM,3) WORD
      WRITE(ITLIS,4) WORD
      NSEL=NSEL+1
C
C          Keyword END
      IF(WORD.EQ.'END     ') THEN
C          Check for previous error
        IF(IFL.NE.0) RETURN
C          Check inconsistent limits
        IF(LOC(2)*LOC(5).NE.0.OR.LOC(2)*LOC(6).NE.0) THEN
          WRITE(ITLIS,2001)
          IFL=11
        ENDIF
C          Set and check jet types
        IF(LOC(15).NE.0.OR.LOC(37).NE.0.OR.LOC(46).NE.0) THEN
          IF(SETTYP(0)) THEN
            WRITE(ITLIS,2006)
            IFL=12
          ENDIF
        ENDIF
C          Check MSSM/SUGRA conflict
        IF((LOC(51).NE.0.OR.LOC(52).NE.0.OR.LOC(53).NE.0).AND.
     $  LOC(55).NE.0) THEN
          WRITE(ITLIS,2007)
          IFL=29
        ENDIF
C          Check overlapping limits
        DO 120 I=1,17
          I1=NLAP(1,I)
          I2=NLAP(2,I)
          I3=NLAP(3,I)
          IF(LOC(I1)*LOC(I2)*LOC(I3).NE.0) WRITE(ITLIS,1001)
  120   CONTINUE
C          Setup PDFLIB
+SELF,IF=PDFLIB
        IF(ISTRUC.EQ.-999) THEN
          WRITE(ITLIS,1200)
1200      FORMAT(//
     $    '1********************************'/
     $    ' *                              *'/
     $    ' * INITIALIZE PDFLIB FOR ISAJET *'/
     $    ' *                              *'/
     $    ' ********************************'/)
          N6=ITLIS
          IFLPRT=2
          CALL PDFSET(PDFPAR,PDFVAL)
          CALL PFTOPDG(0.5D0,1.0D2,DXPDF)
          IFLPRT=0
        ENDIF
+SELF
C          Check EXTRADIM parameters are set
        IF(KEYS(11).AND.LOC(72).EQ.0) THEN
          WRITE(ITLIS,*) 'YOU FORGOT TO SET EXTRAD PARAMETERS'
          IFL=72
        ENDIF  
C
        RETURN
      ENDIF
C
C          Keyword P
      IF(WORD.EQ.'P       ') THEN
        READ(ITCOM,*)  (PMIN(K),PMAX(K),K=1,NJET)
        WRITE(ITLIS,*) (PMIN(K),PMAX(K),K=1,NJET)
        LOC(1)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword Y
      IF(WORD.EQ.'Y       ') THEN
        READ(ITCOM,*)  (YJMIN(K),YJMAX(K),K=1,NJET)
        WRITE(ITLIS,*) (YJMIN(K),YJMAX(K),K=1,NJET)
        LOC(2)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword X
      IF(WORD.EQ.'X       ') THEN
        READ(ITCOM,*)  (XJMIN(K),XJMAX(K),K=1,NJET)
        WRITE(ITLIS,*) (XJMIN(K),XJMAX(K),K=1,NJET)
        LOC(3)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword PHI
      IF(WORD.EQ.'PHI     ') THEN
        READ(ITCOM,*)  (PHIMIN(K),PHIMAX(K),K=1,NJET)
        WRITE(ITLIS,*) (PHIMIN(K),PHIMAX(K),K=1,NJET)
        LOC(4)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword TH
      IF(WORD.EQ.'TH      '.OR.WORD.EQ.'THETA   ') THEN
        READ(ITCOM,*)  (THMIN(K),THMAX(K),K=1,NJET)
        WRITE(ITLIS,*) (THMIN(K),THMAX(K),K=1,NJET)
        LOC(5)=NSEL
        LOC(6)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword PT
      IF(WORD.EQ.'PT      '.OR.WORD.EQ.'PPERP   ') THEN
        READ(ITCOM,*)  (PTMIN(K),PTMAX(K),K=1,NJET)
        WRITE(ITLIS,*) (PTMIN(K),PTMAX(K),K=1,NJET)
        LOC(7)=NSEL
        LOC(8)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NODECAY
      IF(WORD.EQ.'NODECAY ') THEN
        READ(ITCOM,571) NODCAY
571     FORMAT(L1)
        WRITE(ITLIS,572) NODCAY
572     FORMAT(' ',L1)
        LOC(9)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOETA
      IF(WORD.EQ.'NOETA   ') THEN
        READ(ITCOM,571) NOETA
        WRITE(ITLIS,572) NOETA
        LOC(10)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOPI0
      IF(WORD.EQ.'NOPI0   ') THEN
        READ(ITCOM,571) NOPI0
        WRITE(ITLIS,572) NOPI0
        LOC(11)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword BEAMS
      IF(WORD.EQ.'BEAMS   ') THEN
        READ(ITCOM,*) RDID(1),RDID(2)
        WRITE(ITLIS,*) RDID(1),RDID(2)
        IDIN(1)=0
        IDIN(2)=0
        DO 123 K=1,2
          IF(RDID(K).EQ.'P       ') IDIN(K)=+1120
          IF(RDID(K).EQ.'AP      ') IDIN(K)=-1120
          IF(RDID(K).EQ.'N       ') IDIN(K)=+1220
          IF(RDID(K).EQ.'AN      ') IDIN(K)=-1220
123     CONTINUE
        IF(IDIN(1)*IDIN(2).EQ.0) THEN
          WRITE(ITLIS,2002)
          IFL=13
        ENDIF
        LOC(12)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword FRAGMENT
      IF(WORD.EQ.'FRAGMENT') THEN
        READ(ITCOM,*)  FRPAR
        WRITE(ITLIS,*)  FRPAR
        LOC(13)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword SEED
      IF(WORD.EQ.'SEED    ') THEN
+SELF,IF=-RANLUX
        READ(ITCOM,*) SEED
        WRITE(ITLIS,*) SEED
        CALL RANFST(SEED)
        WRITE(XSEED,'(E24.15)') SEED
        LOC(14)=NSEL
        GO TO 100
+SELF,IF=RANLUX
        LUXK1=0
        LUXK2=0
        READ(ITCOM,*) LUXINT,LUXK1,LUXK2
        WRITE(ITLIS,*) LUXINT,LUXK1,LUXK2
        LOC(14)=NSEL
        GO TO 100
+SELF
      ENDIF
C
C          Keywords JETTYPE1, JETTYPE2, JETTYPE3, ...
C          (Yes, this is ugly)
      IF(WORD.EQ.'JETTYPE1'.OR.WORD.EQ.'JETTYPE2'.OR.
     $WORD.EQ.'JETTYPE3'.OR.WORD.EQ.'JETTYPE4'.OR.
     $WORD.EQ.'JETTYPE5'.OR.WORD.EQ.'JETTYPE6'.OR.
     $WORD.EQ.'JETTYPE7'.OR.WORD.EQ.'JETTYPE8') THEN
        IF(WORD.EQ.'JETTYPE1') IJ=1
        IF(WORD.EQ.'JETTYPE2') IJ=2
        IF(WORD.EQ.'JETTYPE3') IJ=3
        IF(WORD.EQ.'JETTYPE4') IJ=4
        IF(WORD.EQ.'JETTYPE5') IJ=5
        IF(WORD.EQ.'JETTYPE6') IJ=6
        IF(WORD.EQ.'JETTYPE7') IJ=7
        IF(WORD.EQ.'JETTYPE8') IJ=8
        DO 151 K=1,30
          JETYP(K,IJ)=BLANK
151     CONTINUE
        READ(ITCOM,*) (JETYP(K,IJ),K=1,30)
        DO 152 K=1,25
152     IF(JETYP(K,IJ).NE.BLANK) NJTTYP(IJ)=NJTTYP(IJ)+1
        WRITE(ITLIS,*) (JETYP(K,IJ),K=1,NJTTYP(IJ))
        LOC(15)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword SIN2W
      IF(WORD.EQ.'SIN2W   ') THEN
        READ(ITCOM,*)  SIN2W
        WRITE(ITLIS,*) SIN2W
        LOC(17)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword TMASS
      IF(WORD.EQ.'TMASS   ') THEN
        READ(ITCOM,*)  AMLEP(6),AMLEP(7),AMLEP(8)
        WRITE(ITLIS,*) AMLEP(6),AMLEP(7),AMLEP(8)
        LOC(18)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword QMH
      IF(WORD.EQ.'QMH     ') THEN
        READ(ITCOM,*) QMIN,QMAX
        WRITE(ITLIS,*) QMIN,QMAX
        LOC(19)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword QMW
      IF(WORD.EQ.'QMW     ') THEN
        READ(ITCOM,*) QMIN,QMAX
        WRITE(ITLIS,*) QMIN,QMAX
        LOC(19)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword QTW
      IF(WORD.EQ.'QTW     ') THEN
        READ(ITCOM,*)  QTMIN,QTMAX
        WRITE(ITLIS,*) QTMIN,QTMAX
        LOC(20)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword YW
      IF(WORD.EQ.'YW      ') THEN
        READ(ITCOM,*)  YWMIN,YWMAX
        WRITE(ITLIS,*) YWMIN,YWMAX
        LOC(21)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword XW
      IF(WORD.EQ.'XW      ') THEN
        READ(ITCOM,*)  XWMIN,XWMAX
        WRITE(ITLIS,*) XWMIN,XWMAX
        LOC(22)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword THW
      IF(WORD.EQ.'THW     ') THEN
        READ(ITCOM,*)  THWMIN,THWMAX
        WRITE(ITLIS,*) THWMIN,THWMAX
        LOC(23)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword PHIW
      IF(WORD.EQ.'PHIW    ') THEN
        READ(ITCOM,*)  PHWMIN,PHWMAX
        WRITE(ITLIS,*) PHWMIN,PHWMAX
        LOC(24)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NONUNU
      IF(WORD.EQ.'NONUNU  ') THEN
        READ(ITCOM,571) NONUNU
        WRITE(ITLIS,572) NONUNU
        LOC(25)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword WTYPE
      IF(WORD.EQ.'WTYPE   ') THEN
        DO 261 J=1,4
          WTYP(J)=BLANK
          GODY(J)=.FALSE.
261     CONTINUE
        READ(ITCOM,*) WTYP
        WRITE(ITLIS,*) WTYP
        DO 262 K=1,4
          IF(WTYP(K).EQ.'GM      ') GODY(1)=.TRUE.
          IF(WTYP(K).EQ.'W+      ') GODY(2)=.TRUE.
          IF(WTYP(K).EQ.'W-      ') GODY(3)=.TRUE.
          IF(WTYP(K).EQ.'Z0      ') GODY(4)=.TRUE.
  262   CONTINUE
        IF(GODY(1)) JWTYP=1
        IF(GODY(2).OR.GODY(3)) JWTYP=3
        IF(GODY(4)) JWTYP=4
        IF((GODY(2).OR.GODY(3)).AND.(GODY(1).OR.GODY(4))) THEN
          WRITE(ITLIS,2003)
          IFL=13
        ENDIF
        LOC(26)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword LAMBDA
      IF(WORD.EQ.'LAMBDA  ') THEN
        READ(ITCOM,*)  ALAM
        WRITE(ITLIS,*)  ALAM
        ALAM2=ALAM**2
        LOC(27)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NTRIES
      IF(WORD.EQ.'NTRIES  ') THEN
        READ(ITCOM,*) NTRIES
        WRITE(ITLIS,*) NTRIES
        LOC(28)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword CUTOFF
      IF(WORD.EQ.'CUTOFF  ') THEN
        READ(ITCOM,*) CUTOFF,CUTPOW
        WRITE(ITLIS,*) CUTOFF,CUTPOW
        LOC(29)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword XGEN
      IF(WORD.EQ.'XGEN    ') THEN
        READ(ITCOM,*) XGEN
        WRITE(ITLIS,*) XGEN
        LOC(30)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword SIGQT
      IF(WORD.EQ.'SIGQT   ') THEN
        READ(ITCOM,*) SIGQT
        WRITE(ITLIS,*) SIGQT
        LOC(31)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword CUTJET
      IF(WORD.EQ.'CUTJET  ') THEN
        READ(ITCOM,*)  CUTJET
        WRITE(ITLIS,*)  CUTJET
        LOC(32)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword WFUDGE
      IF(WORD.EQ.'WFUDGE  ') THEN
        READ(ITCOM,*)  WFUDGE
        WRITE(ITLIS,*)  WFUDGE
        LOC(50)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword STRUC
      IF(WORD.EQ.'STRUC   ') THEN
        ISTRUC=0
        READ(ITCOM,*) LSTRUC
        WRITE(ITLIS,4) LSTRUC
        IF(LSTRUC.EQ.'OWENS   ') ISTRUC=1
        IF(LSTRUC.EQ.'BAIER   ') ISTRUC=2
        IF(LSTRUC.EQ.'EICHTEN '.OR.LSTRUC.EQ.'EHLQ    ') ISTRUC=3
        IF(LSTRUC.EQ.'DUKE    '.OR.LSTRUC.EQ.'DO      ') ISTRUC=4
        IF(LSTRUC.EQ.'CTEQ2L  ') ISTRUC=5
        IF(LSTRUC.EQ.'CTEQ3L  ') ISTRUC=6
        IF(LSTRUC.EQ.'CTEQ    '.OR.LSTRUC.EQ.'CTEQ5L  ') ISTRUC=7
        IF(ISTRUC.EQ.0) THEN
          WRITE(ITLIS,2002)
          IFL=13
        ENDIF
        LOC(33)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NPOMERON
      IF(WORD.EQ.'NPOMERON') THEN
        READ(ITCOM,*) MNPOM,MXPOM
        WRITE(ITLIS,*) MNPOM,MXPOM
        IF(MNPOM.LT.1.OR.MNPOM.GT.MXPOM.OR.MXPOM.GT.LIMPOM) THEN
          WRITE(ITLIS,2004)
          IFL=14
        ENDIF
        LOC(34)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword FORCE
      IF(WORD.EQ.'FORCE   ') THEN
        NFORCE=NFORCE+1
        IF(NFORCE.GT.MXFORC-1) THEN
          WRITE(ITLIS,2004)
          IFL=14
        ENDIF
        DO 351 K=1,5
351     KFORCE(K)=0
        READ(ITCOM,*) IFORCE(NFORCE),(KFORCE(K),K=1,5)
        CALL ORDER(IFORCE(NFORCE),KFORCE,MFORCE(1,NFORCE),
     $  MEFORC(NFORCE),.TRUE.)
        WRITE(ITLIS,*) IFORCE(NFORCE),(MFORCE(K,NFORCE),K=1,5)
        ID=IFORCE(NFORCE)
        IDABS=IABS(ID)
        IF(IDABS.LT.6) THEN
          WRITE(ITLIS,2005)
          IFL=15
        ENDIF
        IDB=IDANTI(ID)
        IF(IDB.NE.ID) THEN
          IFORCE(NFORCE+1)=IDB
          DO 352 K=1,5
  352     MFORCE(K,NFORCE+1)=IDANTI(MFORCE(K,NFORCE))
          NFORCE=NFORCE+1
        ENDIF
        LOC(35)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword FORCE1
      IF(WORD.EQ.'FORCE1  ') THEN
        NFORCE=NFORCE+1
        IF(NFORCE.GT.MXFORC) THEN
          WRITE(ITLIS,2004)
          IFL=14
        ENDIF
        DO 353 K=1,5
353     KFORCE(K)=0
        READ(ITCOM,*) IFORCE(NFORCE),(KFORCE(K),K=1,5)
        CALL ORDER(IFORCE(NFORCE),KFORCE,MFORCE(1,NFORCE),
     $  MEFORC(NFORCE),.TRUE.)
        WRITE(ITLIS,*) IFORCE(NFORCE),(MFORCE(K,NFORCE),K=1,5)
        IF(IABS(IFORCE(NFORCE)).LT.6) THEN
          WRITE(ITLIS,2005)
          IFL=15
        ENDIF
        LOC(35)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword HMASSES - also see HMASS
      IF(WORD.EQ.'HMASSES ') THEN
        CALL FLAVOR(80,I1,I2,I3,J1,INDEX)
        READ(ITCOM,*) (AMLEP(INDEX+K),K=1,9)
        WRITE(ITLIS,*) (AMLEP(INDEX+K),K=1,9)
        LOC(36)=NSEL
        GO TO 100
      ENDIF
C
C          Keywords WMODE1,WMODE2
      IF(WORD.EQ.'WMODE1  '.OR.WORD.EQ.'WMODE2  ') THEN
        IF(WORD.EQ.'WMODE1  ') IJ=1
        IF(WORD.EQ.'WMODE2  ') IJ=2
        READ(ITCOM,*) (WWTYP(K,IJ),K=1,25)
        DO 372 K=1,25
372     IF(WWTYP(K,IJ).NE.BLANK) NWWTYP(IJ)=NWWTYP(IJ)+1
        WRITE(ITLIS,*) (WWTYP(K,IJ),K=1,NWWTYP(IJ))
        LOC(37)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOEVOLVE
      IF(WORD.EQ.'NOEVOLVE') THEN
        READ (ITCOM,571) NOEVOL
        WRITE(ITLIS,572) NOEVOL
        LOC(38)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOHADRON
      IF(WORD.EQ.'NOHADRON') THEN
        READ (ITCOM,571) NOHADR
        WRITE(ITLIS,572) NOHADR
        LOC(39)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword GAUGINO
      IF(WORD.EQ.'GAUGINO ') THEN
        CALL FLAVOR(29,I1,I2,I3,J1,IDG1)
        CALL FLAVOR(30,I1,I2,I3,J1,IDG2)
        CALL FLAVOR(39,I1,I2,I3,J1,IDG3)
        CALL FLAVOR(40,I1,I2,I3,J1,IDG4)
        READ(ITCOM,*) AMLEP(IDG1),AMLEP(IDG2),AMLEP(IDG3),AMLEP(IDG4)
        WRITE(ITLIS,*) AMLEP(IDG1),AMLEP(IDG2),AMLEP(IDG3),AMLEP(IDG4)
        LOC(40)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword SQUARK
      IF(WORD.EQ.'SQUARK  ') THEN
        CALL FLAVOR(21,I1,I2,I3,J1,IDXQKL)
        READ(ITCOM,*) (AMLEP(IDXQKL+K-1),K=1,6)
        WRITE(ITLIS,*) (AMLEP(IDXQKL+K-1),K=1,6)
        CALL FLAVOR(41,I1,I2,I3,J1,IDXQKR)
        DO 411 K=1,6
          AMLEP(IDXQKR+K-1)=AMLEP(IDXQKL+K-1)
411     CONTINUE
        LOC(41)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword SLEPTON
      IF(WORD.EQ.'SLEPTON ') THEN
        CALL FLAVOR(31,I1,I2,I3,J1,IDXLEP)
        READ(ITCOM,*) (AMLEP(IDXLEP+K-1),K=1,6)
        WRITE(ITLIS,*) (AMLEP(IDXLEP+K-1),K=1,6)
        LOC(42)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NSIGMA
      IF(WORD.EQ.'NSIGMA  ') THEN
        READ(ITCOM,*) NSIGMA
        WRITE(ITLIS,*) NSIGMA
        LOC(43)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword XGENSS
      IF(WORD.EQ.'XGENSS  ') THEN
        READ(ITCOM,*) XGENSS(9),(XGENSS(KK),KK=1,8)
        WRITE(ITLIS,*) XGENSS(9),(XGENSS(KK),KK=1,8)
        LOC(44)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword HMASS - just standard Higgs
      IF(WORD.EQ.'HMASS   ') THEN
        CALL FLAVOR(81,I1,I2,I3,J1,INDEX)
        READ(ITCOM,*) AMLEP(INDEX)
        WRITE(ITLIS,*) AMLEP(INDEX)
        LOC(45)=NSEL
        GO TO 100
      ENDIF
C
C          Keywords WPMODE, WMMODE, Z0MODE
      IF(WORD.EQ.'WPMODE  '.OR.WORD.EQ.'WMMODE  '
     $.OR.WORD.EQ.'Z0MODE  ') THEN
        IF(WORD.EQ.'WPMODE  ') IJ=1
        IF(WORD.EQ.'WMMODE  ') IJ=2
        IF(WORD.EQ.'Z0MODE  ') IJ=3
        READ(ITCOM,*) (WMODES(K,IJ),K=1,25)
        DO 463 K=1,25
463     IF(WMODES(K,IJ).NE.BLANK) NWMODE(IJ)=NWMODE(IJ)+1
        WRITE(ITLIS,*) (WMODES(K,IJ),K=1,NWMODE(IJ))
        LOC(46)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword WMASS
      IF(WORD.EQ.'WMASS   ') THEN
        READ(ITCOM,*) AMW,AMZ
        WRITE(ITLIS,*) AMW,AMZ
        WMASS(1)=0.
        WMASS(2)=AMW
        WMASS(3)=AMW
        WMASS(4)=AMZ
        CALL FLAVOR(80,I1,I2,I3,J,INDEX)
        AMLEP(INDEX)=AMW
        CALL FLAVOR(90,I1,I2,I3,J,INDEX)
        AMLEP(INDEX)=AMZ
        LOC(47)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NEVOLVE
      IF(WORD.EQ.'NEVOLVE ') THEN
        READ(ITCOM,*) NEVOLV
        WRITE(ITLIS,*) NEVOLV
        LOC(48)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NHADRON
      IF(WORD.EQ.'NHADRON ') THEN
        READ(ITCOM,*) NFRGMN
        WRITE(ITLIS,*) NFRGMN
        LOC(49)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword TCMASS
      IF(WORD.EQ.'TCMASS  ') THEN
        READ(ITCOM,*) TCMRHO,TCGRHO
        WRITE(ITLIS,*) TCMRHO,TCGRHO
        LOC(50)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MSSMA: gluino, mu, mha, tanb
      IF(WORD.EQ.'MSSMA   ') THEN
        READ(ITCOM,*) XGLSS,XMUSS,XHASS,XTBSS
        WRITE(ITLIS,*) XGLSS,XMUSS,XHASS,XTBSS
        GOMSSM=.TRUE.
        LOC(51)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MSSMB: 1st generation soft terms
      IF(WORD.EQ.'MSSMB   ') THEN
        READ(ITCOM,*) XQ1SS,XDRSS,XURSS,XL1SS,XERSS
        WRITE(ITLIS,*) XQ1SS,XDRSS,XURSS,XL1SS,XERSS
        LOC(52)=NSEL
        GOMSSM=.TRUE.
        GO TO 100
      ENDIF
C
C          Keyword MSSMC: 3rd generation soft terms
      IF(WORD.EQ.'MSSMC   ') THEN
        READ(ITCOM,*)XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS
       WRITE(ITLIS,*)XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS
        LOC(53)=NSEL
        GOMSSM=.TRUE.
        GO TO 100
      ENDIF
C
C          Keyword PDFLIB: parameters for PDFLIB
+SELF,IF=PDFLIB
      IF(WORD.EQ.'PDFLIB  ') THEN
        DO 541 I=1,20
          PDFPAR(I)='                    '
          PDFVAL(I)=0
541     CONTINUE
        READ(ITCOM,*) (PDFPAR(I),PDFVAL(I),I=1,20)
        DO 542 I=1,20
          IF(PDFPAR(I).NE.'                    ') THEN
            WRITE(ITLIS,*) PDFPAR(I),PDFVAL(I)
          ENDIF
542     CONTINUE
        ISTRUC=-999
        LOC(54)=NSEL
        GO TO 100
      ENDIF
+SELF
C
C          Keyword SUGRA
      IF(WORD.EQ.'SUGRA   ') THEN
        READ(ITCOM,*) XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU
        WRITE(ITLIS,*) XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU
        LOC(55)=NSEL
        GOMSSM=.TRUE.
        GOSUG=.TRUE.
        GO TO 100
      ENDIF
C
C          Keyword HTYPE
      IF(WORD.EQ.'HTYPE   ') THEN
        READ(ITCOM,*) HTYPE
        WRITE(ITLIS,*) HTYPE
        LOC(56)=NSEL
        IHTYPE=0
        IF(HTYPE.EQ.'HL0     ') IHTYPE=82
        IF(HTYPE.EQ.'HH0     ') IHTYPE=83
        IF(HTYPE.EQ.'HA0     ') IHTYPE=84
        IF(IHTYPE.EQ.0) THEN
          WRITE(ITLIS,2000) HTYPE
          IFL=16
        ENDIF
        GO TO 100
      ENDIF
C
C          Keyword EPOL
      IF(WORD.EQ.'EPOL  ') THEN
        READ(ITCOM,*) PLEM,PLEP
        WRITE(ITLIS,*) PLEM,PLEP
        LOC(57)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MSSMD: optional 2nd geenration soft terms
      IF(WORD.EQ.'MSSMD   ') THEN
        READ(ITCOM,*) XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS
        WRITE(ITLIS,*) XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS
        LOC(58)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MSSME: optional U(1) and SU(2) gaugino masses
      IF(WORD.EQ.'MSSME   ') THEN
        READ(ITCOM,*) XM1SS,XM2SS
        WRITE(ITLIS,*) XM1SS,XM2SS
        LOC(59)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword GMSB: gauge-mediated SUSY breaking model
      IF(WORD.EQ.'GMSB    ') THEN
        READ(ITCOM,*) XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,XCMGV
        WRITE(ITLIS,*) XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,XCMGV
        GOMSSM=.TRUE.
        GOGMSB=.TRUE.
        LOC(60)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG1: optional GUT scale gaugino masses
      IF(WORD.EQ.'NUSUG1   ') THEN
        READ(ITCOM,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
        WRITE(ITLIS,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
        LOC(61)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG2: optional GUT scale A terms
      IF(WORD.EQ.'NUSUG2   ') THEN
        READ(ITCOM,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
        WRITE(ITLIS,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
        LOC(62)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG3: optional GUT scale Higgs masses
      IF(WORD.EQ.'NUSUG3   ') THEN
        READ(ITCOM,*) XNUSUG(7),XNUSUG(8)
        WRITE(ITLIS,*) XNUSUG(7),XNUSUG(8)
        LOC(63)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG4: optional GUT scale 1st/2nd gen. masses
      IF(WORD.EQ.'NUSUG4   ') THEN
        READ(ITCOM,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10)
     $,XNUSUG(9)
        WRITE(ITLIS,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10)
     $,XNUSUG(9)
        LOC(64)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG5: optional GUT scale 3rd gen. masses
      IF(WORD.EQ.'NUSUG5   ') THEN
        READ(ITCOM,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15)
     $,XNUSUG(14)
        WRITE(ITLIS,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15)
     $,XNUSUG(14)
        LOC(65)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOGRAV: No gravitino decays
      IF(WORD.EQ.'NOGRAV  ') THEN
        READ(ITCOM,571) NOGRAV
        WRITE(ITLIS,572) NOGRAV
        LOC(66)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MGVTNO: Sets the gravitino mass
      IF(WORD.EQ.'MGVTNO  ') THEN
        READ(ITCOM,*) XMGVTO
        WRITE(ITLIS,*) XMGVTO
        LOC(67)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword AL3UNI: Impose alpha_s unification at M_GUT
      IF(WORD.EQ.'AL3UNI  ') THEN
        READ(ITCOM,571) AL3UNI
        WRITE(ITLIS,572) AL3UNI
        LOC(68)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword GMSB2: additional GMSB parameters
      IF(WORD.EQ.'GMSB2   ') THEN
        READ(ITCOM,*) XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM
        WRITE(ITLIS,*) XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM
        LOC(69)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword EEBREM: invoke bremsstrahlung in e+e- reactions
      IF(WORD.EQ.'EEBREM  ') THEN
        READ(ITCOM,*) RSHMIN,RSHMAX
        WRITE(ITLIS,*) RSHMIN,RSHMAX
        IBREM=.TRUE.
        LOC(70)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword EEBEAM: invoke beamstrahlung in e+e- reactions
      IF(WORD.EQ.'EEBEAM  ') THEN
        READ(ITCOM,*) RSHMIN,RSHMAX,UPSLON,SIGZ
        WRITE(ITLIS,*) RSHMIN,RSHMAX,UPSLON,SIGZ
        IBREM=.TRUE.
        IBEAM=.TRUE.
        LOC(71)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword QMKKG (QMW for EXTRADIM)
      IF(WORD.EQ.'QMKKG   ') THEN
        READ(ITCOM,*) QMIN,QMAX
        WRITE(ITLIS,*) QMIN,QMAX
        LOC(19)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword QTKKG (QTW for EXTRADIM)
      IF(WORD.EQ.'QTKKG   ') THEN
        READ(ITCOM,*)  QTMIN,QTMAX
        WRITE(ITLIS,*) QTMIN,QTMAX
        LOC(20)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword EXTRAD for EXTRADIM
      IF(WORD.EQ.'EXTRAD  ') THEN
        READ(ITCOM,*) NEXTRAD,MASSD,UVCUT
        WRITE(ITLIS,*) NEXTRAD,MASSD,UVCUT
        LOC(72)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MIJLIM
      IF(WORD.EQ.'MIJLIM  ') THEN
        READ(ITCOM,*) JLIM1,JLIM2,AMLIM1,AMLIM2
        WRITE(ITLIS,*) JLIM1,JLIM2,AMLIM1,AMLIM2
        IF(JLIM1.EQ.0.AND.JLIM2.EQ.0) THEN
          DO 720 I=1,NJET
            DO 721 J=1,NJET
              AMIJMN(I,J)=AMLIM1
              AMIJMX(I,J)=AMLIM2
721         CONTINUE
720       CONTINUE
        ELSEIF(JLIM1.GT.0.AND.JLIM1.LE.NJET.AND.JLIM2.GT.0.AND.
     $  JLIM2.LE.NJET) THEN
          AMIJMN(JLIM1,JLIM2)=AMLIM1
          AMIJMN(JLIM2,JLIM1)=AMLIM1
          AMIJMX(JLIM1,JLIM2)=AMLIM2
          AMIJMX(JLIM2,JLIM1)=AMLIM2
        ELSE
          WRITE(ITLIS,2008)
          IFL=73
        ENDIF
        LOC(73)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword MTOT
      IF(WORD.EQ.'MTOT    ') THEN
        READ(ITCOM,*) EHMGMN,EHMGMX
        WRITE(ITLIS,*) EHMGMN,EHMGMX
        LOC(74)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword SUGRHN
      IF(WORD.EQ.'SUGRHN  ') THEN
        READ(ITCOM,*) XMN3NR,XMAJNR,XANSS,XNRSS
        WRITE(ITLIS,*) XMN3NR,XMAJNR,XANSS,XNRSS
        LOC(75)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword AMSB
      IF(WORD.EQ.'AMSB    ') THEN
        READ(ITCOM,*) XM0SU,XMHSU,XTGBSU,XSMUSU
        WRITE(ITLIS,*) XM0SU,XMHSU,XTGBSU,XSMUSU
        LOC(76)=NSEL
        GOMSSM=.TRUE.
        GOSUG=.TRUE.
        GOAMSB=.TRUE.
        GO TO 100
      ENDIF
C
C          Keyword SSBCSC
      IF(WORD.EQ.'SSBCSC  ') THEN
        READ(ITCOM,*) XSBCS
        WRITE(ITLIS,*) XSBCS
        LOC(77)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOB
      IF(WORD.EQ.'NOB     ') THEN
        READ(ITCOM,*) NOB
        WRITE(ITLIS,*) NOB
        LOC(78)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOTAU
      IF(WORD.EQ.'NOTAU   ') THEN
        READ(ITCOM,*) NOTAU
        WRITE(ITLIS,*) NOTAU
        LOC(79)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword GAMGAM
      IF(WORD.EQ.'GAMGAM  ') THEN
        READ(ITCOM,*) GAMGAM
        WRITE(ITLIS,*) GAMGAM
        LOC(80)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword AMSB2: additional AMSB parameters
      IF(WORD.EQ.'AMSB2   ') THEN
        READ(ITCOM,*) XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
        WRITE(ITLIS,*) XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
        LOC(81)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUHM: input mu(Q), mA(Q) in lieu of mHd, mHu
      INUHM=0
      IF(WORD.EQ.'NUHM     ') THEN
        READ(ITCOM,*) XNUSUG(19),XNUSUG(20)
        WRITE(ITLIS,*) XNUSUG(19),XNUSUG(20)
        LOC(82)=NSEL
        INUHM=1
        GO TO 100
      ENDIF
C
C          None of the above
C
      WRITE(ITLIS,2000) WORD
      IFL=10
      RETURN
C
C          Error message or warnings
C
 1001     FORMAT(//2X,'YOU HAVE GIVEN LIMITS FOR AN OVERLAPPING SET', 
     $  ' OF VARIABLES. SET MINIMIZING PPERP INTERVAL WILL BE USED.')
 1999     FORMAT(//' YOU FORGOT TO SELECT A PROCESS FOR GENERATION.'
     $    /' AVAILABLE AT PRESENT ARE ',
     $    /' TWOJET  E+E-  DRELLYAN  MINBIAS  WPAIR  SUPERSYM,' 
     $    /' HIGGS  PHOTON  TCOLOR')
 2000 FORMAT(//2X,A8,' IS NOT A RECOGNIZABLE PARAMETER. JOB TERMINATED')
 2001     FORMAT(//2X,' YOU CANNOT GIVE LIMITS FOR BOTH THETA AND Y.',
     $    ' MAKE UP YOUR MIND. JOB TERMINATED.')
 2002     FORMAT(/'  WHAT IS THAT SUPPOSED TO BE')
 2003     FORMAT(/'  YOU CANNOT RUN WS AND Z0 OR GAMMAS AT THE',
     $    ' SAME TIME. JOB TERMINATED')
 2004 FORMAT(//'  PARAMETER OUT OF RANGE. JOB TERMINATED.')
 2005 FORMAT(//'  YOU CANNOT FORCE DECAY OF A QUARK, YOU MUST CHOSE '
     $,' A PARTICLE')
 2006     FORMAT(//2X,' INVALID JETTYPE VALUES. JOB TERMINATED.')
 2007 FORMAT(//2X,'YOU CANNOT USE MSSM AND SUGRA SIMULTANEOUSLY')
 2008 FORMAT(//2X,'INVALID JET-JET MASS LIMITS. JOB TERMINATED.')
C
      END
+EOD
+DECK,REJFRG.
      LOGICAL FUNCTION REJFRG() 
C-----------------------------------------------------------------------
C-
C-         This is called after FRGMNT for TWOJET and DRELLYAN events 
C-         to test the fragmentation. REJFRG=.FALSE. keeps the event.
C-
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PARTCL
      INTEGER I,ID 
      REAL PTL,CUTLEP,CUTNU 
      DATA CUTLEP/50./,CUTNU/100./  
      REJFRG=.FALSE.
C***************************************
C           Sample REJFRG function which keeps the event if it contains
C           any lepton satisfying
C             PT > CUTLEP (charged lepton)  
C             PT > CUTNU  (neutrino)    
C           Appropriate values of the cuts must be set by the user.
C      REJFRG=.TRUE. 
C      DO 1 I=1,NPTCL    
C        IF(IDCAY(I).NE.0) GO TO 1
C        ID=IABS(IDENT(I))   
C        IF(ID.LE.10.OR.ID.GE.20) GO TO 1    
C        PTL=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2)   
C        IF((ID.EQ.11.OR.ID.EQ.13.OR.ID.EQ.15).AND.PTL.GT.CUTNU) THEN
C          REJFRG=.FALSE.    
C          RETURN
C        ELSEIF((ID.EQ.12..OR.ID.EQ.14).AND.PTL.GT.CUTLEP) THEN 
C          REJFRG=.FALSE.    
C          RETURN
C        ENDIF
C   1  CONTINUE  
C***************************************
      RETURN    
      END   
+EOD
+DECK,REJJET.
      LOGICAL FUNCTION REJJET() 
C-----------------------------------------------------------------------
C-
C-         This is called after EVOLVE for TWOJET and DRELLYAN events 
C-         to test the partons (jets). REJJET=.FALSE. keeps the event.
C-
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,JETSET
      INTEGER I,IFLAV  
      REJJET=.FALSE.
C***************************************
C           Sample REJJET function which keeps the event if one of the 
C           outgoing partons is a heavy quark. 
C      REJJET=.TRUE. 
C      DO 1 I=1,NJSET    
C        IF(JDCAY(I).NE.0) GO TO 1   
C        IFLAV=IABS(JTYPE(I))    
C        IF(IFLAV.GE.4.AND.IFLAV.LT.9) THEN
C          REJJET=.FALSE.  
C          RETURN  
C        ENDIF
C  1   CONTINUE  
C***************************************
      RETURN    
      END   
+EOD
+DECK,RESCAL.
      SUBROUTINE RESCAL(N1,N2,PSUM,IFAIL)
C          RESCALE MOMENTA OF PARTICLES N1...N2 TO GIVE TOTAL
C          FOUR-MOMENTUM PSUM.
C          RETURN IFAIL=0 IF OK, IFAIL=1 IF NO GOOD.
+CDE,ITAPES
+CDE,PARTCL
      DIMENSION PSUM(5),PADD(5),BETA(3)
      DATA ERRLIM/.0001/
C          ORIGIONAL MOMENTUM IS PADD.
      IFAIL=1
      IF(N1.GE.N2) RETURN
      DO 100 K=1,5
100   PADD(K)=0.
      DO 110 IP=N1,N2
      DO 110 K=1,5
      PADD(K)=PADD(K)+PPTCL(K,IP)
110   CONTINUE
      IF(PADD(5).GE.PSUM(5)) RETURN
      PADD(5)=PADD(4)**2-PADD(1)**2-PADD(2)**2-PADD(3)**2
      IF(PADD(5).LE.0) RETURN
      PADD(5)=SQRT(PADD(5))
      DO 120 K=1,3
120   BETA(K)=-PADD(K)/PADD(5)
      GAMMA=PADD(4)/PADD(5)
C          BOOST PARTICLES TO REST.
200   CONTINUE
      DO 210 IP=N1,N2
      BP=0.
      DO 220 K=1,3
220   BP=BP+PPTCL(K,IP)*BETA(K)
      DO 230 K=1,3
230   PPTCL(K,IP)=PPTCL(K,IP)+BETA(K)*PPTCL(4,IP)
     $+BETA(K)*BP/(GAMMA+1.)
      PPTCL(4,IP)=GAMMA*PPTCL(4,IP)+BP
210   CONTINUE
      IF(IFAIL.EQ.0) RETURN
C          RESCALE MOMENTA IN REST FRAME.
      SCAL=1.
      DO 301 IPASS=1,200
      SUM=0.
      DO 310 IP=N1,N2
      DO 320 K=1,3
320   PPTCL(K,IP)=SCAL*PPTCL(K,IP)
      PPTCL(4,IP)=SQRT(PPTCL(1,IP)**2+PPTCL(2,IP)**2+PPTCL(3,IP)**2
     $+PPTCL(5,IP)**2)
      SUM=SUM+PPTCL(4,IP)
310   CONTINUE
      SCAL=PSUM(5)/SUM
301   IF(ABS(SCAL-1.).LE.ERRLIM) GO TO 300
300   CONTINUE
C          BOOST BACK WITH PSUM.
      BMAG=0.
      DO 400 K=1,3
      BETA(K)=PSUM(K)/PSUM(5)
      BMAG=BMAG+ABS(BETA(K))
400   CONTINUE
      GAMMA=PSUM(4)/PSUM(5)
      IFAIL=0
      IF(BMAG.EQ.0.) RETURN
      GO TO 200
      END
+EOD
+DECK,RESET.
      SUBROUTINE RESET
C          RESET ALL USER DEFINED VARIABLES
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,DYLIM
+CDE,FRGPAR
+CDE,HCON
+CDE,JETLIM
+CDE,JETPAR
+CDE,NODCAY
+CDE,PRIMAR
+CDE,QLMASS
+CDE,Q1Q2
+CDE,SEED
+CDE,SSPAR
+CDE,TCPAR
+CDE,TYPES
+CDE,WCON
+CDE,FORCE
+CDE,MBGEN
+CDE,ISLOOP
+CDE,LIMEVL
+CDE,XMSSM
+CDE,EEPAR
+CDE,MGLIMS
+CDE,SUGXIN
+CDE,SSMODE
C
      INTEGER I,I1,I2,I3,J1,INDEX,J,K
      REAL UNDEF,AMASS
      CHARACTER*8 BLANK
      DATA BLANK/'        '/
      DATA UNDEF/-1.E9/
C          RESET DYLIM
      DO 110 I=1,12
      BLIM1(I)=UNDEF
      SETLMQ(I)=.TRUE.
110   CONTINUE
C          RESET FRGPAR
      PUD=.43
      PBARY=.10
      SIGQT=.35
      PEND=.14
      XGEN(1)=.96
      XGEN(2)=3.
      XGEN(3)=0.
      XGEN(4)=.8
      XGEN(5)=.5
      XGEN(6)=.5
      XGEN(7)=.5
      XGEN(8)=.5
      DO 111 K=1,9
111   XGENSS(K)=.5
      PSPIN1(1)=.5
      PSPIN1(2)=.5
      PSPIN1(3)=.5
      PSPIN1(4)=.75
      PSPIN1(5)=.75
      PSPIN1(6)=.75
      PSPIN1(7)=.75
      PSPIN1(8)=.75
      PMIXX1(1)=.25
      PMIXX1(2)=.25
      PMIXX1(3)=.5
      PMIXX1(4)=0.
      PMIXX1(5)=.5
      PMIXX1(6)=1.
      PMIXX2(1)=.5
      PMIXX2(2)=.5
      PMIXX2(3)=1.
      PMIXX2(4)=0.
      PMIXX2(5)=0.
      PMIXX2(6)=1.
C          RESET ISLOOP
      NEVOLV=1
      NFRGMN=1
C          RESET JETLIM
      DO 120 I=1,12*MXLIM
        BLIMS(I)=UNDEF
        SETLMJ(I)=.TRUE.
120   CONTINUE
C          RESET NODCAY
      NODCAY=.FALSE.
      NOETA=.FALSE.
      NOPI0=.FALSE.
      NONUNU=.FALSE.
      NOEVOL=.FALSE.
      NOHADR=.FALSE.
      NOGRAV=.FALSE.
C          RESET PRIMAR
      IDIN(1)=1120
      IDIN(2)=1120
      NTRIES=1000
      NSIGMA=20
C          RESET QCDPAR
      ALAM=.2
      ALAM2=ALAM**2
      CUTJET=6.
      ISTRUC=7
C          RESET QLMASS
      AMLEP(6)=175.
      AMLEP(7)=-1.
      AMLEP(8)=-1.
      DO 125 I=1,9
      CALL FLAVOR(80+I,I1,I2,I3,J1,INDEX)
125   AMLEP(INDEX)=0.
      CALL FLAVOR(29,I1,I2,I3,J1,INDEX)
      AMLEP(INDEX)=100.
      CALL FLAVOR(30,I1,I2,I3,J1,INDEX)
      AMLEP(INDEX)=0.
      CALL FLAVOR(39,I1,I2,I3,J1,INDEX)
      AMLEP(INDEX)=100.
      CALL FLAVOR(40,I1,I2,I3,J1,INDEX)
      AMLEP(INDEX)=100.
      DO 126 I=1,6
      CALL FLAVOR(20+I,I1,I2,I3,J1,INDEX)
      AMLEP(INDEX)=100.+AMASS(I)
      CALL FLAVOR(30+I,I1,I2,I3,J1,INDEX)
      AMLEP(INDEX)=100.+AMASS(I+10)
126   CONTINUE
      CALL FLAVOR(81,I1,I2,I3,J1,INDEX)
      IF(INDEX.GT.0) AMLEP(INDEX)=-1.
C          RESET Q1Q2
      DO 130 I=1,MXGOQ
      DO 130 J=1,MXGOJ
130   GOQ(I,J)=.TRUE.
      DO 131 I=1,MXGOJ
131   GOALL(I)=.TRUE.
      GODY(1)=.TRUE.
      GODY(2)=.FALSE.
      GODY(3)=.FALSE.
      GODY(4)=.TRUE.
      DO 132 I=1,2
      ALLWW(I)=.TRUE.
      DO 132 J=1,25
132   GOWW(J,I)=.TRUE.
      DO 133 I=1,3
      DO 133 J=1,25
133   GOWMOD(J,I)=.TRUE.
C          RESET TCPAR
      TCMRHO=1000.
      TCGRHO=100.
C          RESET TYPES
      DO 140 I=1,NTYP
140   LOC(I)=0
      DO 141 I=1,MXTYPE
      NJTTYP(I)=0
      JETYP(1,I)='ALL     '
      DO 141 K=2,30
141   JETYP(K,I)=BLANK
      JWTYP=4
      DO 142 I=1,2
      NWWTYP(I)=0
      WWTYP(1,I)='ALL     '
      DO 142 K=2,4
142   WWTYP(K,I)=BLANK
      DO 143 I=1,3
      NWMODE(I)=0
      WMODES(1,I)='ALL     '
      DO 143 K=2,30
143   WMODES(K,I)=BLANK
C          RESET WCON
      SIN2W=.232
      WMASS(2)=80.2
      WMASS(3)=WMASS(2)
      WMASS(4)=91.19
      CALL FLAVOR(80,I1,I2,I3,J,INDEX)
      AMLEP(INDEX)=WMASS(2)
      CALL FLAVOR(90,I1,I2,I3,J,INDEX)
      AMLEP(INDEX)=WMASS(4)
      CUTOFF=.200
      CUTPOW=1.0
      WFUDGE=1.75
C          RESET MBGEN
      MNPOM=1
      MXPOM=LIMPOM
C          RESET FORCE
      NFORCE=0
C
C          RESET QCD EVOLUTION CUTS
      USELIM=.FALSE.
      CONCUT=1.0
C
C          RESET SSPAR
      AMGVSS=1.E20
C
C          RESET XMSSM
      GOMSSM=.FALSE.
      GOSUG=.FALSE.
      GOAMSB=.FALSE.
      XM1SS=1.E20
      XM2SS=1.E20
      XMAJNR=1.E20
      XMGVTO=1.E20
C
C          RESET HCON
      IHTYPE=0
C
C          RESET EEPAR
      PLEP=0.
      PLEM=0.
C
C          RESET MGLIMS
      EHMGMN=-1.E9
      EHMGMX=-1.E9
      YHMGMN=-1.E9
      YHMGMX=-1.E9
      DO 150 I=1,MXLIM
        DO 151 J=1,MXLIM
          AMIJMN(I,J)=-1.E9
          AMIJMX(I,J)=-1.E9
151     CONTINUE
150   CONTINUE
C
C          RESET SUGXIN
      DO 160 I=1,7
        XSUGIN(I)=0
160   CONTINUE
      XNRIN(1)=0
      XNRIN(2)=1.E20
      XNRIN(3)=0
      XNRIN(4)=0
C
C          RESET SSMODE
      NSSMOD=0
      DO 170 I=1,MXSS
        ISSMOD(I)=0
        DO 171 J=1,5
          JSSMOD(J,I)=0
171     CONTINUE
        GSSMOD(I)=0.
        BSSMOD(I)=0.
        MSSMOD(I)=0
170   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SETCON.
      SUBROUTINE SETCON
C          THIS SUBROUTINE SETS THE CONSTANTS IN /CONST/.
+CDE,ITAPES
+CDE,CONST
      PI=4.*ATAN(1.)
      SQRT2=SQRT(2.)
      ALFA=1./137.036
      GF=1.16570E-5
      UNITS=1./2.56815
      RETURN
      END
+EOD
+DECK,SETDKY.
      SUBROUTINE SETDKY(LPRINT)
C
C          Read in decay table from tape ITDKY and set up /DKYTAB/.
C          Then append forced decay modes and set LOOK to negative
C          number pointing to LOOK2, which points to table.
C          Forced decays for antiparticles are stored in conjugated 
C          form so that DECAY can always conjugate them.
C
C          Logical flag LPRINT controls printing of table.
C
C          Ver 7.41: Check version of decay table. Also read matrix 
C          element flags and save in MELEM:
C          MELEM=0: Phase space
C          MELEM=1: Dalitz decay
C          MELEM=2: omega/phi decay
C          MELEM=3: V-A
C          MELEM=4: V-A plus W propagator (for top)
C          MELEM=5: tau -> ell nu nu
C          MELEM=6: tau -> nu pi/K
C          MELEM=7: tau -> nu rho/a1
C          MELEM=8: tau -> tau (for NOTAU)
C          MELEM=9: H -> W f fbar
C
C          Ver 7.52: add NOB and NOTAU flags
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,FORCE
+CDE,DKYTAB
+CDE,NODCAY
+CDE,SSMODE
+CDE,SSTYPE
+CDE,XMSSM
+CDE,KEYS
C
      INTEGER IMODE(6),LOOP,IOLD,I,IRES,ITYPE,K,J,IPOINT
      INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,ID1,IDANTI,KTYPE,IRES2
      REAL    BR
      CHARACTER*8 LABEL,LMODE(6),LRES
      CHARACTER*8 IBLANK,LREAD(10),IQUIT
      LOGICAL LPRINT
      INTEGER NOUT,NTHAD
      PARAMETER (NOUT=33)
      PARAMETER (NTHAD=12)
      INTEGER IDOUT(NOUT),ITHAD(NTHAD),IDUMMY(5),MEOUT
      REAL SUMBR,SUMBR2,SUMGAM
      CHARACTER*40,V,VOLD,VISAJE
C
      DATA IDOUT/
     $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR,
     $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL,
     $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,
     $ISHL,ISHH,ISHA,ISHC/
      DATA IQUIT/'////'/,IBLANK/' '/
      DATA ITHAD/-160,-260,-360,
     $  1160,1260,2260,2160,1360,2360,3160,3260,3360/
C
C          Print header for table.
C
      IF(LPRINT) WRITE(ITLIS,10)
10    FORMAT('1',30('*')/' *',28X,'*'/
     1' *',5X,'ISAJET DECAY TABLE',5X,'*'/
     2' *',28X,'*'/' ',30('*')//
     33X,'PART',16X,'DECAY MODE',16X,'CUM BR',10X,'IDENT',18X,
     4'DECAY IDENT'/)
C
C          Initialize. LOOP is the decay mode counter.
C
      LOOP=0
      IOLD=0
      DO 100 I=1,MXLOOK
        LOOK(I)=0
100   CONTINUE
      DO 110 I=1,MXFORC
        LOOK2(1,I)=0
        LOOK2(2,I)=0
110   CONTINUE
C
C          Read in table, checking for valid version.
C
      IF(NODCAY.OR.ITDKY.EQ.0) RETURN
      REWIND ITDKY
C
      VOLD=VISAJE()
      READ(ITDKY,*) V
      IF(V.NE.VOLD) THEN
        WRITE(ITLIS,2000) V,VOLD
2000    FORMAT(//
     $  '  ***WARNING: DECAY TABLE DOES NOT MATCH ISAJET VERSION'/
     $  '  ***DECAY VERSION  : ',A40/
     $  '  ***PROGRAM VERSION: ',A40)
      ENDIF
C
200   LOOP=LOOP+1
      IF(LOOP.GT.MXDKY) GO TO 9999
220   DO 210 I=1,5
        IMODE(I)=0
        LMODE(I)=IBLANK
210   CONTINUE
      READ(ITDKY,*) IRES,ITYPE,BR,IMODE
C
      IF(IRES.NE.0) THEN
        IF(NOPI0.AND.IRES.EQ.110) GO TO 220
        IF(NOETA.AND.IRES.EQ.220) GO TO 220
        IF(NOB.AND.IRES.GT.100.AND.IRES.LT.1000.AND.
     $  MOD(IRES/10,10).EQ.5) GO TO 220
        IF(NOTAU.AND.IRES.EQ.16) GO TO 220
        IF(IRES.NE.IOLD) THEN
          CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX)
          LOOK(INDEX)=LOOP
        ENDIF
        IOLD=IRES
        CBR(LOOP)=BR
        MELEM(LOOP)=ITYPE
        DO 240 I=1,5
          MODE(I,LOOP)=IMODE(I)
          IF(IMODE(I).NE.0) LMODE(I)=LABEL(IMODE(I))
240     CONTINUE
        LRES=LABEL(IRES)
        IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5),
     1  BR,IRES,(IMODE(K),K=1,5)
20      FORMAT(3X,A5,4X,5(A5,2X),F8.5,10X,I5,4X,5(I7,2X))
        GO TO 200
      ENDIF
C
C          Add TAU -> TAUL,TAUR if NOTAU
C
      IF(NOTAU) THEN
        IRES=16
        LRES=LABEL(IRES)
        LOOP=LOOP+1
        CALL FLAVOR(16,IFL1,IFL2,IFL3,JSPIN,INDEX)
        LOOK(INDEX)=LOOP
        BR=.5
        CBR(LOOP)=BR
        MELEM(LOOP)=8
        MODE(1,LOOP)=IDTAUL
        LMODE(1)=LABEL(IDTAUL)
        DO 241 I=2,5
          MODE(I,LOOP)=0
          LMODE(I)=LABEL(0)
241     CONTINUE
        IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5),
     1  BR,IRES,(IMODE(K),K=1,5)
        LOOP=LOOP+1
        BR=1.0
        CBR(LOOP)=BR
        MELEM(LOOP)=8
        MODE(1,LOOP)=IDTAUR
        LMODE(1)=LABEL(IDTAUR)
        DO 242 I=2,5
          MODE(I,LOOP)=0
242     CONTINUE
        IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5),
     1  BR,IRES,(IMODE(K),K=1,5)
      ENDIF
C
C          Add HIGGS for E+E- or WHIGGS
C
      IF((KEYS(2).OR.KEYS(10)).AND..NOT.GOMSSM) THEN
          SUMGAM=0
          SUMBR=0
          DO 244 J=1,NSSMOD
            IF(ISSMOD(J).EQ.81.AND.GSSMOD(J).GT.0) THEN
              SUMGAM=SUMGAM+GSSMOD(J)
            ENDIF
244       CONTINUE
          DO 245 J=1,NSSMOD
            IF(ISSMOD(J).EQ.81.AND.GSSMOD(J).GT.0) THEN
              BSSMOD(J)=GSSMOD(J)/SUMGAM
            ENDIF
245       CONTINUE
          DO 246 J=1,NSSMOD
            IF(ISSMOD(J).EQ.81.AND.BSSMOD(J).GT.0) THEN
              SUMBR=SUMBR+BSSMOD(J)
            ENDIF
246       CONTINUE
C          If modes exist, add them
          IF(SUMBR.LE.0) GO TO 249
          IRES=81
          LRES=LABEL(IRES)
          CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX)
          LOOK(INDEX)=LOOP+1
          SUMBR2=0
          DO 247 J=1,NSSMOD
            IF(ISSMOD(J).EQ.81.AND.BSSMOD(J).GT.0) THEN
              LOOP=LOOP+1
              SUMBR2=SUMBR2+BSSMOD(J)
              BR=SUMBR2/SUMBR
              CBR(LOOP)=BR
              MELEM(LOOP)=MSSMOD(J)
              DO 248 K=1,5
                MODE(K,LOOP)=JSSMOD(K,J)
                LMODE(K)=LABEL(MODE(K,LOOP))
248           CONTINUE
              IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5),
     $        BR,IRES,(MODE(K,LOOP),K=1,5)
            ENDIF
247       CONTINUE
249     CONTINUE
      END IF
C
C          Add MSSM decay modes if applicable, OR H_SM FOR WHIGGS
C
      IF(GOMSSM) THEN
        DO 250 I=1,NOUT
C          Check for modes
          SUMBR=0
          DO 251 J=1,NSSMOD
            IF(ISSMOD(J).EQ.IDOUT(I).AND.BSSMOD(J).GT.0) THEN
              SUMBR=SUMBR+BSSMOD(J)
            ENDIF
251       CONTINUE
C          If modes exist, add them
          IF(SUMBR.LE.0) GO TO 250
          IRES=IDOUT(I)
          LRES=LABEL(IRES)
          CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX)
          LOOK(INDEX)=LOOP+1
          SUMBR2=0
          DO 252 J=1,NSSMOD
            IF(ISSMOD(J).EQ.IDOUT(I).AND.BSSMOD(J).GT.0) THEN
              LOOP=LOOP+1
              SUMBR2=SUMBR2+BSSMOD(J)
              BR=SUMBR2/SUMBR
              CBR(LOOP)=BR
              MELEM(LOOP)=MSSMOD(J)
              DO 253 K=1,5
                MODE(K,LOOP)=JSSMOD(K,J)
                LMODE(K)=LABEL(MODE(K,LOOP))
253           CONTINUE
              IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5),
     $        BR,IRES,(MODE(K,LOOP),K=1,5)
            ENDIF
252       CONTINUE
250     CONTINUE
C
C          Top hadron decays
C
        DO 260 I=1,NTHAD
C          Check for modes
          SUMBR=0
          DO 261 J=1,NSSMOD
            IF(ISSMOD(J).EQ.6.AND.BSSMOD(J).GT.0) THEN
              SUMBR=SUMBR+BSSMOD(J)
            ENDIF
261       CONTINUE
C          If modes exist, add them -- conjugate for antimesons
          IF(SUMBR.LE.0) GO TO 260
          IRES=IABS(ITHAD(I))
          LRES=LABEL(IRES)
          CALL FLAVOR(IRES,IFL1,IFL2,IFL3,JSPIN,INDEX)
          LOOK(INDEX)=LOOP+1
          SUMBR2=0
          DO 262 J=1,NSSMOD
            IF(ISSMOD(J).EQ.6.AND.BSSMOD(J).GT.0) THEN
              LOOP=LOOP+1
              SUMBR2=SUMBR2+BSSMOD(J)
              BR=SUMBR2/SUMBR
              CBR(LOOP)=BR
              IF(IABS(JSSMOD(1,J)).LT.20.AND.IABS(JSSMOD(2,J)).LT.20
     $        .AND.IABS(JSSMOD(3,J)).LT.20.AND.IABS(JSSMOD(4,J)).LT.20
     $        .AND.IABS(JSSMOD(5,J)).LT.20) THEN
                MELEM(LOOP)=4
              ELSE
                MELEM(LOOP)=0
              ENDIF
              DO 263 K=1,5
                IF(ITHAD(I).GT.0) THEN
                  MODE(K,LOOP)=JSSMOD(K,J)
                ELSE
                  MODE(K,LOOP)=IDANTI(JSSMOD(K,J))
                ENDIF
                LMODE(K)=LABEL(MODE(K,LOOP))
263           CONTINUE
              IF(LPRINT) WRITE(ITLIS,20) LRES,(LMODE(K),K=1,5),
     $        BR,IRES,(MODE(K,LOOP),K=1,5)
            ENDIF
262       CONTINUE
260     CONTINUE
      ENDIF
C
C          Set forced decay modes.
C          LOOK(INDEX) = -IRES, where LOOK2(K,IRES) points to entries in
C          decay table for IDENT>0 and IDENT<0.
C          LOOKST(IRES) = standard LOOK value.
C
      IF(NFORCE.EQ.0) GO TO 400
C          Append each forced decay to table
      IRES=0
      DO 310 I=1,NFORCE
        IF(IFORCE(I).EQ.0) GO TO 310
        LOOP=LOOP+1
        IF(LOOP.GT.MXDKY) GO TO 9999
        CALL FLAVOR(IFORCE(I),IFL1,IFL2,IFL3,JSPIN,INDEX)
        IF(IFORCE(I).GT.0) THEN
          KTYPE=1
        ELSE
          KTYPE=2
        ENDIF
C
        IF(LOOK(INDEX).GE.0) THEN
          IRES=IRES+1
          IF(IRES.GT.MXFORC) GO TO 9998
          LOOKST(IRES)=LOOK(INDEX)
          LOOK2(KTYPE,IRES)=LOOP
          LOOK2(3-KTYPE,IRES)=LOOKST(IRES)
          LOOK(INDEX)=-IRES
        ELSE
          IRES2=-LOOK(INDEX)
          IF(IRES2.GT.MXFORC) GO TO 9998
          LOOK2(KTYPE,IRES2)=LOOP
        ENDIF
C          Set forced decay mode - conjugate if necessary
        IF(KTYPE.EQ.1) THEN
          DO 320 K=1,5
320       MODE(K,LOOP)=MFORCE(K,I)
        ELSE
          DO 330 K=1,5
330       MODE(K,LOOP)=IDANTI(MFORCE(K,I))
        ENDIF
        CBR(LOOP)=1.
C          Set matrix element flag
        CALL ORDER(IFORCE(I),MFORCE(1,I),IDUMMY,MEOUT,.FALSE.)
        MELEM(LOOP)=MEOUT
        MEFORC(I)=MEOUT
310   CONTINUE
C
400   RETURN
C
C          Errors
C
9999  WRITE(ITLIS,3001) LOOP
3001  FORMAT(//' ***** ERROR IN SETDKY ... DECAY COUNTER LOOP = ',
     $I6,' *****')
      STOP 99
9998  WRITE(ITLIS,3002) IRES
3002  FORMAT(//' ***** ERROR IN SETDKY ... FORCE COUNTER IRES = ',
     $I6,' *****')
      STOP 99
      END
+EOD
+DECK,SETH.
      SUBROUTINE SETH
C
C          Set the standard Weinberg-Salam Higgs parameters in /HCON/.
C          HMASS  = Higgs mass
C          HGAM   = Higgs width
C          HGAMS  = Higgs partial width
C          ZSTARS = minimum allowed mass for Z*
C
C          IQ = 1  2  3  4  5  6  7  8  9  10 11 12 13
C               GL UP UB DN DB ST SB CH CB BT BB TP TB
C          IQ = 14  15   16 17 18   19   20  21  22  23   24   25
C               NUE ANUE E- E+ NUMU ANUM MU- MU+ NUT ANUT TAU- TAU+
C          IQ = 26 27 28 29
C               GM W+ W- Z0
C
C          Ver 6.25: Added H -> GM GM.
C          Ver 6.26: Added H -> Z0 Z* from Keung and Marciano, Phys. 
C                    Rev. D30, 248 (1984).
C          Ver 6.30: Fixed sign of FFR in H -> GM GM for TAU<1. Added
C                    H -> W W* to total width but not to partial widths
C                    to get right branching ratios.
C          Ver 7.38: Add H_SM decay modes to SSSAVE for use in WHIGGS
C          Ver 7.54: Flag matrix element for H -> WW*
C                    Require sufficient phase space for all W* decays
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES.
+CDE,KEYS.
+CDE,WCON.
+CDE,QLMASS.
+CDE,Q1Q2.
+CDE,NODCAY.
+CDE,CONST.
+CDE,HCON.
C
      REAL GAMFCN,X,AMASS,AMQ,GAMQ,AML,WM,GAMWW,TAU,FFR,FFI,FR,FI,
     $ROOT,ROOTLN,TM,SUMBR,TERM,ETAR,ETAI,RQ,RQLOG,PHIR,PHII
      REAL EPS,FEPS,AM12
      INTEGER IQ,IQ1,IQ2,I,IW
      INTEGER LISTJ(25),LISTW(4)
      DATA LISTJ/
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/
      DATA LISTW/10,80,-80,90/
C
      GAMFCN(X)=SQRT(1.-4*X**2)*(1.-4.*X**2+12.*X**4)
C
C          Calculate Higgs mass and width
C
      HMASS=AMASS(81)
      HGAM=0.
      DO 100 IQ=1,29
100   HGAMS(IQ)=0.
      IF(HMASS.LE.0) RETURN
C
C          Quarks and leptons
      DO 110 IQ=1,6
        AMQ=AMASS(IQ)
        IF(AMQ.GT.0..AND.AMQ.LT..5*HMASS) THEN
          GAMQ=3.*GF*AMQ**2*HMASS/(4.*PI*SQRT2)
     $    *(SQRT(1.-4.*AMQ**2/HMASS**2))**3
          HGAM=HGAM+GAMQ
          HGAMS(2*IQ)=.5*GAMQ
          HGAMS(2*IQ+1)=.5*GAMQ
          CALL SSSAVE(81,GAMQ,IQ,-IQ,0,0,0)
        ENDIF
        AML=AMASS(IQ+10)
        IF(AML.GT.0..AND.AML.LT..5*HMASS) THEN
          GAMQ=GF*AML**2*HMASS/(4.*PI*SQRT2)
     $    *(SQRT(1.-4.*AML**2/HMASS**2))**3
          HGAM=HGAM+GAMQ
          HGAMS(2*IQ+12)=.5*GAMQ
          HGAMS(2*IQ+13)=.5*GAMQ
          CALL SSSAVE(81,GAMQ,IQ+10,-(IQ+10),0,0,0)
        ENDIF
110   CONTINUE
C
C          W+ W- and Z0 Z0, including W W* and Z Z*.
      WM=WMASS(2)
      IF(HMASS.GT.2.*WM) THEN
        GAMWW=GF*HMASS**3*GAMFCN(WM/HMASS)/(8.*PI*SQRT2)
        HGAM=HGAM+GAMWW
        HGAMS(27)=.5*GAMWW
        HGAMS(28)=.5*GAMWW
        CALL SSSAVE(81,GAMWW,80,-80,0,0,0)
      ELSEIF(HMASS.GT.WM+AMASS(4)+2.) THEN
        EPS=WM/HMASS
        FEPS=3.*(1.-8.*EPS**2+20.*EPS**4)/SQRT(4.*EPS**2-1.)
     $  *ACOS((3.*EPS**2-1.)/(2.*EPS**3))
     $  -(1.-EPS**2)*(47./2.*EPS**2-13./2.+1./EPS**2)
     $  -3.*(1.-6.*EPS**2+4.*EPS**4)*ALOG(EPS)
        GAMWW=3.*ALFA**2*HMASS/(32.*PI*SIN2W**2)*FEPS
        HGAM=HGAM+GAMWW
        HGAMS(27)=.5*GAMWW
        HGAMS(28)=.5*GAMWW
        CALL SSSAVE(81,GAMWW/18.,80,12,-11,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/18.,-80,-12,11,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/18.,80,14,-13,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/18.,-80,-14,13,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/18.,80,16,-15,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/18.,-80,-16,15,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/6.,80,-1,2,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/6.,-80,1,-2,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/6.,80,-4,3,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,GAMWW/6.,-80,4,-3,0,0)
        CALL SSSVME(9)
      ENDIF
      WM=WMASS(4)
      IF(HMASS.GT.2.*WM) THEN
        GAMWW=GF*HMASS**3*GAMFCN(WM/HMASS)/(16.*PI*SQRT2)
        HGAM=HGAM+GAMWW
        HGAMS(29)=GAMWW
        CALL SSSAVE(81,GAMWW,90,90,0,0,0)
      ELSEIF(HMASS.GT.WM+2*AMASS(5)+2.) THEN
        EPS=WM/HMASS
        FEPS=3.*(1.-8.*EPS**2+20.*EPS**4)/SQRT(4.*EPS**2-1.)
     $  *ACOS((3.*EPS**2-1.)/(2.*EPS**3))
     $  -(1.-EPS**2)*(47./2.*EPS**2-13./2.+1./EPS**2)
     $  -3.*(1.-6.*EPS**2+4.*EPS**4)*ALOG(EPS)
        GAMWW=ALFA**2*HMASS/(128.*PI*SIN2W**2*(1.-SIN2W)**2)
     $  *(7.-40./3.*SIN2W+160./9.*SIN2W**2)*FEPS
        HGAM=HGAM+GAMWW
        HGAMS(29)=GAMWW
        CALL SSSAVE(81,.11922*GAMWW,90,-1,1,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.15375*GAMWW,90,-2,2,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.15375*GAMWW,90,-3,3,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.11922*GAMWW,90,-4,4,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.15375*GAMWW,90,-5,5,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.06668*GAMWW,90,-11,11,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.03343*GAMWW,90,-12,12,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.06668*GAMWW,90,-13,13,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.03343*GAMWW,90,-14,14,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.06668*GAMWW,90,-15,15,0,0)
        CALL SSSVME(9)
        CALL SSSAVE(81,.03343*GAMWW,90,-16,16,0,0)
        CALL SSSVME(9)
      ENDIF
C          W* and Z* mass limits
      DO 120 I=1,2
        ZSTARS(1,I)=0.
        DO 130 IW=2,4
          ZSTARS(IW,I)=AMASS(LISTW(IW))
          DO 140 IQ1=2,25
            IQ2=MATCH(IQ1,IW)
            IF(IQ2.EQ.0) GO TO 140
            IF(GOWW(IQ1,1).AND.GOWW(IQ2,2)) THEN
              AM12=AMASS(LISTJ(IQ1))+AMASS(LISTJ(IQ2))
              ZSTARS(IW,I)=MIN(ZSTARS(IW,I),AM12)
            ENDIF
140       CONTINUE
130     CONTINUE
120   CONTINUE
C
C          GM GM -- W loop term
      WM=WMASS(2)
      TAU=4.*WM**2/HMASS**2
      IF(TAU.GE.1.0) THEN
        FFR=(ASIN(1./SQRT(TAU)))**2
        FFI=0.
      ELSE
        ROOT=SQRT(1.-TAU)
        ROOTLN=ALOG((1.+ROOT)/(1.-ROOT))
        FFR=-0.25*(ROOTLN**2-PI**2)
        FFI=0.5*PI*ROOTLN
      ENDIF
      FR=2.+3.*TAU+3.*TAU*(2.-TAU)*FFR
      FI=3.*TAU*(2.-TAU)*FFI
C          Top loop term
      TM=AMASS(6)
      TAU=4.*TM**2/HMASS**2
      IF(TAU.GE.1.0) THEN
        FFR=(ASIN(1./SQRT(TAU)))**2
        FFI=0.
      ELSE
        ROOT=SQRT(1.-TAU)
        ROOTLN=ALOG((1.+ROOT)/(1.-ROOT))
        FFR=-0.25*(ROOTLN**2-PI**2)
        FFI=0.5*PI*ROOTLN
      ENDIF
      FR=FR-8./3.*TAU*(1.+(1.-TAU)*FFR)
      FI=FI-8./3.*TAU*(1.-TAU)*FFI
C          Total GM GM
      HGAMS(26)=ALFA**3/(256.*PI**2*SIN2W)*HMASS**3/WM**2*(FR**2+FI**2)
      HGAM=HGAM+HGAMS(26)
      CALL SSSAVE(81,HGAMS(26),10,10,0,0,0)
C
C          Calculate Higgs-gluon-gluon coupling
C
      ETAR=0.
      ETAI=0.
      DO 300 IQ=1,8
        AMQ=AMASS(IQ)
        IF(AMQ.LE.0.) GO TO 300
        RQ=(2.*AMQ/HMASS)**2
        IF(RQ.GE.1.) THEN
          ETAR=ETAR+.5*RQ*(1.+(1.-RQ)*ASIN(1./SQRT(RQ))**2)
        ELSE
          RQLOG=ALOG((1.+SQRT(1.-RQ))/(1.-SQRT(1.-RQ)))
          PHIR=.25*(RQLOG**2-PI**2)
          ETAR=ETAR+.5*RQ*(1.+(RQ-1.)*PHIR)
          PHII=.5*PI*RQLOG
          ETAI=ETAI+.5*RQ*(1.+(RQ-1.)*PHII)
        ENDIF
300   CONTINUE
      ETAHGG=ETAR**2+ETAI**2
C
      RETURN
      END
+EOD
+DECK,SETHSS
      SUBROUTINE SETHSS
C
C          Set the MSSM Higgs parameters in /HCON/.
C          HMASS  = Higgs mass for HTYPE
C          HGAM   = Higgs width
C          HGAMSS = Higgs partial widths. Note HGAMSS is not
C                   necessarily diagonal for SUSY decays.
C          ZSTARS = minimum allowed mass for Z*
C
C          Note LISTSS(78) => W+, LISTSS(79) => W-, LISTSS(80) => Z0
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,HCON
+CDE,LISTSS
+CDE,Q1Q2
+CDE,SSMODE
+CDE,SSTYPE
+CDE,WCON
C
      REAL AMASS
      REAL AM12
      INTEGER I,J,N,IQ1,IQ2,IW,K
      INTEGER LISTJ(25),LISTW(4)
C
      DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/
      DATA LISTW/10,80,-80,90/
C
C          Initialize
C
      IF(IHTYPE.EQ.0) THEN
        WRITE(ITLIS,*) ' YOU MUST SELECT AN HTYPE FOR SUSY HIGGS'
        WRITE(ITLIS,*) ' JOB TERMINATED'
        STOP99
      ENDIF
      HMASS=AMASS(IHTYPE)
      HGAM=0.
      DO 100 I=1,85
        DO 110 J=1,85
          HGAMSS(I,J)=0
110     CONTINUE
100   CONTINUE
C
C          Extract widths from SSMODE common block
C          Note the only 3-body modes are Zff or Wff
C          These are added to the ZZ and WW entries in HCONSS,
C          and the Z* or W* decay is generated later, as for SM Higgs
C
      DO 200 N=1,NSSMOD
        IF(ISSMOD(N).NE.IHTYPE) GO TO 200
        HGAM=HGAM+GSSMOD(N)
        IF(JSSMOD(3,N).NE.0) THEN
C          3-body modes
          IF(IABS(JSSMOD(1,N)).EQ.80) THEN
            HGAMSS(78,79)=HGAMSS(78,79)+0.5*GSSMOD(N)
            HGAMSS(79,78)=HGAMSS(79,78)+0.5*GSSMOD(N)
          ELSEIF(JSSMOD(1,N).EQ.90) THEN
            HGAMSS(80,80)=HGAMSS(80,80)+GSSMOD(N)
          ELSE
            WRITE(ITLIS,1000) ISSMOD(N),(JSSMOD(K,N),K=1,5)
1000        FORMAT(' SETHSS: UNEXPECTED MODE ',I8,' --> ',5I8)
            STOP 99
          ENDIF
          GO TO 200
        ELSE
C          2-body modes
          DO 210 I=1,85
            IF(JSSMOD(1,N).NE.LISTSS(I)) GO TO 210
            DO 220 J=1,85
              IF(JSSMOD(2,N).NE.LISTSS(J)) GO TO 220
              HGAMSS(I,J)=HGAMSS(I,J)+.5*GSSMOD(N)
              HGAMSS(J,I)=HGAMSS(J,I)+.5*GSSMOD(N)
              GO TO 200
220         CONTINUE
210       CONTINUE
        ENDIF
        WRITE(ITLIS,1000) ISSMOD(N),(JSSMOD(K,N),K=1,5)
        STOP99
200   CONTINUE
C
C          W* and Z* mass limits
C
      DO 300 I=1,2
        ZSTARS(1,I)=0.
        DO 310 IW=2,4
          ZSTARS(IW,I)=AMASS(LISTW(IW))
          DO 320 IQ1=2,25
            IQ2=MATCH(IQ1,IW)
            IF(IQ2.EQ.0) GO TO 320
            IF(GOWW(IQ1,I).AND.GOWW(IQ2,I)) THEN
              AM12=AMASS(LISTJ(IQ1))+AMASS(LISTJ(IQ2))+1.0
              ZSTARS(IW,I)=MIN(ZSTARS(IW,I),AM12)
            ENDIF
320       CONTINUE
310     CONTINUE
300   CONTINUE
      RETURN
      END
+EOD
+DECK,SETKKG.
      SUBROUTINE SETKKG
C
C          Set the standard KKG parameters in /KKGRAVI/.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,KKGRAV
+CDE,CONST
C
      REAL DIM2,GMMA,GAMMA
      EXTERNAL GAMMA
C          Calculate D-surface:
      DIM2 = (NEXTRAD*1.0)/2.
      GMMA = GAMMA(DIM2)
      SURFD = (2.*PI**DIM2) / GMMA
      KKGSD = SURFD / (MASSD**(NEXTRAD+2))
      RETURN
      END
+EOD
+DECK,SETNXT.
      SUBROUTINE SETNXT
C
C            RESET LIMITS BEFORE NEXT SET
C
+CDE,ITAPES
+CDE,LSTPRT
+CDE,TOTALS
+CDE,DYLIM
+CDE,JETLIM
+CDE,PRIMAR
+CDE,JETSET
+CDE,PARTCL
      DATA UNDEF/-1.E9/
      DO 1 I=1,36
      IF(SETLMJ(I)) BLIMS(I)=UNDEF
    1 CONTINUE
      DO 2 I=1,12
      IF(SETLMQ(I)) BLIM1(I)=UNDEF
    2 CONTINUE
C          RESET /TOTALS/
      NKINPT=0
      NWGEN=0
      NKEEP=0
      SUMWT=0.
C          RESET /LSTPRT/
      LSTPRT=0
C          RESET NJSET AND NPTCL
      NJSET=0
      NPTCL=0
      NPAIR=0
      RETURN
      END
+EOD
+DECK,SETTYP
      LOGICAL FUNCTION SETTYP(LPRT)
C
C          Set JETTYPE flags and WMODE flags for WPAIR.
C          Set WMODES and ZMODES flags for secondary W+- and Z0.
C          Return .FALSE. if no error, .TRUE. otherwise.
C
C          Ver 7.18: Initialize all GOQ to false (limit = MXGOQ)
C                    Use LISTSS for Higgs if GOMSSM
C          Ver 7.29: SUSY Higgs decays are done in SETHSS and SIGHSS
C                    using LISTSS order, so SUSY list should be used.
C                    I.e., 7.18 fix was wrong.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,KEYS
+CDE,TYPES
+CDE,Q1Q2
+CDE,XMSSM
C
      INTEGER JET,K,I,IW,LPRT
      INTEGER NLIST
      CHARACTER*8 WORD,BLANK,LIST(30),LISTW(4),LISTXY(4),LISTSS(85)
      DATA BLANK/'        '/
      DATA LIST/'GL','UP','UB','DN','DB','ST','SB','CH','CB','BT','BB',
     $'TP','TB','NUE','ANUE','E-','E+','NUM','ANUM','MU-','MU+',
     $'NUT','ANUT','TAU-','TAU+','GM','W+','W-','Z0','HIGGS'/
      DATA LISTW/'GM','W+','W-','Z0'/
      DATA LISTXY/'Y','YB','X','XB'/
      DATA LISTSS/'GLSS',
     $'UPSSL','UBSSL','DNSSL','DBSSL','STSSL','SBSSL','CHSSL','CBSSL',
     $'BTSS1','BBSS1','TPSS1','TBSS1',
     $'UPSSR','UBSSR','DNSSR','DBSSR','STSSR','SBSSR','CHSSR','CBSSR',
     $'BTSS2','BBSS2','TPSS2','TBSS2',
     $'W1SS+','W1SS-','W2SS+','W2SS-','Z1SS','Z2SS','Z3SS','Z4SS',
     $'NUEL','ANUEL','EL-','EL+','NUML','ANUML','MUL-','MUL+',
     $'NUTL','ANUTL','TAU1-','TAU1+','ER-','ER+','MUR-','MUR+',
     $'TAU2-','TAU2+',
     $'GL','UP','UB','DN','DB','ST','SB','CH','CB','BT','BB',
     $'TP','TB','NUE','ANUE','E-','E+','NUM','ANUM','MU-','MU+',
     $'NUT','ANUT','TAU-','TAU+','GM','W+','W-','Z0',
     $'HL0','HH0','HA0','H+','H-'/
C
      SETTYP=.FALSE.
C       
      IF(KEYS(5)) GO TO 5
      IF(KEYS(2).AND.GOMSSM) GO TO 5
      IF(KEYS(6).OR.KEYS(9)) GO TO 6
      IF(KEYS(7).AND..NOT.GOMSSM) GO TO 7
      IF(KEYS(7).AND.GOMSSM) GO TO 5
      IF(KEYS(10).AND.GOMSSM) GO TO 5
C
C          JETTYPE flags all processes except WPAIR and HIGGS.
C          NJTTYP is set in READIN to number of non-blank values read.
C          Check for legal jet type names and set appropriate flags.
C
      DO 1000 JET=1,MXGOJ
        IF(NJTTYP(JET).EQ.0) GO TO 1000
C          Initialize everything to .FALSE.
        GOALL(JET)=.FALSE.
        DO 1100 K=1,MXGOQ
          GOQ(K,JET)=.FALSE.
1100    CONTINUE
C          Loop over non-blank JETTYPE entries
        DO 1200 I=1,NJTTYP(JET)
          WORD=JETYP(I,JET)
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 1200
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            GOALL(JET)=.TRUE.
            DO 1210 K=1,MXGOQ
1210        GOQ(K,JET)=.TRUE.
            GO TO 1000
          ENDIF
C          Quarks
          IF(WORD.EQ.'QUARKS  ') THEN
            DO 1220 K=2,13
1220        GOQ(K,JET)=.TRUE.
            GO TO 1200
          ENDIF
C          Charged leptons
          IF(WORD.EQ.'LEPTONS ') THEN
            DO 1230 K=16,24,4
            GOQ(K,JET)=.TRUE.
1230        GOQ(K+1,JET)=.TRUE.
            GO TO 1200
          ENDIF
C          Neutrinos
          IF(WORD.EQ.'NUS     ') THEN
            DO 1240 K=14,22,4
            GOQ(K,JET)=.TRUE.
1240        GOQ(K+1,JET)=.TRUE.
            GO TO 1200
          ENDIF
C          Explicit types
C          E+E- now also contains W+, W-, Z0
          IF(KEYS(2).OR.KEYS(10).OR.KEYS(11).OR.KEYS(12)) THEN
            NLIST=30
          ELSE
            NLIST=25
          ENDIF
          DO 1250 K=1,NLIST
            IF(WORD.EQ.LIST(K)) THEN
              GOQ(K,JET)=.TRUE.
              GO TO 1200
            ENDIF
1250      CONTINUE
C          Special types for TWOJET
          DO 1270 K=1,4
            IF(KEYS(1).AND.WORD.EQ.LISTXY(K)) THEN
              GOQ(13+K,JET)=.TRUE.
              GO TO 1200
            ENDIF
1270      CONTINUE
C          Special type for PHOTON
          IF(KEYS(8).AND.WORD.EQ.LISTW(1)) THEN
            GOQ(26,JET)=.TRUE.
            GO TO 1200
          ENDIF
C          Error
          WRITE(ITLIS,1300) WORD,JET
1300      FORMAT(1X,A8,' IS NOT RECOGNIZABLE FOR JETTYPE',I1)
          SETTYP=.TRUE.
1200    CONTINUE
1000  CONTINUE
      GO TO 4000
C
C          JETTYPE flags for SUSY
C
5     DO 5000 JET=1,2
        IF(NJTTYP(JET).EQ.0) GO TO 5000
        GOALL(JET)=.FALSE.
        DO 5100 K=1,MXGOQ
5100    GOQ(K,JET)=.FALSE.
        DO 5200 I=1,NJTTYP(JET)
          WORD=JETYP(I,JET)
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 5200
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            GOALL(JET)=.TRUE.
            DO 5210 K=1,85
5210        GOQ(K,JET)=.TRUE.
            GO TO 5000
          ENDIF
C          Squarks
          IF(WORD.EQ.'SQUARKS ') THEN
            DO 5220 K=2,25
5220        GOQ(K,JET)=.TRUE.
            GO TO 5200
          ENDIF
C           Gauginos
          IF(WORD.EQ.'GAUGINOS') THEN
            DO 5230 K=26,33
5230        GOQ(K,JET)=.TRUE.
            GO TO 5200
          ENDIF
C           Sleptons
          IF(WORD.EQ.'SLEPTONS') THEN
            DO 5240 K=34,51
5240        GOQ(K,JET)=.TRUE.
            GO TO 5200
          ENDIF
C          Explicit susy types
          DO 5300 K=1,85
            IF(WORD.EQ.LISTSS(K)) THEN
              GOQ(K,JET)=.TRUE.
              GO TO 5200
            ENDIF
5300      CONTINUE
5200    CONTINUE
5000  CONTINUE
      GO TO 4000
C
C          JETTYPE and WMODE flags for WPAIR
C          NJTTYP and NWWTYP are the number of non-blank values.
C
6     DO 2000 JET=1,2
        IF(NJTTYP(JET).EQ.0) GO TO 2300
C          Initialize to FALSE
        GOALL(JET)=.FALSE.
        DO 2100 K=1,4
2100    GOQ(K,JET)=.FALSE.
C
C          Loop over non-blank JETTYPE flags
C
        DO 2200 I=1,NJTTYP(JET)
          WORD=JETYP(I,JET)
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 2200
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            GOALL(JET)=.TRUE.
            DO 2210 K=1,4
2210        GOQ(K,JET)=.TRUE.
            GO TO 2300
          ENDIF
C          Explicit types
          DO 2220 K=1,4
            IF(WORD.EQ.LISTW(K)) THEN
              GOQ(K,JET)=.TRUE.
              GO TO 2200
            ENDIF
2220      CONTINUE
C          Error
          WRITE(ITLIS,1300) WORD,JET
          SETTYP=.TRUE.
2200    CONTINUE
C
C          Loop over nonblank WMODE flags
C
2300    IF(NWWTYP(JET).EQ.0) GO TO 2000
        ALLWW(JET)=.FALSE.
C         Initialize everything to FALSE
        DO 2350 K=1,25
2350    GOWW(K,JET)=.FALSE.
C
        DO 2400 I=1,NWWTYP(JET)
          WORD=WWTYP(I,JET)
          IF(WORD.NE.BLANK) NWWTYP(JET)=I
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 2400
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            ALLWW(JET)=.TRUE.
            DO 2410 K=1,25
2410        GOWW(K,JET)=.TRUE.
            GO TO 2000
          ENDIF
C          Quarks
          IF(WORD.EQ.'QUARKS  ') THEN
            DO 2420 K=2,13
2420        GOWW(K,JET)=.TRUE.
            GO TO 2400
          ENDIF
C          Charged leptons
          IF(WORD.EQ.'LEPTONS ') THEN
            DO 2430 K=16,24,4
            GOWW(K,JET)=.TRUE.
2430        GOWW(K+1,JET)=.TRUE.
            GO TO 2400
          ENDIF
C          Neutrinos
          IF(WORD.EQ.'NUS     ') THEN
            DO 2440 K=14,22,4
            GOWW(K,JET)=.TRUE.
2440        GOWW(K+1,JET)=.TRUE.
            GO TO 2400
          ENDIF
C          Explicit types
          DO 2450 K=1,25
            IF(WORD.EQ.LIST(K)) THEN
              GOWW(K,JET)=.TRUE.
              GO TO 2400
            ENDIF
2450      CONTINUE
C          Error
          WRITE(ITLIS,2500) WORD,JET
2500      FORMAT(1X,A8,' IS NOT A VALID CODE FOR WMODE',I1)
          SETTYP=.TRUE.
2400    CONTINUE
2000  CONTINUE
      GO TO 4000
C
C          JETTYPE and WMODE flags for HIGGS
C          SUSY HIGGS uses LISTSS order and hence SUSY part
C
7     DO 3000 JET=1,2
        IF(NJTTYP(JET).EQ.0) GO TO 3300
C          Initialize to FALSE
        GOALL(JET)=.FALSE.
        DO 3100 K=1,MXGOQ
3100    GOQ(K,JET)=.FALSE.
C
C          Loop over non-blank JETTYPE flags
C
        DO 3200 I=1,NJTTYP(JET)
          WORD=JETYP(I,JET)
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 3200
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            GOALL(JET)=.TRUE.
            DO 3210 K=1,MXGOQ
3210        GOQ(K,JET)=.TRUE.
            GO TO 3300
          ENDIF
C          Quarks
          IF(WORD.EQ.'QUARKS  ') THEN
            DO 3220 K=2,13
3220        GOQ(K,JET)=.TRUE.
            GO TO 3200
          ENDIF
C          Charged leptons
          IF(WORD.EQ.'LEPTONS ') THEN
            DO 3240 K=16,24,4
            GOQ(K,JET)=.TRUE.
3240        GOQ(K+1,JET)=.TRUE.
            GO TO 3200
          ENDIF
          DO 3250 K=1,85
            IF(WORD.EQ.LIST(K)) THEN
              GOQ(K,JET)=.TRUE.
              GO TO 3200
            ENDIF
3250      CONTINUE
C          Error
          WRITE(ITLIS,1300) WORD,JET
          SETTYP=.TRUE.
3200    CONTINUE
C
C          Loop over nonblank WMODE flags
C
3300    IF(NWWTYP(JET).EQ.0) GO TO 3000
        ALLWW(JET)=.FALSE.
C         Initialize everything to FALSE
        DO 3350 K=1,25
3350    GOWW(K,JET)=.FALSE.
C
        DO 3400 I=1,NWWTYP(JET)
          WORD=WWTYP(I,JET)
          IF(WORD.NE.BLANK) NWWTYP(JET)=I
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 3400
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            ALLWW(JET)=.TRUE.
            DO 3410 K=1,25
3410        GOWW(K,JET)=.TRUE.
            GO TO 3000
          ENDIF
C          Quarks
          IF(WORD.EQ.'QUARKS  ') THEN
            DO 3420 K=2,13
3420        GOWW(K,JET)=.TRUE.
            GO TO 3400
          ENDIF
C          Charged leptons
          IF(WORD.EQ.'LEPTONS ') THEN
            DO 3430 K=16,24,4
            GOWW(K,JET)=.TRUE.
3430        GOWW(K+1,JET)=.TRUE.
            GO TO 3400
          ENDIF
C          Neutrinos
          IF(WORD.EQ.'NUS     ') THEN
            DO 3440 K=14,22,4
            GOWW(K,JET)=.TRUE.
3440        GOWW(K+1,JET)=.TRUE.
            GO TO 3400
          ENDIF
C          Explicit types
          DO 3450 K=1,25
            IF(WORD.EQ.LIST(K)) THEN
              GOWW(K,JET)=.TRUE.
              GO TO 3400
            ENDIF
3450      CONTINUE
C          Error
          WRITE(ITLIS,2500) WORD,JET
3500      FORMAT(1X,A8,' IS NOT A VALID CODE FOR WMODE',I1)
          SETTYP=.TRUE.
3400    CONTINUE
3000  CONTINUE
C
C          Set WMODES and ZMODES flags for secondary W+- and Z0
C
4000  DO 4100 IW=1,3
        IF(NWMODE(IW).EQ.0) GO TO 4100
C           Initialize everything to .FALSE.
        DO 4200 K=1,25
4200    GOWMOD(K,IW)=.FALSE.
C          Loop over non-blank WMODE entries
        DO 4300 I=1,NWMODE(IW)
          WORD=WMODES(I,IW)
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 4300
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            DO 4310 K=1,25
4310        GOWMOD(K,IW)=.TRUE.
            GO TO 4100
          ENDIF
C          Quarks
          IF(WORD.EQ.'QUARKS  ') THEN
            DO 4320 K=2,13
4320        GOWMOD(K,IW)=.TRUE.
            GO TO 4300
          ENDIF
C          Charged leptons
          IF(WORD.EQ.'LEPTONS ') THEN
            DO 4330 K=16,24,4
            GOWMOD(K,IW)=.TRUE.
4330        GOWMOD(K+1,IW)=.TRUE.
            GO TO 4300
          ENDIF
C          Neutrinos
          IF(WORD.EQ.'NUS     ') THEN
            DO 4340 K=14,22,4
            GOWMOD(K,IW)=.TRUE.
4340        GOWMOD(K+1,IW)=.TRUE.
            GO TO 4300
          ENDIF
C          Explicit types
          DO 4350 K=1,25
            IF(WORD.EQ.LIST(K)) THEN
              GOWMOD(K,IW)=.TRUE.
              GO TO 4300
            ENDIF
4350      CONTINUE
C          Error
          WRITE(ITLIS,4380) WORD
4380      FORMAT(1X,A8,' IS NOT RECOGNIZABLE FOR SECONDARY WS')
          SETTYP=.TRUE.
4300    CONTINUE
4100  CONTINUE
C
C          Loop over nonblank WMODE flags FOR WHIGGS
C
      IF (KEYS(10)) THEN
      DO 6000 JET=1,2
6300    IF(NWWTYP(JET).EQ.0) GO TO 6000
        ALLWW(JET)=.FALSE.
C         Initialize everything to FALSE
        DO 6350 K=1,25
6350    GOWW(K,JET)=.FALSE.
C
        DO 6400 I=1,NWWTYP(JET)
          WORD=WWTYP(I,JET)
          IF(WORD.NE.BLANK) NWWTYP(JET)=I
C          Blank
          IF(WORD.EQ.BLANK) THEN
            GO TO 6400
          ENDIF
C          All
          IF(WORD.EQ.'ALL     ') THEN
            ALLWW(JET)=.TRUE.
            DO 6410 K=1,25
6410        GOWW(K,JET)=.TRUE.
            GO TO 6000
          ENDIF
C          Quarks
          IF(WORD.EQ.'QUARKS  ') THEN
            DO 6420 K=2,13
6420        GOWW(K,JET)=.TRUE.
            GO TO 6400
          ENDIF
C          Charged leptons
          IF(WORD.EQ.'LEPTONS ') THEN
            DO 6430 K=16,24,4
            GOWW(K,JET)=.TRUE.
6430        GOWW(K+1,JET)=.TRUE.
            GO TO 6400
          ENDIF
C          Neutrinos
          IF(WORD.EQ.'NUS     ') THEN
            DO 6440 K=14,22,4
            GOWW(K,JET)=.TRUE.
6440        GOWW(K+1,JET)=.TRUE.
            GO TO 6400
          ENDIF
C          Explicit types
          DO 6450 K=1,25
            IF(WORD.EQ.LIST(K)) THEN
              GOWW(K,JET)=.TRUE.
              GO TO 6400
            ENDIF
6450      CONTINUE
C          Error
          WRITE(ITLIS,6500) WORD,JET
6500      FORMAT(1X,A8,' IS NOT A VALID CODE FOR WMODE',I1)
          SETTYP=.TRUE.
6400    CONTINUE
6000  CONTINUE
      END IF
      RETURN
      END
+EOD
+DECK,SETW.
      SUBROUTINE SETW
C
C          Set the W parameters in /WCON/.
C          SIN2W         = sin**2(theta-sub-w)
C          AQ, BQ        = vector, axial couplings normalized to ALFA.
C          MATCH(IQ1,IW) = Cabibbo favored type for W --> QK1 + QK2.
C          WCBR(IQ,IW)   = cumulative branching ratio for JETTYP(1)=IQ
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,KEYS
+CDE,WCON
+CDE,QLMASS
+CDE,Q1Q2
+CDE,NODCAY
+CDE,CONST
+CDE,XMSSM
C
      REAL SINW,COSW,AMW,AMZ,AW,FACZ,GAMW,GAMZ,TERM,SUM,AM1,AMASS,AM2
      INTEGER I1,I2,I3,J,INDEX,IFL,NGAM,NUP,IW,IQ1,IQ2,IFL1,JET,IQ,IFL2
      INTEGER IW1
      REAL T3(12),EQ3(12)
      INTEGER NUTYP(25),LISTJ(25)
+SELF,IF=SINGLE
      REAL SIN2WD,SINWD,COSWD,AWD,FACZD
+SELF,IF=DOUBLE.
      DOUBLE PRECISION SIN2WD,SINWD,COSWD,AWD,FACZD
+SELF.
      DATA T3/.5,-.5,-.5,.5,-.5,.5,.5,-.5,.5,-.5,.5,-.5/
      DATA EQ3/2.,-1.,-1.,2.,-1.,2.,0.,-3.,0.,-3.,0.,-3./
      DATA NUTYP/13*0,1,1,0,0,1,1,0,0,1,1,0,0/
      DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/
C
C          Masses can be changed with WMASS
C
      SINW=SQRT(SIN2W)
      COSW=SQRT(1.-SIN2W)
      AMW=WMASS(2)
      AMZ=WMASS(4)
C
C          Couplings for Weinberg-Salam model
C
      AW=1./(2.*SQRT2*SINW)
      FACZ=1./(2.*SINW*COSW)
      EZ=SQRT((1.-SIN2W)/SIN2W)
      DO 110 IFL=1,12
        AQ(IFL,1)=EQ3(IFL)/3.
        BQ(IFL,1)=0.
        AQ(IFL,2)=AW
        BQ(IFL,2)=AW
        AQ(IFL,3)=AW
        BQ(IFL,3)=AW
        AQ(IFL,4)=FACZ*(T3(IFL)-2.*EQ3(IFL)/3.*SIN2W)
        BQ(IFL,4)=FACZ*T3(IFL)
110   CONTINUE
+SELF,IF=SINGLE.
C          Double precision couplings not needed.
      EZDP=EZ
      DO 120 IW=1,4
      DO 120 IFL=1,12
        AQDP(IFL,IW)=AQ(IFL,IW)
        BQDP(IFL,IW)=BQ(IFL,IW)
120   CONTINUE
+SELF,IF=DOUBLE.
C          Double precision couplings for 32-bit machines.
      SIN2WD=SIN2W
      SINWD=DSQRT(SIN2WD)
      COSWD=DSQRT(1.-SIN2WD)
      AWD=1./(2.*DSQRT(2.D0)*SINWD)
      FACZD=1./(2.*SINWD*COSWD)
      EZDP=COSWD/SINWD
      DO 120 IFL=1,12
        AQDP(IFL,1)=EQ3(IFL)/3.D0
        BQDP(IFL,1)=0.
        AQDP(IFL,2)=AWD
        BQDP(IFL,2)=AWD
        AQDP(IFL,3)=AWD
        BQDP(IFL,3)=AWD
        AQDP(IFL,4)=FACZD*(T3(IFL)-2.D0*EQ3(IFL)/3.D0*SIN2WD)
        BQDP(IFL,4)=FACZD*T3(IFL)
120   CONTINUE
+SELF.
C
C          Widths
C
      NGAM=12
      IF(AMLEP(5)+AMLEP(6).GT.AMW) NGAM=9
      GAMW=GF*AMW**3/(6.*PI*SQRT2)*NGAM
      NUP=3
      IF(2.*AMLEP(6).GT.AMZ) NUP=2
      GAMZ=NUP*3.*(AQ(1,4)**2+BQ(1,4)**2)+3.*3.*(AQ(2,4)**2+BQ(2,4)**2)
     1+3.*(AQ(7,4)**2+BQ(7,4)**2+AQ(8,4)**2+BQ(8,4)**2)
      GAMZ=GAMZ*2./FACZ**2
      GAMZ=GAMZ*GF*AMZ**3/(12.*PI*SQRT2)
      WGAM(1)=0.
      WGAM(2)=GAMW
      WGAM(3)=GAMW
      WGAM(4)=GAMZ
C
C          Branching ratios for secondary W+- and Z0
C
      DO 210 IW=2,4
        IW1=IW-1
        SUM=0.
        CUMWBR(1,IW1)=0.
        DO 220 IQ1=2,25
          CUMWBR(IQ1,IW1)=CUMWBR(IQ1-1,IW1)
          IQ2=MATCH(IQ1,IW)
          IF(IQ2.EQ.0) GO TO 220
          IF(.NOT.(GOWMOD(IQ1,IW-1).AND.GOWMOD(IQ2,IW-1))) GO TO 220
          IFL1=LISTJ(IQ1)
          IFL2=LISTJ(IQ2)
          AM1=AMASS(IFL1)
          AM2=AMASS(IFL2)
          IF(AM1+AM2.GE.WMASS(IW)) GO TO 220
          TERM=AQ(IQ1/2,IW)**2+BQ(IQ1/2,IW)**2
          IF(IQ1.LE.13) TERM=3.*TERM
          CUMWBR(IQ1,IW1)=CUMWBR(IQ1-1,IW1)+TERM
          SUM=SUM+TERM
220     CONTINUE
        IF(SUM.LE.0.) THEN
          WRITE(ITLIS,2000) IW
2000      FORMAT(//' ***** NO ALLOWED DECAY MODE FOR SECONDARY W TYPE',
     $    I2,' *****')
          STOP 99
        ENDIF
        DO 230 IQ1=2,25
          CUMWBR(IQ1,IW1)=CUMWBR(IQ1,IW1)/SUM
230     CONTINUE
210   CONTINUE
C
C          Decay channels for DRELLYAN
C
      IF(KEYS(3)) THEN
        DO 310 IW=1,4
          COUT(IW)=0.
          IF(.NOT.GODY(IW)) GO TO 310
          DO 320 IQ1=2,25
            IQ2=MATCH(IQ1,IW)
            IF(IQ2.EQ.0) GO TO 320
            IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 320
            IF(NUTYP(IQ1)*NUTYP(IQ2).EQ.1.AND.NONUNU) GO TO 320
            IFL1=IQ1/2
            TERM=.5*(AQ(IFL1,IW)**2+BQ(IFL1,IW)**2)
            IF(IQ1.LE.13) TERM=3.*TERM
            COUT(IW)=COUT(IW)+TERM
320       CONTINUE
          IF(COUT(IW).EQ.0.) THEN
            WRITE(ITLIS,3000) IW
3000        FORMAT(//' ***** ERROR IN SETW ... NO ALLOWED DECAY MODE ',
     $      'FOR W TYPE',I2,' *****')
            STOP 99
          ENDIF
310     CONTINUE
C          W branching ratios
        DO 330 IW=1,4
          IF(.NOT.GODY(IW)) GO TO 330
          SUM=0.
          DO 340 IQ1=1,25
            WCBR(IQ1,IW)=SUM
            IQ2=MATCH(IQ1,IW)
            IF(IQ2.EQ.0) GO TO 340
            IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 340
            IF(NUTYP(IQ1)*NUTYP(IQ2).EQ.1.AND.NONUNU) GO TO 340
            IFL1=IQ1/2
            TERM=.5*(AQ(IFL1,IW)**2+BQ(IFL1,IW)**2)/COUT(IW)
            IF(IQ1.LE.13) TERM=3.*TERM
            SUM=SUM+TERM
            WCBR(IQ1,IW)=SUM
340       CONTINUE
330     CONTINUE
      ENDIF
C
C          Calculate branching ratios for WPAIR events summed over
C          modes allowed by WMODE cards.
C          TBRWW = total allowed branching ratio.
C          RBRWW = relative branching ratios.
C          TBRWW*RBRWW = physical branching ratios.
C
      IF((KEYS(2).AND.(.NOT.GOMSSM)).OR.KEYS(6)
     ,.OR.KEYS(7).OR.KEYS(9).OR.KEYS(10)) THEN
        DO 400 JET=1,2
          TBRWW(1,JET)=1.
          DO 410 IW=2,4
            TBRWW(IW,JET)=0.
            IF(KEYS(6).OR.KEYS(9)) THEN
              IF(.NOT.GOQ(IW,JET)) GO TO 410
            ELSEIF((KEYS(2).OR.KEYS(7).OR.KEYS(10)).AND..NOT.GOMSSM)THEN
              IF(.NOT.GOQ(IW+25,JET)) GO TO 410
            ELSEIF((KEYS(7).OR.KEYS(10)).AND.GOMSSM) THEN
              IF(.NOT.GOQ(IW+76,JET)) GO TO 410
            ENDIF
            SUM=0.
            DO 420 IQ=1,12
              RBRWW(IQ,IW,JET)=0.
              IQ1=2*IQ
              IQ2=MATCH(IQ1,IW)
              IF(IQ2.EQ.0) GO TO 420
              IFL1=IQ1/2
              IF(IQ1.GT.13) IFL1=IFL1+4
              IFL2=IQ2/2
              IF(IQ2.GT.13) IFL2=IFL2+4
              AM1=AMASS(IFL1)
              AM2=AMASS(IFL2)
              IF(AM1+AM2.GE.WMASS(IW)) GO TO 420
              TERM=AQ(IQ1/2,IW)**2+BQ(IQ1/2,IW)**2
              IF(IQ1.LE.13) TERM=3*TERM
              SUM=SUM+TERM
              IF(.NOT.(GOWW(IQ1,JET).AND.GOWW(IQ2,JET))) GO TO 420
              RBRWW(IQ,IW,JET)=TERM
              TBRWW(IW,JET)=TBRWW(IW,JET)+TERM
420         CONTINUE
            TBRWW(IW,JET)=TBRWW(IW,JET)/SUM
            IF(TBRWW(IW,JET).GT.0.) THEN
              DO 430 IQ=1,12
430           RBRWW(IQ,IW,JET)=RBRWW(IQ,IW,JET)/(SUM*TBRWW(IW,JET))
            ELSE
              WRITE(ITLIS,445) IW,JET
445           FORMAT(/' ***** NO ALLOWED MODE FOR W TYPE ',I2,
     $        ' IN JET ',I2,' *****'/)
              STOP 99
            ENDIF
410       CONTINUE
400   CONTINUE
      ENDIF
      RETURN
      END
+EOD
+DECK,SIGDY2.
      SUBROUTINE SIGDY2
C
C          Compute the lepton-lepton-jet cross or quark-antiquark-jet
C          cross section
C          d(sigma)/d(qmw**2)d(qtw**2)d(yw)d(yj)d(omega*)
C          for the specified W and jet types
C
C          Also fix the incoming partons to be the selected types.
C
C          QT cutoff from Parisi and Petronzio, Nucl Phys B154, 427
C          qk+gl-->qk+w suppressed at low QTW
C
C          Ver 6.40: Fix underflow in standard Drell-Yan
C
C          Ver 7.17: include top mass for gb --> Wt and gt --> Zt 
C          with no extra qt suppression factor. Note we do NOT include
C          gt --> Wb; while this process makes sense for qt >> m_t,
C          it has a pole in the physical region at low qt from the 
C          on-shell decay t --> Wb. We let Q**2 --> Q**2 + m_t**2 
C          in the scale for the parton distributions.
C
C          Ver 7.32: Rewrite AJLWT for gb --> Wt, etc., in terms of 
C          scaled variables, and restore SWT**5 later to avoid 
C          floating errors on VMS.
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,WSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
C
      REAL PROP,AJLWT,FCDIR,FCINT,QT2CUT,QFCN,AMASS,STRUC
      REAL AJLZT1,AJLZT2,AJLZT3,AJLZT4
      REAL X1WT,X2WT,P1WT,P2WT,SWT,TWT,UWT,QZW,P3Z,
     $S,T,U,S1,T1,U1,TDIR,UDIR,TINT,UINT,COUPL,DENOM,
     $AMT,AMT2,TERM1,TERM2,SIG0,QMW2,Q2,XX,S1WT,T1WT,U1WT,P1M,P2M,
     $AMI2,AMF2,EFWT,A2,A2B2,AB,AL2BL2,ALBL,QQ,TM2
      REAL AMFAC(13)
      INTEGER I,JF,IFLQ,JQK,IQ1,IQ2,IFL1,IQ,IFLL,IH,IQ3
      INTEGER NZERO(4)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      EQUIVALENCE (S1,SHAT1),(T1,THAT1),(U1,UHAT1)
C
      DATA NZERO/13,9,9,11/
      DATA AMFAC/11*0.,2*1./

C          Functions.  FCDIR and FCINT are direct and interference
C          terms for virtual Compton cross section.
C
      PROP(I)=1./((QMW2-WMASS(I)**2)**2+(WMASS(I)*WGAM(I))**2)
      FCDIR(S,T,U,S1,T1,U1)=COUPL*(S*(2.*S1**2-2.*S1*U1-2.*T1*U1)
     1+T*(-2.*S1*T1-4.*S1*U1-2.*T1*U1)+U*(2.*U1**2-2.*S1*T1-2.*S1*U1)
     2+QMW2*(S**2+U**2+2.*T*QMW2))*(-T)/DENOM
      FCINT(S,T,U,S1,T1,U1)=-COUPL*(S1*(S*T-T*U+T*QMW2+QMW2**2)
     1+T1*(-S**2+U**2+2.*S*QMW2-2.*U*QMW2)+U1*(S*T-T*U-T*QMW2-QMW2**2))
     2*(-T)/DENOM
C          QT cutoff function
      QT2CUT(QMW)=CUTOFF*QMW**CUTPOW
C          Parton distributions for top processes
      QFCN(XX,IQ,IH)=STRUC(XX,QSQ+AMT2,IQ,IDIN(IH))/XX          
C          Matrix elements JL/128 from FORM
      AJLWT(S,T,T1,U1,QQ,TM2)=
     $ + 2*QQ**3*S*T - 2*QQ**3*S*TM2 - 2*QQ**2*S**2*TM2
     $ - 2*QQ**2*S*T**2 + 4*QQ**2*S*T*T1 + 2*QQ**2*S*T*U1
     $ - 4*QQ**2*S*T1*TM2 - 2*QQ**2*S*U1*TM2 + 2*QQ**2*S*TM2**2
     $ + QQ*S**2*T*TM2 - 4*QQ*S**2*T1*TM2 + QQ*S**2*TM2**2
     $ + QQ*S*T**3 - 2*QQ*S*T**2*T1 - QQ*S*T**2*TM2 + 2*QQ*S*T*T1**2
     $ + 2*QQ*S*T*T1*U1 - 2*QQ*S*T*T1*TM2 + QQ*S*T*U1**2
     $ - 3*QQ*S*T*U1*TM2 + QQ*S*T*TM2**2 - 2*QQ*S*T1**2*TM2
     $ - 2*QQ*S*T1*U1*TM2 + 4*QQ*S*T1*TM2**2 - QQ*S*U1**2*TM2
     $ + 3*QQ*S*U1*TM2**2 - QQ*S*TM2**3 + S**2*T*T1*TM2
     $ - S**2*T*U1*TM2 - 2*S**2*T1**2*TM2 + S**2*T1*TM2**2
     $ + S**2*U1*TM2**2 + S*T**2*T1*TM2 - 2*S*T*T1**2*TM2
     $ - 2*S*T*T1*U1*TM2 - S*T*U1**2*TM2 + S*T*U1*TM2**2
     $ + 2*S*T1**2*TM2**2 + 2*S*T1*U1*TM2**2 - S*T1*TM2**3
     $ + S*U1**2*TM2**2 - S*U1*TM2**3
C
      AJLZT1(S,T,T1,U1,QQ,TM2)=
     $ + A2*AL2BL2 * ( 8*QQ**2*S*T*TM2 - 8*QQ**2*S*TM2**2
     $ - 8*QQ**2*T*TM2**2 + 8*QQ**2*TM2**3 - 8*QQ*S**2*T*TM2
     $ - 8*QQ*S*T**2*TM2 + 16*QQ*S*T*TM2**2 + 8*QQ*S*TM2**3
     $ + 8*QQ*T*TM2**3 - 16*QQ*TM2**4 + 8*S**2*T*U1*TM2
     $ - 8*S**2*U1*TM2**2 + 8*S*T**2*U1*TM2 + 8*S*T*U1**2*TM2
     $ - 32*S*T*U1*TM2**2 - 8*S*U1**2*TM2**2 + 24*S*U1*TM2**3
     $ - 8*T**2*U1*TM2**2 - 8*T*U1**2*TM2**2 + 24*T*U1*TM2**3
     $ + 8*U1**2*TM2**3 - 16*U1*TM2**4 )/8.
      AJLZT2(S,T,T1,U1,QQ,TM2)=
     $ + A2B2*AL2BL2 * ( 2*QQ**3*S*T - 2*QQ**3*S*TM2
     $ - 2*QQ**3*T*TM2 + 2*QQ**3*TM2**2 - 2*QQ**2*S**2*TM2
     $ - 2*QQ**2*S*T**2 + 4*QQ**2*S*T*T1 + 2*QQ**2*S*T*U1
     $ - 8*QQ**2*S*T*TM2 - 4*QQ**2*S*T1*TM2 - 2*QQ**2*S*U1*TM2
     $ + 14*QQ**2*S*TM2**2 - 4*QQ**2*T*T1*TM2 - 2*QQ**2*T*U1*TM2
     $ + 12*QQ**2*T*TM2**2 + 4*QQ**2*T1*TM2**2 + 2*QQ**2*U1*TM2**2
     $ - 14*QQ**2*TM2**3 + QQ*S**3*T - QQ*S**3*TM2 + 2*QQ*S**2*T*T1
     $ + 2*QQ*S**2*T*U1 - QQ*S**2*T*TM2 - 6*QQ*S**2*T1*TM2
     $ - 2*QQ*S**2*U1*TM2 + 9*QQ*S**2*TM2**2 + QQ*S*T**3
     $ - 2*QQ*S*T**2*T1 + 3*QQ*S*T**2*TM2 + 4*QQ*S*T*T1**2
     $ + 4*QQ*S*T*T1*U1 - 16*QQ*S*T*T1*TM2 + 2*QQ*S*T*U1**2
     $ - 12*QQ*S*T*U1*TM2 + 10*QQ*S*T*TM2**2 - 4*QQ*S*T1**2*TM2
     $ - 4*QQ*S*T1*U1*TM2 + 26*QQ*S*T1*TM2**2 - 2*QQ*S*U1**2*TM2
     $ + 12*QQ*S*U1*TM2**2 - 30*QQ*S*TM2**3 - QQ*T**3*TM2
     $ - 2*QQ*T**2*T1*TM2 - 4*QQ*T**2*U1*TM2 + 5*QQ*T**2*TM2**2
     $ - 4*QQ*T*T1**2*TM2 - 4*QQ*T*T1*U1*TM2 + 22*QQ*T*T1*TM2**2
     $ - 2*QQ*T*U1**2*TM2 + 18*QQ*T*U1*TM2**2 )/8.
      AJLZT3(S,T,T1,U1,QQ,TM2)=
     $ + A2B2*AL2BL2 * ( - 26*QQ*T*TM2**3 + 4*QQ*T1**2*TM2**2
     $ + 4*QQ*T1*U1*TM2**2 - 24*QQ*T1*TM2**3 + 2*QQ*U1**2*TM2**2
     $ - 14*QQ*U1*TM2**3 + 30*QQ*TM2**4 - 8*S**2*T*U1*TM2
     $ - 4*S**2*T1**2*TM2 + 8*S**2*T1*TM2**2 + 8*S**2*U1*TM2**2
     $ - 4*S**2*TM2**3 - 8*S*T**2*U1*TM2 - 8*S*T*T1**2*TM2
     $ - 8*S*T*T1*U1*TM2 + 16*S*T*T1*TM2**2 - 8*S*T*U1**2*TM2
     $ + 40*S*T*U1*TM2**2 - 8*S*T*TM2**3 + 16*S*T1**2*TM2**2
     $ + 8*S*T1*U1*TM2**2 - 32*S*T1*TM2**3 + 8*S*U1**2*TM2**2
     $ - 32*S*U1*TM2**3 + 16*S*TM2**4 - 4*T**2*T1**2*TM2
     $ - 8*T**2*T1*U1*TM2 + 8*T**2*T1*TM2**2 - 4*T**2*U1**2*TM2
     $ + 16*T**2*U1*TM2**2 - 4*T**2*TM2**3 + 16*T*T1**2*TM2**2
     $ + 24*T*T1*U1*TM2**2 - 32*T*T1*TM2**3 + 16*T*U1**2*TM2**2
     $ - 48*T*U1*TM2**3 + 16*T*TM2**4 - 16*T1**2*TM2**3
     $ - 16*T1*U1*TM2**3 + 32*T1*TM2**4 - 12*U1**2*TM2**3
     $ + 32*U1*TM2**4 - 16*TM2**5 )/8.
      AJLZT4(S,T,T1,U1,QQ,TM2)=
     $ + AB*ALBL * ( 8*QQ**3*S*T - 8*QQ**3*S*TM2 - 8*QQ**3*T*TM2
     $ + 8*QQ**3*TM2**2 - 8*QQ**2*S**2*TM2 - 8*QQ**2*S*T**2
     $ + 16*QQ**2*S*T*T1 + 8*QQ**2*S*T*U1 - 16*QQ**2*S*T*TM2
     $ - 16*QQ**2*S*T1*TM2 - 8*QQ**2*S*U1*TM2 + 40*QQ**2*S*TM2**2
     $ - 16*QQ**2*T*T1*TM2 - 8*QQ**2*T*U1*TM2 + 32*QQ**2*T*TM2**2
     $ + 16*QQ**2*T1*TM2**2 + 8*QQ**2*U1*TM2**2 - 40*QQ**2*TM2**3
     $ - 4*QQ*S**3*T + 4*QQ*S**3*TM2 - 8*QQ*S**2*T*T1
     $ - 8*QQ*S**2*T*U1 + 20*QQ*S**2*T*TM2 - 8*QQ*S**2*T1*TM2
     $ + 8*QQ*S**2*U1*TM2 - 4*QQ*S**2*TM2**2 + 4*QQ*S*T**3
     $ - 8*QQ*S*T**2*T1 - 4*QQ*S*T**2*TM2 + 40*QQ*S*T1*TM2**2
     $ - 32*QQ*S*TM2**3 - 4*QQ*T**3*TM2 - 8*QQ*T**2*T1*TM2
     $ - 16*QQ*T**2*U1*TM2 + 20*QQ*T**2*TM2**2 + 40*QQ*T*T1*TM2**2
     $ + 40*QQ*T*U1*TM2**2 - 48*QQ*T*TM2**3 - 48*QQ*T1*TM2**3
     $ - 24*QQ*U1*TM2**3 + 48*QQ*TM2**4 )/8.
C
C          Find whether JETTYP(1) or JETTYP(2) is particle
C
      JF=1
      IF(2*(JETTYP(1)/2).NE.JETTYP(1)) JF=2
C
C          Kinematics
C
      QMW2=QMW**2
      QZW=QTMW*SINH(YW)
      Q0W=QTMW*COSH(YW)
      QW=SQRT(QZW**2+QTW**2)

      T1=-X2*ECM*PT(JF)*EXP(YJ(JF))
      U1=-X1*ECM*PT(JF)*EXP(-YJ(JF))
      S1=-T1-U1-QMW2
      SIGLLQ=0.
      IF(STDDY) GO TO 400
C
C          qk + qb --> gl + w
C
      IF(JETTYP(3).EQ.1) THEN
        IFLL=JETTYP(1)/2
        COUPL=-ALFA**2*ALFQSQ*PROP(JWTYP)/(9.*PI*SCM*S)
        DENOM=S**2*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2))
        TDIR=FCDIR(T,S,U,T1,S1,U1)*(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2)
        UDIR=FCDIR(U,S,T,U1,S1,T1)*(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2)
        TINT=FCINT(T,S,U,T1,S1,U1)*2.*AQ(IFLL,JWTYP)*BQ(IFLL,JWTYP)
        UINT=FCINT(U,S,T,U1,S1,T1)*2.*AQ(IFLL,JWTYP)*BQ(IFLL,JWTYP)
        IQ1=INITYP(1)
        IQ2=INITYP(2)
        IFL1=IQ1/2
        IF(2*IFL1.EQ.IQ1) THEN
          TERM1=TDIR*(AQ(IFL1,JWTYP)**2+BQ(IFL1,JWTYP)**2)
     $    *QSAVE(IQ1,1)*QSAVE(IQ2,2)
          TERM2=TINT*2.*AQ(IFL1,JWTYP)*BQ(IFL1,JWTYP)
     $    *QSAVE(IQ1,1)*QSAVE(IQ2,2)
          SIGLLQ=SIGLLQ+TERM1+TERM2
        ELSE
          TERM1=UDIR*(AQ(IFL1,JWTYP)**2+BQ(IFL1,JWTYP)**2)
     $    *QSAVE(IQ1,1)*QSAVE(IQ2,2)
          TERM2=UINT*2.*AQ(IFL1,JWTYP)*BQ(IFL1,JWTYP)
     $    *QSAVE(IQ1,1)*QSAVE(IQ2,2)
          SIGLLQ=SIGLLQ+TERM1+TERM2
        ENDIF
        SIGLLQ=SIGLLQ*UNITS
        IF(JETTYP(1).LE.13) SIGLLQ=3.*SIGLLQ
        RETURN
C
C          qk + gl --> qk + w
C
      ELSEIF(JETTYP(3).LE.NZERO(JWTYP)) THEN
        JQK=MATCH(JETTYP(3),4)
        JQK=MATCH(JQK,JWTYP)
        IF(JQK.EQ.0) RETURN
        COUPL=ALFA**2*ALFQSQ*PROP(JWTYP)/(24.*PI*SCM*S)
        DENOM=S**2*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2))
        IFLQ=JQK/2
        IFLL=JETTYP(1)/2
        IF(INITYP(2).EQ.1) THEN
          TDIR=FCDIR(S,T,U,S1,T1,U1)*QSAVE(JQK,1)*QSAVE(1,2)
        ELSE
          TDIR=FCDIR(S,U,T,S1,U1,T1)*QSAVE(JQK,2)*QSAVE(1,1)
        ENDIF
        TDIR=TDIR*(AQ(IFLQ,JWTYP)**2+BQ(IFLQ,JWTYP)**2)
     $  *(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2)
        IF(INITYP(2).EQ.1) THEN
          TINT=FCINT(S,T,U,S1,T1,U1)*QSAVE(JQK,1)*QSAVE(1,2)
        ELSE
          TINT=FCINT(S,U,T,S1,U1,T1)*QSAVE(JQK,2)*QSAVE(1,1)
        ENDIF
        TINT=TINT*4.*AQ(IFLQ,JWTYP)*BQ(IFLQ,JWTYP)*AQ(IFLL,JWTYP)
     $  *BQ(IFLL,JWTYP)
        SIGLLQ=TDIR+TINT
        SIGLLQ=SIGLLQ*UNITS
        IF(JETTYP(1).LE.13) SIGLLQ=3.*SIGLLQ
        SIGLLQ=SIGLLQ*QTW**2/(QTW**2+QT2CUT(QMW))
        RETURN
C
C          bt,tp + gl --> bt,tp + W,Z
C
      ELSEIF(JETTYP(3).GE.NZERO(JWTYP)+1) THEN
        IQ3=JETTYP(3)
        JQK=MATCH(IQ3,4)
        JQK=MATCH(JQK,JWTYP)
        IF(JQK.EQ.0) RETURN
        AMT=AMASS(6)
        AMT2=AMT**2
        Q2=QMW2
        AMF2=AMFAC(IQ3)*AMT2
        AMI2=AMFAC(JQK)*AMT2
        EFWT=SQRT(P(3)**2+AMF2)
        P3Z=P(3)*CTH(3)
        SWT=QMW2+AMF2+2.*Q0W*EFWT-2.*QZW*P3Z+2.*PT(3)**2
C          Kinematics
        IF(INITYP(2).EQ.1) THEN
          P1WT=EFWT+P3Z+Q0W+QZW
          P1M=AMI2/P1WT
          P2WT=EFWT-P3Z+Q0W-QZW-P1M
          X1WT=.5*P1WT/HALFE
          X2WT=.5*P2WT/HALFE
          TWT=-P1WT*(EFWT-P3Z)-P1M*(P(3)+P3Z)+AMI2+AMF2
          UWT=-P2WT*(EFWT+P3Z)+AMF2
          T1WT=-X2WT*ECM*PT(JF)*EXP(YJ(JF))
          U1WT=-X1WT*ECM*PT(JF)*EXP(-YJ(JF))-P1M*PT(JF)*EXP(YJ(JF))
          S1WT=-T1WT-U1WT-QMW2+AMI2+AMF2
        ELSE
          P2WT=EFWT-P3Z+Q0W-QZW
          P2M=AMI2/P2WT
          P1WT=EFWT+P3Z+Q0W+QZW-P2M
          X1WT=.5*P1WT/HALFE
          X2WT=.5*P2WT/HALFE
          TWT=-P1WT*(EFWT-P3Z)+AMF2
          UWT=-P2WT*(EFWT+P3Z)-P2M*(EFWT-P3Z)+AMI2+AMF2
          T1WT=-X2WT*ECM*PT(JF)*EXP(YJ(JF))-P2M*PT(JF)*EXP(-YJ(JF))
          U1WT=-X1WT*ECM*PT(JF)*EXP(-YJ(JF))
          S1WT=-T1WT-U1WT-QMW2+AMI2+AMF2
        ENDIF
C          Cross section
        SIG0=-ALFA**2*ALFQSQ/(12*PI*SCM*SWT)*PROP(JWTYP)*UNITS
        IF(JETTYP(1).LE.13) SIG0=3*SIG0
        IF(JWTYP.EQ.2.OR.JWTYP.EQ.3) THEN
          SIG0=SIG0*(AQ(6,JWTYP)**2+BQ(6,JWTYP)**2)**2
          IF(INITYP(2).EQ.1.AND.(IQ3.EQ.12.OR.IQ3.EQ.13)) THEN
            SIGLLQ=AJLWT(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT,Q2/SWT,
     $      AMT2/SWT)
            SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2
            SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,1)*QFCN(X2WT,1,2)
          ELSEIF(INITYP(1).EQ.1.AND.(IQ3.EQ.12.OR.IQ3.EQ.13)) THEN
            SIGLLQ=AJLWT(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT,Q2/SWT,
     $      AMT2/SWT)
            SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2
            SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,2)*QFCN(X2WT,1,1)
          ENDIF
        ELSEIF(JWTYP.EQ.4) THEN
          A2=AQ(6,JWTYP)**2
          A2B2=AQ(6,JWTYP)**2+BQ(6,JWTYP)**2
          AB=AQ(6,JWTYP)*BQ(6,JWTYP)
          AL2BL2=AQ(JETTYP(1)/2,JWTYP)**2+BQ(JETTYP(1)/2,JWTYP)**2
          ALBL=AQ(JETTYP(1)/2,JWTYP)*BQ(JETTYP(1)/2,JWTYP)
          IF(INITYP(2).EQ.1) THEN
            SIGLLQ=AJLZT1(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ+AJLZT2(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ+AJLZT3(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ+AJLZT4(SWT/SWT,TWT/SWT,T1WT/SWT,U1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2
            SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,1)*QFCN(X2WT,1,2)
          ELSEIF(INITYP(1).EQ.1) THEN
            SIGLLQ=AJLZT1(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ+AJLZT2(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ+AJLZT3(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ+AJLZT4(SWT/SWT,UWT/SWT,U1WT/SWT,T1WT/SWT,
     $      Q2/SWT,AMT2/SWT)
            SIGLLQ=SIGLLQ*SWT*(SWT/(SWT-AMI2))**2*(SWT/(UWT-AMF2))**2
            SIGLLQ=SIGLLQ*SIG0*QFCN(X1WT,JQK,2)*QFCN(X2WT,1,1)
          ENDIF
        ENDIF
      ENDIF
      RETURN
C
C          Standard Drell-Yan with QT=0.
C
400   CONTINUE
      IFLL=JETTYP(1)/2
      COUPL=ALFA**2*PROP(JWTYP)*UNITS
      TDIR=COUPL*(AQ(IFLL,JWTYP)**2+BQ(IFLL,JWTYP)**2)
     $*((U1**2+T1**2)/(6.*SCM*QMW2))
      TINT=COUPL*2.*AQ(IFLL,JWTYP)*BQ(IFLL,JWTYP)
     $*((U1**2-T1**2)/(6.*SCM*QMW2))
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IFL1=IQ1/2
      TERM1=TDIR*(AQ(IFL1,JWTYP)**2+BQ(IFL1,JWTYP)**2)
     $*QSAVE(IQ1,1)*QSAVE(IQ2,2)
      TERM2=-TINT*2.*AQ(IFL1,JWTYP)*BQ(IFL1,JWTYP)
     $*QSAVE(IQ1,1)*QSAVE(IQ2,2)
      IF(2*IFL1.EQ.IQ1) SIGLLQ=SIGLLQ+TERM1+TERM2
      IF(2*IFL1.NE.IQ1) SIGLLQ=SIGLLQ+TERM1-TERM2
      IF(JETTYP(1).LE.13) SIGLLQ=3.*SIGLLQ
      RETURN
      END
+EOD
+DECK,SIGDY.
      SUBROUTINE SIGDY
C
C          Compute the Drell-Yan and Drell-Yan plus jet cross sections
C          d(sigma)/d(qmw**2)d(qtw**2)d(yw)d(yj)
C
C          SIGMA    = cross section summed over quark types allowed by
C                     JETTYPE3 and WTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code.
C
C          QT cutoff for W+JET taken from Parisi and Petronzio,
C          Nucl Phys B154, 427
C          qk + gl --> qk + w suppressed at low QTW by extra factor
C          of qtw**2/(qtw**2+qt2cut(qmw))
C
C          Ver 7.17: include top mass for gb --> Wt and gt --> Zt 
C          with no extra qt suppression factor. Note we do NOT include
C          gt --> Wb; while this process makes sense for qt >> m_t,
C          it has a pole in the physical region at low qt from the 
C          on-shell decay t --> Wb. We let Q**2 --> Q**2 + m_t**2 
C          in the scale for the parton distributions.
C
C          Ver 7.32: Rewrite AJLWT for gb --> Wt, etc., in terms of 
C          scaled variables, and restore SWT**5 later to avoid 
C          floating errors on VMS.
C
C          Ver 7.41: Recalculate COUT for each mass(!).
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,NODCAY
C
      REAL X(2)
      REAL Z,S,T,U,QMW2,QZW,EHAT,Q2SAVE,YHAT,EY,P3Z,P1,P2,AMASS,ANEFF,
     $SIG0,DENOM,QT2CUT,SIGT,SIGU,FAC,PROP,FACTOR,SIG,AMT,AMT2,SWT,
     $P1WT,P2WT,X1WT,X2WT,TWT,UWT,Q2,QFCN,STRUC,XX,ACOSH,ATANH,P2M,P1M
      REAL AMI2,AMF2,EFWT
      REAL AJLWT,AJLZT1,AJLZT2,A2,A2B2,QQ,TM2
      INTEGER I,IQ,IH,IQ1,IFL,IQ2,IW
      INTEGER NZERO(4)
      REAL AMFAC(13)
      INTEGER NUTYP(25)
      INTEGER IFL1,IFL2
      REAL TERM
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1)
C
      DATA NZERO/11,9,9,11/
      DATA AMFAC/11*0.,2*1./
      DATA NUTYP/13*0,1,1,0,0,1,1,0,0,1,1,0,0/
C
C          Functions
      ACOSH(Z)=ALOG(Z+SQRT(Z**2-1.))
      ATANH(Z)=.5*ALOG((1.+Z)/(1.-Z))
      PROP(I)=1./((QMW2-WMASS(I)**2)**2+(WMASS(I)*WGAM(I))**2)
C          Qt cutoff function
      QT2CUT(QMW)=CUTOFF*QMW**CUTPOW
C          Parton distributions
      QFCN(XX,IQ,IH)=STRUC(XX,QSQ+AMT2,IQ,IDIN(IH))/XX
C          Integrated matrix elements JLint from FORM
      AJLWT(S,T,QQ,TM2)=
     $ - 32*QQ**3*S*T + 32*QQ**3*S*TM2 + 32*QQ**2*S**2*T 
     $ + 32*QQ**2*S*T**2 - 16*QQ**2*S*T*TM2 - 16*QQ**2*S*TM2**2 
     $ - 16*QQ*S**3*T + 16*QQ*S**3*TM2 - 16*QQ*S**2*T*TM2
     $ - 16*QQ*S*T**3 + 32*QQ*S*T**2*TM2 - 16*QQ*S*T*TM2**2 
     $ - 8*S**3*T*TM2 + 8*S**3*TM2**2 - 16*S**2*T**2*TM2 
     $ + 16*S**2*T*TM2**2 - 16*S**2*TM2**3 - 8*S*T**3*TM2 
     $ + 8*S*T**2*TM2**2 - 8*S*T*TM2**3 + 8*S*TM2**4
C
      AJLZT1(S,T,QQ,TM2)=
     $ + A2 * ( - 96*QQ**2*S*T*TM2 + 96*QQ**2*S*TM2**2
     $ + 96*QQ**2*T*TM2**2 - 96*QQ**2*TM2**3 + 96*QQ*S**2*T*TM2
     $ + 96*QQ*S*T**2*TM2 - 192*QQ*S*T*TM2**2 - 96*QQ*S*TM2**3
     $ - 96*QQ*T*TM2**3 + 192*QQ*TM2**4 + 16*S**3*T*TM2
     $ - 16*S**3*TM2**2 + 32*S**2*T**2*TM2 - 112*S**2*T*TM2**2
     $ + 80*S**2*TM2**3 + 16*S*T**3*TM2 - 112*S*T**2*TM2**2
     $ + 224*S*T*TM2**3 - 128*S*TM2**4 - 16*T**3*TM2**2
     $ + 80*T**2*TM2**3 - 128*T*TM2**4 + 64*TM2**5 )
      AJLZT2(S,T,QQ,TM2)=
     $ + A2B2 * ( - 16*QQ**3*S*T + 16*QQ**3*S*TM2 + 16*QQ**3*T*TM2
     $ - 16*QQ**3*TM2**2 + 16*QQ**2*S**2*T + 16*QQ**2*S*T**2
     $ + 32*QQ**2*S*T*TM2 - 80*QQ**2*S*TM2**2 - 80*QQ**2*T*TM2**2
     $ + 96*QQ**2*TM2**3 - 8*QQ*S**3*T + 8*QQ*S**3*TM2
     $ - 40*QQ*S**2*T*TM2 - 24*QQ*S**2*TM2**2 - 8*QQ*S*T**3
     $ - 40*QQ*S*T**2*TM2 + 80*QQ*S*T*TM2**2 + 96*QQ*S*TM2**3
     $ + 8*QQ*T**3*TM2 - 24*QQ*T**2*TM2**2 + 96*QQ*T*TM2**3
     $ - 144*QQ*TM2**4 - 16*S**3*T*TM2 + 16*S**3*TM2**2
     $ - 32*S**2*T**2*TM2 + 112*S**2*T*TM2**2 - 80*S**2*TM2**3
     $ - 16*S*T**3*TM2 + 112*S*T**2*TM2**2 - 224*S*T*TM2**3
     $ + 128*S*TM2**4 + 16*T**3*TM2**2 - 80*T**2*TM2**3
     $ + 128*T*TM2**4 - 64*TM2**5 )
C
C          Kinematics
C
      QMW2=QMW**2
      QTMW=SQRT(QMW2+QTW**2)
      Q0W=QTMW*COSH(YW)
      QZW=QTMW*SINH(YW)
      QW=SQRT(QZW**2+QTW**2)
C          Protect against errors
      IF(QW.NE.0.) THEN
        CTHW=QZW/QW
        STHW=QTW/QW
        IF(ABS(CTHW).LT.1.) THEN
          THW=ACOS(CTHW)
        ELSE
          CTHW=0.
          STHW=1.
          THW=.5*PI
        ENDIF
      ELSE
        CTHW=0.
        STHW=1.
        THW=.5*PI
      ENDIF
C
      IF(STDDY) THEN
C          Kinematics for standard Drell-Yan
        EHAT=QMW
        SHAT=QMW**2
        QSQ=SHAT
        Q2SAVE=QSQ
        YHAT=YW
        EY=EXP(YHAT)
        X1=EHAT/ECM*EY
        X2=EHAT/(ECM*EY)
      ELSE
C          Kinematics for Drell-Yan plus jet
        P3Z=P(3)*CTH(3)
        SHAT=QMW2+2.*Q0W*P(3)-2.*QZW*P3Z+2.*PT(3)**2
        P1=.5*(P(3)+P3Z+Q0W+QZW)
        P2=.5*(P(3)-P3Z+Q0W-QZW)
        X1=P1/HALFE
        X2=P2/HALFE
        THAT=-2.*P1*(P(3)-P3Z)
        UHAT=-2.*P2*(P(3)+P3Z)
        QSQ=QTW**2
        QSQ=AMAX1(QSQ,4.)
        ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2)
        ALFQSQ=12.*PI/((33.-2.*ANEFF)*ALOG(QSQ/ALAM2))
        Q2SAVE=QSQ
        QSQ=SHAT
      ENDIF
C
C          Initialize
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
        SIGS(I)=0.
100   CONTINUE
      IF(X1.GE.1..OR.X2.GE.1.) RETURN
C
C          Compute structure functions
C
      DO 110 IH=1,2
        DO 120 IQ=1,11
          QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
120     CONTINUE
        QSAVE(12,IH)=0
        QSAVE(13,IH)=0
110   CONTINUE
      QSQ=Q2SAVE
C
C          Recompute COUT for this mass
C
      DO 130 IW=1,4
        COUT(IW)=0.
        IF(.NOT.GODY(IW)) GO TO 130
        DO 140 IQ1=2,25
          IQ2=MATCH(IQ1,IW)
          IF(IQ2.EQ.0) GO TO 140
          IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 140
          IF(NUTYP(IQ1)*NUTYP(IQ2).EQ.1.AND.NONUNU) GO TO 140
          IFL1=IQ1/2
          IFL2=IQ2/2
          IF(AMASS(IFL1)+AMASS(IFL2).GE.QMW) GO TO 140
          TERM=.5*(AQ(IFL1,IW)**2+BQ(IFL1,IW)**2)
          IF(IQ1.LE.13) TERM=3.*TERM
          COUT(IW)=COUT(IW)+TERM
140     CONTINUE
130   CONTINUE
C
      IF(STDDY) GO TO 400
C
C          Compute cross section for types allowed by WTYPE and
C          JETTYPE cards.
C
C          qk + gl --> qk + W
C
      SIG0=ALFA**2*ALFQSQ*QMW2/(9.*SCM*S)*UNITS
      DENOM=S**2*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2))
      SIGT=SIG0*(S**2+U**2+2.*T*QMW2)*(-T)/DENOM
      SIGU=SIG0*(S**2+T**2+2.*U*QMW2)*(-U)/DENOM
      DO 200 IW=1,4
        IF(.NOT.GODY(IW)) GO TO 200
        FAC=COUT(IW)*PROP(IW)
        DO 210 IQ=2,NZERO(IW)
          IF(.NOT.GOQ(IQ,3)) GO TO 210
          IQ1=MATCH(IQ,4)
          IQ1=MATCH(IQ1,IW)
          IF(IQ1.EQ.0) GO TO 210
          IFL=IQ/2
          FACTOR=FAC*(AQ(IFL,IW)**2+BQ(IFL,IW)**2)
     $    *QTW**2/(QTW**2+QT2CUT(QMW))
          SIG=FACTOR*SIGT*QSAVE(IQ1,1)*QSAVE(1,2)
          CALL SIGFIL(SIG,IQ1,1,IW,IQ)
          SIG=FACTOR*SIGU*QSAVE(IQ1,2)*QSAVE(1,1)
          CALL SIGFIL(SIG,1,IQ1,IW,IQ)
210     CONTINUE
200   CONTINUE
C
C          bt,tp + gl -> bt,tp + W,Z
C
      AMT=AMASS(6)
      AMT2=AMT**2
      Q2=QMW2
      DO 220 IW=2,4
        IF(.NOT.GODY(IW)) GO TO 220
        DO 230 IQ=NZERO(IW)+1,13
          IF(.NOT.GOQ(IQ,3)) GO TO 230
          IQ1=MATCH(IQ,4)
          IQ1=MATCH(IQ1,IW)
          IF(IQ1.EQ.0) GO TO 230
          IF(IQ1.GE.12.AND.IW.NE.4) GO TO 230
C          Assign zero or top masses for initial/final quarks
          AMF2=AMT2*AMFAC(IQ)
          AMI2=AMT2*AMFAC(IQ1)
          EFWT=SQRT(P(3)**2+AMF2)
          SWT=QMW2+AMF2+2.*Q0W*EFWT-2.*QZW*P3Z+2.*PT(3)**2
C
C          qk + gl initial state
C          Do kinematics using p(small) = 0 for gluon
C
          P1WT=EFWT+P3Z+Q0W+QZW
          P1M=AMI2/P1WT
          P2WT=EFWT-P3Z+Q0W-QZW-P1M
          X1WT=.5*P1WT/HALFE
          X2WT=.5*P2WT/HALFE
          TWT=-P1WT*(EFWT-P3Z)-P1M*(EFWT+P3Z)+AMI2+AMF2
          UWT=-P2WT*(EFWT+P3Z)+AMF2
          IF(X1WT.LT.0.OR.X1WT.GT.1.OR.X2WT.LT.0.OR.X2WT.GT.1)
     $    GO TO 240
C          Cross sections
          IF(IW.EQ.2.OR.IW.EQ.3) THEN
            SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS
            SIG0=SIG0*(AQ(5,IW)**2+BQ(5,IW)**2)*COUT(IW)*PROP(IW)
            SIGU=SIG0*AJLWT(SWT/SWT,UWT/SWT,Q2/SWT,AMT2/SWT)*SWT*
     $      (SWT/(SWT-AMI2))**2*(SWT/(UWT-AMF2))**2
            SIG=SIGU*QFCN(X1WT,IQ1,1)*QFCN(X2WT,1,2)
            CALL SIGFIL(SIG,IQ1,1,IW,IQ)
          ELSEIF(IW.EQ.4) THEN
            SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS
            SIG0=SIG0*COUT(IW)*PROP(IW)
            A2=AQ(6,IW)**2
            A2B2=AQ(6,IW)**2+BQ(6,IW)**2
            SIGU=SIG0*(AJLZT1(SWT/SWT,UWT/SWT,Q2/SWT,AMT2/SWT)+
     $      AJLZT2(SWT/SWT,UWT/SWT,Q2/SWT,AMT2/SWT))*SWT*
     $      (SWT/(SWT-AMI2))**2*(SWT/(UWT-AMF2))**2
            SIG=SIGU*QFCN(X1WT,IQ1,1)*QFCN(X2WT,1,2)
            CALL SIGFIL(SIG,IQ1,1,IW,IQ)
          ENDIF
C
C          gl + qk initial state
C          Do kinematics  using p(small) = 0 for gluon
C
240       P2WT=EFWT-P3Z+Q0W-QZW
          P2M=AMI2/P2WT
          P1WT=EFWT+P3Z+Q0W+QZW-P2M
          X1WT=.5*P1WT/HALFE
          X2WT=.5*P2WT/HALFE
          TWT=-P1WT*(EFWT-P3Z)+AMF2
          UWT=-P2WT*(EFWT+P3Z)-P2M*(EFWT-P3Z)+AMI2+AMF2
          IF(X1WT.LT.0.OR.X1WT.GT.1.OR.X2WT.LT.0.OR.X2WT.GT.1)
     $    GO TO 230
C          Cross sections
          IF(IW.EQ.2.OR.IW.EQ.3) THEN
            SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS
            SIG0=SIG0*(AQ(5,IW)**2+BQ(5,IW)**2)*COUT(IW)*PROP(IW)
            SIGT=SIG0*AJLWT(SWT/SWT,TWT/SWT,Q2/SWT,AMT2/SWT)*SWT*
     $      (SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2)**2)
            SIG=SIGT*QFCN(X1WT,1,1)*QFCN(X2WT,IQ1,2)
            CALL SIGFIL(SIG,1,IQ1,IW,IQ)
          ELSEIF(IW.EQ.4) THEN
            SIG0=ALFA**2*ALFQSQ/(144*SCM*SWT)*UNITS
            SIG0=SIG0*COUT(IW)*PROP(IW)
            A2=AQ(6,IW)**2
            A2B2=AQ(6,IW)**2+BQ(6,IW)**2
            SIGU=SIG0*(AJLZT1(SWT/SWT,TWT/SWT,Q2/SWT,AMT2/SWT)+
     $      AJLZT2(SWT/SWT,TWT/SWT,Q2/SWT,AMT2/SWT))*SWT*
     $      (SWT/(SWT-AMI2))**2*(SWT/(TWT-AMF2))**2
            SIG=SIGU*QFCN(X1WT,1,1)*QFCN(X2WT,IQ1,2)
            CALL SIGFIL(SIG,1,IQ1,IW,IQ)
          ENDIF
230     CONTINUE
220   CONTINUE
C
C          qk + qb --> gl + W
C
      IF(.NOT.GOQ(1,3)) RETURN
      SIG0=8.*ALFA**2*ALFQSQ*QMW2/(27.*SCM*S)*UNITS
      DENOM=S*EXP(.5*ALOG(QTW**4+QT2CUT(QMW)**2))
      SIG0=SIG0*(T**2+U**2+2.*S*QMW2)/DENOM
      DO 300 IW=1,4
        IF(.NOT.GODY(IW)) GO TO 300
        FAC=COUT(IW)*PROP(IW)
        DO 310 IQ1=2,11
          IQ2=MATCH(IQ1,IW)
          IF(IQ2.EQ.0) GO TO 310
          IFL=IQ1/2
          SIG=FAC*SIG0*(AQ(IFL,IW)**2+BQ(IFL,IW)**2)
     $    *QSAVE(IQ1,1)*QSAVE(IQ2,2)
          CALL SIGFIL(SIG,IQ1,IQ2,IW,1)
310     CONTINUE
300   CONTINUE
      RETURN
C
C          Standard Drell-Yan for QT=0.
C
400   CONTINUE
      SIG0=4.*PI*ALFA**2*QMW2/(9.*SCM)*UNITS
      DO 410 IW=1,4
        IF(.NOT.GODY(IW)) GO TO 410
        FAC=COUT(IW)*PROP(IW)
        DO 420 IQ1=2,13
          IQ2=MATCH(IQ1,IW)
          IF(IQ2.EQ.0) GO TO 420
          IFL=IQ1/2
          SIG=FAC*SIG0*(AQ(IFL,IW)**2+BQ(IFL,IW)**2)
     $    *QSAVE(IQ1,1)*QSAVE(IQ2,2)
          CALL SIGFIL(SIG,IQ1,IQ2,IW,0)
420     CONTINUE
410   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SIGEE.
      SUBROUTINE SIGEE
C
C          Compute d(sigma)/d(cos theta) with interference 
C          and polarization for
C          E+ E- --> GM, Z0 ----> QK QB, L LB, N NB, W+ W-, Z Z
C
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     USING JETTYPE CODE.
C
C          Extra factor of 1/2 needed because all jets are treated
C          as identical.
C          Version 7.42 includes bremsstrahlung contribution;
C          also, beamstrahlung
C          Version 7.54: Add Z+H
C          Add gamma+gamma -> f+ fbar 1/27/04
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETSIG
+CDE,EEPAR
+CDE,PRIMAR
+CDE,JETPAR
+CDE,Q1Q2
+CDE,CONST
+CDE,WCON
+CDE,BREMBM
+CDE,HCON
C
      REAL FLEP,FLEM,FREP,FREM,PROPZ,REDZ,SH,E,G,GP,COS2W,
     $TNTHW,CTTHW,ALQ(2),BEQ(2),ALL(2),BEL(2),AE,BE,EQ,AMQ,AMQ2,
     $PCM,Z,AF,BF,PHILRG,PHILRZ,PHILRI,PHIRLG,PHIRLZ,PHIRLI,
     $THT,UH,RSH,UT,PHIRL,PHILR,SIGLR,SIGRL,SIG,AMASS,EE,
     $ALFAEM,AMZ,GAMZ,AMW,JAC,ESTRUC,SSFEL,FACLR,FACRL,EZ0,FAC1,
     $BKT_GG,SIG_GG,GSTRUC,GBEAM
      REAL AMH,SSXLAM
      INTEGER I,IQ,IQ2,IFL,ISGN,IQ2EQ(25),LISTJ(29)
      DATA IQ2EQ/0,2,-2,-1,1,-1,1,2,-2,-1,1,2,-2,0,0,-3,3,
     $0,0,-3,3,0,0,-3,3/
      DATA LISTJ/
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
     $10,80,-80,90/
C          Fractional polarizations
      FLEP=(1.+PLEP)/2.
      FLEM=(1.+PLEM)/2.
      FREP=(1.-PLEP)/2.
      FREM=(1.-PLEM)/2.
C          FUNCTIONS
      ALFAEM=1./128.
      AMZ=WMASS(4)
      GAMZ=WGAM(4)
      AMW=WMASS(3)
      AMH=HMASS
      IF (IBREM) THEN
        SH=SHAT
        JAC=2*(1.-SHAT/SCM)*2*SQRT(SH)*(RSHMAX-RSHMIN)/SCM/(X1+X2)
      ELSE
        SH=SCM
      END IF
      PROPZ=(SH-AMZ**2)**2+AMZ**2*GAMZ**2
      REDZ=(SH-AMZ**2)/PROPZ
C
C          CONSTANTS
      RSH=SQRT(SH)
      EE=RSH/2.
      QSQBM=QSQ
      E=SQRT(4*PI*ALFAEM)
      G=SQRT(4*PI*ALFAEM/SIN2W)
      GP=G*SQRT(SIN2W/(1.-SIN2W))
      COS2W=1.-SIN2W
      TNTHW=SQRT(SIN2W/COS2W)
      CTTHW=1./TNTHW
      ALQ(1)=CTTHW/4.-5*TNTHW/12.
      BEQ(1)=-(CTTHW+TNTHW)/4.
      ALQ(2)=TNTHW/12.-CTTHW/4.
      BEQ(2)=-BEQ(1)
      ALL(1)=(CTTHW+TNTHW)/4.
      BEL(1)=-(CTTHW+TNTHW)/4.
      ALL(2)=(3*TNTHW-CTTHW)/4.
      BEL(2)=-BEL(1)
      AE=ALL(2)
      BE=BEL(2)
C
C          ENTRY
      SIG=0.
      SIGMA=0.
      NSIGS=0
      DO 10 I=1,MXSIGS
10    SIGS(I)=0.
C
C          Sum over allowed jet types. IQ labels JETTYPE1.
C
      DO 100 IQ=2,25
        IQ2=MATCH(IQ,4)
        IF(.NOT.(GOQ(IQ,1).AND.GOQ(IQ2,2))) GO TO 100
        IFL=IQ/2
        EQ=ABS(FLOAT(IQ2EQ(IQ))/3.)
        IF (EQ.LT..5.OR.EQ.GT..8) EQ=-EQ
        ISGN=1
        IF(2*IFL.NE.IQ) ISGN=2
        AMQ=AMASS(LISTJ(IQ))
        AMQ2=AMQ**2
        IF(2.*AMQ.GE.ECM) GO TO 100
        PCM=.5*SQRT(SH-4.*AMQ2)
        Z=CTH(ISGN)
        IF (IQ.LE.13.AND.ABS(EQ).GT..5) THEN
          AF=ALQ(1)
          BF=BEQ(1)
        ELSE IF (IQ.LE.13.AND.ABS(EQ).LT..5) THEN
          AF=ALQ(2)
          BF=BEQ(2)
        ELSE IF (IQ.GT.13.AND.ABS(EQ).EQ.0.) THEN
          AF=ALL(1)
          BF=BEL(1)
        ELSE
          AF=ALL(2)
          BF=BEL(2)
        END IF
        PHILRG=EQ**2/SH**2*(EE**2*(1.+Z**2)+AMQ2*(1.-Z**2))
        PHILRZ=(AE-BE)**2/PROPZ*((AF**2+BF**2)*(EE**2+PCM**2*Z**2)-
     ,     4*AF*BF*EE*PCM*Z+(AF**2-BF**2)*AMQ2)
        PHILRI=-2*EQ*(AE-BE)*REDZ/SH*
     ,     (AF*(EE**2*(1.+Z**2)+AMQ2*(1.-Z**2))-2*BF*EE*PCM*Z)
        PHILR=E**4*(PHILRG+PHILRZ+PHILRI)
        PHIRLG=PHILRG
        PHIRLZ=(AE+BE)**2/PROPZ*((AF**2+BF**2)*(EE**2+PCM**2*Z**2)+
     ,     4*AF*BF*EE*PCM*Z+(AF**2-BF**2)*AMQ2)
        PHIRLI=-2*EQ*(AE+BE)*REDZ/SH*
     ,     (AF*(EE**2*(1.+Z**2)+AMQ2*(1.-Z**2))+2*BF*EE*PCM*Z)
        PHIRL=E**4*(PHIRLG+PHIRLZ+PHIRLI)
        SIGLR=4*PCM*PHILR/16./PI/EE
        SIGRL=4*PCM*PHIRL/16./PI/EE
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        BKT_GG=(EE**2+PCM**2*Z**2)/(AMQ2+PCM**2*(1.-Z**2))+
     ,        2*AMQ2/(AMQ2+PCM**2*(1.-Z**2))-2*AMQ2**2/
     ,        (AMQ2+PCM**2*(1.-Z**2))**2
        SIG_GG=EQ**4*2*PI*ALFAEM**2/SH*(PCM/EE)*BKT_GG*UNITS/2.
        IF (IQ.LE.13) THEN
          SIG=3*SIG
          SIG_GG=3*SIG_GG
        END IF
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
          SIG=SIG+SIG_GG*GSTRUC(X1,QSQ)*GSTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
          IF (GAMGAM) THEN
          SIG=SIG+SIG_GG*GSTRUC(X1,QSQ)*GSTRUC(X2,QSQ)*JAC+
     ,    SIG_GG*GBEAM(X1,EB)*GBEAM(X2,EB)*JAC
          END IF
        END IF
        CALL SIGFIL(SIG,0,0,IQ,IQ2)
100   CONTINUE
C           Z Z Cross section
      IF(.NOT.(GOQ(29,1).AND.GOQ(29,2))) GO TO 200
        PCM=.5*SQRT(SH-4.*AMZ**2)
        THT=AMZ**2-SH/2.+RSH*PCM*CTH(1)
        UH=2*AMZ**2-SH-THT
        SIGLR=4*E**4*(AE-BE)**4*PCM/16./PI/SH/RSH*
     ,   (UH/THT+THT/UH+4*AMZ**2*SH/UH/THT-AMZ**4*(1./THT**2+1./UH**2))
        SIGRL=4*E**4*(AE+BE)**4*PCM/16./PI/SH/RSH*
     ,   (UH/THT+THT/UH+4*AMZ**2*SH/UH/THT-AMZ**4*(1./THT**2+1./UH**2))
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,29,29)
200   CONTINUE
C           W W Cross section
      IF(.NOT.(GOQ(27,1).AND.GOQ(28,2))) GO TO 300
        PCM=.5*SQRT(SH-4.*AMW**2)
        THT=AMW**2-SH/2.+RSH*PCM*CTH(2)
        UH=2*AMW**2-SH-THT
        UT=UH*THT-AMW**4
        PHIRL=4*(AE+BE)**2*TNTHW**2/SH/SH/PROPZ*
     ,        (UT*(PCM**2*SH+3*AMW**4)+4*AMW**2*PCM**2*SH*SH)
        PHILR=UT/SH/SH*(3.+2*(AE-BE)*TNTHW*(SH-6*AMW**2)*REDZ+
     ,      4*(AE-BE)**2*TNTHW**2*(PCM**2*SH+3*AMW**4)/PROPZ)+
     ,      8*(AE-BE)*TNTHW*AMW**2*REDZ+16*(AE-BE)**2*TNTHW**2*
     ,      AMW**2*PCM**2/PROPZ+2*(1.-2*(AE-BE)*TNTHW*AMW**2*REDZ)*
     ,      (UT/SH/THT-2*AMW**2/THT)+UT/THT**2
        SIGLR=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHILR
        SIGRL=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHIRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,27,28)
300   CONTINUE
      IF(.NOT.(GOQ(28,1).AND.GOQ(27,2))) GO TO 400
        PCM=.5*SQRT(SH-4.*AMW**2)
        THT=AMW**2-SH/2.+RSH*PCM*CTH(1)
        UH=2*AMW**2-SH-THT
        UT=UH*THT-AMW**4
        PHIRL=4*(AE+BE)**2*TNTHW**2/SH/SH/PROPZ*
     ,        (UT*(PCM**2*SH+3*AMW**4)+4*AMW**2*PCM**2*SH*SH)
        PHILR=UT/SH/SH*(3.+2*(AE-BE)*TNTHW*(SH-6*AMW**2)*REDZ+
     ,      4*(AE-BE)**2*TNTHW**2*(PCM**2*SH+3*AMW**4)/PROPZ)+
     ,      8*(AE-BE)*TNTHW*AMW**2*REDZ+16*(AE-BE)**2*TNTHW**2*
     ,      AMW**2*PCM**2/PROPZ+2*(1.-2*(AE-BE)*TNTHW*AMW**2*REDZ)*
     ,      (UT/SH/THT-2*AMW**2/THT)+UT/THT**2
        SIGLR=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHILR
        SIGRL=4*E**4*PCM/64./PI/SH/RSH/SIN2W**2*PHIRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,28,27)
400   CONTINUE
C
C          Higgs boson mechanisms
C          E+ E- --> Z H_SM; symmetric in cos(theta)
C
      IF(AMH.GT.0.AND.(AMZ+AMH).LT.RSH) THEN
        FACLR=E**2*G**2*(AE-BE)**2/COS2W
        FACRL=E**2*G**2*(AE+BE)**2/COS2W
        Z=CTH(1)
        PCM=SQRT(SSXLAM(SH,AMZ**2,AMH**2))/4./EE
        EZ0=SQRT(PCM**2+AMZ**2)
        FAC1=AMZ**2+EZ0**2-PCM**2*Z**2
        SIGLR=2*FACLR/32./PI/PROPZ/SQRT(SH)*PCM*FAC1
        SIGRL=2*FACRL/32./PI/PROPZ/SQRT(SH)*PCM*FAC1
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(29,1).AND.GOQ(30,2)) CALL SIGFIL(SIG,0,0,29,30)
        IF(GOQ(30,1).AND.GOQ(29,2)) CALL SIGFIL(SIG,0,0,30,29)
      ENDIF
C-----------------------------------------------------------------------
      RETURN
      END
+EOD
+DECK,SIGFIL.
      SUBROUTINE SIGFIL(SIG,I1,I2,I3,I4)
C          Fill /JETSIG/ arrays if SIG > 0
C          Write error message if SIG < 0
+CDE,ITAPES
+CDE,JETSIG.
C
      IF(SIG.GT.0) THEN
        NSIGS=NSIGS+1
        SIGMA=SIGMA+SIG
        SIGS(NSIGS)=SIG
        INOUT(NSIGS)=I1+IOPAK*(I2+IOPAK*(I3+IOPAK*I4))
      ELSEIF(SIG.LT.0.) THEN
        WRITE(ITLIS,1010) SIG,I1,I2,I3,I4
1010    FORMAT(' ERROR IN SIGFIL ... SIG = ',E12.5,' FOR ',4I6)
      ENDIF
      RETURN
      END
+EOD
+DECK,SIGGAM.
      SUBROUTINE SIGGAM
C
C          Compute D(SIGMA)/D(PT**2)D(Y1)D(Y2) for gamma + jet and
C          gamma + gamma.
C
C          SIGMA    = cross section summed over quark types allowed by
C                     JETTYPE card.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code.
C
C          Cross sections from Berger, Bratten, and Field, Nucl. Phys.
C          B239, 52 (1984), Table 2. Masses are neglected.
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,CONST
+CDE,WCON
C
      REAL BBF1,BBF2,BBF3,S,T,U,FJAC,STRUC,SIG0,SIG,BBF3TU,BBF3UT
      INTEGER I,IH,IQ,IFL
      REAL X(2),QSAVE(13,2)
      INTEGER LISTJ(13)
      EQUIVALENCE (X(1),X1),(S,SHAT),(T,THAT),(U,UHAT)
      DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6/
C
C          Cross sections with couplings and Jacobean removed.
      BBF1(S,T,U)=8./9.*(U/T+T/U)
      BBF2(S,T,U)=2./3.*(U/T+T/U)
      BBF3(S,T,U)=-1./3.*(U/S+S/U)
C
C          Initialize cross sections.
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
      SIGS(I)=0.
100   CONTINUE
C
C          Kinematics and structure functions for CH and lighter quarks
C
      CALL TWOKIN(0.,0.,0.,0.)
      FJAC=SHAT/SCM*UNITS*PI/SHAT**2
      IF(X1.GE.1.0.OR.X2.GE.1.0) RETURN
      DO 110 IH=1,2
      DO 110 IQ=1,9
        QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
110   CONTINUE
C
C          Compute cross sections summed over all types allowed by
C          JETTYPE card.
C
      IF(.NOT.(GOQ(26,1).OR.GOQ(26,2))) RETURN
C
C          Gluon-photon
C
      IF((GOQ(1,1).AND.GOQ(26,2)).OR.(GOQ(26,1).AND.GOQ(1,2))) THEN
        SIG0=.5*FJAC*ALFQSQ*ALFA*BBF1(S,T,U)
        DO 210 I=1,4
          IFL=LISTJ(2*I)
          SIG=SIG0*AQ(IFL,1)**2*QSAVE(2*I,1)*QSAVE(2*I+1,2)
          IF(GOQ(26,1).AND.GOQ(1,2)) CALL SIGFIL(SIG,2*I,2*I+1,26,1)
          IF(GOQ(1,1).AND.GOQ(26,2)) CALL SIGFIL(SIG,2*I,2*I+1,1,26)
          SIG=SIG0*AQ(IFL,1)**2*QSAVE(2*I+1,1)*QSAVE(2*I,2)
          IF(GOQ(26,1).AND.GOQ(1,2)) CALL SIGFIL(SIG,2*I+1,2*I,26,1)
          IF(GOQ(1,1).AND.GOQ(26,2)) CALL SIGFIL(SIG,2*I+1,2*I,1,26)
210     CONTINUE
      ENDIF
C
C          Photon-photon
C
      IF(GOQ(26,1).AND.GOQ(26,2)) THEN
        SIG0=.5*FJAC*ALFA**2*BBF2(S,T,U)
        DO 220 I=1,4
          IFL=LISTJ(2*I)
          SIG=SIG0*AQ(IFL,1)**4*QSAVE(2*I,1)*QSAVE(2*I+1,2)
          CALL SIGFIL(SIG,2*I,2*I+1,26,26)
          SIG=SIG0*AQ(IFL,1)**4*QSAVE(2*I+1,1)*QSAVE(2*I,2)
          CALL SIGFIL(SIG,2*I+1,2*I,26,26)
220     CONTINUE
      ENDIF
C
C          Quark-photon
C
      BBF3TU=.5*FJAC*ALFA*ALFQSQ*BBF3(S,T,U)
      BBF3UT=.5*FJAC*ALFA*ALFQSQ*BBF3(S,U,T)
      DO 230 I=2,9
        IFL=IABS(LISTJ(I))
        IF(GOQ(26,1).AND.GOQ(I,2)) THEN
          SIG=BBF3TU*AQ(IFL,1)**2*QSAVE(I,1)*QSAVE(1,2)
          CALL SIGFIL(SIG,I,1,26,I)
          SIG=BBF3UT*AQ(IFL,1)**2*QSAVE(1,1)*QSAVE(I,2)
          CALL SIGFIL(SIG,1,I,26,I)
        ENDIF
        IF(GOQ(I,1).AND.GOQ(26,2)) THEN
          SIG=BBF3UT*AQ(IFL,1)**2*QSAVE(I,1)*QSAVE(1,2)
          CALL SIGFIL(SIG,I,1,I,26)
          SIG=BBF3TU*AQ(IFL,1)**2*QSAVE(1,1)*QSAVE(I,2)
          CALL SIGFIL(SIG,1,I,I,26)
        ENDIF
230   CONTINUE
C
      RETURN
      END               
+EOD
+DECK,SIGH2
      SUBROUTINE SIGH2
C
C          COMPUTE THE WEINBERG-SALAM HIGGS CROSS SECTION
C          D(SIGMA)/D(QMW**2)D(YW)D(OMEGA)
C          FOR THE SPECIFIED JET TYPES. TRIVIAL EXCEPT FOR W W FUSION,
C          WHICH HAS INTERFERENCE WITH W W SCATTERING.
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,WSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,HCON
C
      DIMENSION X(2),LISTJ(29),WTHELI(4)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION C,TERM,SUM,DENOM,ZCM
+SELF.
C
C          WTHELI ARE WEIGHTS OF HELICITY AMPLITUDES IN SIGMA.
      DATA WTHELI/1.,2.,2.,4./
      DATA LISTJ/
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
     $10,80,-80,90/
C
C          QUARK OR GLUON FUSION TO HIGGS
C
      IF(INITYP(1).LE.25) THEN
        SIGLLQ=SIGEVT/(4.*PI)
        RETURN
      ENDIF
C
C          W+W FUSION AND W+W->W+W IN EFFECTIVE W APPROXIMATION.
C
C          KINEMATICS
      IFL1=LISTJ(JETTYP(1))
      IFL2=LISTJ(JETTYP(2))
      IFIN1=LISTJ(INITYP(1))
      IFIN2=LISTJ(INITYP(2))
      WMF=AMASS(IFL1)
      WMI=AMASS(IFIN1)
      PINPF=SQRT((S-4.*WMI**2)*(S-4.*WMF**2))
      ZCM=(.5*S+T-WMI**2-WMF**2)/(.5*PINPF)
C          RESET COEFFICIENTS FOR SELECTED PROCESS
      IABSI=IABS(IFIN1)
      IABSF=IABS(IFL1)
      IF(IABSI.EQ.80) THEN
        IF(IABSF.EQ.80) THEN
          CALL XWWWW
        ELSE
          CALL XWWZZ
        ENDIF
      ELSE
        IF(IABSF.EQ.80) THEN
          CALL XZZWW
        ELSE
          CALL XZZZZ
        ENDIF
      ENDIF
C          SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS.
C          L RUNS OVER HELICITY STATES. N RUNS OVER POWERS.
C          REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2)
      SUM=0.
      DO 111 I=1,4
      DO 111 J=I,4
      DENOM=1./((ADWWWW(1,I)+ADWWWW(2,I)*ZCM)
     $*(ADWWWW(1,J)+ADWWWW(2,J)*ZCM))
        DO 112 L=1,4
        TERM=0.
          DO 113 N=0,6
          C=0.
          N1=MAX(N-3,0)
          N2=MIN(3,N)
          DO 114 K=N1,N2
114       C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L)
          C=C*WTHELI(L)
          IF(J.NE.I) C=2.*C
          TERM=TERM+C*ZCM**N
113       CONTINUE
        IF(L.EQ.4) TERM=TERM*(1.-ZCM**2)/2.
        TERM=TERM*DENOM
        SUM=SUM+TERM
112     CONTINUE
111   CONTINUE
C          ADD IMAGINARY PART SQUARED.
      SUM=SUM+WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2
     $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2
C          CROSS SECTION. NOTE D(OMEGA)=2.*PI*D(Z)
      SIG0=SUM/(64.*PI**2*S*SCM)*UNITS
      SIG0=SIG0*TBRWW(JETTYP(1)-25,1)*TBRWW(JETTYP(2)-25,2)
C          SYMMETRY FACTOR
      IF(IABSF.EQ.90) SIG0=.5*SIG0
      SIGLLQ=SIG0*QSAVE(INITYP(1),1)*QSAVE(INITYP(2),2)
      RETURN
      END
+EOD
+DECK,SIGH3
      SUBROUTINE SIGH3
C
C          Calculate angular distributions for W decays from Higgs,
C          d(sigma)/d(qmw**2)d(yw)d(omega)d(omega1)d(omega2)
C
C          Ver 7.14: Only modification needed for MSSM is to check
C          GOMSSM flag instead of INITYP
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,WSIG
+CDE,WWSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,WWPAR
+CDE,HCON
+CDE,XMSSM
C
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      DIMENSION IDADDR(4),IW(2),LAM(3),LISTJ(29)
     $,T12(3,3),T34(3,3),FTERM(4),FR(3,3),FI(3,3)
     $,CPHI12(3),SPHI12(3),CPHI34(3),SPHI34(3)
      DIMENSION PFCM(5,4),PWCM(5,2)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION TERM,FTERM,ZCM
+SELF.
      DATA LAM/0,1,-1/
      DATA LISTJ/
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
     $10,80,-80,90/
C
C          FUNCTIONS
      DOTP(I,J)=PPAIR(4,I)*PPAIR(4,J)-PPAIR(1,I)*PPAIR(1,J)
     $-PPAIR(2,I)*PPAIR(2,J)-PPAIR(3,I)*PPAIR(3,J)
C
C          ENTRY
      IF(NPAIR.NE.4) RETURN
C
C          RECONSTRUCT W-->FF DECAY ANGLES
C
C          INITIALIZE PFCM AND PWCM
      DO 10 I=1,4
      DO 10 K=1,5
10    PFCM(K,I)=PPAIR(K,I)
      DO 11 I=1,2
      DO 11 K=1,5
11    PWCM(K,I)=PJETS(K,I)
C
C          Z BOOST TO WW CENTER OF MASS
      CHWW=QWJET(4)/QWJET(5)
      SHWW=QWJET(3)/QWJET(5)
      DO 20 I=1,4
      TMP=CHWW*PFCM(4,I)-SHWW*PFCM(3,I)
      PFCM(3,I)=-SHWW*PFCM(4,I)+CHWW*PFCM(3,I)
20    PFCM(4,I)=TMP
      DO 21 I=1,2
      TMP=CHWW*PWCM(4,I)-SHWW*PWCM(3,I)
      PWCM(3,I)=-SHWW*PWCM(4,I)+CHWW*PWCM(3,I)
21    PWCM(4,I)=TMP
C
C          ROTATE W1 TO +Z AXIS
      PTW1=SQRT(PWCM(1,1)**2+PWCM(2,1)**2)
      CPHIW1=PWCM(1,1)/PTW1
      SPHIW1=PWCM(2,1)/PTW1
      PW1=SQRT(PTW1**2+PWCM(3,1)**2)
      CTHW1=PWCM(3,1)/PW1
      STHW1=PTW1/PW1
C          Z ROTATION
      DO 30 I=1,4
      TMP=CPHIW1*PFCM(1,I)+SPHIW1*PFCM(2,I)
      PFCM(2,I)=-SPHIW1*PFCM(1,I)+CPHIW1*PFCM(2,I)
30    PFCM(1,I)=TMP
C          Y ROTATION
      DO 31 I=1,4
      TMP=CTHW1*PFCM(1,I)-STHW1*PFCM(3,I)
      PFCM(3,I)=STHW1*PFCM(1,I)+CTHW1*PFCM(3,I)
31    PFCM(1,I)=TMP
C
C          BOOST TO W REST FRAMES
      CHW1=PWCM(4,1)/PWCM(5,1)
      SHW1=PW1/PWCM(5,1)
      DO 40 I=1,4
      IF(I.LE.2) THEN
        SHWI=SHW1
      ELSE
        SHWI=-SHW1
      ENDIF
      TMP=CHW1*PFCM(4,I)-SHWI*PFCM(3,I)
      PFCM(3,I)=-SHWI*PFCM(4,I)+CHW1*PFCM(3,I)
40    PFCM(4,I)=TMP
C
C          COMPUTE ANGLES
      TH12=ACOS(PFCM(3,1)/SQRT(PFCM(1,1)**2+PFCM(2,1)**2+PFCM(3,1)**2))
      PHI12=ATAN2(PFCM(2,1),PFCM(1,1))
      TH34=ACOS(PFCM(3,3)/SQRT(PFCM(1,3)**2+PFCM(2,3)**2+PFCM(3,3)**2))
      PHI34=ATAN2(PFCM(2,3),PFCM(1,3))
C
C          COMPUTE DECAY ANGULAR DISTRIBUTIONS.
C
      DO 100 I=1,4
      IDADDR(I)=IABS(IDPAIR(I))
100   IF(IDADDR(I).GE.11) IDADDR(I)=IDADDR(I)-4
      IF(GOMSSM) THEN
        IW(1)=JETTYP(1)-76
        IW(2)=JETTYP(2)-76
      ELSE
        IW(1)=JETTYP(1)-25
        IW(2)=JETTYP(2)-25
      ENDIF
C
      AMV=PJETS(5,1)
      GAMV=WGAM(IW(1))
      QMH=QMW
C          COUPLINGS
      A12=AQ(IDADDR(1),IW(1))
      B12=BQ(IDADDR(1),IW(1))
      A34=AQ(IDADDR(3),IW(2))
      B34=BQ(IDADDR(3),IW(2))
C          DECAY DISTRIBUTIONS
      TVV12=8.*PI*ALFA*(A12**2+B12**2)
      TVA12=16.*PI*ALFA*A12*B12
      COS12=COS(TH12)
      SIN12=SIN(TH12)
      T12(1,1)=TVV12*SIN12**2
      T12(1,2)=TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2
      T12(1,3)=-TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2
      T12(2,1)=T12(1,2)
      T12(2,2)=TVV12*(.5+.5*COS12**2)+TVA12*COS12
      T12(2,3)=TVV12*.5*SIN12**2
      T12(3,1)=T12(1,3)
      T12(3,2)=T12(2,3)
      T12(3,3)=TVV12*(.5+.5*COS12**2)-TVA12*COS12
C
      TVV34=8.*PI*ALFA*(A34**2+B34**2)
      TVA34=16.*PI*ALFA*A34*B34
      COS34=COS(TH34)
      SIN34=SIN(TH34)
      T34(1,1)=TVV34*SIN34**2
      T34(1,2)=TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2
      T34(1,3)=-TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2
      T34(2,1)=T34(1,2)
      T34(2,2)=TVV34*(.5+.5*COS34**2)+TVA34*COS34
      T34(2,3)=TVV34*.5*SIN34**2
      T34(3,1)=T34(1,3)
      T34(3,2)=T34(2,3)
      T34(3,3)=TVV34*(.5+.5*COS34**2)-TVA34*COS34
C
      CPHI12(1)=1.
      CPHI12(2)=COS(PHI12)
      CPHI12(3)=COS(2.*PHI12)
      SPHI12(1)=0.
      SPHI12(2)=SIN(PHI12)
      SPHI12(3)=SIN(2.*PHI12)
      CPHI34(1)=1.
      CPHI34(2)=COS(PHI34)
      CPHI34(3)=COS(2.*PHI34)
      SPHI34(1)=0.
      SPHI34(2)=SIN(PHI34)
      SPHI34(3)=SIN(2.*PHI34)
C
      TCPHI=CPHI12(2)*CPHI34(2)-SPHI12(2)*SPHI34(2)
      TSPHI=SPHI12(2)*CPHI34(2)+CPHI12(2)*SPHI34(2)
      TC2PHI=CPHI12(3)*CPHI34(3)-SPHI12(3)*SPHI34(3)
      TS2PHI=SPHI12(3)*CPHI34(3)+CPHI12(3)*SPHI34(3)
C
C          PURE HIGGS --> W W. CALCULATE ANGULAR DISTRIBUTION FOR
C          HIGGS DECAY AND MULTIPLY BY CROSS SECTION.
C
      IF(INITYP(1).LE.25.OR.GOMSSM) THEN
        F0=.5*QMH**2/AMV**2-1.
        F1=1.
        TOTAL=(8.*PI/3.)**2*TVV12*TVV34*(F0**2+2.*F1**2)
        DIFF=F0**2*T12(1,1)*T34(1,1)
     $  +F0*F1*(2.*T12(1,2)*T34(1,2)+2.*T12(1,3)*T34(1,3))*TCPHI
     $  +F1**2*(T12(2,2)*T34(1,2)+T12(3,3)*T34(3,3)
     $    +2.*T12(2,3)*T34(2,3)*TC2PHI)
        WWSIG=SIGLLQ*DIFF/TOTAL
        RETURN
      ENDIF
C
C          W W FUSION. CALCULATE ANGULAR DISTRIUBTION FOR DECAY
C          INCLUDING ALL GRAPHS.
C
C          KINEMATICS
      IFL1=LISTJ(JETTYP(1))
      IFL2=LISTJ(JETTYP(2))
      IFIN1=LISTJ(INITYP(1))
      IFIN2=LISTJ(INITYP(2))
      WMF=AMASS(IFL1)
      WMI=AMASS(IFIN1)
      PINPF=SQRT((S-4.*WMI**2)*(S-4.*WMF**2))
      ZCM=(.5*S+T-WMI**2-WMF**2)/(.5*PINPF)
C          PRODUCTION AMPLITUDES. REMEMBER MISSING SIN(THETA)/SQRT(2)
      DO 110 L=1,4
      FTERM(L)=0.
      DO 120 J=1,4
      TERM=0.
      DO 130 I=1,4
130   TERM=TERM+ANWWWW(I,J,L)*ZCM**(I-1)
      TERM=TERM/(ADWWWW(1,J)+ADWWWW(2,J)*ZCM)
120   FTERM(L)=FTERM(L)+TERM
110   CONTINUE
      FTERM(4)=FTERM(4)*SQRT(ABS(1.-ZCM**2))/SQRT2
C          HELICITY AMPLITUDES. NOTATION IS 0,+,-
      FR(1,1)=FTERM(1)
      FI(1,1)=AIWWWW(1)
      FR(1,2)=FTERM(4)
      FI(1,2)=AIWWWW(4)
      FR(2,2)=FTERM(3)
      FI(2,2)=AIWWWW(3)
      FR(2,3)=FTERM(2)
      FI(2,3)=AIWWWW(2)
C
      FR(1,3)=FR(1,2)
      FI(1,3)=FI(1,2)
      FR(3,1)=FR(1,3)
      FI(3,1)=FI(1,3)
      FR(2,1)=FR(1,2)
      FI(2,1)=FI(1,2)
C
      FR(3,3)=FR(2,2)
      FI(3,3)=FI(2,2)
      FR(3,2)=FR(2,3)
      FI(3,2)=FI(2,3)
C
C          DIFFERENTIAL DISTRIBUTION FROM DENSITY MATRIX
      DIFF=0.
      DO 140 I1=1,3
      L1=LAM(I1)
      DO 140 I2=1,3
      L2=LAM(I2)
      DO 140 I3=1,3
      L3=LAM(I3)
      DO 140 I4=1,3
      L4=LAM(I4)
      L12=L1-L2
      I12=IABS(L12)+1
      IF(I12.EQ.0) I12=3
      L34=L3-L4
      I34=IABS(L34)+1
      IF(I34.EQ.0) I34=3
      C1234=CPHI12(I12)*CPHI34(I34)
     $-SPHI12(I12)*ISIGN(1,L12)*SPHI34(I34)*ISIGN(1,L34)
      S1234=SPHI12(I12)*ISIGN(1,L12)*CPHI34(I34)
     $+CPHI12(I12)*SPHI34(I34)*ISIGN(1,L34)
      DIFF=DIFF+(FR(I1,I2)*FR(I3,I4)+FI(I1,I2)*FI(I3,I4))
     $*T12(I3,I1)*T34(I4,I2)*C1234
     $+(FR(I1,I2)*FI(I3,I4)-FI(I1,I2)*FR(I3,I4))
     $*T12(I3,I1)*T34(I4,I2)*S1234
140   CONTINUE
C          INTEGRATED DISTRIBUTION
      TOTAL=0.
      DO 150 I1=1,3
      DO 150 I2=1,3
      TOTAL=TOTAL+FR(I1,I2)**2+FI(I1,I2)**2
150   CONTINUE
      FAC=(16.*PI/3.*4.*PI*ALFA)**2
      FAC=FAC*(A12**2+B12**2)*(A34**2+B34**2)
      TOTAL=TOTAL*FAC
      WWSIG=DIFF/TOTAL*SIGLLQ
      RETURN
      END
+EOD
+DECK,SIGH
      SUBROUTINE SIGH
C
C          COMPUTE THE INTEGRATED WEINBERG-SALAM HIGGS CROSS SECTION
C          D(SIGMA)/D(QMW**2)D(YW)
C
C          SIGMA    = CROSS SECTION SUMMED OVER QUARK TYPES ALLOWED BY
C                     JETTYPE3 AND WTYPE CARDS.
C          SIGS(I)  = PARTIAL CROSS SECTION FOR I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     USING JETTYPE CODE.
C
C          VER. 7.14: CHECK INITIAL QUARK MASS IS ALLOWED
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,JETLIM
+CDE,HCON
C
      DIMENSION AMQCUR(6),LISTW(4),WTHELI(4),FINT(9)
      DIMENSION X(2)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION C,TERM,SUM,FINT,ZLIM
+SELF.
      DATA AMQCUR/.005,.009,.175,1.25,4.50,30./
      DATA LISTW/10,80,-80,90/
C          WTHELI ARE WEIGHTS OF HELICITY AMPLITUDES IN SIGMA.
      DATA WTHELI/1.,2.,2.,4./
C
C          FUNCTIONS
      ACOSH(Z)=ALOG(Z+SQRT(Z**2-1.))
      ATANH(Z)=.5*ALOG((1.+Z)/(1.-Z))
C
C          KINEMATICS (IDENTICAL TO DRELL-YAN)
C
      AMQCUR(6)=AMASS(6)
      QMW2=QMW**2
      QTMW=SQRT(QMW2+QTW**2)
      Q0W=QTMW*COSH(YW)
      QZW=QTMW*SINH(YW)
      QW=SQRT(QZW**2+QTW**2)
      IF(QW.NE.0.) THEN
        CTHW=QZW/QW
        STHW=QTW/QW
        IF(ABS(CTHW).LT.1.) THEN
          THW=ACOS(CTHW)
        ELSE
          CTHW=0.
          STHW=1.
          THW=.5*PI
        ENDIF
      ELSE
        CTHW=0.
        STHW=1.
        THW=.5*PI
      ENDIF
      EHAT=QMW
      SHAT=QMW**2
      QSQ=SHAT
      ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2)
      ALFQSQ=12.*PI/((33.-ANEFF)*ALOG(QSQ/ALAM2))
      Q2SAVE=QSQ
      YHAT=YW
      EY=EXP(YHAT)
      X1=EHAT/ECM*EY
      X2=EHAT/(ECM*EY)
C
C          INITIALIZE
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
100   SIGS(I)=0
C
      IF(X1.GE.1..OR.X2.GE.1.) RETURN
C
C          COMPUTE STRUCTURE FUNCTIONS
      DO 110 IH=1,2
      DO 120 IQ=1,13
120   QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      DO 130 IQ=14,26
130   QSAVE(IQ,IH)=0.
      DO 140 IW=2,4
      AMW=AMASS(LISTW(IW))
      IF(QMW.GT.2.*AMW) THEN
        QSAVE(25+IW,IH)=STRUCW(X(IH),IW,IDIN(IH))/X(IH)
      ELSE
        QSAVE(25+IW,IH)=0.
      ENDIF
140   CONTINUE
110   CONTINUE
C
C          CALCULATE HIGGS-GLUON-GLUON COUPLING FOR GIVEN Q**2
      ETAR=0.
      ETAI=0.
      DO 150 IQ=1,8
      AMQ=AMASS(IQ)
      IF(AMQ.LE.0.) GO TO 150
      RQ=(2.*AMQ/HMASS)**2
      IF(RQ.GE.1.) THEN
        ETAR=ETAR+.5*RQ*(1.+(1.-RQ)*ASIN(1./SQRT(RQ))**2)
      ELSE
        RQLOG=ALOG((1.+SQRT(1.-RQ))/(1.-SQRT(1.-RQ)))
        PHIR=.25*(RQLOG**2-PI**2)
        ETAR=ETAR+.5*RQ*(1.+(RQ-1.)*PHIR)
        PHII=.5*PI*RQLOG
        ETAI=ETAI+.5*RQ*(RQ-1.)*PHII
      ENDIF
150   CONTINUE
      ETAHGG=ETAR**2+ETAI**2
C
C          GL + GL --> HIGGS
C
      SIG0=GF*ALFQSQ**2/(32.*PI*SQRT2)*ETAHGG*X1*X2*UNITS
      SIG0=SIG0*S/(PI*HMASS*((S-HMASS**2)**2+(HMASS*HGAM)**2))
      SIG0=SIG0*QSAVE(1,1)*QSAVE(1,2)
      DO 160 IQ1=2,29
      IQ2=MATCHH(IQ1)
      IF(GOQ(IQ1,1).AND.GOQ(IQ2,2)) THEN
        SIG=SIG0*HGAMS(IQ1)
        IF(IQ1.GT.25) SIG=SIG*TBRWW(IQ1-25,1)*TBRWW(IQ2-25,2)
        CALL SIGFIL(SIG,1,1,IQ1,IQ2)
      ENDIF
160   CONTINUE
C
C          QK + QB --> HIGGS
C
      SIG0=PI*GF/(3.*SQRT2*HMASS**2)*X1*X2*UNITS
      SIG0=SIG0*S/(PI*HMASS*((S-HMASS**2)**2+(HMASS*HGAM)**2))
      DO 210 IQ1=2,13
      IQ2=MATCHH(IQ1)
      AMQ=AMQCUR(IQ1/2)
      IF(QMW.LE.2*AMQ) GO TO 210
      SIG1=SIG0*AMQ**2*QSAVE(IQ1,1)*QSAVE(IQ2,2)
      DO 220 IQ3=2,29
      IQ4=MATCHH(IQ3)
      IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN
        SIG=SIG1*HGAMS(IQ3)
        IF(IQ3.GT.25) SIG=SIG*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2)
        CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4)
      ENDIF
220   CONTINUE
210   CONTINUE
C
C          W+W FUSION AND W+W->W+W IN EFFECTIVE W APPROXIMATION WITH
C          ANGULAR DISTRIBUTION CUT OFF BY PTMIN.
C          Z0 Z0 FINAL STATE HAS SYMMETRY FACTOR OF .5
C
      IF(QMW.LE.2.*AMASS(80)) GO TO 500
C
C          W+ W- --> W+ W-
C
      IF(.NOT.((GOQ(27,1).AND.GOQ(28,2)).OR.(GOQ(28,1).AND.GOQ(27,2))))
     $GO TO 400
      WM=AMASS(80)
      PWWCM=.5*SQRT(QMW**2-4.*WM**2)
      STHLIM=PTMIN(1)/PWWCM
      IF(STHLIM.LE.1) THEN
        ZLIM=SQRT(1.-STHLIM**2)
      ELSE
        GO TO 400
      ENDIF
C          SET UP AMPLITUDES
      CALL XWWWW
C          SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS.
C          L RUNS OVER HELICITY STATES. N RUNS OVER POWERS.
C          REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2)
      SUM=0.
      DO 311 I=1,4
      DO 311 J=I,4
      CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J),
     $ADWWWW(2,J))
        DO 312 L=1,4
        TERM=0.
          DO 313 N=0,6
          C=0.
          N1=MAX(N-3,0)
          N2=MIN(3,N)
          DO 314 K=N1,N2
314       C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L)
          C=C*WTHELI(L)
          IF(J.NE.I) C=2.*C
          IF(L.EQ.4) THEN
            TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3)
          ELSE
            TERM=TERM+C*FINT(N+1)
          ENDIF
313       CONTINUE
        SUM=SUM+TERM
312     CONTINUE
311   CONTINUE
C          ADD INTEGRAL OF IMAGINARY PART SQUARED.
      SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2
     $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2)
C          CROSS SECTION
      SIG0=SUM/(32.*PI*S*SCM)*UNITS
      SIG1=.5*SIG0*QSAVE(27,1)*QSAVE(28,2)
      IF(GOQ(27,1).AND.GOQ(28,2)) THEN
        SIG=SIG1*TBRWW(2,1)*TBRWW(3,2)
        CALL SIGFIL(SIG,27,28,27,28)
      ENDIF
      IF(GOQ(28,1).AND.GOQ(27,2)) THEN
        SIG=SIG1*TBRWW(3,1)*TBRWW(2,2)
        CALL SIGFIL(SIG,27,28,28,27)
      ENDIF
      SIG1=.5*SIG0*QSAVE(28,1)*QSAVE(27,2)
      IF(GOQ(27,1).AND.GOQ(28,2)) THEN
        SIG=SIG1*TBRWW(2,1)*TBRWW(3,2)
        CALL SIGFIL(SIG,28,27,27,28)
      ENDIF
      IF(GOQ(28,1).AND.GOQ(27,2)) THEN
        SIG=SIG1*TBRWW(3,1)*TBRWW(2,2)
        CALL SIGFIL(SIG,28,27,28,27)
      ENDIF
C
C          Z0 Z0 --> W+ W-
C
C          SET UP AMPLITUDES
      IF(QMW.LE.2.*AMASS(90)) GO TO 500
      CALL XZZWW
C          SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS.
C          L RUNS OVER HELICITY STATES. N RUNS OVER POWERS.
C          REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2)
      SUM=0.
      DO 321 I=1,4
      DO 321 J=I,4
      CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J),
     $ADWWWW(2,J))
        DO 322 L=1,4
        TERM=0.
          DO 323 N=0,6
          C=0.
          N1=MAX(N-3,0)
          N2=MIN(3,N)
          DO 324 K=N1,N2
324       C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L)
          C=C*WTHELI(L)
          IF(J.NE.I) C=2.*C
          IF(L.EQ.4) THEN
            TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3)
          ELSE
            TERM=TERM+C*FINT(N+1)
          ENDIF
323       CONTINUE
        SUM=SUM+TERM
322     CONTINUE
321   CONTINUE
C          ADD INTEGRAL OF IMAGINARY PART SQUARED.
      SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2
     $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2)
C          CROSS SECTION
      SIG0=SUM/(32.*PI*S*SCM)*UNITS
      SIG1=.5*SIG0*QSAVE(29,1)*QSAVE(29,2)
      IF(GOQ(27,1).AND.GOQ(28,2)) THEN
        SIG=SIG1*TBRWW(2,1)*TBRWW(3,2)
        CALL SIGFIL(SIG,29,29,27,28)
      ENDIF
      IF(GOQ(28,1).AND.GOQ(27,2)) THEN
        SIG=SIG1*TBRWW(3,1)*TBRWW(2,2)
        CALL SIGFIL(SIG,29,29,28,27)
      ENDIF
C
C          W+ W- --> Z0 Z0
C
400   IF(QMW.LE.2.*AMASS(90)) GO TO 500
      IF(.NOT.(GOQ(29,1).AND.GOQ(29,2))) GO TO 500
      WM=AMASS(90)
      PWWCM=.5*SQRT(QMW**2-4.*WM**2)
      STHLIM=PTMIN(1)/PWWCM
      IF(STHLIM.LE.1) THEN
        ZLIM=SQRT(1.-STHLIM**2)
      ELSE
        GO TO 500
      ENDIF
C          SET UP AMPLITUDES
      CALL XWWZZ
C          SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS.
C          L RUNS OVER HELICITY STATES. N RUNS OVER POWERS.
C          REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2)
      SUM=0.
      DO 411 I=1,4
      DO 411 J=I,4
      CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J),
     $ADWWWW(2,J))
        DO 412 L=1,4
        TERM=0.
          DO 413 N=0,6
          C=0.
          N1=MAX(N-3,0)
          N2=MIN(3,N)
          DO 414 K=N1,N2
414       C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L)
          C=C*WTHELI(L)
          IF(J.NE.I) C=2.*C
          IF(L.EQ.4) THEN
            TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3)
          ELSE
            TERM=TERM+C*FINT(N+1)
          ENDIF
413       CONTINUE
        SUM=SUM+TERM
412     CONTINUE
411   CONTINUE
C          ADD INTEGRAL OF IMAGINARY PART SQUARED.
      SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2
     $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2)
C          CROSS SECTION
      SIG0=SUM/(32.*PI*S*SCM)*UNITS
      SIG0=.5*SIG0
      SIG0=SIG0*TBRWW(4,1)*TBRWW(4,2)
      SIG=SIG0*QSAVE(27,1)*QSAVE(28,2)
      CALL SIGFIL(SIG,27,28,29,29)
      SIG=SIG0*QSAVE(28,1)*QSAVE(27,2)
      CALL SIGFIL(SIG,28,27,29,29)
C
C          Z0 Z0 --> Z0 Z0
C
C          SET UP AMPLITUDES
      CALL XZZZZ
C          SUM CROSS SECTION TERMS. I,J RUN OVER AMPLITUDE TERMS.
C          L RUNS OVER HELICITY STATES. N RUNS OVER POWERS.
C          REMEMBER THAT L=4 IS MISSING SIN(THETA)/SQRT(2)
      SUM=0.
      DO 421 I=1,4
      DO 421 J=I,4
      CALL SIGINT(FINT,ZLIM,ADWWWW(1,I),ADWWWW(2,I),ADWWWW(1,J),
     $ADWWWW(2,J))
        DO 422 L=1,4
        TERM=0.
          DO 423 N=0,6
          C=0.
          N1=MAX(N-3,0)
          N2=MIN(3,N)
          DO 424 K=N1,N2
424       C=C+ANWWWW(K+1,I,L)*ANWWWW(N-K+1,J,L)
          C=C*WTHELI(L)
          IF(J.NE.I) C=2.*C
          IF(L.EQ.4) THEN
            TERM=TERM+.5*C*FINT(N+1)-.5*C*FINT(N+3)
          ELSE
            TERM=TERM+C*FINT(N+1)
          ENDIF
423       CONTINUE
        SUM=SUM+TERM
422     CONTINUE
421   CONTINUE
C          ADD INTEGRAL OF IMAGINARY PART SQUARED.
      SUM=SUM+2.*ZLIM*(WTHELI(1)*AIWWWW(1)**2+WTHELI(2)*AIWWWW(2)**2
     $+WTHELI(3)*AIWWWW(3)**2+WTHELI(4)*AIWWWW(4)**2)
C          CROSS SECTION
      SIG0=SUM/(32.*PI*S*SCM)*UNITS
      SIG0=.5*SIG0
      SIG0=SIG0*TBRWW(4,1)*TBRWW(4,2)
      SIG=SIG0*QSAVE(29,1)*QSAVE(29,2)
      CALL SIGFIL(SIG,29,29,29,29)
C
500   RETURN
      END
+EOD
+DECK,SIGHSS
      SUBROUTINE SIGHSS
C
C          Compute the integrated MSSM Higgs cross section
C          d(sigma)/d(QMW**2)d(YW)
C          Since SUSY Higgs are always narrow, can use the widths to
C          determine couplings and ignore interference with continuum.
C
C          SIGMA    = cross section summed over quark types allowed by
C                     JETTYPE and WTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code from LISTSS.
C
C          Ver 7.18: Correct GOQ's and include TBRWW for W/Z modes.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,JETLIM
+CDE,HCON
C
      REAL X(2)
      REAL AMASS,STRUC
      REAL AM1,AM2,S,T,U,Q2SAVE,YHAT,EY,ANEFF,QMW2,QZW,EHAT,SIG0,SIG,
     $AMW
      INTEGER JT1,JT2,I,J,IH,IQ,I1,I2,JTGL,JTOFF
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1)
C
C          Kinematics (identical to Drell-Yan)
C
      QMW2=QMW**2
      QTMW=SQRT(QMW2+QTW**2)
      Q0W=QTMW*COSH(YW)
      QZW=QTMW*SINH(YW)
      QW=SQRT(QZW**2+QTW**2)
      IF(QW.NE.0.) THEN
        CTHW=QZW/QW
        STHW=QTW/QW
        IF(ABS(CTHW).LT.1.) THEN
          THW=ACOS(CTHW)
        ELSE
          CTHW=0.
          STHW=1.
          THW=.5*PI
        ENDIF
      ELSE
        CTHW=0.
        STHW=1.
        THW=.5*PI
      ENDIF
      EHAT=QMW
      SHAT=QMW**2
      QSQ=SHAT
      ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2)
      ALFQSQ=12.*PI/((33.-ANEFF)*ALOG(QSQ/ALAM2))
      Q2SAVE=QSQ
      YHAT=YW
      EY=EXP(YHAT)
      X1=EHAT/ECM*EY
      X2=EHAT/(ECM*EY)
C
C          Initialize
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
100   SIGS(I)=0
      IF(X1.GE.1..OR.X2.GE.1.) RETURN
C
C          Compute structure functions
C
      DO 110 IH=1,2
        DO 120 IQ=1,13
120     QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
        DO 130 IQ=14,26
130     QSAVE(IQ,IH)=0.
110   CONTINUE
C
C          gl + gl -> Higgs
C
      JTGL=52
      SIG0=PI*HMASS**2/(8*S**2)*HGAMSS(JTGL,JTGL)*X1*X2*UNITS
     $/((S-HMASS**2)**2+(HMASS*HGAM)**2)
      SIG0=SIG0*QSAVE(1,1)*QSAVE(1,2)
      DO 200 I=1,85
        DO 210 J=1,85
          IF(HGAMSS(I,J).EQ.0) GO TO 210
          IF(.NOT.(GOQ(I,1).AND.GOQ(J,2))) GO TO 210
          SIG=SIG0*HGAMSS(I,J)
C          Include W/Z branching ratios
          IF((I.GE.78.AND.I.LE.80).AND.(J.GE.78.AND.J.LE.80)) THEN
            SIG=SIG*TBRWW(I-76,1)*TBRWW(J-76,2)
          ENDIF
          CALL SIGFIL(SIG,JTGL,JTGL,I,J)
210     CONTINUE
200   CONTINUE
C
C          qk + qb -> Higgs
C
      JTOFF=51
C          Note I1,I2 run over quarks; JT1,JT2,I,J over LISTSS
      DO 300 I1=2,13
        AM1=AMASS(I1/2)
        JT1=I1+JTOFF
        DO 310 I2=2,13
          AM2=AMASS(I2/2)
          JT2=I2+JTOFF
          IF(HGAMSS(JT1,JT2).LE.0) GO TO 310
          SIG0=4*PI*HMASS**2/(9*S**2)*HGAMSS(JT1,JT2)*X1*X2*UNITS
     $    /((S-HMASS**2)**2+(HMASS*HGAM)**2)
          SIG0=SIG0*QSAVE(I1,1)*QSAVE(I2,2)
C          Decay partial cross sections
          DO 320 I=1,85
            DO 330 J=1,85
              IF(HGAMSS(I,J).EQ.0) GO TO 330
              IF(.NOT.(GOQ(I,1).AND.GOQ(J,2))) GO TO 330
              SIG=SIG0*HGAMSS(I,J)
C          Include W/Z branching ratios
              IF((I.GE.78.AND.I.LE.80).AND.(J.GE.78.AND.J.LE.80)) THEN
                SIG=SIG*TBRWW(I-76,1)*TBRWW(J-76,2)
              ENDIF
              CALL SIGFIL(SIG,JT1,JT2,I,J)
330         CONTINUE
320       CONTINUE
310     CONTINUE
300   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SIGINT
      SUBROUTINE SIGINT(F,Z,A1S,B1S,A2S,B2S)
C
C          F(N+1) = INT(-Z,Z)(DX X**N/((A1+B1*X)*A2+B2*X)))
C          F(8) = F(9) = 0 (DUMMY VALUES)
C
      DIMENSION F(9)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION A1,B1,A2,B2,A,B,C,Z,F,A1S,B1S,A2S,B2S
+SELF.
C
      A1=A1S
      B1=B1S
      A2=A2S
      B2=B2S
      F(8)=0.
      F(9)=0.
C
C          SPECIAL CASE: X**N/(A1*A2)
      IF(B1.EQ.0..AND.B2.EQ.0.) THEN
        F(1)=2.*Z/(A1*A2)
        F(2)=0.
        F(3)=2.*Z**3/(3.*A1*A2)
        F(4)=0.
        F(5)=2.*Z**5/(5.*A1*A2)
        F(6)=0.
        F(7)=2.*Z**7/(7.*A1*A2)
        RETURN
      ENDIF
C
C          SPECIAL CASE: X**N/(A+BX)
      IF(B1.EQ.0..OR.B2.EQ.0.) THEN
        IF(B1.EQ.0.) THEN
          A=A2/B2
          C=1./(A1*B2)
        ELSE
          A=A1/B1
          C=1./(A2*B1)
        ENDIF
        F(1)=LOG((A+Z)/(A-Z))
        F(1)=F(1)*C
        F(2)=-A*LOG((A+Z)/(A-Z))+2.*Z
        F(2)=F(2)*C
        F(3)=A**2*LOG((A+Z)/(A-Z))-2.*A*Z
        F(3)=F(3)*C
        F(4)=-A**3*LOG((A+Z)/(A-Z))+2.*A**2*Z+2.*Z**3/3.
        F(4)=F(4)*C
        F(5)=A**4*LOG((A+Z)/(A-Z))-2.*A**3*Z-2.*A*Z**3/3.
        F(5)=F(5)*C
        F(6)=-A**5*LOG((A+Z)/(A-Z))+2.*A**4*Z+2.*A**2*Z**3/3.+2.*Z**5/5.
        F(6)=F(6)*C
        F(7)=A**6*LOG((A+Z)/(A-Z))-2.*A**5*Z-2.*A**3*Z**3/3.
     $  -2.*A*Z**5/5.
        F(7)=F(7)*C
        RETURN
      ENDIF
C
C          B1 AND B2 NONZERO
      A1=A1/B1
      A2=A2/B2
      C=1./(B1*B2)
C
C          SPECIAL CASE: X**N/(A+B*X)**2
      IF(A1.EQ.A2) THEN
        A=A1
        F(1)=2.*Z/(A**2-Z**2)
        F(1)=F(1)*C
        F(2)=-2.*A*Z/(A**2-Z**2)+LOG((A+Z)/(A-Z))
        F(2)=F(2)*C
        F(3)=(4.*A**2*Z-2.*Z**3)/(A**2-Z**2)-2.*A*LOG((A+Z)/(A-Z))
        F(3)=F(3)*C
        F(4)=(4.*A*Z**3-6.*A**3*Z)/(A**2-Z**2)+3.*A**2*LOG((A+Z)/(A-Z))
        F(4)=F(4)*C
        F(5)=(-16.*A**2*Z**3/3.+8.*A**4*Z-2.*Z**5/3.)/(A**2-Z**2)
     $  -4.*A**3*LOG((A+Z)/(A-Z))
        F(5)=F(5)*C
        F(6)=(4.*A*Z**5/3.+20.*A**3*Z**3/3.-10.*A**5*Z)/(A**2-Z**2)
     $  +5*A**4*LOG((A+Z)/(A-Z))
        F(6)=F(6)*C
        F(7)=(-8.*A**2*Z**5/5.-8.*A**4*Z**3+12.*A**6*Z-2.*Z**7/5.)
     $  /(A**2-Z**2)-6.*A**5*LOG((A+Z)/(A-Z))
        F(7)=F(7)*C
        RETURN
      ENDIF
C
C          GENERAL CASE
      F(1)=(-LOG((A1+Z)/(A1-Z))+LOG((A2+Z)/(A2-Z)))/(A1-A2)
      F(1)=F(1)*C
      F(2)=(A1*LOG((A1+Z)/(A1-Z))-A2*LOG((A2+Z)/(A2-Z)))/(A1-A2)
      F(2)=F(2)*C
      F(3)=(-A1**2*LOG((A1+Z)/(A1-Z))+A2**2*LOG((A2+Z)/(A2-Z)))/(A1-A2)
     $+2.*Z
      F(3)=F(3)*C
      F(4)=(A1**3*LOG((A1+Z)/(A1-Z))-A2**3*LOG((A2+Z)/(A2-Z)))/(A1-A2)
     $+2.*Z*(-A1-A2)
      F(4)=F(4)*C
      F(5)=(-A1**4*LOG((A1+Z)/(A1-Z))+A2**4*LOG((A2+Z)/(A2-Z)))/(A1-A2)
     $+2.*Z*(A1*A2+A1**2+A2**2)+2.*Z**3/3.
      F(5)=F(5)*C
      F(6)=(A1**5*LOG((A1+Z)/(A1-Z))-A2**5*LOG((A2+Z)/(A2-Z)))/(A1-A2)
     $+2.*Z*(-A1*A2**2-A1**2*A2-A1**3-A2**3)+2.*Z**3/3.*(-A1-A2)
      F(6)=F(6)*C
      F(7)=(-A1**6*LOG((A1+Z)/(A1-Z))+A2**6*LOG((A2+Z)/(A2-Z)))/(A1-A2)
     $+2.*Z*(A1*A2**3+A1**2*A2**2+A1**3*A2+A1**4+A2**4)
     $+2.*Z**3/3.*(A1*A2+A1**2+A2**2)+2.*Z**5/5.
      F(7)=F(7)*C
      RETURN
      END
+EOD
+DECK,SIGKKG
      SUBROUTINE SIGKKG
C
C          Compute the KK graviton direct production cross-section
C          d(sigma)/d(m**2)d(pT**2)d(y3)d(y4)
C          X-sections: G.F.Giudice et al.  hep-ph/9811291
C          Kinematics: sigdy.car (Drell-Yan + jet)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,NODCAY
+CDE,KKGRAV
C
      REAL X(2)
      REAL Z,S,T,U,QMW2,QZW,EHAT,Q2SAVE,YHAT,EY,P3Z,P1,P2,AMASS,ANEFF,
     $SIG0,DENOM,QT2CUT,SIGT,SIGU,FAC,PROP,FACTOR,SIG,AMT,AMT2,SWT,
     $P1WT,P2WT,X1WT,X2WT,TWT,UWT,Q2,QFCN,STRUC,XX,ACOSH,ATANH,P2M,P1M
      REAL AMI2,AMF2,EFWT
      REAL AJLWT,AJLZT1,AJLZT2,A2,A2B2,QQ,TM2
      INTEGER I,IQ,IH,IQ1,IFL,IQ2,IW,IQ3
      INTEGER NZERO(4)
      REAL AMFAC(13)
      INTEGER NUTYP(25)
      INTEGER IFL1,IFL2
      REAL TERM
      REAL KKGF1,KKGF2,KKGF3,SIG1,SIG2,XG,YG,F1,F2T,F2U,F3
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1)
C          Electric charge:
      REAL CHARGE
      EXTERNAL CHARGE
C
C          Kinematics: (Drell-Yan plus jet)
C
      QMW2=QMW**2
      QTMW=SQRT(QMW2+QTW**2)
      Q0W=QTMW*COSH(YW)
      QZW=QTMW*SINH(YW)
      QW=SQRT(QZW**2+QTW**2)
C          Protect against errors
      IF(QW.NE.0.) THEN
        CTHW=QZW/QW
        STHW=QTW/QW
        IF(ABS(CTHW).LT.1.) THEN
          THW=ACOS(CTHW)
        ELSE
          CTHW=0.
          STHW=1.
          THW=.5*PI
        ENDIF
      ELSE
        CTHW=0.
        STHW=1.
        THW=.5*PI
      ENDIF
c          Drell-Yan plus jet
      P3Z=P(3)*CTH(3)
      SHAT=QMW2+2.*Q0W*P(3)-2.*QZW*P3Z+2.*PT(3)**2
      P1=.5*(P(3)+P3Z+Q0W+QZW)
      P2=.5*(P(3)-P3Z+Q0W-QZW)
      X1=P1/HALFE
      X2=P2/HALFE
      THAT=-2.*P1*(P(3)-P3Z)
      UHAT=-2.*P2*(P(3)+P3Z)
      QSQ=QTW**2
      QSQ=AMAX1(QSQ,4.)
      ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2)
      ALFQSQ=12.*PI/((33.-2.*ANEFF)*ALOG(QSQ/ALAM2))
      Q2SAVE=QSQ
      QSQ=SHAT
C
C          Initialize
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
        SIGS(I)=0.
100   CONTINUE
      IF(X1.GE.1..OR.X2.GE.1.) RETURN
C
C          Structure functions
C
      DO 110 IH=1,2
        DO 120 IQ=1,11
          QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
120     CONTINUE
        QSAVE(12,IH)=0
        QSAVE(13,IH)=0
110   CONTINUE
      QSQ=Q2SAVE
C
      IF((THAT/SHAT).EQ.0.) RETURN
      IF(ABS(THAT/SHAT+1).LT.1.E-06) RETURN
      F1=KKGF1(SHAT,THAT,QMW2)
      F2T=KKGF2(SHAT,THAT,QMW2)
      F2U=KKGF2(SHAT,UHAT,QMW2)
      F3=KKGF3(SHAT,THAT,QMW2)
      IF(F1.LE.0.OR.F2T.LE.0.OR.F2U.LE.0.OR.F3.LE.0) RETURN
C
      SIG0=UNITS*0.5*KKGSD*ALFQSQ*QMW**(NEXTRAD-2)/SCM
C
C          Jet 3 = gamma:
C
      IF(GOQ(26,3)) THEN
        SIG1=UNITS*0.5*KKGSD*ALFA*QMW**(NEXTRAD-2)/SCM
        SIG1=SIG1*F1/48.0
C          qk + qb --> gamma + KKG
        DO 410 IFL=1,5
          IQ1=2*IFL
          IQ2=IQ1+1
          SIG2=SIG1*ABS(CHARGE(IFL))
          SIG=SIG2*QSAVE(IQ1,1)*QSAVE(IQ2,2)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
          CALL SIGFIL(SIG,IQ1,IQ2,5,26)
          SIG=SIG2*QSAVE(IQ2,1)*QSAVE(IQ1,2)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
          CALL SIGFIL(SIG,IQ2,IQ1,5,26)
410     CONTINUE
      ENDIF
C
C          Jet 3 = gluon:
C
      IF(GOQ(1,3)) THEN
        SIG1=SIG0*F1/36.0
C          qk + qb --> gl + KKG
        DO 210 IFL=1,5
          IQ1=2*IFL
          IQ2=IQ1+1
          SIG=SIG1*QSAVE(IQ1,1)*QSAVE(IQ2,2)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
          CALL SIGFIL(SIG,IQ1,IQ2,5,1)
          SIG=SIG1*QSAVE(IQ2,1)*QSAVE(IQ1,2)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
          CALL SIGFIL(SIG,IQ1,IQ1,5,1)
210     CONTINUE
C          gl + gl --> gl + KKG
        SIG1=SIG0*F3*3.0/16.0
        SIG=SIG1*QSAVE(1,1)*QSAVE(1,2)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
        CALL SIGFIL(SIG,1,1,5,1)
      ENDIF
C
C          Jet 3 = quark:
C
      SIGT=SIG0*F2T/96.0
      SIGU=SIG0*F2U/96.0
C          qk + gl --> qk + KKG      
      DO 310 IQ1=2,11
        IQ3=IQ1
        IF(GOQ(IQ3,3)) THEN
          SIG=SIGU*QSAVE(IQ1,1)*QSAVE(1,2)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
          CALL SIGFIL(SIG,IQ1,1,5,IQ3)
          SIG=SIGT*QSAVE(IQ1,2)*QSAVE(1,1)
          IF(UVCUT.AND.SHAT.GE.(MASSD**2)) SIG=SIG*(MASSD**2/SHAT)**2
          CALL SIGFIL(SIG,1,IQ1,5,IQ3)
        ENDIF
310   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SIGQCD.
      SUBROUTINE SIGQCD
C
C          Compute D(SIGMA)/D(PT**2)D(Y1)D(Y2)
C          Include quark masses for ch, bt, and tp and 4th generation.
C          Note ch is now treated as heavy.
C
C          SIGMA    = cross section summed over quark types allowed by
C                     JETTYPE card.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code.
C
C          Cross sections from Feynman, Field and Fox, P.R. D18, 3320
C          Massive cross sections from B. Combridge, N.P. B151, 429.
C          Extra factor of 1/2 needed for  non-identical jets since all
C          all jets are treated as identical.
C
C          Ver 6.35: Fix kinematics for gl + tp -> gl + tp, etc.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,CONST
C
      REAL    X(2),QSAVE(13,2),EBT(2)
      EQUIVALENCE (X(1),X1),(S,SHAT),(T,THAT),(U,UHAT)
      REAL    FFF1,FFF2,FFF3,FFF4,FFF5,FFF6,FFF7,S,T,U,FGQ,AM2,FQQ,
     $        QFCN,STRUC,FJAC,SIG,AMASS,SIG1,AMQ,FJACBT,SIG2,QQ,XQMIN,
     $        E1,E2
      INTEGER IQ,IH,I,J,IFL,JTYP1,JTYP2,IQ1,IQ2
C
C          Elementary cross sections from Feynman, Field, and Fox.
C
      FFF1(S,T,U)=4./9.*(S**2+U**2)/T**2
      FFF2(S,T,U)=4./9.*((S**2+U**2)/T**2+(S**2+T**2)/U**2)
     1-8./27.*S**2/(U*T)
      FFF3(S,T,U)=4./9.*((S**2+U**2)/T**2+(T**2+U**2)/S**2)
     1-8./27.*U**2/(S*T)
      FFF4(S,T,U)=32./27.*(U**2+T**2)/(U*T)-8./3.*(U**2+T**2)/S**2
      FFF5(S,T,U)=1./6.*(U**2+T**2)/(U*T)-3./8.*(U**2+T**2)/S**2
      FFF6(S,T,U)=-4./9.*(U**2+S**2)/(U*S)+(U**2+S**2)/T**2
      FFF7(S,T,U)=9./2.*(3.-U*T/S**2-U*S/T**2-S*T/U**2)
C          Heavy quark cross sections from Combridge
      FGQ(S,T,U)=2.*(S-AM2)*(AM2-U)/T**2
     1+4./9.*((S-AM2)*(AM2-U)+2.*AM2*(S+AM2))/(S-AM2)**2
     2+4./9.*((S-AM2)*(AM2-U)+2.*AM2*(AM2+U))/(AM2-U)**2
     3+1./9.*AM2*(4.*AM2-T)/((S-AM2)*(AM2-U))
     4+((S-AM2)*(AM2-U)+AM2*(S-U))/(T*(S-AM2))
     5-((S-AM2)*(AM2-U)-AM2*(S-U))/(T*(AM2-U))
      FQQ(S,T,U)=4./9.*((AM2-U)**2+(S-AM2)**2+2.*AM2*T)/T**2
      QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
C
C          Use massless kinematics for ch and lighter quarks.
C
      CALL TWOKIN(0.,0.,0.,0.)
      FJAC=SHAT/SCM*UNITS
      FJAC=FJAC*PI*ALFQSQ**2/SHAT**2
C
C          Initialize cross sections.
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
        SIGS(I)=0.
100   CONTINUE
      IF(X1.GE.1.0.OR.X2.GE.1.0) RETURN
C          Compute structure functions
      DO 110 IH=1,2
      DO 110 IQ=1,7
        QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
110   CONTINUE
C
C          Compute cross sections summed over quark types allowed by
C          JETTYPE card.
C
C          Gluon-gluon
      IF(.NOT.(GOQ(1,1).AND.GOQ(1,2))) GO TO 210
      SIG=.5*FJAC*QSAVE(1,1)*QSAVE(1,2)*FFF7(S,T,U)
      CALL SIGFIL(SIG,1,1,1,1)
C
      DO 201 I=1,3
        SIG=.5*FJAC*QSAVE(2*I,1)*QSAVE(2*I+1,2)*FFF4(S,T,U)
        CALL SIGFIL(SIG,2*I,2*I+1,1,1)
        SIG=.5*FJAC*QSAVE(2*I+1,1)*QSAVE(2*I,2)*FFF4(S,U,T)
        CALL SIGFIL(SIG,2*I+1,2*I,1,1)
201   CONTINUE
C
C          Quark-gluon
210   CONTINUE
      DO 211 I=2,7
        IF(.NOT.(GOQ(I,1).AND.GOQ(1,2))) GO TO 212
        SIG=.5*FJAC*QSAVE(I,1)*QSAVE(1,2)*FFF6(S,T,U)
        CALL SIGFIL(SIG,I,1,I,1)
        SIG=.5*FJAC*QSAVE(1,1)*QSAVE(I,2)*FFF6(S,U,T)
        CALL SIGFIL(SIG,1,I,I,1)
212     CONTINUE
        IF(.NOT.(GOQ(1,1).AND.GOQ(I,2))) GO TO 211
        SIG=.5*FJAC*QSAVE(1,1)*QSAVE(I,2)*FFF6(S,T,U)
        CALL SIGFIL(SIG,1,I,1,I)
        SIG=.5*FJAC*QSAVE(I,1)*QSAVE(1,2)*FFF6(S,U,T)
        CALL SIGFIL(SIG,I,1,1,I)
211   CONTINUE
C
C          Identical quark-quark
      DO 220 I=2,7
        IF(.NOT.(GOQ(I,1).AND.GOQ(I,2))) GO TO 220
        SIG=.5*FJAC*QSAVE(I,1)*QSAVE(I,2)*FFF2(S,T,U)
        CALL SIGFIL(SIG,I,I,I,I)
220   CONTINUE
C
C          Identical quark-antiquark
      DO 230 I=1,3
        IF(SHAT.LT.4.*AMASS(I)**2) GO TO 230
        IF(.NOT.(GOQ(2*I,1).AND.GOQ(2*I+1,2))) GO TO 235
        SIG=.5*FJAC*QSAVE(1,1)*QSAVE(1,2)*FFF5(S,T,U)
        CALL SIGFIL(SIG,1,1,2*I,2*I+1)
        DO 231 J=1,3
          IF(J.EQ.I) GO TO 231
          SIG=.5*FJAC*QSAVE(2*J,1)*QSAVE(2*J+1,2)*FFF1(T,S,U)
          CALL SIGFIL(SIG,2*J,2*J+1,2*I,2*I+1)
          SIG=.5*FJAC*QSAVE(2*J+1,1)*QSAVE(2*J,2)*FFF1(T,S,U)
          CALL SIGFIL(SIG,2*J+1,2*J,2*I,2*I+1)
231     CONTINUE
        SIG=.5*FJAC*QSAVE(2*I,1)*QSAVE(2*I+1,2)*FFF3(S,T,U)
        CALL SIGFIL(SIG,2*I,2*I+1,2*I,2*I+1)
        SIG=.5*FJAC*QSAVE(2*I+1,1)*QSAVE(2*I,2)*FFF3(S,U,T)
        CALL SIGFIL(SIG,2*I+1,2*I,2*I,2*I+1)
C
235     CONTINUE
        IF(.NOT.(GOQ(2*I+1,1).AND.GOQ(2*I,2))) GO TO 230
        SIG=.5*FJAC*QSAVE(1,1)*QSAVE(1,2)*FFF5(S,T,U)
        CALL SIGFIL(SIG,1,1,2*I+1,2*I)
        DO 236 J=1,3
          IF(J.EQ.I) GO TO 236
          SIG=.5*FJAC*QSAVE(2*J,1)*QSAVE(2*J+1,2)*FFF1(T,S,U)
          CALL SIGFIL(SIG,2*J,2*J+1,2*I+1,2*I)
          SIG=.5*FJAC*QSAVE(2*J+1,1)*QSAVE(2*J,2)*FFF1(T,S,U)
          CALL SIGFIL(SIG,2*J+1,2*J,2*I+1,2*I)
236     CONTINUE
        SIG1=.5*FJAC*QSAVE(2*I,1)*QSAVE(2*I+1,2)*FFF3(S,U,T)
        CALL SIGFIL(SIG1,2*I,2*I+1,2*I+1,2*I)
        SIG=.5*FJAC*QSAVE(2*I+1,1)*QSAVE(2*I,2)*FFF3(S,T,U)
        CALL SIGFIL(SIG,2*I+1,2*I,2*I+1,2*I)
230   CONTINUE
C
C          General massless quark-quark
      DO 240 I=2,7
        DO 241 J=2,7
          IF(.NOT.(GOQ(I,1).AND.GOQ(J,2))) GO TO 241
          IF((I/2).EQ.(J/2)) GO TO 241
          SIG=.5*FJAC*QSAVE(I,1)*QSAVE(J,2)*FFF1(S,T,U)
          CALL SIGFIL(SIG,I,J,I,J)
          SIG=.5*FJAC*QSAVE(J,1)*QSAVE(I,2)*FFF1(S,U,T)
          CALL SIGFIL(SIG,I,J,J,I)
241     CONTINUE
240   CONTINUE
C
C          CH+CB, BT+BB, and TP+TB cross sections.
C          Y=-log(tan(theta/2)), so Jacobean contains P1*P2/E1*E2.
C          Also fourth generation.
C
      DO 250 IQ=1,5
        IFL=IQ+3
        JTYP1=2*IFL
        JTYP2=JTYP1+1
        IF(.NOT.((GOQ(JTYP1,1).AND.GOQ(JTYP2,2)).OR.
     1  (GOQ(JTYP2,1).AND.GOQ(JTYP1,2)))) GO TO 250
        AMQ=AMASS(IFL)
        IF(AMQ.LT.0.) GO TO 250
        AM2=AMQ**2
        CALL TWOKIN(0.,0.,AMQ,AMQ)
        IF(X(1).GE.1..OR.X(2).GE.1.) GO TO 250
        EBT(1)=SQRT(P(1)**2+AM2)
        EBT(2)=SQRT(P(2)**2+AM2)
        FJACBT=.5*S/SCM*UNITS*P(1)*P(2)/(EBT(1)*EBT(2))
        SIG1=12.*(AM2-T)*(AM2-U)/S**2
     1  +8./3.*((AM2-T)*(AM2-U)-2.*AM2*(AM2+T))/(AM2-T)**2
     2  +8./3.*((AM2-T)*(AM2-U)-2.*AM2*(AM2+U))/(AM2-U)**2
     3  -2./3.*AM2*(S-4.*AM2)/((AM2-T)*(AM2-U))
     4  -6.*((AM2-T)*(AM2-U)+AM2*(U-T))/(S*(AM2-T))
     5  -6.*((AM2-T)*(AM2-U)+AM2*(T-U))/(S*(AM2-U))
        SIG1=SIG1*PI**2*ALFQSQ**2/(16.*PI*S**2)
        SIG=FJACBT*SIG1*STRUC(X(1),QSQ,1,IDIN(1))/X(1)
     1  *STRUC(X(2),QSQ,1,IDIN(2))/X(2)
        IF(GOQ(JTYP1,1).AND.GOQ(JTYP2,2)) 
     $  CALL SIGFIL(SIG,1,1,JTYP1,JTYP2)
        IF(GOQ(JTYP2,1).AND.GOQ(JTYP1,2)) 
     $  CALL SIGFIL(SIG,1,1,JTYP2,JTYP1)
C
        SIG2=((AM2-T)**2+(AM2-U)**2+2.*S*AM2)/S**2
        SIG2=FJACBT*SIG2*64.*PI**2*ALFQSQ**2/(9.*16.*PI*S**2)
        DO 255 I=1,3
          QQ=STRUC(X(1),QSQ,2*I,IDIN(1))*STRUC(X(2),QSQ,2*I+1,IDIN(2))
          SIG=SIG2*QQ/(X(1)*X(2))
          IF(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))
     $    CALL SIGFIL(SIG,2*I,2*I+1,JTYP1,JTYP2)
          IF(GOQ(JTYP2,1).AND.GOQ(JTYP1,2))
     $    CALL SIGFIL(SIG,2*I,2*I+1,JTYP2,JTYP1)
          QQ=STRUC(X(1),QSQ,2*I+1,IDIN(1))*STRUC(X(2),QSQ,2*I,IDIN(2))
          SIG=SIG2*QQ/(X(1)*X(2))
          IF(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))
     $    CALL SIGFIL(SIG,2*I+1,2*I,JTYP1,JTYP2)
          IF(GOQ(JTYP2,1).AND.GOQ(JTYP1,2))
     $    CALL SIGFIL(SIG,2*I+1,2*I,JTYP2,JTYP1)
255     CONTINUE
250   CONTINUE
C
C          Gluon + heavy quark
      DO 300 IQ=8,13
        IF(.NOT.(GOQ(1,1).AND.GOQ(IQ,2))) GO TO 310
        AMQ=AMASS(IQ/2)
        AM2=AMQ**2
        XQMIN=AMQ/ECM
        E1=P(1)
        E2=SQRT(P(2)**2+AM2)
        FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2
        CALL TWOKIN(0.,AMQ,0.,AMQ)
        IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN
          SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,T,U)*QFCN(1,1)*QFCN(IQ,2)
          CALL SIGFIL(SIG,1,IQ,1,IQ)
        ENDIF
        CALL TWOKIN(AMQ,0.,0.,AMQ)        
        IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN
          SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,U,T)*QFCN(IQ,1)*QFCN(1,2)
          CALL SIGFIL(SIG,IQ,1,1,IQ)
        ENDIF
C
310     IF(.NOT.(GOQ(IQ,1).AND.GOQ(1,2))) GO TO 300
        AMQ=AMASS(IQ/2)
        AM2=AMQ**2
        XQMIN=AMQ/ECM
        E1=SQRT(P(1)**2+AM2)
        E2=P(2)
        FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2
        CALL TWOKIN(0.,AMQ,AMQ,0.)
        IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN
          SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,U,T)*QFCN(1,1)*QFCN(IQ,2)
          CALL SIGFIL(SIG,1,IQ,IQ,1)
        ENDIF
        CALL TWOKIN(AMQ,0.,AMQ,0.)
        IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN
          SIG=FJAC*P(1)*P(2)/(E1*E2)*FGQ(S,T,U)*QFCN(IQ,1)*QFCN(1,2)
          CALL SIGFIL(SIG,IQ,1,IQ,1)
        ENDIF
300   CONTINUE
C
C          Light quark + heavy quark
      DO 320 IQ1=2,7
        DO 330 IQ2=8,13
          IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 340
          AMQ=AMASS(IQ2/2)
          AM2=AMQ**2
          XQMIN=AMQ/ECM
          E1=P(1)
          E2=SQRT(P(2)**2+AM2)
          FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2
          CALL TWOKIN(0.,AMQ,0.,AMQ)
          IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN
            SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,T,U)*QFCN(IQ1,1)
     $      *QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,IQ1,IQ2)
          ENDIF
          CALL TWOKIN(AMQ,0.,0.,AMQ)
          IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN
            SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,U,T)*QFCN(IQ1,2)
     $      *QFCN(IQ2,1)
            CALL SIGFIL(SIG,IQ2,IQ1,IQ1,IQ2)
          ENDIF
C
340       IF(.NOT.(GOQ(IQ1,2).AND.GOQ(IQ2,1))) GO TO 330
          AMQ=AMASS(IQ2/2)
          AM2=AMQ**2
          XQMIN=AMQ/ECM
          E1=SQRT(P(1)**2+AM2)
          E2=P(2)
          FJAC=.5*S/SCM*UNITS*PI*ALFQSQ**2/S**2
          CALL TWOKIN(0.,AMQ,AMQ,0.)
          IF(X(1).LT.1..AND.X(2).LT.1..AND.X(2).GT.XQMIN) THEN
            SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,U,T)*QFCN(IQ1,1)
     $      *QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,IQ2,IQ1)
          ENDIF
          CALL TWOKIN(AMQ,0.,AMQ,0.)      
          IF(X(1).LT.1..AND.X(2).LT.1..AND.X(1).GT.XQMIN) THEN
            SIG=FJAC*P(1)*P(2)/(E1*E2)*FQQ(S,T,U)*QFCN(IQ1,2)
     $      *QFCN(IQ2,1)
            CALL SIGFIL(SIG,IQ2,IQ1,IQ2,IQ1)
          ENDIF
330     CONTINUE
320   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SIGSSE.
      SUBROUTINE SIGSSE
C
C          Compute d(sigma)/d(cos theta) for
C          e+ e- ----> SUSY particles
C          See Baer et. al., IJMP A4, 4111 (1989) for sigma's
C          Polarized cross sections added 9/18/95 hb
C          Mixed sbottoms and staus included 10/23/96 hb
C
C          SIGMA    = cross section summed over quark types allowed by
C                     JETTYPE and WTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code.
C
C          Extra factor of 1/2 needed because all jets are treated
C          as identical.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,JETSIG
+CDE,EEPAR
+CDE,PRIMAR
+CDE,JETPAR
+CDE,Q1Q2
+CDE,WCON
+CDE,CONST
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTYPE
+CDE,BREMBM
C
      REAL ALQ(2),BEQ(2),E,CS2THW,TNTHW,CTTHW,AE,BE,AM1,AM2,
     $EQ,ALR,Z,PHIZ,PROPZ,SIG,PCM,AMASS,ALL(2),BEL(2),
     $G,MSNE,TM2,TM3,TM4,TM5,TM6,AZJ,AZI,MEL,MER,
     $AEZS,BEZS,SR2,GP,AN,BN,AEZJS,BEZJS,SSXLAM,
     $TGG,TNN,TGN,TZN,AMWI,XS,YS,XC,YC,SINGL,SINGR,
     $COSGL,COSGR,XM,YM,THX,THY,XI,DEL,AMWISS(2),KK,
     $AMZIZ1,AMZIZ2,SIGLL,SIGRR,SIGLZ,SIGRZ,SSGT,SSGST,
     $FAC1,EZ0,BETA,EEL,EER,
     $FLEP,FLEM,FREP,FREM,SIGLR,SIGRL,PHIZLR,PHIZRL,
     $TM1LR,TM1RL,TZZRL,TZZLR,TGZLR,TGZRL,SIGZZL,SIGZZR,
     $FACLR,FACRL,RSH,JAC,ESTRUC,SH,SSFEL
      COMPLEX AEZ(4),BEZ(4),ZI,ZONE,WIJ
      INTEGER IS2UD(25),IUD(13),JS2JT(25),IQ1,IQ2,IFL1,IFL2,
     $IFLQ,IFM,I,IDQSS(25),MATCHL(18),IL2JS(18),IS2LN(18),
     $I1,I2,IL1,IL2,IDL1,IDL2,IZ,IZ1,IP,ITHZ(4),IDLSS(18),
     $IW2JS(4),IW1,JW1,JTW1,JTW2,IZ2JS(4),
     $IZ2,JTYPZ1,JTYPZ2
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2,
     $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MSW1=-ISW1)
      PARAMETER (MSW2=-ISW2)
      PARAMETER (MSNEL=-ISNEL)
      PARAMETER (MSEL=-ISEL)
      PARAMETER (MSNML=-ISNML)
      PARAMETER (MSMUL=-ISMUL)
      PARAMETER (MSNTL=-ISNTL)
      PARAMETER (MSTAU1=-ISTAU1)
      PARAMETER (MSER=-ISER)
      PARAMETER (MSMUR=-ISMUR)
      PARAMETER (MSTAU2=-ISTAU2)
      DATA IDQSS/0,
     $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1,
     $ISTP1,MSTP1,
     $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2,
     $ISTP2,MSTP2/
      DATA IDLSS/ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,
     $ISNTL,MSNTL,ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,
     $ISTAU2,MSTAU2/
      DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/
      DATA IUD/0,1,-1,2,-2,2,-2,1,-1,2,-2,1,-1/
      DATA JS2JT/1,
     $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/
      DATA MATCHL/2,1,4,3,6,5,8,7,10,9,12,11,14,13,16,15,18,17/
      DATA IL2JS/34,35,36,37,38,39,40,41,42,43,44,45,46,47,
     $48,49,50,51/
      DATA IS2LN/1,1,2,2,1,1,2,2,1,1,2,2,2,2,2,2,2,2/
      DATA IW2JS/26,27,28,29/
      DATA IZ2JS/30,31,32,33/
      DATA ZONE,ZI/(1.,0.),(0.,1.)/
C
C          FUNCTIONS
      IF (IBREM) THEN
        SH=SHAT
        JAC=2*(1.-SHAT/SCM)*2*SQRT(SHAT)*(RSHMAX-RSHMIN)/SCM/(X1+X2)
      ELSE
        SH=SCM
      END IF
      PROPZ=(SH-AMZ**2)**2+AMZ**2*GAMZ**2
C
C          CONSTANTS
      RSH=SQRT(SH)
      EB=RSH/2.
      QSQBM=QSQ
      E=SQRT(4*PI*ALFAEM)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      BETA=ATAN(1./RV2V1)
      SR2=SQRT(2.)
      CS2THW=1.-SN2THW
      TNTHW=SQRT(SN2THW/CS2THW)
      CTTHW=1./TNTHW
      ALQ(1)=CTTHW/4.-5*TNTHW/12.
      BEQ(1)=-(CTTHW+TNTHW)/4.
      ALQ(2)=TNTHW/12.-CTTHW/4.
      BEQ(2)=-BEQ(1)
      ALL(1)=(CTTHW+TNTHW)/4.
      BEL(1)=-(CTTHW+TNTHW)/4.
      ALL(2)=(3*TNTHW-CTTHW)/4.
      BEL(2)=-BEL(1)
      AE=ALL(2)
      BE=BEL(2)
      AN=ALL(1)
      BN=BEL(1)
      FLEP=(1.+PLEP)/2.
      FLEM=(1.+PLEM)/2.
      FREP=(1.-PLEP)/2.
      FREM=(1.-PLEM)/2.
      MEL=AMASS(ISEL)
      MER=AMASS(ISER)
      MSNE=AMASS(ISNEL)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      AMWISS(1)=ABS(AMW1SS)
      AMWISS(2)=ABS(AMW2SS)
      DO 5 IZ=1,4
        ITHZ(IZ)=0
        IF (AMZISS(IZ).LT.0.) ITHZ(IZ)=1
        AEZ(IZ)=-1*ZI**(ITHZ(IZ)-1)*(-1)**(ITHZ(IZ)+1)*
     $      (G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
        BEZ(IZ)=-1*ZI**(ITHZ(IZ)-1)*SR2*GP*ZMIXSS(4,IZ)
5     CONTINUE
C
C          ENTRY
      SIG=0.
      SIGMA=0.
      NSIGS=0
      DO 10 I=1,MXSIGS
        SIGS(I)=0.
10    CONTINUE
C
C          First do squark pairs: IQ1 labels JETTYPE1.
C
      DO 100 IQ1=2,25
        IQ2=MATCH(IQ1,4)
        IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 100
        IFL1=IDQSS(IQ1)
        IFL2=IDQSS(IQ2)
        AM1=AMASS(IFL1)
        AM2=AMASS(IFL2)
        IF((AM1+AM2).GE.RSH) GO TO 100
        IFLQ=IS2UD(IQ1)
        IF (IFLQ.EQ.1) THEN
          EQ=2./3.
        ELSE
          EQ=-1./3.
        END IF
C          Left squarks
        IF(IQ1.LE.9) THEN
          ALR=2*(ALQ(IFLQ)-BEQ(IFLQ))
C          Right squarks
        ELSEIF(IQ1.GE.14.AND.IQ1.LE.21) THEN
          ALR=2*(ALQ(IFLQ)+BEQ(IFLQ))
C          Mixed stops and sbottoms
        ELSEIF(IQ1.EQ.10.OR.IQ1.EQ.11) THEN
          ALR=2*(ALQ(IFLQ)-BEQ(IFLQ)*COS(2*THETAB))
        ELSEIF(IQ1.EQ.12.OR.IQ1.EQ.13) THEN
          ALR=2*(ALQ(IFLQ)-BEQ(IFLQ)*COS(2*THETAT))
        ELSEIF(IQ1.EQ.22.OR.IQ1.EQ.23) THEN
          ALR=2*(ALQ(IFLQ)+BEQ(IFLQ)*COS(2*THETAB))
        ELSEIF(IQ1.EQ.24.OR.IQ1.EQ.25) THEN
          ALR=2*(ALQ(IFLQ)+BEQ(IFLQ)*COS(2*THETAT))
        END IF
        PCM=.5*SQRT(SH-4.*AM1**2)
        IFM=ISIGN(1,IUD(JS2JT(IQ1)))
        IF (IFM.GT.0) THEN
          Z=CTH(1)
        ELSE
          Z=-CTH(1)
        END IF
C          Calculate d(sigma)/d(cos theta) in mb
        PHIZLR=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2*
     $   SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        PHIZRL=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2*
     $   SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        SIGLR=3*PCM**3/512./PI/EB**3*PHIZLR
        SIGRL=3*PCM**3/512./PI/EB**3*PHIZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,IQ1,IQ2)
100   CONTINUE
C        Mixed sbottom_1 and sbottom_2 production
      IF ((AMB1SS+AMB2SS).LT.RSH) THEN
        Z=CTH(1)
        PCM=SQRT(SSXLAM(SH,AMB1SS**2,AMB2SS**2))/2./RSH
        SIGLR=2*3*8*PI*ALFAEM**2*BEQ(2)**2*COS(THETAB)**2*
     $   SIN(THETAB)**2*(AE-BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ
        SIGRL=2*3*8*PI*ALFAEM**2*BEQ(2)**2*COS(THETAB)**2*
     $   SIN(THETAB)**2*(AE+BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(10,1).AND.GOQ(23,2)) THEN
          CALL SIGFIL(SIG,0,0,10,23)
        END IF
        IF(GOQ(23,1).AND.GOQ(10,2)) THEN
          CALL SIGFIL(SIG,0,0,23,10)
        END IF
        IF(GOQ(11,1).AND.GOQ(22,2)) THEN
          CALL SIGFIL(SIG,0,0,11,22)
        END IF
        IF(GOQ(22,1).AND.GOQ(11,2)) THEN
          CALL SIGFIL(SIG,0,0,22,11)
        END IF
      ENDIF
C        Mixed stop_1 and stop_2 production
      IF ((AMT1SS+AMT2SS).LT.RSH) THEN
        Z=CTH(1)
        PCM=SQRT(SSXLAM(SH,AMT1SS**2,AMT2SS**2))/2./RSH
        SIGLR=2*3*8*PI*ALFAEM**2*BEQ(1)**2*COS(THETAT)**2*
     $   SIN(THETAT)**2*(AE-BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ
        SIGRL=2*3*8*PI*ALFAEM**2*BEQ(1)**2*COS(THETAT)**2*
     $   SIN(THETAT)**2*(AE+BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(12,1).AND.GOQ(25,2)) THEN
          CALL SIGFIL(SIG,0,0,12,25)
        END IF
        IF(GOQ(25,1).AND.GOQ(12,2)) THEN
          CALL SIGFIL(SIG,0,0,25,12)
        END IF
        IF(GOQ(13,1).AND.GOQ(24,2)) THEN
          CALL SIGFIL(SIG,0,0,13,24)
        END IF
        IF(GOQ(24,1).AND.GOQ(13,2)) THEN
          CALL SIGFIL(SIG,0,0,24,13)
        END IF
      ENDIF
C
C          2nd and 3rd generation sleptons: IL1 labels JETTYPE1.
C
      DO 200 I=5,16
        I1=I
        IF (I1.GE.13) I1=I1+2
        I2=MATCHL(I1)
        IL1=IL2JS(I1)
        IL2=IL2JS(I2)
        IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 200
        IDL1=IDLSS(I1)
        IDL2=IDLSS(I2)
        AM1=AMASS(IDL1)
        AM2=AMASS(IDL2)
        IF((AM1+AM2).GE.RSH) GO TO 200
        IFL1=IS2LN(I1)
        IFL2=IS2LN(I2)
        IF (IFL1.EQ.1) THEN
          EQ=0.
        ELSE
          EQ=-1.
        END IF
        IF (I1.EQ.15.OR.I1.EQ.16)  THEN
          ALR=2*(ALL(IFL1)+BEL(IFL1))
        ELSE IF (I1.GE.5.AND.I1.LE.10) THEN
          ALR=2*(ALL(IFL1)-BEL(IFL1))
        ELSE IF (I1.EQ.11.OR.I1.EQ.12) THEN
          ALR=2*(ALL(IFL1)-BEL(IFL1)*COS(2*THETAL))
        ELSE IF (I1.EQ.17.OR.I1.EQ.18) THEN
          ALR=2*(ALL(IFL1)+BEL(IFL1)*COS(2*THETAL))
        END IF
        PCM=.5*SQRT(SH-4.*AM1**2)
        IFM=ISIGN(1,IDL1)
        IF (IFM.GT.0) THEN
          Z=CTH(1)
         ELSE
          Z=-CTH(1)
        END IF
C          Calculate d(sigma)/d(cos theta) in mb
        PHIZLR=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2*
     $   SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        PHIZRL=2*E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2*
     $   SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        SIGLR=PCM**3/512./PI/EB**3*PHIZLR
        SIGRL=PCM**3/512./PI/EB**3*PHIZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,IL1,IL2)
200   CONTINUE
C        Mixed stau_1 and stau_2 production
      IF ((AML1SS+AML2SS).LT.RSH) THEN
        Z=CTH(1)
        PCM=SQRT(SSXLAM(SH,AML1SS**2,AML2SS**2))/2./RSH
        SIGLR=2*8*PI*ALFAEM**2*BEL(2)**2*COS(THETAL)**2*
     $   SIN(THETAL)**2*(AE-BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ
        SIGRL=2*8*PI*ALFAEM**2*BEL(2)**2*COS(THETAL)**2*
     $   SIN(THETAL)**2*(AE+BE)**2*PCM**3*(1.-Z**2)/RSH/PROPZ
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(44,1).AND.GOQ(51,2)) THEN
          CALL SIGFIL(SIG,0,0,44,51)
        END IF
        IF(GOQ(51,1).AND.GOQ(44,2)) THEN
          CALL SIGFIL(SIG,0,0,51,44)
        END IF
        IF(GOQ(45,1).AND.GOQ(50,2)) THEN
          CALL SIGFIL(SIG,0,0,45,50)
        END IF
        IF(GOQ(50,1).AND.GOQ(45,2)) THEN
          CALL SIGFIL(SIG,0,0,50,45)
        END IF
      ENDIF
C
C         Next do 1st generation sleptons
C
C         Sneutrino_e pairs
      DO 210 I1=1,2
        I2=MATCHL(I1)
        IL1=IL2JS(I1)
        IL2=IL2JS(I2)
        IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 210
        MSNE=AMASS(ISNEL)
        IF((2*MSNE).GE.RSH) GO TO 210
        IF (I1.EQ.1) THEN
          Z=CTH(1)
        ELSE
          Z=-CTH(1)
        END IF
        PCM=.5*SQRT(SH-4*MSNE**2)
        TM1LR=32*E**4*(AN-BN)**2*(AE-BE)**2/PROPZ
        TM1RL=32*E**4*(AN-BN)**2*(AE+BE)**2/PROPZ
        TM2=8*G**4*SIN(GAMMAR)**4/(2*EB*(EB-PCM*Z)+AMW1SS**2-MSNE**2)**2
        TM3=8*G**4*COS(GAMMAR)**4/(2*EB*(EB-PCM*Z)+AMW2SS**2-MSNE**2)**2
        TM4=-32*E**2*(AN-BN)*G**2*SIN(GAMMAR)**2*(SH-AMZ**2)*(AE-BE)/
     $  PROPZ/(2*EB*(EB-PCM*Z)+AMW1SS**2-MSNE**2)
        TM5=-32*E**2*(AN-BN)*G**2*COS(GAMMAR)**2*(SH-AMZ**2)*(AE-BE)/
     $  PROPZ/(2*EB*(EB-PCM*Z)+AMW2SS**2-MSNE**2)
        TM6=16*G**4*SIN(GAMMAR)**2*COS(GAMMAR)**2/
     $  (2*EB*(EB-PCM*Z)+AMW1SS**2-MSNE**2)/
     $  (2*EB*(EB-PCM*Z)+AMW2SS**2-MSNE**2)
        SIGLR=2*PCM**3*EB*(1.-Z**2)/128./PI/SH*
     $   (TM1LR+TM2+TM3+TM4+TM5+TM6)
        SIGRL=2*PCM**3*EB*(1.-Z**2)/128./PI/SH*TM1RL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,IL1,IL2)
210   CONTINUE
C         E_L~ pairs
      DO 220 I1=3,4
        I2=MATCHL(I1)
        IL1=IL2JS(I1)
        IL2=IL2JS(I2)
        IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 220
        IF(2*MEL.GE.RSH) GO TO 220
        PCM=.5*SQRT(SH-4.*MEL**2)
        EQ=-1.
        ALR=2*(AE-BE)
        IF (I1.EQ.3) THEN
          Z=CTH(1)
        ELSE
          Z=-CTH(1)
        END IF
        PHIZLR=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2*
     $   SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        PHIZRL=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2*
     $   SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        DO 221 IZ1=1,4
          AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1))
          PHIZLR=PHIZLR+2*AEZS**2*SH*(1.-Z**2)/(2*EB*(EB-PCM*Z)-
     $    MEL**2+AMZISS(IZ1)**2)**2-4*E**2*(1.-Z**2)*AEZS/
     $    (2*EB*(EB-PCM*Z)-MEL**2+AMZISS(IZ1)**2)*(2.+(AE-BE)*ALR*
     $    SH*(SH-AMZ**2)/PROPZ)
          IF (IZ1.LE.3) THEN
            DO 222 IP=IZ1+1,4
              AEZJS=AEZ(IP)*CONJG(AEZ(IP))
              PHIZLR=PHIZLR+4*AEZS*AEZJS*SH*(1.-Z**2)/
     $        (2*EB*(EB-PCM*Z)-MEL**2+AMZISS(IZ1)**2)/
     $        (2*EB*(EB-PCM*Z)-MEL**2+AMZISS(IP)**2)
222         CONTINUE
          END IF
221     CONTINUE
        SIGLR=2*PCM**3/512./PI/EB**3*PHIZLR
        SIGRL=2*PCM**3/512./PI/EB**3*PHIZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,IL1,IL2)
220   CONTINUE
C         E_R~ pairs
      DO 230 I1=13,14
        I2=MATCHL(I1)
        IL1=IL2JS(I1)
        IL2=IL2JS(I2)
        IF(.NOT.(GOQ(IL1,1).AND.GOQ(IL2,2))) GO TO 230
        IF(2*MER.GE.RSH) GO TO 230
        PCM=.5*SQRT(SH-4.*MER**2)
        EQ=-1.
        ALR=2*(AE+BE)
        IF (I1.EQ.13) THEN
          Z=CTH(1)
        ELSE
          Z=-CTH(1)
        END IF
        PHIZLR=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE-BE)**2*
     $   SH-8*(AE-BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        PHIZRL=E**4*(1.-Z**2)*(8*EQ**2/SH+(2*ALR**2*(AE+BE)**2*
     $   SH-8*(AE+BE)*EQ*ALR*(SH-AMZ**2))/PROPZ)
        DO 231 IZ1=1,4
          BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1))
          PHIZRL=PHIZRL+2*BEZS**2*SH*(1.-Z**2)/(2*EB*(EB-PCM*Z)-
     $    MER**2+AMZISS(IZ1)**2)**2-4*E**2*(1.-Z**2)*BEZS/
     $    (2*EB*(EB-PCM*Z)-MER**2+AMZISS(IZ1)**2)*(2.+(AE+BE)*ALR*
     $    SH*(SH-AMZ**2)/PROPZ)
          IF (IZ1.LE.3) THEN
            DO 232 IP=IZ1+1,4
              BEZJS=BEZ(IP)*CONJG(BEZ(IP))
              PHIZRL=PHIZRL+4*BEZS*BEZJS*SH*(1.-Z**2)/
     $        (2*EB*(EB-PCM*Z)-MER**2+AMZISS(IZ1)**2)/
     $        (2*EB*(EB-PCM*Z)-MER**2+AMZISS(IP)**2)
232         CONTINUE
          END IF
231     CONTINUE
        SIGLR=2*PCM**3/512./PI/EB**3*PHIZLR
        SIGRL=2*PCM**3/512./PI/EB**3*PHIZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,IL1,IL2)
230   CONTINUE
C         E_L~+E_R~bar and E_R~+E_L~bar pairs; now has MEL =/ MER !
      IF((MEL+MER).GE.RSH) GO TO 270
      IF(GOQ(36,1).AND.GOQ(47,2)) THEN
        PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB
        EEL=SQRT(PCM**2+MEL**2)
        Z=CTH(1)
        PHIZ=0.
        DO 241 IZ1=1,4
          BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1))
          AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1))
          AZI=(AMZISS(IZ1)**2-MEL**2)/2./EB
          PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EEL-PCM*Z+AZI)**2
          IF (IZ1.LE.3) THEN
            DO 242 IP=IZ1+1,4
              AZJ=(AMZISS(IP)**2-MEL**2)/2./EB
              PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))*
     $        REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/
     $        (EEL-PCM*Z+AZI)/(EEL-PCM*Z+AZJ)
242         CONTINUE
          END IF
241     CONTINUE
        SIG=4*PCM/128./PI/SH/EB*PHIZ
        SIG=FLEM*FLEP*SIG*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,36,47)
      ENDIF
      IF(GOQ(46,1).AND.GOQ(37,2)) THEN
        PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB
        EER=SQRT(PCM**2+MER**2)
        Z=CTH(1)
        PHIZ=0.
        DO 243 IZ1=1,4
          BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1))
          AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1))
          AZI=(AMZISS(IZ1)**2-MER**2)/2./EB
          PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EER-PCM*Z+AZI)**2
          IF (IZ1.LE.3) THEN
            DO 244 IP=IZ1+1,4
              AZJ=(AMZISS(IP)**2-MER**2)/2./EB
              PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))*
     $        REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/
     $        (EER-PCM*Z+AZI)/(EER-PCM*Z+AZJ)
244         CONTINUE
          END IF
243     CONTINUE
        SIG=4*PCM/128./PI/SH/EB*PHIZ
        SIG=FREM*FREP*SIG*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,46,37)
      ENDIF
C         E_R~bar+E_L~ and E_L~bar+E_R~ pairs; now assumes MEL =/ MER !
      IF(GOQ(47,1).AND.GOQ(36,2)) THEN
        PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB
        EEL=SQRT(PCM**2+MEL**2)
        Z=-CTH(1)
        PHIZ=0.
        DO 251 IZ1=1,4
          BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1))
          AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1))
          AZI=(AMZISS(IZ1)**2-MEL**2)/2./EB
          PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EEL-PCM*Z+AZI)**2
          IF (IZ1.LE.3) THEN
            DO 252 IP=IZ1+1,4
              AZJ=(AMZISS(IP)**2-MEL**2)/2./EB
              PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))*
     $        REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/
     $        (EEL-PCM*Z+AZI)/(EEL-PCM*Z+AZJ)
252         CONTINUE
          END IF
251     CONTINUE
        SIG=4*PCM/128./PI/SH/EB*PHIZ
        SIG=FLEM*FLEP*SIG*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,47,36)
      ENDIF
      IF(GOQ(37,1).AND.GOQ(46,2)) THEN
        PCM=SQRT(SSXLAM(SH,MEL**2,MER**2))/4./EB
        EER=SQRT(PCM**2+MER**2)
        Z=-CTH(1)
        PHIZ=0.
        DO 253 IZ1=1,4
          BEZS=BEZ(IZ1)*CONJG(BEZ(IZ1))
          AEZS=AEZ(IZ1)*CONJG(AEZ(IZ1))
          AZI=(AMZISS(IZ1)**2-MER**2)/2./EB
          PHIZ=PHIZ+AEZS*BEZS*AMZISS(IZ1)**2/(EER-PCM*Z+AZI)**2
          IF (IZ1.LE.3) THEN
            DO 254 IP=IZ1+1,4
              AZJ=(AMZISS(IP)**2-MER**2)/2./EB
              PHIZ=PHIZ+2*ABS(AMZISS(IZ1)*AMZISS(IP))*
     $        REAL(AEZ(IZ1)*CONJG(AEZ(IP))*CONJG(BEZ(IZ1))*BEZ(IP))/
     $        (EER-PCM*Z+AZI)/(EER-PCM*Z+AZJ)
254         CONTINUE
          END IF
253     CONTINUE
        SIG=4*PCM/128./PI/SH/EB*PHIZ
        SIG=FREM*FREP*SIG*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,37,46)
      ENDIF
270   CONTINUE
C
C          Chargino pair production
C
      DO 300 IW1=1,4
        JW1=(IW1+1)/2
        AMWI=ABS(AMWISS(JW1))
        JTW1=IW2JS(IW1)
        JTW2=IW2JS(MATCHL(IW1))
        IF (.NOT.(GOQ(JTW1,1).AND.GOQ(JTW2,2))) GO TO 300
        IF((2*AMWI).GE.RSH) GO TO 300
        PCM=SQRT(SSXLAM(SH,AMWI**2,AMWI**2))/4./EB
        Z=CTH(1)
        IF (IW1.EQ.1.OR.IW1.EQ.3) Z=-CTH(1)
        SINGR=SIN(GAMMAR)
        COSGR=COS(GAMMAR)
        SINGL=SIN(GAMMAL)
        COSGL=COS(GAMMAL)
        XC=1.-(COSGL**2+COSGR**2)/4./CS2THW
        YC=(COSGR**2-COSGL**2)/4./CS2THW
        XS=1.-(SINGL**2+SINGR**2)/4./CS2THW
        YS=(SINGR**2-SINGL**2)/4./CS2THW
        IF (IW1.GE.3) THEN
          XC=XS
          YC=YS
          SINGR=COSGR
        END IF
        TGG=16*E**4/SH*(EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))
        TZZLR=16*E**4*CTTHW**2*SH/PROPZ*((XC**2+YC**2)*(AE-BE)**2*
     $  (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))-
     $  2*YC**2*(AE-BE)**2*AMWI**2+4*XC*YC*(AE-BE)**2*EB*PCM*Z)
        TZZRL=16*E**4*CTTHW**2*SH/PROPZ*((XC**2+YC**2)*(AE+BE)**2*
     $  (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))-
     $  2*YC**2*(AE+BE)**2*AMWI**2-4*XC*YC*(AE+BE)**2*EB*PCM*Z)
        TGZLR=-32*E**4*CTTHW*(SH-AMZ**2)/PROPZ*((AE-BE)*XC*
     $  (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))-2*(BE-AE)*YC*EB*PCM*Z)
        TGZRL=-32*E**4*CTTHW*(SH-AMZ**2)/PROPZ*((AE+BE)*XC*
     $  (EB**2*(1.+Z**2)+AMWI**2*(1.-Z**2))-2*(BE+AE)*YC*EB*PCM*Z)
        TNN=2*E**4*SINGR**4*SH*(EB-PCM*Z)**2/SN2THW**2/
     $  (EB**2+PCM**2-2*EB*PCM*Z+MSNE**2)**2
        TGN=-8*E**4*SINGR**2*((EB-PCM*Z)**2+AMWI**2)/SN2THW/
     $  (EB**2+PCM**2-2*EB*PCM*Z+MSNE**2)
        TZN=8*E**4*CTTHW*SINGR**2*(SH-AMZ**2)*(AE-BE)*SH/
     $  SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2+AMWI**2)+2*YC*AMWI**2)/
     $  (EB**2+PCM**2-2*EB*PCM*Z+MSNE**2)
        SIGLR=2*PCM/128./PI/SH/EB*(TGG+TZZLR+TGZLR+TNN+TGN+TZN)
        SIGRL=2*PCM/128./PI/SH/EB*(TGG+TZZRL+TGZRL)
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,JTW1,JTW2)
300   CONTINUE
C
C     Chargino_1 + chargino_2 pair production
      IF((ABS(AMW1SS)+ABS(AMW2SS)).GE.RSH) GO TO 340
      PCM=SQRT(SSXLAM(SH,AMW1SS**2,AMW2SS**2))/4./EB
      XC=(THX*SIN(GAMMAL)*COS(GAMMAL)-THY*SIN(GAMMAR)*COS(GAMMAR))/2.
      YC=(THX*SIN(GAMMAL)*COS(GAMMAL)+THY*SIN(GAMMAR)*COS(GAMMAR))/2.
      DEL=(AMW2SS**2-AMW1SS**2)/4./EB
      XI=-1.*SIGN(1.,AMWISS(1))*SIGN(1.,AMWISS(2))
      IF (.NOT.(GOQ(27,1).AND.GOQ(28,2))) GO TO 310
        Z=CTH(1)
        TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+
     $  4*XC*YC*(AE-BE)**2*EB*PCM*Z)
        TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)-
     $  4*XC*YC*(AE+BE)**2*EB*PCM*Z)
        TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/
     $  SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2
        TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2)
     $  *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2-
     $  XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/
     $  (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)
        SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN)
        SIGRL=2*E**4*PCM/128./PI/EB*TZZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,27,28)
310   CONTINUE
      IF (.NOT.(GOQ(28,1).AND.GOQ(27,2))) GO TO 320
        Z=-CTH(1)
        TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+
     $  4*XC*YC*(AE-BE)**2*EB*PCM*Z)
        TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)-
     $  4*XC*YC*(AE+BE)**2*EB*PCM*Z)
        TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/
     $  SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2
        TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2)
     $  *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2-
     $  XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/
     $  (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)
        SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN)
        SIGRL=2*E**4*PCM/128./PI/EB*TZZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,28,27)
320   CONTINUE
      IF (.NOT.(GOQ(29,1).AND.GOQ(26,2))) GO TO 330
        Z=CTH(1)
        TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+
     $  4*XC*YC*(AE-BE)**2*EB*PCM*Z)
        TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)-
     $  4*XC*YC*(AE+BE)**2*EB*PCM*Z)
        TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/
     $  SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2
        TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2)
     $  *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2-
     $  XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/
     $  (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)
        SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN)
        SIGRL=2*E**4*PCM/128./PI/EB*TZZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,29,26)
330   CONTINUE
      IF (.NOT.(GOQ(26,1).AND.GOQ(29,2))) GO TO 340
        Z=-CTH(1)
        TZZLR=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE-BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE-BE)**2*ABS(AMW1SS*AMW2SS)+
     $  4*XC*YC*(AE-BE)**2*EB*PCM*Z)
        TZZRL=4*(CTTHW+TNTHW)**2/PROPZ*((XC**2+YC**2)*(AE+BE)**2*
     $  (EB**2+PCM**2*Z**2-DEL**2-XI*ABS(AMW1SS*AMW2SS))+
     $  2*XC**2*XI*(AE+BE)**2*ABS(AMW1SS*AMW2SS)-
     $  4*XC*YC*(AE+BE)**2*EB*PCM*Z)
        TNN=2*SIN(GAMMAR)**2*COS(GAMMAR)**2*((EB-PCM*Z)**2-DEL**2)/
     $  SN2THW**2/(2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)**2
        TZN=-4*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*(SH-AMZ**2)
     $  *(AE-BE)/SN2THW/PROPZ*((XC-YC)*((EB-PCM*Z)**2-DEL**2-
     $  XI*ABS(AMW1SS*AMW2SS))+2*XC*XI*ABS(AMW1SS*AMW2SS))/
     $  (2*EB*(EB-DEL)-2*EB*PCM*Z+MSNE**2-AMW1SS**2)
        SIGLR=2*E**4*PCM/128./PI/EB*(TZZLR+TNN+TZN)
        SIGRL=2*E**4*PCM/128./PI/EB*TZZRL
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        CALL SIGFIL(SIG,0,0,26,29)
340   CONTINUE
C
C         Neutralino pair production
C
      DO 400 IZ1=1,4
        AMZIZ1=ABS(AMZISS(IZ1))
        JTYPZ1=IZ2JS(IZ1)
        DO 410 IZ2=1,4
          AMZIZ2=ABS(AMZISS(IZ2))
          JTYPZ2=IZ2JS(IZ2)
          IF(.NOT.(GOQ(JTYPZ1,1).AND.GOQ(JTYPZ2,2))) GO TO 410
          IF((AMZIZ1+AMZIZ2).GE.RSH) GO TO 410
          WIJ=SQRT(G**2+GP**2)*ZI**(ITHZ(IZ2))*(-ZI)**(ITHZ(IZ1))*
     $    (ZMIXSS(1,IZ1)*ZMIXSS(1,IZ2)-ZMIXSS(2,IZ1)*
     $    ZMIXSS(2,IZ2))/4.
          KK=SQRT(SH*SH+(AMZIZ1**2-AMZIZ2**2)**2-2*SH*
     $    (AMZIZ1**2+AMZIZ2**2))/4./EB
          Z=CTH(1)
          SIGLL=2*AEZ(IZ1)*CONJG(AEZ(IZ1))*AEZ(IZ2)*CONJG(AEZ(IZ2))*
     $    SSGT(SH,MEL,Z,IZ1,IZ2)
          SIGRR=2*BEZ(IZ1)*CONJG(BEZ(IZ1))*BEZ(IZ2)*CONJG(BEZ(IZ2))*
     $    SSGT(SH,MER,Z,IZ1,IZ2)
          SIGZZL=4*E**2*WIJ*CONJG(WIJ)*(AE-BE)**2*
     $    (SH*SH-(AMZIZ1**2-AMZIZ2**2)**2+4*(-1.)**(ITHZ(IZ1)+
     $    ITHZ(IZ2)+1)*SH*AMZIZ1*AMZIZ2+4*SH*KK*KK*Z*Z)/PROPZ
          SIGZZR=4*E**2*WIJ*CONJG(WIJ)*(AE+BE)**2*
     $    (SH*SH-(AMZIZ1**2-AMZIZ2**2)**2+4*(-1.)**(ITHZ(IZ1)+
     $    ITHZ(IZ2)+1)*SH*AMZIZ1*AMZIZ2+4*SH*KK*KK*Z*Z)/PROPZ
          SIGLZ=-E*(AE-BE)*(SH-AMZ**2)/2./PROPZ*
     $    (REAL(WIJ*CONJG(AEZ(IZ1))*AEZ(IZ2))*
     $    SSGST(SH,MEL,Z,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))*
     $    REAL(WIJ*AEZ(IZ1)*CONJG(AEZ(IZ2)))*
     $    SSGST(SH,MEL,-Z,IZ1,IZ2))
          SIGRZ=-E*(-1.)**(ITHZ(IZ1)+ITHZ(IZ2)+1)*
     $    (AE+BE)*(SH-AMZ**2)/2./PROPZ*
     $    (REAL(WIJ*CONJG(BEZ(IZ1))*BEZ(IZ2))*
     $    SSGST(SH,MER,Z,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))*
     $    REAL(WIJ*BEZ(IZ1)*CONJG(BEZ(IZ2)))*
     $    SSGST(SH,MER,-Z,IZ1,IZ2))
          SIGLR=2*KK/16./PI/SH/SQRT(SH)*(SIGLL+SIGZZL+SIGLZ)
          SIGRL=2*KK/16./PI/SH/SQRT(SH)*(SIGRR+SIGZZR+SIGRZ)
C         BELOW FACTOR OF 2 FOR ID PARTICLES AND JETTYP SWITCH
          SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
          IF (IBREM.AND..NOT.IBEAM) THEN
            SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
          ELSE IF (IBEAM) THEN
            SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
          END IF
          CALL SIGFIL(SIG,0,0,JTYPZ1,JTYPZ2)
410     CONTINUE
400   CONTINUE
C
C     Higgs boson mechanisms
C
C          E+ E- --> Z H_L; symmetric in cos(theta)
      IF((AMZ+AMHL).LT.RSH) THEN
        FACLR=E**2*G**2*(SIN(ALFAH+BETA))**2*(AE-BE)**2/CS2THW
        FACRL=E**2*G**2*(SIN(ALFAH+BETA))**2*(AE+BE)**2/CS2THW
        Z=CTH(1)
        PCM=SQRT(SSXLAM(SH,AMZ**2,AMHL**2))/4./EB
        EZ0=SQRT(PCM**2+AMZ**2)
        FAC1=AMZ**2+EZ0**2-PCM**2*Z**2
        SIGLR=2*FACLR/32./PI/PROPZ/SQRT(SH)*PCM*FAC1
        SIGRL=2*FACRL/32./PI/PROPZ/SQRT(SH)*PCM*FAC1
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(80,1).AND.GOQ(81,2)) CALL SIGFIL(SIG,0,0,80,81)
        IF(GOQ(81,1).AND.GOQ(80,2)) CALL SIGFIL(SIG,0,0,81,80)
      ENDIF
C          E+ E- --> Z H_H; symmetric in cos(theta)
      IF((AMZ+AMHH).LT.RSH) THEN
        FACLR=E**2*G**2*(COS(ALFAH+BETA))**2*(AE-BE)**2/CS2THW
        FACRL=E**2*G**2*(COS(ALFAH+BETA))**2*(AE+BE)**2/CS2THW
        Z=CTH(1)
        PCM=SQRT(SSXLAM(SH,AMZ**2,AMHH**2))/4./EB
        EZ0=SQRT(PCM**2+AMZ**2)
        FAC1=AMZ**2+EZ0**2-PCM**2*Z**2
        SIGLR=2*FACLR/32./PI/PROPZ/SQRT(SH)*PCM*FAC1
        SIGRL=2*FACRL/32./PI/PROPZ/SQRT(SH)*PCM*FAC1
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(80,1).AND.GOQ(82,2)) CALL SIGFIL(SIG,0,0,80,82)
        IF(GOQ(82,1).AND.GOQ(80,2)) CALL SIGFIL(SIG,0,0,82,80)
      ENDIF
C          E+ E- --> H_P H_L; symmetric in cos(theta)
      IF((AMHA+AMHL).LT.RSH) THEN
        PCM=SQRT(SSXLAM(SH,AMHA**2,AMHL**2))/4./EB
        Z=CTH(1)
        FAC1=PCM**3*(1.-Z**2)
        FACLR=E**4*(COS(ALFAH+BETA))**2*(AE-BE)**2*FAC1
        FACRL=E**4*(COS(ALFAH+BETA))**2*(AE+BE)**2*FAC1
        SIGLR=2*FACLR/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ
        SIGRL=2*FACRL/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(81,1).AND.GOQ(83,2)) CALL SIGFIL(SIG,0,0,81,83)
        IF(GOQ(83,1).AND.GOQ(81,2)) CALL SIGFIL(SIG,0,0,83,81)
      ENDIF
C          E+ E- --> H_P H_H; SYMMETRIC IN COS(THETA)
      IF((AMHA+AMHH).LT.RSH) THEN
        PCM=SQRT(SSXLAM(SH,AMHA**2,AMHH**2))/4./EB
        Z=CTH(1)
        FAC1=PCM**3*(1.-Z**2)
        FACLR=E**4*(SIN(ALFAH+BETA))**2*(AE-BE)**2*FAC1
        FACRL=E**4*(SIN(ALFAH+BETA))**2*(AE+BE)**2*FAC1
        SIGLR=2*FACLR/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ
        SIGRL=2*FACRL/32./PI/SQRT(SH)/SN2THW/CS2THW/PROPZ
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(82,1).AND.GOQ(83,2)) CALL SIGFIL(SIG,0,0,82,83)
        IF(GOQ(83,1).AND.GOQ(82,2)) CALL SIGFIL(SIG,0,0,83,82)
      ENDIF
C          E+ E- --> H^+ H^-; symmetric in cos(theta)
      IF((2*AMHC).LT.RSH) THEN
        PCM=SQRT(SSXLAM(SH,AMHC**2,AMHC**2))/4./EB
        Z=CTH(1)
        FAC1=PCM**3*(1.-Z**2)
        FACLR=FAC1*(1./SH**2+(2*SN2THW-1.)**2/SN2THW/CS2THW*
     $(AE-BE)**2/4./PROPZ+(2*SN2THW-1.)*(AE-BE)*(SH-AMZ**2)/SH/
     $SQRT(SN2THW*CS2THW)/PROPZ)
        FACRL=FAC1*(1./SH**2+(2*SN2THW-1.)**2/SN2THW/CS2THW*
     $(AE+BE)**2/4./PROPZ+(2*SN2THW-1.)*(AE+BE)*(SH-AMZ**2)/SH/
     $SQRT(SN2THW*CS2THW)/PROPZ)
        SIGLR=2*E**4*FACLR/8./PI/SQRT(SH)
        SIGRL=2*E**4*FACRL/8./PI/SQRT(SH)
        SIG=(FLEM*FREP*SIGLR+FREM*FLEP*SIGRL)*UNITS/2.
        IF (IBREM.AND..NOT.IBEAM) THEN
          SIG=SIG*ESTRUC(X1,QSQ)*ESTRUC(X2,QSQ)*JAC
        ELSE IF (IBEAM) THEN
          SIG=SIG*SSFEL(X1,0)*SSFEL(X2,0)*JAC
        END IF
        IF(GOQ(84,1).AND.GOQ(85,2)) CALL SIGFIL(SIG,0,0,84,85)
        IF(GOQ(85,1).AND.GOQ(84,2)) CALL SIGFIL(SIG,0,0,85,84)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,SIGSSL.
      SUBROUTINE SIGSSL
C
C          Calculate d(sigma)/d(pt**2)d(y1)d(y2) for supersymmetric
C          sleptons and sneutrinos in MSSM using cross
C          sections from Baer and Tata.
C
C          SIGMA    = cross section summed over types allowed by
C                     JETTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1
C          JETTYP -> IDENT mapping:
C          GLSS, UPSSL, UBSSL, ..., UPSSR, UBSSR, ...,
C          W1SS+, W1SS-, WS22+, W2SS-, Z1SS, Z2SS, Z3SS, Z4SS
C          NUEL, ANUEL, EL-, ..., TAUL+
C
C          Extra factor of 1/2 needed for nonidentical final jets.
C          Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2
C
C          Called from SIGSSY and so does not reinitialize /JETSIG/.
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,CONST
+CDE,JETPAR
+CDE,JETSIG
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,QCDPAR
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTYPE
+CDE,WCON
C
      REAL X(2)
      EQUIVALENCE (X(1),X1)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      INTEGER JS2JT(25),IW2JS(4),IW2IM(4),IZ2JS(4),IS2UD(25)
      SAVE JS2JT,IW2JS,IW2IM,IZ2JS,IS2UD
      INTEGER IDLSS(18)
      SAVE IDLSS
      INTEGER IL2JS(18),IS2LN(18),II
      SAVE IL2JS,IS2LN
      REAL SIG,S,T,U,FAC,AM22,AM12,TT,GP,G,
     $E1,E2
      INTEGER IQ,IQ1,IQ2,IH
      REAL QFCN,STRUC,PSIFCN,AMASS
      REAL SR2,AML,AMN,SIGW,PROPZ
      REAL CS2THW,TNTHW,CTTHW,AL(2),BE(2),ESQ,XWI(2),YWI(2)
      REAL ALL(2),BEL(2),EL1
      REAL EQ1,XMGG,XMZZ,XMGZ,XM,CTH2L
      REAL SIGUT,SIGTU,EHAT,PHAT,EBM,TPP,AMWI,AMQ,PROPW
      REAL A,B,ASPBS,ASMBS,TM1,TM2,TM3,COTB,TANB
      INTEGER JTYP1,JTYP2,IFLQ,IUD(13)
      INTEGER IFLL,IL,IN,IDL,IDN,IL1,IL2,JTYPL1,JTYPL2,IDL1,IDL2
C
C          IDENT codes from /SSTYPE/. (Fortran 77 allows - signs in
C          parameter statements but not data statements.)
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2,
     $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MSW1=-ISW1)
      PARAMETER (MSW2=-ISW2)
      PARAMETER (MSNEL=-ISNEL)
      PARAMETER (MSEL=-ISEL)
      PARAMETER (MSNML=-ISNML)
      PARAMETER (MSMUL=-ISMUL)
      PARAMETER (MSNTL=-ISNTL)
      PARAMETER (MSTAU1=-ISTAU1)
      PARAMETER (MSER=-ISER)
      PARAMETER (MSMUR=-ISMUR)
      PARAMETER (MSTAU2=-ISTAU2)
      DATA IDLSS/ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,
     $ISNTL,MSNTL,ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,
     $ISTAU2,MSTAU2/
      DATA IUD/0,1,-1,2,-2,2,-2,1,-1,2,-2,1,-1/
C
C          JS2JT: Susy jettype -> normal jettype
      DATA JS2JT/1,
     $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/
C          IW2JS: Wino index -> susy jettype
      DATA IW2JS/26,27,28,29/
C          IW2IM: Wino index -> match code
      DATA IW2IM/2,3,2,3/
C          IZ2JS: Zino index -> susy jettype
      DATA IZ2JS/30,31,32,33/
C          IS2UD: Susy jettype -> u/d code
      DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/
      DATA IS2LN/1,1,2,2,1,1,2,2,1,1,2,2,2,2,2,2,2,2/
      DATA IL2JS/34,35,36,37,38,39,40,41,42,43,44,45,46,47,
     $48,49,50,51/
C
C          Functions
      QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      PSIFCN(AM12,AM22,TT)=((S+TT-AM12)/(2*S)
     $-AM12*(AM22-TT)/(AM12-TT)**2
     $+(TT*(AM22-AM12)+AM22*(S-AM22+AM12))/(S*(AM12-TT)))
C
C          Constants from Baer and Tata,
C
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
C          Quark couplings to Z
      CS2THW=1.-SN2THW
      TNTHW=SQRT(SN2THW/CS2THW)
      CTTHW=1./TNTHW
      AL(1)=(CTTHW/4.-5*TNTHW/12.)
      AL(2)=(TNTHW/12.-CTTHW/4.)
      BE(1)=-(CTTHW+TNTHW)/4.
      BE(2)=-BE(1)
      ALL(1)=(CTTHW+TNTHW)/4.
      ALL(2)=(-CTTHW+3*TNTHW)/4.
      BEL(1)=-(CTTHW+TNTHW)/4.
      BEL(2)=-BEL(1)
      ESQ=4*PI*ALFAEM
      SR2=SQRT(2.)
      COTB=RV2V1
      TANB=1./COTB
C
C         qk qb --> slss slbss
C
C
C     Left-leftbar slepton pair production
C
      DO 200 IL=1,6
        IL1=2*IL-1
        IL2=IL1+1
        AML=AMASS(IDLSS(IL1))
        JTYPL1=IL2JS(IL1)
        JTYPL2=IL2JS(IL2)
        IDL1=IDLSS(IL1)
        IDL2=IDLSS(IL2)
          IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 210
          CALL TWOKIN(0.,0.,AML,AML)
          IF (X1.GE.1..OR.X2.GE.1.) GO TO 210
          E1=SQRT(P(1)**2+AML**2)
          E2=SQRT(P(2)**2+AML**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          DO 220 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IFLL=IS2LN(IL1)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IF (IFLL.EQ.1) THEN
              EL1=0.
            ELSE
              EL1=-1.
            END IF
            IQ2=MATCH(IQ1,4)
            PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 220
              XMGG=EL1**2*EQ1**2/S/S
              CTH2L=1.
              IF (JTYPL1.EQ.44) CTH2L=COS(2*THETAL)
              XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)-BEL(IFLL)*
     $              CTH2L)**2/PROPZ
              XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)-BEL(IFLL)*CTH2L)*
     $             (S-AMZ**2)/S/PROPZ
              XM=2*ESQ*ESQ*(U*T-AML**4)/3.
              SIG=XM*(XMGG+XMZZ+XMGZ)
              SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
              SIG=.5*SIG
              CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2)
220       CONTINUE
210     CONTINUE
200   CONTINUE
C          stau_1 + stau_2 bar
      IF (GOQ(44,1).AND.GOQ(51,2)) THEN
          CALL TWOKIN(0.,0.,AML1SS,AML2SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 231
          E1=SQRT(P(1)**2+AML1SS**2)
          E2=SQRT(P(2)**2+AML2SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 230 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 230
            SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2*
     $     SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,44,51)
230         CONTINUE
231       CONTINUE
      END IF
C
C
C     Right-rightbar slepton pair production
C
      DO 300 IL=1,3
        IL1=11+2*IL
        IL2=IL1+1
        AML=AMASS(IDLSS(IL1))
        JTYPL1=IL2JS(IL1)
        JTYPL2=IL2JS(IL2)
        IDL1=IDLSS(IL1)
        IDL2=IDLSS(IL2)
          IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 310
          CALL TWOKIN(0.,0.,AML,AML)
          IF (X1.GE.1..OR.X2.GE.1.) GO TO 310
          E1=SQRT(P(1)**2+AML**2)
          E2=SQRT(P(2)**2+AML**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          DO 320 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IFLL=IS2LN(IL1)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IF (IFLL.EQ.1) THEN
              EL1=0.
            ELSE
              EL1=-1.
            END IF
            IQ2=MATCH(IQ1,4)
            PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 320
              XMGG=EL1**2*EQ1**2/S/S
              CTH2L=1.
              IF (JTYPL1.EQ.50) CTH2L=COS(2*THETAL)
              XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)+BEL(IFLL)*
     $              CTH2L)**2/PROPZ
              XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)+BEL(IFLL)*CTH2L)*
     $             (S-AMZ**2)/S/PROPZ
              XM=2*ESQ*ESQ*(U*T-AML**4)/3.
              SIG=XM*(XMGG+XMZZ+XMGZ)
              SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
              SIG=.5*SIG
              CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2)
320       CONTINUE
310     CONTINUE
300   CONTINUE
C          stau_2 bar + stau_1
      IF (GOQ(51,1).AND.GOQ(44,2)) THEN
          CALL TWOKIN(0.,0.,AML2SS,AML1SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 331
          E1=SQRT(P(1)**2+AML2SS**2)
          E2=SQRT(P(2)**2+AML1SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 330 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 330
            SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2*
     $     SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,51,44)
330         CONTINUE
331       CONTINUE
      END IF
C
C
C     Leftbar-left slepton pair production
C
      DO 400 IL=1,6
        IL1=2*IL
        IL2=IL1-1
        AML=AMASS(IDLSS(IL1))
        JTYPL1=IL2JS(IL1)
        JTYPL2=IL2JS(IL2)
        IDL1=IDLSS(IL1)
        IDL2=IDLSS(IL2)
          IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 410
          CALL TWOKIN(0.,0.,AML,AML)
          IF (X1.GE.1..OR.X2.GE.1.) GO TO 410
          E1=SQRT(P(1)**2+AML**2)
          E2=SQRT(P(2)**2+AML**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          DO 420 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IFLL=IS2LN(IL1)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IF (IFLL.EQ.1) THEN
              EL1=0.
            ELSE
              EL1=-1.
            END IF
            IQ2=MATCH(IQ1,4)
            PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 420
              XMGG=EL1**2*EQ1**2/S/S
              CTH2L=1.
              IF (JTYPL1.EQ.45) CTH2L=COS(2*THETAL)
              XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)-BEL(IFLL)*
     $              CTH2L)**2/PROPZ
              XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)-BEL(IFLL)*CTH2L)*
     $             (S-AMZ**2)/S/PROPZ
              XM=2*ESQ*ESQ*(U*T-AML**4)/3.
              SIG=XM*(XMGG+XMZZ+XMGZ)
              SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
              SIG=.5*SIG
              CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2)
420       CONTINUE
410     CONTINUE
400   CONTINUE
C          stau_1 bar + stau_2
      IF (GOQ(45,1).AND.GOQ(50,2)) THEN
          CALL TWOKIN(0.,0.,AML1SS,AML2SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 431
          E1=SQRT(P(1)**2+AML1SS**2)
          E2=SQRT(P(2)**2+AML2SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 430 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 430
            SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2*
     $     SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,45,50)
430         CONTINUE
431       CONTINUE
      END IF
C
C
C     Rightbar-right slepton pair production
C
      DO 500 IL=1,3
        IL1=12+2*IL
        IL2=IL1-1
        AML=AMASS(IDLSS(IL1))
        JTYPL1=IL2JS(IL1)
        JTYPL2=IL2JS(IL2)
        IDL1=IDLSS(IL1)
        IDL2=IDLSS(IL2)
          IF (.NOT.(GOQ(JTYPL1,1).AND.GOQ(JTYPL2,2))) GO TO 510
          CALL TWOKIN(0.,0.,AML,AML)
          IF (X1.GE.1..OR.X2.GE.1.) GO TO 510
          E1=SQRT(P(1)**2+AML**2)
          E2=SQRT(P(2)**2+AML**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          DO 520 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IFLL=IS2LN(IL1)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IF (IFLL.EQ.1) THEN
              EL1=0.
            ELSE
              EL1=-1.
            END IF
            IQ2=MATCH(IQ1,4)
            PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 520
              XMGG=EL1**2*EQ1**2/S/S
              CTH2L=1.
              IF (JTYPL1.EQ.51) CTH2L=COS(2*THETAL)
              XMZZ=(AL(IFLQ)**2+BE(IFLQ)**2)*(ALL(IFLL)+BEL(IFLL)*
     $              CTH2L)**2/PROPZ
              XMGZ=2*EL1*EQ1*AL(IFLQ)*(ALL(IFLL)+BEL(IFLL)*CTH2L)*
     $             (S-AMZ**2)/S/PROPZ
              XM=2*ESQ*ESQ*(U*T-AML**4)/3.
              SIG=XM*(XMGG+XMZZ+XMGZ)
              SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
              SIG=.5*SIG
              CALL SIGFIL(SIG,IQ1,IQ2,JTYPL1,JTYPL2)
520       CONTINUE
510     CONTINUE
500   CONTINUE
C          stau_2 + stau_1 bar
      IF (GOQ(50,1).AND.GOQ(45,2)) THEN
          CALL TWOKIN(0.,0.,AML2SS,AML1SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 531
          E1=SQRT(P(1)**2+AML2SS**2)
          E2=SQRT(P(2)**2+AML1SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 530 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 530
            SIG=2*ESQ**2*(AL(IFLQ)**2+BE(IFLQ)**2)*BEL(2)**2*
     $     SIN(2*THETAL)**2*(U*T-AML1SS**2*AML2SS**2)/3./PROPZ
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,50,45)
530         CONTINUE
531       CONTINUE
      END IF
C
C          slepton+sneutrino-bar via W-*
C
      DO 600 II=1,3
        IL=4*II-1
        IN=IL-1
        IDL=IDLSS(IL)
        IDN=IDLSS(IN)
        AML=AMASS(IDL)
        AMN=AMASS(IDN)
        JTYP1=IL2JS(IL)
        JTYP2=IL2JS(IN)
          IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 610
          CALL TWOKIN(0.,0.,AML,AMN)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 610
          E1=SQRT(P(1)**2+AML**2)
          E2=SQRT(P(2)**2+AMN**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW
          IF (JTYP1.EQ.44) SIGW=SIGW*COS(THETAL)**2
            SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2)
            CALL SIGFIL(SIG,3,4,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2)
            CALL SIGFIL(SIG,4,3,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2)
            CALL SIGFIL(SIG,9,6,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2)
            CALL SIGFIL(SIG,6,9,JTYP1,JTYP2)
610     CONTINUE
600   CONTINUE
C          stau_2 +nu_tau bar
      IF (GOQ(50,1).AND.GOQ(43,2)) THEN
          CALL TWOKIN(0.,0.,AML2SS,AMN3SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 620
          E1=SQRT(P(1)**2+AML2SS**2)
          E2=SQRT(P(2)**2+AMN3SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW
          SIGW=SIGW*SIN(THETAL)**2
          SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2)
          CALL SIGFIL(SIG,3,4,50,43)
          SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2)
          CALL SIGFIL(SIG,4,3,50,43)
          SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2)
          CALL SIGFIL(SIG,9,6,50,43)
          SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2)
          CALL SIGFIL(SIG,6,9,50,43)
620       CONTINUE
      END IF
C
C          sneutrino-bar+slepton via W-*
C
      DO 700 II=1,3
        IN=4*II-2
        IL=IN+1
        IDL=IDLSS(IL)
        IDN=IDLSS(IN)
        AML=AMASS(IDL)
        AMN=AMASS(IDN)
        JTYP1=IL2JS(IN)
        JTYP2=IL2JS(IL)
          IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 710
          CALL TWOKIN(0.,0.,AMN,AML)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 710
          E1=SQRT(P(1)**2+AMN**2)
          E2=SQRT(P(2)**2+AML**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW
          IF (JTYP2.EQ.44) SIGW=SIGW*COS(THETAL)**2
            SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2)
            CALL SIGFIL(SIG,3,4,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2)
            CALL SIGFIL(SIG,4,3,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2)
            CALL SIGFIL(SIG,9,6,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2)
            CALL SIGFIL(SIG,6,9,JTYP1,JTYP2)
710     CONTINUE
700   CONTINUE
C          nu_tau bar + STAU_2
      IF (GOQ(43,1).AND.GOQ(50,2)) THEN
          CALL TWOKIN(0.,0.,AMN3SS,AML2SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 720
          E1=SQRT(P(1)**2+AMN3SS**2)
          E2=SQRT(P(2)**2+AML2SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW
          SIGW=SIGW*SIN(THETAL)**2
          SIG=.5*SIGW*FAC*QFCN(3,1)*QFCN(4,2)
          CALL SIGFIL(SIG,3,4,43,50)
          SIG=.5*SIGW*FAC*QFCN(4,1)*QFCN(3,2)
          CALL SIGFIL(SIG,4,3,43,50)
          SIG=.5*SIGW*FAC*QFCN(9,1)*QFCN(6,2)
          CALL SIGFIL(SIG,9,6,43,50)
          SIG=.5*SIGW*FAC*QFCN(6,1)*QFCN(9,2)
          CALL SIGFIL(SIG,6,9,43,50)
720       CONTINUE
      END IF
C
C          slepton-bar+sneutrino via W+*
C
      DO 800 II=1,3
        IL=4*II
        IN=IL-3
        IDL=IDLSS(IL)
        IDN=IDLSS(IN)
        AML=AMASS(IDL)
        AMN=AMASS(IDN)
        JTYP1=IL2JS(IL)
        JTYP2=IL2JS(IN)
          IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 810
          CALL TWOKIN(0.,0.,AML,AMN)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 810
          E1=SQRT(P(1)**2+AML**2)
          E2=SQRT(P(2)**2+AMN**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW
          IF (JTYP1.EQ.45) SIGW=SIGW*COS(THETAL)**2
            SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2)
            CALL SIGFIL(SIG,2,5,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2)
            CALL SIGFIL(SIG,5,2,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2)
            CALL SIGFIL(SIG,8,7,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2)
            CALL SIGFIL(SIG,7,8,JTYP1,JTYP2)
810     CONTINUE
800   CONTINUE
C          stau_2 bar+nu_tau
      IF (GOQ(51,1).AND.GOQ(42,2)) THEN
          CALL TWOKIN(0.,0.,AML2SS,AMN3SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 820
          E1=SQRT(P(1)**2+AML2SS**2)
          E2=SQRT(P(2)**2+AMN3SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW
          SIGW=SIGW*SIN(THETAL)**2
          SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2)
          CALL SIGFIL(SIG,2,5,51,42)
          SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2)
          CALL SIGFIL(SIG,5,2,51,42)
          SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2)
          CALL SIGFIL(SIG,8,7,51,42)
          SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2)
          CALL SIGFIL(SIG,7,8,51,42)
820       CONTINUE
      END IF
C
C          sneutrino+slepton-bar via W+*
C
      DO 900 II=1,3
        IN=4*II-3
        IL=IN+3
        IDL=IDLSS(IL)
        IDN=IDLSS(IN)
        AML=AMASS(IDL)
        AMN=AMASS(IDN)
        JTYP1=IL2JS(IN)
        JTYP2=IL2JS(IL)
          IF(.NOT.(GOQ(JTYP1,1).AND.GOQ(JTYP2,2))) GO TO 910
          CALL TWOKIN(0.,0.,AMN,AML)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 910
          E1=SQRT(P(1)**2+AMN**2)
          E2=SQRT(P(2)**2+AML**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML**2*AMN**2)/12./PROPW
          IF (JTYP2.EQ.45) SIGW=SIGW*COS(THETAL)**2
            SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2)
            CALL SIGFIL(SIG,2,5,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2)
            CALL SIGFIL(SIG,5,2,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2)
            CALL SIGFIL(SIG,8,7,JTYP1,JTYP2)
            SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2)
            CALL SIGFIL(SIG,7,8,JTYP1,JTYP2)
910     CONTINUE
900   CONTINUE
C          nu_tau + stau_2 bar
      IF (GOQ(42,1).AND.GOQ(51,2)) THEN
          CALL TWOKIN(0.,0.,AMN3SS,AML2SS)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 920
          E1=SQRT(P(1)**2+AMN3SS**2)
          E2=SQRT(P(2)**2+AML2SS**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGW=G**4*(U*T-AML2SS**2*AMN3SS**2)/12./PROPW
          SIGW=SIGW*SIN(THETAL)**2
          SIG=.5*SIGW*FAC*QFCN(2,1)*QFCN(5,2)
          CALL SIGFIL(SIG,2,5,42,51)
          SIG=.5*SIGW*FAC*QFCN(5,1)*QFCN(2,2)
          CALL SIGFIL(SIG,5,2,42,51)
          SIG=.5*SIGW*FAC*QFCN(8,1)*QFCN(7,2)
          CALL SIGFIL(SIG,8,7,42,51)
          SIG=.5*SIGW*FAC*QFCN(7,1)*QFCN(8,2)
          CALL SIGFIL(SIG,7,8,42,51)
920       CONTINUE
      END IF
C
      RETURN
      END
+EOD
+DECK,SIGSSY.
      SUBROUTINE SIGSSY
C
C          Calculate d(sigma)/d(pt**2)d(y1)d(y2) for supersymmetric
C          particle pairs, including gluinos, gauginos, and squarks.
C
C          SIGMA    = cross section summed over types allowed by
C                     JETTYPE cards (with natural equivalence.)
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1
C
C          Extra factor of 1/2 needed for nonidentical final jets.
C          Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2
C
C          Dec. 1992: Use cross sections from Baer and Tata, Phys. 
C          Lett. 160B, 159; Phys. Rev. D42, 2259. These papers
C          separate L and R squarks.
C
C          Gauginos are included only for MSSM. The cross sections are
C          calculated in SIGSSZ, which is called from here.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,CONST
+CDE,QSAVE
+CDE,WCON.
+CDE,SSTYPE
+CDE,XMSSM
C
      REAL X(2)
      INTEGER IDQ(13),IDQSS(25),JS2JT(25)
      EQUIVALENCE (X(1),X1)
      LOGICAL LLRR
      REAL QFCN,STRUC,AMASS,FQG
      REAL AMG,SIG0,SIGR,AM1,SIG,FAC,AMQ,AM,AM2,AMQ2,S,T,U,AMG2,E1,E2,
     $AMSQ,AM1SQ,AM2SQ,SIGL
      INTEGER IFL1,IFL2,IQ1,IQ2,JQ1,JQ2,I,IFLQ1,IFLQ2,IH,IQ,     
     $JQ,JQIN1,JQIN2
C
C          IDENT codes from /SSTYPE/. (Fortran 77 allows - signs in
C          parameter statements but not data statements.)
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,
     $MDUP,MDDN,MDST,MDCH,MDBT,MDTP
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MDUP=-IDUP)
      PARAMETER (MDDN=-IDDN)
      PARAMETER (MDST=-IDST)
      PARAMETER (MDCH=-IDCH)
      PARAMETER (MDBT=-IDBT)
      PARAMETER (MDTP=-IDTP)
      DATA IDQSS/0,
     $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1,
     $ISTP1,MSTP1,
     $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2,
     $ISTP2,MSTP2/
      DATA IDQ/IDGL,IDUP,MDUP,IDDN,MDDN,IDST,MDST,IDCH,MDCH,
     $IDBT,MDBT,IDTP,MDTP/
C          JS2JT: Susy jettype -> normal jettype
      DATA JS2JT/1,
     $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/
C
C          Functions
      QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      FQG(S,T,U)=((16./3.)*(1./(U*T)**2+1./(S*U)**2)
     $+2.*(-2./3.)/(S*T*U**2))*(-U*S*T**2+2.*U*S*T*(AMG2-AMQ2)
     $-2.*U*S*(AMG2-AMQ2)**2-2.*S**2*AMG2*(AMG2-AMQ2))
C
C          Initialize
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
        SIGS(I)=0.
100   CONTINUE
C
C          Gluino + gluino
C
      IF(.NOT.(GOQ(1,1).AND.GOQ(1,2))) GO TO 300
      AM=AMASS(ISGL)
      CALL TWOKIN(0.,0.,AM,AM)
      IF(X1.GE.1..OR.X2.GE.1.) GO TO 300
      AM2=AM**2
      S=SHAT
      T=THAT
      U=UHAT
      E1=SQRT(P(1)**2+AM2)
      E2=SQRT(P(2)**2+AM2)
      FAC=PI*ALFQSQ**2/S**2
      FAC=FAC*(S/SCM)*(P(1)*P(2)/(E1*E2))*UNITS
C
C          gl gl ---> glss glss
      SIG=9./4.*(2.*(T-AM2)*(U-AM2)/S**2
     $+((T-AM2)*(U-AM2)-2.*AM2*(T+AM2))/(T-AM2)**2
     $+((U-AM2)*(T-AM2)-2.*AM2*(U+AM2))/(U-AM2)**2
     $+((T-AM2)*(U-AM2)+AM2*(U-T))/(S*(T-AM2))
     $+((U-AM2)*(T-AM2)+AM2*(T-U))/(S*(U-AM2))
     $+AM2*(S-4*AM2)/((T-AM2)*(U-AM2)))
      SIG=.5*FAC*SIG*QFCN(1,1)*QFCN(1,2)
      CALL SIGFIL(SIG,1,1,1,1)
C
C          qk qb ---> glss glss
      DO 220 IQ=1,5
        IQ1=2*IQ
        IQ2=IQ1+1
C          Left squark exchange
        AMQ=AMASS(IDQSS(IQ1))
        AMQ2=AMQ**2
        SIGL=(8./3.)*((T-AM2)**2+(U-AM2)**2+2.*AM2*S)/(S**2)
     $  +(32./27.)*(T-AM2)**2/(T-AMQ2)**2
     $  +(32./27.)*(U-AM2)**2/(U-AMQ2)**2
     $  +(8./3.)*((T-AM2)**2+AM2*S)/(S*(T-AMQ2))
     $  +(8./3.)*((U-AM2)**2+AM2*S)/(S*(U-AMQ2))
     $  +(8./27.)*AM2*S/((T-AMQ2)*(U-AMQ2))
        SIGL=.5*FAC*SIGL
C          Right squark exchange
        AMQ=AMASS(IDQSS(IQ1+12))
        AMQ2=AMQ**2
        SIGR=(8./3.)*((T-AM2)**2+(U-AM2)**2+2.*AM2*S)/(S**2)
     $  +(32./27.)*(T-AM2)**2/(T-AMQ2)**2
     $  +(32./27.)*(U-AM2)**2/(U-AMQ2)**2
     $  +(8./3.)*((T-AM2)**2+AM2*S)/(S*(T-AMQ2))
     $  +(8./3.)*((U-AM2)**2+AM2*S)/(S*(U-AMQ2))
     $  +(8./27.)*AM2*S/((T-AMQ2)*(U-AMQ2))
        SIGR=.5*FAC*SIGR
        SIG0=.5*(SIGL+SIGR)
C          Total
        SIG=SIG0*QFCN(IQ1,1)*QFCN(IQ2,2)
        CALL SIGFIL(SIG,IQ1,IQ2,1,1)
        SIG=SIG0*QFCN(IQ2,1)*QFCN(IQ1,2)
        CALL SIGFIL(SIG,IQ2,IQ1,1,1)
220   CONTINUE
C
C          Scalar quark + scalar (anti)quark
C
300   CONTINUE
      AMG=AMASS(ISGL)
      AMG2=AMG**2
C          IQ1 and IQ2 loop over left and right (anti)squarks
      DO 310 IQ1=2,25
      DO 320 IQ2=2,25
        IF(.NOT.(GOQ(IQ1,1).AND.GOQ(IQ2,2))) GO TO 320
        JQ1=JS2JT(IQ1)
        JQ2=JS2JT(IQ2)
C        IF(JQ1.GE.12.OR.JQ2.GE.12) GO TO 320
        IFL1=IDQSS(IQ1)
        IFL2=IDQSS(IQ2)
        IFLQ1=IDQ(JQ1)
        IFLQ2=IDQ(JQ2)
C          LLRR is true for left-left or right-right
        IF((IQ1.LE.13.AND.IQ2.LE.13).OR.(IQ1.GT.13.AND.IQ2.GT.13))
     $  THEN
          LLRR=.TRUE.
        ELSE
          LLRR=.FALSE.
        ENDIF
C          Kinematics
        AM1=AMASS(IFL1)
        AM2=AMASS(IFL2)
        AM=AM1
        CALL TWOKIN(0.,0.,AM1,AM2)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 320
        AMSQ=AM**2
        AM1SQ=AM1**2
        AM2SQ=AM2**2
        S=SHAT
        T=THAT
        U=UHAT
        E1=SQRT(P(1)**2+AM1SQ)
        E2=SQRT(P(2)**2+AM2SQ)
        FAC=PI*ALFQSQ**2/S**2
        FAC=FAC*(S/SCM)*(P(1)*P(2)/(E1*E2))*UNITS
C
C          gl gl ---> qkss qbss
C
        IF(IFL1.EQ.-IFL2) THEN
          SIG=(7./48.+3.*(U-T)**2/(16.*S**2))
     $    *(1.+2.*AMSQ*T/(T-AMSQ)**2+2.*AMSQ*U/(U-AMSQ)**2
     $    +4.*AMSQ**2/((T-AMSQ)*(U-AMSQ)))
          SIG=SIG*FAC*QFCN(1,1)*QFCN(1,2)
          SIG=.5*SIG
C          Another .5 to sum over L and R
          SIG=.5*SIG
          CALL SIGFIL(SIG,1,1,IQ1,IQ2)
        ENDIF
C
C          qk qb ---> qkss qbss
C
        IF(IFLQ1.EQ.-IFLQ2.AND.LLRR) THEN
C          Identical squark-antisquark, LL or RR
          SIG=(2./9.)*(1/(T-AMG2)**2+2/S**2-2/(3*S*(T-AMG2)))
     $     *(-S*T-(T-AMSQ)**2)*FAC*QFCN(JQ1,1)*QFCN(JQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
          SIG=(2./9.)*(1/(U-AMG2)**2+2/S**2-2/(3*S*(U-AMG2)))
     $     *(-S*U-(U-AMSQ)**2)*FAC*QFCN(JQ2,1)*QFCN(JQ1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2)
        ELSEIF(IFLQ1.EQ.-IFLQ2.AND..NOT.LLRR) THEN
C          Identical squark-antisquark, LR or RL
          SIG=(2./9.)*AMG2*S/(T-AMG2)**2*FAC*QFCN(JQ1,1)*QFCN(JQ2,2)
        SIG=.5*SIG
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
          SIG=(2./9.)*AMG2*S/(U-AMG2)**2*FAC*QFCN(JQ2,1)*QFCN(JQ1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2)
        ELSEIF(IFLQ1.EQ.IFLQ2.AND.LLRR) THEN
C          Identical squark-squark, LL or RR
          SIG=(1./9.)*AMG2*S*(1/(T-AMG2)**2+1/(U-AMG2)**2
     $    -(2./3.)/((T-AMG2)*(U-AMG2)))*FAC*QFCN(JQ1,1)*QFCN(JQ2,2)
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
        ELSEIF(IFLQ1.EQ.IFLQ2.AND..NOT.LLRR) THEN
C          Identical squark-squark, LR or RL
          SIG=(2./9.)*(1/(T-AMG2)**2*(-S*T-(T-AM1SQ)*(T-AM2SQ))
     $    +1/(U-AMG2)**2*(-S*U-(U-AM1SQ)*(U-AM2SQ)))
     $    *FAC*QFCN(JQ1,1)*QFCN(JQ2,2)
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
        ELSEIF(IFL1*IFL2.LT.0.AND.LLRR) THEN
C          Nonidentical squark-antisquark, LL or RR
          SIG=(2./9.)*(-S*T-(T-AM1SQ)*(T-AM2SQ))/(T-AMG2)**2*FAC
     $    *QFCN(JQ1,1)*QFCN(JQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
          SIG=(2./9.)*(-S*U-(U-AM1SQ)*(U-AM2SQ))/(U-AMG2)**2*FAC
     $    *QFCN(JQ2,1)*QFCN(JQ1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2)
        ELSEIF(IFL1*IFL2.LT.0.AND..NOT.LLRR) THEN
C          Nonidentical squark-antisquark, LR or RL
          SIG=(2./9.)*AMG2*S/(T-AMG2)**2*FAC*QFCN(JQ1,1)*QFCN(JQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
          SIG=(2./9.)*AMG2*S/(U-AMG2)**2*FAC*QFCN(JQ2,1)*QFCN(JQ1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2)
        ELSEIF(IFL1*IFL2.GT.0.AND.LLRR) THEN
C          Nonidentical squark-squark, LL or RR
          SIG=(2./9.)*AMG2*S/(T-AMG2)**2*FAC*QFCN(JQ1,1)*QFCN(JQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
          SIG=(2./9.)*AMG2*S/(U-AMG2)**2*FAC*QFCN(JQ2,1)*QFCN(JQ1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2)
        ELSEIF(IFL1*IFL2.GT.0.AND..NOT.LLRR) THEN
C          Nonidentical squark-squark, LR or RL
          SIG=(2./9.)*(-S*T-(T-AM1SQ)*(T-AM2SQ))/(T-AMG2)**2*FAC
     $    *QFCN(JQ1,1)*QFCN(JQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ1,JQ2,IQ1,IQ2)
          SIG=(2./9.)*(-S*U-(U-AM1SQ)*(U-AM2SQ))/(U-AMG2)**2*FAC
     $    *QFCN(JQ2,1)*QFCN(JQ1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ2,JQ1,IQ1,IQ2)
        ELSE
          STOP99
        ENDIF
C
C          q1 + q1bar --> q2ss + q2ssbar
C
        IF(IFLQ1.EQ.-IFLQ2.AND.LLRR) THEN
          DO 330 JQIN1=2,10,2
            IF(JQIN1.EQ.JQ1.OR.JQIN1.EQ.JQ2) GO TO 330
            JQIN2=MATCH(JQIN1,4)
            SIG=(4./9.)*(-S*T-(T-AM1SQ)**2)/S**2*FAC
     $      *QFCN(JQIN1,1)*QFCN(JQIN2,2)
            SIG=.5*SIG
            CALL SIGFIL(SIG,JQIN1,JQIN2,IQ1,IQ2)
            SIG=(4./9.)*(-S*U-(U-AM1SQ)**2)/S**2*FAC
     $      *QFCN(JQIN2,1)*QFCN(JQIN1,2)
            SIG=.5*SIG
            CALL SIGFIL(SIG,JQIN2,JQIN1,IQ1,IQ2)
330       CONTINUE
        ENDIF
320   CONTINUE
310   CONTINUE
C
C          Scalar quark + gluino
C
      AMG=AMASS(ISGL)
      AMG2=AMG**2
      DO 400 IQ=2,25
        AMQ=AMASS(IDQSS(IQ))
        AMQ2=AMQ**2
        JQ=JS2JT(IQ)        
C
C          Jet 1 = scalar quark
        IF(.NOT.(GOQ(JQ,1).AND.GOQ(1,2))) GO TO 410
        CALL TWOKIN(0.,0.,AMQ,AMG)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 410
        S=SHAT
        E1=SQRT(P(1)**2+AMQ2)
        E2=SQRT(P(2)**2+AMG2)
        FAC=PI*ALFQSQ**2/S**2
        FAC=FAC*S/SCM*P(1)*P(2)/(E1*E2)*UNITS
C
        T=THAT-AMQ2
        U=UHAT-AMG2
        SIG=FQG(S,T,U)*FAC/12.*QFCN(JQ,1)*QFCN(1,2)
        SIG=.5*SIG
        SIG=.5*SIG
        CALL SIGFIL(SIG,JQ,1,IQ,1)
C
        T=UHAT-AMQ2
        U=THAT-AMG2
        SIG=FQG(S,T,U)*FAC/12.*QFCN(1,1)*QFCN(JQ,2)
        SIG=.5*SIG
        SIG=.5*SIG
        CALL SIGFIL(SIG,1,JQ,IQ,1)
C
C          Jet 2 = scalar quark
410     IF(.NOT.(GOQ(1,1).AND.GOQ(JQ,2))) GO TO 400
        CALL TWOKIN(0.,0.,AMG,AMQ)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 400
        S=SHAT
        E1=SQRT(P(1)**2+AMG2)
        E2=SQRT(P(2)**2+AMQ2)
        FAC=PI*ALFQSQ**2/S**2
        FAC=FAC*S/SCM*P(1)*P(2)/(E1*E2)*UNITS
C 
        T=UHAT-AMQ2
        U=THAT-AMG2
        SIG=FQG(S,T,U)*FAC/12.*QFCN(1,1)*QFCN(JQ,2)
        SIG=.5*SIG
        SIG=.5*SIG
        CALL SIGFIL(SIG,1,JQ,1,IQ)
C
        T=THAT-AMQ2
        U=UHAT-AMG2
        SIG=FQG(S,T,U)*FAC/12.*QFCN(JQ,1)*QFCN(1,2)
        SIG=.5*SIG
        SIG=.5*SIG
        CALL SIGFIL(SIG,JQ,1,1,IQ)
400   CONTINUE
C
C          Calculate gaugino AND slepton cross sections only for MSSM
C
      IF(GOMSSM) CALL SIGSSZ
      IF(GOMSSM) CALL SIGSSL
C
      RETURN
      END
+EOD
+DECK,SIGSSZ.
      SUBROUTINE SIGSSZ
C
C          Calculate d(sigma)/d(pt**2)d(y1)d(y2) for supersymmetric
C          zino or wino plus squark or gluino in MSSM using cross
C          sections from Baer, Karatas, and Tata, PR D42, 2259.
C          Also include wino and zino pairs.
C
C          SIGMA    = cross section summed over types allowed by
C                     JETTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1
C          JETTYP -> IDENT mapping:
C          GLSS, UPSSL, UBSSL, ..., UPSSR, UBSSR, ...,
C          W1SS+, W1SS-, WS22+, W2SS-, Z1SS, Z2SS, Z3SS, Z4SS
C
C          Extra factor of 1/2 needed for nonidentical final jets.
C          Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2
C
C          Called from SIGSSY and so does not reinitialize /JETSIG/.
C
C          Ver 7.23: Add test setting SIG=0 for Z_i pairs if 
C          ABS(ZZ)>0.999 and SIG<0.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,CONST
+CDE,JETPAR
+CDE,JETSIG
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,QCDPAR
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTYPE
+CDE,WCON
C
      REAL X(2)
      EQUIVALENCE (X(1),X1)
      COMPLEX AQZ(2,4),BQZ(2,4),AQW(2,2),WIJ
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      INTEGER JS2JT(25),IW2JS(4),IW2IM(4),IZ2JS(4),IS2UD(25)
      SAVE JS2JT,IW2JS,IW2IM,IZ2JS,IS2UD
      INTEGER IDQSS(25),IDZSS(4),IDWSS(4)
      SAVE IDQSS,IDZSS,IDWSS
      INTEGER ITHZ(4),ITHW(2)
      REAL AMWISS(2)
      REAL XZIWJ(4,2),YZIWJ(4,2)
      REAL SIG,SIG0,CON,AMQIQ,S,T,U,AMWIW,FAC,AM22,AM12,TT,GP,G,
     $E1,E2,AMG,YM,XM,GS,THX,THY,AMZIZ,AMSQK
      INTEGER IX,JQ,IQ,IQ1,IQ2,JW,IW,JTYPW,IH,JTYPZ,IZ,ITHG,IWM
      COMPLEX ZONE,ZI
      SAVE ZONE,ZI
      REAL QFCN,STRUC,PSIFCN,AMASS
      REAL CON11,CON22,CON12,AMQIQ1,AMQIQ2
      INTEGER IX1,IX2
      REAL CS2THW,TNTHW,CTTHW,AL(2),BE(2),ESQ,XWI(2),YWI(2)
      REAL X12,Y12,SN12,AMWIW1,AMWIW2,EQ1,ZZ,XMGG,XMZZ
      REAL XMGZ,XMUU,XMGU,XMZU,XMDD,XMGD,XMZD,DEL,RSH,SR2
      REAL SIGUT,SIGTU,EHAT,PHAT,EBM,TPP,AMWI,AMQ,PROPW
      REAL SIGUT1,SIGUT2,SIGUT3,SGUT12,SGUT13,SGUT23
      REAL SIGTU1,SIGTU2,SIGTU3,SGTU12,SGTU13,SGTU23
      REAL AMSQL,AMSQR,KK,AMZIZ1,AMZIZ2
      REAL SIGLL,SIGRR,SIGZZ,SIGLZ,SIGRZ,SSGT,SSGST,PROPZ,SSXLAM
      INTEGER IZ1,JTYPZ1,IZ2,JTYPZ2
      INTEGER IW1,JW1,JTYPW1,IDW1,IW2,JW2,JTYPW2,IDW2,IFLQ,IUD(13)
C
C          IDENT codes from /SSTYPE/. (Fortran 77 allows - signs in
C          parameter statements but not data statements.)
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MSW1=-ISW1)
      PARAMETER (MSW2=-ISW2)
      DATA IDQSS/0,
     $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1,
     $ISTP1,MSTP1,
     $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2,
     $ISTP2,MSTP2/
      DATA IDZSS/ISZ1,ISZ2,ISZ3,ISZ4/
      DATA IDWSS/ISW1,MSW1,ISW2,MSW2/
      DATA IUD/0,1,-1,2,-2,2,-2,1,-1,2,-2,1,-1/
C
C          JS2JT: Susy jettype -> normal jettype
      DATA JS2JT/1,
     $2,3,4,5,6,7,8,9,10,11,12,13,2,3,4,5,6,7,8,9,10,11,12,13/
C          IW2JS: Wino index -> susy jettype
      DATA IW2JS/26,27,28,29/
C          IW2IM: Wino index -> match code
      DATA IW2IM/2,3,2,3/
C          IZ2JS: Zino index -> susy jettype
      DATA IZ2JS/30,31,32,33/
C          IS2UD: Susy jettype -> u/d code
      DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/
C
      DATA ZONE,ZI/(1.,0.),(0.,1.)/
C
C          Functions
      QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      PSIFCN(AM12,AM22,TT)=((S+TT-AM12)/(2*S)
     $-AM12*(AM22-TT)/(AM12-TT)**2
     $+(TT*(AM22-AM12)+AM22*(S-AM22+AM12))/(S*(AM12-TT)))
C
C          Constants from Baer, Barger, Karatas, and Tata,
C          PR D36, 96, using results from SSMIX
C
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
C     GS=SQRT(4.*PI*ALFA3)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      AMG=AMASS(ISGL)
      ITHG=+1
C          Signed masses
      AMWISS(1)=AMW1SS
      AMWISS(2)=AMW2SS
C          Zi couplings
      DO 100 IZ=1,4
        ITHZ(IZ)=0
        IF(AMZISS(IZ).LT.0) ITHZ(IZ)=1
        AQZ(1,IZ)=ZI**(ITHZ(IZ)-1)*(-ZONE)**(ITHZ(IZ)+1)
     $  *(+G/SQRT2*ZMIXSS(3,IZ)+GP/(3*SQRT2)*ZMIXSS(4,IZ))
        AQZ(2,IZ)=ZI**(ITHZ(IZ)-1)*(-ZONE)**(ITHZ(IZ)+1)
     $  *(-G/SQRT2*ZMIXSS(3,IZ)+GP/(3*SQRT2)*ZMIXSS(4,IZ))
        BQZ(1,IZ)=+(4./3.)*ZI**(ITHZ(IZ)-1)*GP/SQRT2*ZMIXSS(4,IZ)
        BQZ(2,IZ)=-(2./3.)*ZI**(ITHZ(IZ)-1)*GP/SQRT2*ZMIXSS(4,IZ)
100   CONTINUE
C          Wi couplings
      ITHW(1)=0
      IF(AMW1SS.LT.0.) ITHW(1)=1
      AQW(1,1)=ZI*G*SIN(GAMMAL)
      AQW(2,1)=ZI*G*(-ZONE)**ITHW(1)*SIN(GAMMAR)
      ITHW(2)=0
      IF(AMW2SS.LT.0.) ITHW(2)=1
      AQW(1,2)=ZI*G*THX*COS(GAMMAL)
      AQW(2,2)=ZI*G*(-ZONE)**ITHW(2)*THY*COS(GAMMAR)
C          Quark couplings to Z
      CS2THW=1.-SN2THW
      TNTHW=SQRT(SN2THW/CS2THW)
      CTTHW=1./TNTHW
      AL(1)=CTTHW/4.-5*TNTHW/12.
      AL(2)=TNTHW/12.-CTTHW/4.
      BE(1)=-(CTTHW+TNTHW)/4.
      BE(2)=-BE(1)
      ESQ=4*PI*ALFAEM
C           Chargino couplings to Z
      XWI(1)=1.-(COS(GAMMAL)**2+COS(GAMMAR)**2)/4./CS2THW
      XWI(2)=1.-(SIN(GAMMAL)**2+SIN(GAMMAR)**2)/4./CS2THW
      YWI(1)=(COS(GAMMAR)**2-COS(GAMMAL)**2)/4./CS2THW
      YWI(2)=(SIN(GAMMAR)**2-SIN(GAMMAL)**2)/4./CS2THW
      X12=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)-
     $    THY*SIN(GAMMAR)*COS(GAMMAR))
      Y12=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)+
     $    THY*SIN(GAMMAR)*COS(GAMMAR))
      SN12=-1.*SIGN(1.,AMW1SS)*SIGN(1.,AMW2SS)
C
C         qk qb --> ziss glss
C
      DO 200 IZ=1,4
        AMZIZ=ABS(AMZISS(IZ))
        JTYPZ=IZ2JS(IZ)
C          Jet 1 = ziss, jet 2 = glss
        IF(.NOT.(GOQ(JTYPZ,1).AND.GOQ(1,2))) GO TO 220
        CALL TWOKIN(0.,0.,AMZIZ,AMG)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 220
        GS=SQRT(4*PI*ALFQSQ)
        E1=SQRT(P(1)**2+AMZIZ**2)
        E2=SQRT(P(2)**2+AMG**2)
        FAC=1./(16.*PI*S**2)
        FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
C          Sum over initial quarks (no top quarks)
        DO 210 IQ=2,11
          IQ1=IQ
          IQ2=MATCH(IQ1,4)
          AMQIQ=AMASS(IDQSS(IQ))
          SIG0=(AMZIZ**2-T)*(AMG**2-T)/(AMQIQ**2-T)**2
     $    +(AMZIZ**2-U)*(AMG**2-U)/(AMQIQ**2-U)**2
     $    -2*(-1)**(ITHZ(IZ)+ITHG)*AMG*AMZIZ*S
     $    /((AMQIQ**2-T)*(AMQIQ**2-U))
          SIG0=SIG0*2*GS**2/9
          CON=AQZ(IS2UD(IQ),IZ)*CONJG(AQZ(IS2UD(IQ),IZ))
     $    +BQZ(IS2UD(IQ),IZ)*CONJG(BQZ(IS2UD(IQ),IZ))
          SIG=FAC*CON*SIG0*QFCN(IQ1,1)*QFCN(IQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,IQ1,IQ2,JTYPZ,1)
210     CONTINUE
C          Jet 1 = glss, jet 2 = ziss
220     IF(.NOT.(GOQ(1,1).AND.GOQ(JTYPZ,2))) GO TO 200
        CALL TWOKIN(0.,0.,AMG,AMZIZ)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 200
        GS=SQRT(4*PI*ALFQSQ)
        E1=SQRT(P(1)**2+AMG**2)
        E2=SQRT(P(2)**2+AMZIZ**2)
        FAC=1./(16.*PI*S**2)
        FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
        DO 230 IQ=2,11
          IQ1=IQ
          IQ2=MATCH(IQ1,4)
          AMQIQ=AMASS(IDQSS(IQ))
          SIG0=(AMZIZ**2-T)*(AMG**2-T)/(AMQIQ**2-T)**2
     $    +(AMZIZ**2-U)*(AMG**2-U)/(AMQIQ**2-U)**2
     $    -2*(-1)**(ITHZ(IZ)+ITHG)*AMG*AMZIZ*S
     $    /((AMQIQ**2-T)*(AMQIQ**2-U))
          SIG0=SIG0*2*GS**2/9
          CON=AQZ(IS2UD(IQ),IZ)*CONJG(AQZ(IS2UD(IQ),IZ))
     $    +BQZ(IS2UD(IQ),IZ)*CONJG(BQZ(IS2UD(IQ),IZ))
          SIG=FAC*CON*SIG0*QFCN(IQ1,1)*QFCN(IQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,IQ1,IQ2,1,JTYPZ)
230     CONTINUE
200   CONTINUE
C
C          qk gl -> ziss qkss 
C
      DO 300 IZ=1,4
        AMZIZ=ABS(AMZISS(IZ))
        JTYPZ=IZ2JS(IZ)
        DO 310 IQ=2,25
          JQ=JS2JT(IQ)
          IF(IABS(JQ).GE.12) GO TO 310
          AMQIQ=AMASS(IDQSS(IQ))
C          Jet 1 = ziss, jet 2 = qkss
          IF(.NOT.(GOQ(JTYPZ,1).AND.GOQ(IQ,2))) GO TO 320
          CALL TWOKIN(0.,0.,AMZIZ,AMQIQ)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 320
          GS=SQRT(4*PI*ALFQSQ)
          E1=SQRT(P(1)**2+AMZIZ**2)
          E2=SQRT(P(2)**2+AMQIQ**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          IX=IS2UD(IQ)
C          Use AQZ for left squarks, BQZ for right
          IF(IQ.LE.13) THEN
            CON=AQZ(IX,IZ)*CONJG(AQZ(IX,IZ))
          ELSE
            CON=BQZ(IX,IZ)*CONJG(BQZ(IX,IZ))
          ENDIF
          SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMZIZ**2,T)
     $    *QFCN(JQ,1)*QFCN(1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ,1,JTYPZ,IQ)
          SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMZIZ**2,U)
     $    *QFCN(1,1)*QFCN(JQ,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,1,JQ,JTYPZ,IQ)
C          Jet 1 = qkss, jet 2 = ziss
320       IF(.NOT.(GOQ(IQ,1).AND.GOQ(JTYPZ,2))) GO TO 310
          CALL TWOKIN(0.,0.,AMQIQ,AMZIZ)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 310
          GS=SQRT(4*PI*ALFQSQ)
          E1=SQRT(P(1)**2+AMQIQ**2)
          E2=SQRT(P(2)**2+AMZIZ**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          IX=IS2UD(IQ)
C          Use AQZ for left squarks, BQZ for right
          IF(IQ.LE.13) THEN
            CON=AQZ(IX,IZ)*CONJG(AQZ(IX,IZ))
          ELSE
            CON=BQZ(IX,IZ)*CONJG(BQZ(IX,IZ))
          ENDIF
          SIG=GS**2/6*CON*FAC*PSIFCN(AMQIQ**2,AMZIZ**2,U)
     $    *QFCN(JQ,1)*QFCN(1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ,1,IQ,JTYPZ)
          SIG=GS**2/6*CON*FAC*PSIFCN(AMQIQ**2,AMZIZ**2,T)
     $    *QFCN(1,1)*QFCN(JQ,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,1,JQ,IQ,JTYPZ)
310     CONTINUE
300   CONTINUE
C
C          qk gl -> wiss qkss 
C
      DO 400 IW=1,4
        JW=(IW+1)/2
        AMWIW=ABS(AMWISS(JW))
        JTYPW=IW2JS(IW)
        IWM=IW2IM(IW)
C          Left squarks only - 
        DO 410 IQ=2,11
          AMQIQ=AMASS(IDQSS(IQ))
C          JQ is the matching incoming quark
          JQ=JS2JT(IQ)
          JQ=MATCH(JQ,4)
          JQ=MATCH(JQ,IWM)
          IF(JQ.EQ.0.OR.JQ.GE.12) GO TO 410
C          Jet 1 = wiss, jet 2 = qkss
          IF(.NOT.(GOQ(JTYPW,1).AND.GOQ(IQ,2))) GO TO 420
          CALL TWOKIN(0.,0.,AMWIW,AMQIQ)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 420
          GS=SQRT(4*PI*ALFQSQ)
          E1=SQRT(P(1)**2+AMWIW**2)
          E2=SQRT(P(2)**2+AMQIQ**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          IX=IS2UD(JQ)
          CON=AQW(IX,JW)*CONJG(AQW(IX,JW))
          SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,T)
     $    *QFCN(JQ,1)*QFCN(1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ,1,JTYPW,IQ)
          SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,U)
     $    *QFCN(1,1)*QFCN(JQ,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,1,JQ,JTYPW,IQ)
C          Jet 1 = qkss, jet 2 = wiss
420       IF(.NOT.(GOQ(IQ,1).AND.GOQ(JTYPW,2))) GO TO 410
          CALL TWOKIN(0.,0.,AMQIQ,AMWIW)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 410
          GS=SQRT(4*PI*ALFQSQ)
          E1=SQRT(P(1)**2+AMQIQ**2)
          E2=SQRT(P(2)**2+AMWIW**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          IX=IS2UD(JQ)
          CON=AQW(IX,JW)*CONJG(AQW(IX,JW))
          SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,U)
     $    *QFCN(JQ,1)*QFCN(1,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,JQ,1,IQ,JTYPW)
          SIG=GS**2/6*FAC*CON*PSIFCN(AMQIQ**2,AMWIW**2,T)
     $    *QFCN(1,1)*QFCN(JQ,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,1,JQ,IQ,JTYPW)
410     CONTINUE
400   CONTINUE
C
C          qk qb -> wiss glss 
C
      DO 500 IW=1,4
        JW=(IW+1)/2
        AMWIW=ABS(AMWISS(JW))
        JTYPW=IW2JS(IW)
        IWM=IW2IM(IW)
C          Jet 1 = wiss, jet 2 = glss
        IF(.NOT.(GOQ(JTYPW,1).AND.GOQ(1,2))) GO TO 520
        CALL TWOKIN(0.,0.,AMWIW,AMG)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 520
        GS=SQRT(4*PI*ALFQSQ)
        E1=SQRT(P(1)**2+AMWIW**2)
        E2=SQRT(P(2)**2+AMG**2)
        FAC=1./(16.*PI*S**2)
        FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
C          Loop over quarks (no top quarks)
        DO 510 IQ=2,11
          IQ1=IQ
          IQ2=MATCH(IQ1,IWM)
          IF(IQ2.EQ.0.OR.IQ2.GE.12) GO TO 510
          AMQIQ1=AMASS(IDQSS(IQ1))
          IX1=IS2UD(IQ1)
          AMQIQ2=AMASS(IDQSS(IQ2))
          IX2=IS2UD(IQ2)
          CON11=AQW(IX1,JW)*CONJG(AQW(IX1,JW))
          CON22=AQW(IX2,JW)*CONJG(AQW(IX2,JW))
          CON12=2*(-1)**ITHG*REAL(AQW(IX1,JW)*AQW(IX2,JW))
          SIG=CON11*(AMWIW**2-T)*(AMG**2-T)/(AMQIQ2**2-T)**2
     $    +CON22*(AMWIW**2-U)*(AMG**2-U)/(AMQIQ1**2-U)**2
     $    +CON12*AMG*AMWIW*S/((AMQIQ2**2-T)*(AMQIQ1**2-U))
          SIG=2*GS**2/9*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,IQ1,IQ2,JTYPW,1)
C          No interchange needed here
510     CONTINUE
C          Jet 1 = glss, jet 2 = wiss
520     IF(.NOT.(GOQ(1,1).AND.GOQ(JTYPW,2))) GO TO 500
        CALL TWOKIN(0.,0.,AMG,AMWIW)
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 500
        GS=SQRT(4*PI*ALFQSQ)
        E1=SQRT(P(1)**2+AMG**2)
        E2=SQRT(P(2)**2+AMWIW**2)
        FAC=1./(16.*PI*S**2)
        FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
C          Loop over quarks (no top quarks)
        DO 530 IQ=2,11
          IQ1=IQ
          IQ2=MATCH(IQ1,IWM)
          IF(IQ2.EQ.0.OR.IQ2.GE.12) GO TO 530
          AMQIQ1=AMASS(IDQSS(IQ1))
          IX1=IS2UD(IQ1)
          AMQIQ2=AMASS(IDQSS(IQ2))
          IX2=IS2UD(IQ2)
          CON11=AQW(IX1,JW)*CONJG(AQW(IX1,JW))
          CON22=AQW(IX2,JW)*CONJG(AQW(IX2,JW))
          CON12=2*(-1)**ITHG*REAL(AQW(IX1,JW)*AQW(IX2,JW))
          SIG=CON11*(AMWIW**2-U)*(AMG**2-U)/(AMQIQ2**2-U)**2
     $    +CON22*(AMWIW**2-T)*(AMG**2-T)/(AMQIQ1**2-T)**2
     $    +CON12*AMG*AMWIW*S/((AMQIQ2**2-U)*(AMQIQ1**2-T))
          SIG=2*GS**2/9*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
          SIG=.5*SIG
          CALL SIGFIL(SIG,IQ1,IQ2,1,JTYPW)
C       NO INTERCHANGE NEEDED HERE
530     CONTINUE
500   CONTINUE
C
C          Gaugino pair production. The W,Z poles are assumed
C          to be outside the physical region.
C          Constants from SSWZBF:
C
      SR2=SQRT(2.)
      DO 601 IZ=1,4
        XZIWJ(IZ,1)=.5*(SIGN(1.,AMWISS(1))*SIGN(1.,AMZISS(IZ))
     $  *(COS(GAMMAR)*ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ))
     $  -COS(GAMMAL)*ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ))
        YZIWJ(IZ,1)=.5*(-SIGN(1.,AMWISS(1))*SIGN(1.,AMZISS(IZ))
     $  *(COS(GAMMAR)*ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ))
     $  -COS(GAMMAL)*ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ))
        XZIWJ(IZ,2)=.5*(SIGN(1.,AMWISS(2))*SIGN(1.,AMZISS(IZ))*THY
     $  *(-SIN(GAMMAR)*ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ))
     $  +THX*(SIN(GAMMAL)*ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ)))
        YZIWJ(IZ,2)=.5*(-SIGN(1.,AMWISS(2))*SIGN(1.,AMZISS(IZ))
     $  *THY*(-SIN(GAMMAR)*ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ))
     $  +THX*(SIN(GAMMAL)*ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ)))
601   CONTINUE
C
C          Zino + wino: W* and squark graphs included
C
      DO 610 IW=1,4
        JW=(IW+1)/2
        AMWIW=ABS(AMWISS(JW))
        JTYPW=IW2JS(IW)
        IWM=IW2IM(IW)
        DO 620 IZ=1,4
          AMZIZ=ABS(AMZISS(IZ))
          JTYPZ=IZ2JS(IZ)
          AMQ=AMASS(IDQSS(2))
C          Jet 1 = wiss, jet 2 = zjss
          IF(.NOT.(GOQ(JTYPW,1).AND.GOQ(JTYPZ,2))) GO TO 630
          CALL TWOKIN(0.,0.,AMWIW,AMZIZ)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 630
          E1=SQRT(P(1)**2+AMWIW**2)
          E2=SQRT(P(2)**2+AMZIZ**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
C          Loop over quarks (no top quarks)
          SIGUT1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2)
     $    *((AMWIW**2-U)*(AMZIZ**2-U)+(AMWIW**2-T)*(AMZIZ**2-T))/4.
     $    +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW)
     $    *((AMWIW**2-U)*(AMZIZ**2-U)-(AMWIW**2-T)*(AMZIZ**2-T))/4.
     $    +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2.
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGUT1=2*G**4/3./PROPW*SIGUT1
          SIGUT2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))*
     $    (AQW(1,JW)*CONJG(AQW(1,JW)))
     $    *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2
          SIGUT3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))*
     $    (AQW(2,JW)*CONJG(AQW(2,JW)))
     $    *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2
          SGUT12=-G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.*
     $    REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4.
     $    +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGUT13=G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.*
     $    REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4.
     $    +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGUT23=-4*AMWIW*AMZIZ*S/2./(U-AMQ**2)/(T-AMQ**2)/12.*
     $    REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW)))
          SIGUT=SIGUT1+SIGUT2+SIGUT3+SGUT12+SGUT13+SGUT23
C
          SIGTU1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2)
     $    *((AMWIW**2-T)*(AMZIZ**2-T)+(AMWIW**2-U)*(AMZIZ**2-U))/4.
     $    +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW)
     $    *((AMWIW**2-T)*(AMZIZ**2-T)-(AMWIW**2-U)*(AMZIZ**2-U))/4.
     $    +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2.
          SIGTU1=2*G**4/3./PROPW*SIGTU1
          SIGTU2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))*
     $    (AQW(1,JW)*CONJG(AQW(1,JW)))
     $    *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2
          SIGTU3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))*
     $    (AQW(2,JW)*CONJG(AQW(2,JW)))
     $    *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2
          SGTU12=-G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.*
     $    REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4.
     $    +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGTU13=G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.*
     $    REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4.
     $    +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGTU23=-4*AMWIW*AMZIZ*S/2./(T-AMQ**2)/(U-AMQ**2)/12.*
     $    REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW)))
          SIGTU=SIGTU1+SIGTU2+SIGTU3+SGTU12+SGTU13+SGTU23
          IF (IWM.EQ.2) THEN
            SIG=.5*SIGUT*FAC*QFCN(5,1)*QFCN(2,2)
            CALL SIGFIL(SIG,5,2,JTYPW,JTYPZ)
            SIG=.5*SIGUT*FAC*QFCN(7,1)*QFCN(8,2)
            CALL SIGFIL(SIG,7,8,JTYPW,JTYPZ)
            SIG=.5*SIGTU*FAC*QFCN(2,1)*QFCN(5,2)
            CALL SIGFIL(SIG,2,5,JTYPW,JTYPZ)
            SIG=.5*SIGTU*FAC*QFCN(8,1)*QFCN(7,2)
            CALL SIGFIL(SIG,8,7,JTYPW,JTYPZ)
          ELSE
            SIG=.5*SIGTU*FAC*QFCN(4,1)*QFCN(3,2)
            CALL SIGFIL(SIG,4,3,JTYPW,JTYPZ)
            SIG=.5*SIGTU*FAC*QFCN(6,1)*QFCN(9,2)
            CALL SIGFIL(SIG,6,9,JTYPW,JTYPZ)
            SIG=.5*SIGUT*FAC*QFCN(3,1)*QFCN(4,2)
            CALL SIGFIL(SIG,3,4,JTYPW,JTYPZ)
            SIG=.5*SIGUT*FAC*QFCN(9,1)*QFCN(6,2)
            CALL SIGFIL(SIG,9,6,JTYPW,JTYPZ)
          END IF
C          Jet 1 = zjss, jet 2 = wiss
630       IF(.NOT.(GOQ(JTYPZ,1).AND.GOQ(JTYPW,2))) GO TO 620
          CALL TWOKIN(0.,0.,AMZIZ,AMWIW)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 610
          E1=SQRT(P(1)**2+AMZIZ**2)
          E2=SQRT(P(2)**2+AMWIW**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
C          Loop over quarks (no top quarks)
          SIGUT1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2)
     $    *((AMWIW**2-U)*(AMZIZ**2-U)+(AMWIW**2-T)*(AMZIZ**2-T))/4.
     $    +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW)
     $    *((AMWIW**2-U)*(AMZIZ**2-U)-(AMWIW**2-T)*(AMZIZ**2-T))/4.
     $    +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2.
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGUT1=2*G**4/3./PROPW*SIGUT1
          SIGUT2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))*
     $    (AQW(1,JW)*CONJG(AQW(1,JW)))
     $    *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2
          SIGUT3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))*
     $    (AQW(2,JW)*CONJG(AQW(2,JW)))
     $    *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2
          SGUT12=-G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.*
     $    REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4.
     $    +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGUT13=G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.*
     $    REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4.
     $    +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGUT23=-4*AMWIW*AMZIZ*S/2./(U-AMQ**2)/(T-AMQ**2)/12.*
     $    REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW)))
          SIGUT=SIGUT1+SIGUT2+SIGUT3+SGUT12+SGUT13+SGUT23
C
          SIGTU1=(XZIWJ(IZ,JW)**2+YZIWJ(IZ,JW)**2)
     $    *((AMWIW**2-T)*(AMZIZ**2-T)+(AMWIW**2-U)*(AMZIZ**2-U))/4.
     $    +2*XZIWJ(IZ,JW)*YZIWJ(IZ,JW)
     $    *((AMWIW**2-T)*(AMZIZ**2-T)-(AMWIW**2-U)*(AMZIZ**2-U))/4.
     $    +AMWIW*AMZIZ*(XZIWJ(IZ,JW)**2-YZIWJ(IZ,JW)**2)*S/2.
          SIGTU1=2*G**4/3./PROPW*SIGTU1
          SIGTU2=(AQZ(2,IZ)*CONJG(AQZ(2,IZ)))*
     $    (AQW(1,JW)*CONJG(AQW(1,JW)))
     $    *(AMWIW**2-T)*(AMZIZ**2-T)/4./3./(T-AMQ**2)**2
          SIGTU3=(AQZ(1,IZ)*CONJG(AQZ(1,IZ)))*
     $    (AQW(2,JW)*CONJG(AQW(2,JW)))
     $    *(AMWIW**2-U)*(AMZIZ**2-U)/4./3./(U-AMQ**2)**2
          SGTU12=-G**2*SR2*(S-AMW**2)/PROPW/(T-AMQ**2)/12.*
     $    REAL(CONJG(AQZ(2,IZ))*AQW(1,JW)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*(AMZIZ**2-T)*(AMWIW**2-T)/4.
     $    +4*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGTU13=G**2*SR2*(S-AMW**2)/PROPW/(U-AMQ**2)/12.*
     $    REAL(CONJG(AQW(2,JW))*AQZ(1,IZ)*(-ZI)**(ITHZ(IZ)))*
     $    (8*(XZIWJ(IZ,JW)-YZIWJ(IZ,JW))*(AMZIZ**2-U)*(AMWIW**2-U)/4.
     $    +4*(XZIWJ(IZ,JW)+YZIWJ(IZ,JW))*AMWIW*AMZIZ*S/2.)
          SGTU23=-4*AMWIW*AMZIZ*S/2./(T-AMQ**2)/(U-AMQ**2)/12.*
     $    REAL(AQZ(1,IZ)*AQZ(2,IZ)*CONJG(AQW(1,JW)*AQW(2,JW)))
          SIGTU=SIGTU1+SIGTU2+SIGTU3+SGTU12+SGTU13+SGTU23
          IF (IWM.EQ.2) THEN
            SIG=.5*SIGTU*FAC*QFCN(5,1)*QFCN(2,2)
            CALL SIGFIL(SIG,5,2,JTYPZ,JTYPW)
            SIG=.5*SIGTU*FAC*QFCN(7,1)*QFCN(8,2)
            CALL SIGFIL(SIG,7,8,JTYPZ,JTYPW)
            SIG=.5*SIGUT*FAC*QFCN(2,1)*QFCN(5,2)
            CALL SIGFIL(SIG,2,5,JTYPZ,JTYPW)
            SIG=.5*SIGUT*FAC*QFCN(8,1)*QFCN(7,2)
            CALL SIGFIL(SIG,8,7,JTYPZ,JTYPW)
          ELSE
            SIG=.5*SIGUT*FAC*QFCN(4,1)*QFCN(3,2)
            CALL SIGFIL(SIG,4,3,JTYPZ,JTYPW)
            SIG=.5*SIGUT*FAC*QFCN(6,1)*QFCN(9,2)
            CALL SIGFIL(SIG,6,9,JTYPZ,JTYPW)
            SIG=.5*SIGTU*FAC*QFCN(3,1)*QFCN(4,2)
            CALL SIGFIL(SIG,3,4,JTYPZ,JTYPW)
            SIG=.5*SIGTU*FAC*QFCN(9,1)*QFCN(6,2)
            CALL SIGFIL(SIG,9,6,JTYPZ,JTYPW)
          END IF
620     CONTINUE
610   CONTINUE
C
C          Chargino pair production
C          added squark exchange contribution 7/11/97
C
      DO 700 IW1=1,4
        JW1=(IW1+1)/2
        AMWIW1=ABS(AMWISS(JW1))
        JTYPW1=IW2JS(IW1)
        IDW1=IDWSS(IW1)
        DO 710 IW2=1,4
          JW2=(IW2+1)/2
          AMWIW2=ABS(AMWISS(JW2))
          JTYPW2=IW2JS(IW2)
          IDW2=IDWSS(IW2)
          IF (.NOT.(GOQ(JTYPW1,1).AND.GOQ(JTYPW2,2))) GO TO 710
          CALL TWOKIN(0.,0.,AMWIW1,AMWIW2)
          IF (X1.GE.1..OR.X2.GE.1.) GO TO 710
          E1=SQRT(P(1)**2+AMWIW1**2)
          E2=SQRT(P(2)**2+AMWIW2**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          DO 720 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IQ2=MATCH(IQ1,4)
            IF (IQ1.EQ.2.OR.IQ1.EQ.3) AMSQK=AMDLSS
            IF (IQ1.EQ.4.OR.IQ1.EQ.5) AMSQK=AMULSS
            IF (IQ1.EQ.6.OR.IQ1.EQ.7) AMSQK=AMCLSS
            IF (IQ1.EQ.8.OR.IQ1.EQ.9) AMSQK=AMSLSS
            IF (IQ1.EQ.10.OR.IQ1.EQ.11) AMSQK=AMB1SS
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 720
            IF (IDW1.EQ.-IDW2) THEN
C          Convert ISAJET t_hat to particle-particle t_hat
              IF (IUD(IQ1)*IDW1.GT.0) THEN
                TPP=U
              ELSE
                TPP=T
              END IF
              ZZ=(2*TPP-2*AMWIW1**2+S)/SQRT(S*S-4*S*AMWIW1**2)
              EHAT=SQRT(S)/2.
              PHAT=SQRT(EHAT**2-AMWIW1**2)
              XMGG=16.*ESQ*ESQ*(EHAT**2*(1.+ZZ**2)+
     $        AMWIW1**2*(1.-ZZ**2))/S*EQ1**2
              XMZZ=16*ESQ*ESQ*CTTHW**2*S/((S-AMZ**2)**2+
     $        (GAMZ*AMZ)**2)*((XWI(JW1)**2+YWI(JW1)**2)*
     $        (AL(IFLQ)**2+BE(IFLQ)**2)*
     $        (EHAT**2*(1.+ZZ**2)+AMWIW1**2*(1.-ZZ**2))-2.*
     $        YWI(JW1)**2*(AL(IFLQ)**2+
     $        BE(IFLQ)**2)*AMWIW1**2-8*XWI(JW1)*YWI(JW1)*
     $        AL(IFLQ)*BE(IFLQ)*EHAT*PHAT*ZZ)
              XMGZ=(-EQ1)*(-32.)*ESQ*ESQ*CTTHW*(S-AMZ**2)/
     $        ((S-AMZ**2)**2+(GAMZ*AMZ)**2)*
     $        (AL(IFLQ)*XWI(JW1)*(EHAT**2*
     $        (1.+ZZ**2)+AMWIW1**2*(1.-ZZ**2))-2*
     $        BE(IFLQ)*YWI(JW1)*EHAT*PHAT*ZZ)
              XMUU=ESQ*ESQ*SIN(GAMMAR)**4*S*(EHAT-PHAT*ZZ)**2/
     $         SN2THW**2/(EHAT**2+PHAT**2-2*EHAT*PHAT*ZZ+
     $         AMSQK**2)**2
              XMGU=EQ1*4*ESQ*ESQ*SIN(GAMMAR)**2*
     $         ((EHAT-PHAT*ZZ)**2+AMWIW1**2)/SN2THW/
     $         (EHAT**2+PHAT**2-2*EHAT*PHAT*ZZ+AMSQK**2)
              XMZU=4*ESQ*ESQ*CTTHW*SIN(GAMMAR)**2*(S-AMZ**2)
     $         *(AL(IFLQ)-BE(IFLQ))*S/SN2THW/((S-AMZ**2)**2+
     $         (GAMZ*AMZ)**2)*((XWI(JW1)-YWI(JW1))*
     $         ((EHAT-PHAT*ZZ)**2+AMWIW1**2)+2*YWI(JW1)*
     $         AMWIW1**2)/(EHAT**2+PHAT**2-2*EHAT*PHAT*ZZ+
     $         AMSQK**2)
              XMDD=ESQ*ESQ*SIN(GAMMAL)**4*S*(EHAT+PHAT*ZZ)**2/
     $         SN2THW**2/(EHAT**2+PHAT**2+2*EHAT*PHAT*ZZ+
     $         AMSQK**2)**2
              XMGD=-4*EQ1*ESQ*ESQ*SIN(GAMMAL)**2*
     $         ((EHAT+PHAT*ZZ)**2+AMWIW1**2)/SN2THW/
     $         (EHAT**2+PHAT**2+2*EHAT*PHAT*ZZ+AMSQK**2)
              XMZD=-4*ESQ*ESQ*CTTHW*SIN(GAMMAL)**2*(S-AMZ**2)
     $         *(AL(IFLQ)-BE(IFLQ))*S/SN2THW/((S-AMZ**2)**2+
     $         (GAMZ*AMZ)**2)*((XWI(JW1)+YWI(JW1))*
     $         ((EHAT+PHAT*ZZ)**2+AMWIW1**2)-2*YWI(JW1)*
     $         AMWIW1**2)/(EHAT**2+PHAT**2+2*EHAT*PHAT*ZZ+
     $         AMSQK**2)
              IF (IFLQ.EQ.1) THEN
               SIG=(XMGG+XMZZ+XMGZ+XMDD+XMGD+XMZD)/12.
              ELSE
               SIG=(XMGG+XMZZ+XMGZ+XMUU+XMGU+XMZU)/12.
              END IF
              SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
              SIG=.5*SIG
C              IF(SIG.LT.0.AND.ABS(ZZ).GT.0.999) SIG=0
              CALL SIGFIL(SIG,IQ1,IQ2,JTYPW1,JTYPW2)
            ELSEIF (IDW1*IDW2.LT.0) THEN
              PHAT=SQRT(S*S+AMWIW1**4+AMWIW2**4-2*S*AMWIW1**2
     $        -2*S*AMWIW2**2-2*AMWIW1**2*AMWIW2**2)/2./SQRT(S)
              IF (IUD(IQ1)*IDW1.GT.0) THEN
                TPP=U
              ELSE
                TPP=T
              END IF
              IF (IDW1.LT.0) THEN
                AMWI=AMWIW1
              ELSE
                AMWI=AMWIW2
              END IF
              EHAT=SQRT(PHAT**2+AMWI**2)
              EBM=SQRT(S)/2.
              ZZ=(TPP-AMWI**2+SQRT(S)*EHAT)/SQRT(S)/PHAT
              DEL=(AMW2SS**2-AMW1SS**2)/4./EBM
              XMZZ=4*(CTTHW+TNTHW)**2/((S-AMZ**2)**2+
     $        (GAMZ*AMZ)**2)*((X12**2+Y12**2)*
     $        (AL(IFLQ)**2+BE(IFLQ)**2)*
     $        (EBM**2+PHAT**2*ZZ**2-DEL**2-SN12*AMWIW1*AMWIW2)+
     $        2*X12**2*SN12*(AL(IFLQ)**2+ BE(IFLQ)**2)*AMWIW1*
     $        AMWIW2-8*X12*Y12*AL(IFLQ)*BE(IFLQ)*EBM*PHAT*ZZ)
              XMUU=SIN(GAMMAR)**2*COS(GAMMAR)**2*((EBM-PHAT*ZZ)
     $         **2-DEL**2)/SN2THW**2/(2*EBM*(EBM-DEL)-2*EBM*PHAT*
     $         ZZ+AMSQK**2-AMW1SS**2)**2
              XMZU=-2*THY*(CTTHW+TNTHW)*SIN(GAMMAR)*COS(GAMMAR)*
     $         (S-AMZ**2)*(AL(IFLQ)-BE(IFLQ))/SN2THW/((S-AMZ**2)
     $         **2+(GAMZ*AMZ)**2)*((X12-Y12)*((EBM-PHAT*ZZ)**2-
     $         DEL**2-SN12*AMWIW1*AMWIW2)+2*X12*SN12*AMWIW1*
     $         AMWIW2)/(2*EBM*(EBM-DEL)-2*EBM*PHAT*ZZ+AMSQK**2
     $         -AMW1SS**2)
              XMDD=SIN(GAMMAL)**2*COS(GAMMAL)**2*((EBM+PHAT*ZZ)
     $         **2-DEL**2)/SN2THW**2/(2*EBM*(EBM-DEL)+2*EBM*PHAT*
     $         ZZ+AMSQK**2-AMW1SS**2)**2
              XMZD=-2*THX*(CTTHW+TNTHW)*SIN(GAMMAL)*COS(GAMMAL)*
     $         (S-AMZ**2)*(AL(IFLQ)-BE(IFLQ))/SN2THW/((S-AMZ**2)
     $         **2+(GAMZ*AMZ)**2)*((X12+Y12)*((EBM+PHAT*ZZ)**2-
     $         DEL**2+SN12*AMWIW1*AMWIW2)-2*Y12*SN12*AMWIW1*
     $         AMWIW2)/(2*EBM*(EBM-DEL)+2*EBM*PHAT*ZZ+AMSQK**2
     $         -AMW1SS**2)
              IF (IFLQ.EQ.1) THEN
               SIG=ESQ*ESQ*(XMZZ+XMDD+XMZD)*S/12.
              ELSE
               SIG=ESQ*ESQ*(XMZZ+XMUU+XMZU)*S/12.
              END IF
              SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
              SIG=.5*SIG
              CALL SIGFIL(SIG,IQ1,IQ2,JTYPW1,JTYPW2)
            END IF
720       CONTINUE
710     CONTINUE
700   CONTINUE
C
C         qk qb --> ziss zjss
C
      DO 800 IZ1=1,4
        AMZIZ1=ABS(AMZISS(IZ1))
        JTYPZ1=IZ2JS(IZ1)
        DO 810 IZ2=1,4
          AMZIZ2=ABS(AMZISS(IZ2))
          JTYPZ2=IZ2JS(IZ2)
          IF(.NOT.(GOQ(JTYPZ1,1).AND.GOQ(JTYPZ2,2))) GO TO 810
          CALL TWOKIN(0.,0.,AMZIZ1,AMZIZ2)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 810
          E1=SQRT(P(1)**2+AMZIZ1**2)
          E2=SQRT(P(2)**2+AMZIZ2**2)
          FAC=1./(16.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          WIJ=SQRT(G**2+GP**2)*ZI**(ITHZ(IZ2))*(-ZI)**(ITHZ(IZ1))*
     $    (ZMIXSS(1,IZ1)*ZMIXSS(1,IZ2)-ZMIXSS(2,IZ1)*
     $    ZMIXSS(2,IZ2))/4.
          RSH=SQRT(S)
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          KK=SQRT(S*S+(AMZIZ1**2-AMZIZ2**2)**2-2*S*
     $    (AMZIZ1**2+AMZIZ2**2))/2./RSH
C          Sum over initial quarks (no top quarks)
          DO 820 IQ=2,11
            IQ1=IQ
            IQ2=MATCH(IQ1,4)
            AMSQL=AMASS(IDQSS(IQ))
            AMSQR=AMASS(IDQSS(IQ+12))
            PHAT=SQRT(SSXLAM(S,AMZIZ1**2,AMZIZ2**2))/2./RSH
            EHAT=SQRT(PHAT**2+AMZIZ1**2)
            ZZ=(T-AMZIZ1**2+RSH*EHAT)/RSH/PHAT
            IF (IUD(IQ).LT.0) ZZ=-ZZ
            IFLQ=IS2UD(IQ)
            SIGLL=AQZ(IFLQ,IZ1)*CONJG(AQZ(IFLQ,IZ1))*AQZ(IFLQ,IZ2)*
     $      CONJG(AQZ(IFLQ,IZ2))*SSGT(S,AMSQL,ZZ,IZ1,IZ2)
            SIGRR=BQZ(IFLQ,IZ1)*CONJG(BQZ(IFLQ,IZ1))*BQZ(IFLQ,IZ2)*
     $      CONJG(BQZ(IFLQ,IZ2))*SSGT(S,AMSQR,ZZ,IZ1,IZ2)
            SIGZZ=4*ESQ*WIJ*CONJG(WIJ)*(AL(IFLQ)**2+BE(IFLQ)**2)*
     $      (S*S-(AMZIZ1**2-AMZIZ2**2)**2+4*(-1.)**(ITHZ(IZ1)+
     $      ITHZ(IZ2)+1)*S*AMZIZ1*AMZIZ2+4*S*KK*KK*ZZ*ZZ)/PROPZ
            SIGLZ=-SQRT(ESQ)*(AL(IFLQ)-BE(IFLQ))*(S-AMZ**2)/2./
     $      PROPZ*(REAL(WIJ*CONJG(AQZ(IFLQ,IZ1))*AQZ(IFLQ,IZ2))*
     $      SSGST(S,AMSQL,ZZ,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))*
     $      REAL(WIJ*AQZ(IFLQ,IZ1)*CONJG(AQZ(IFLQ,IZ2)))*
     $      SSGST(S,AMSQL,-ZZ,IZ1,IZ2))
            SIGRZ=-SQRT(ESQ)*(-1.)**(ITHZ(IZ1)+ITHZ(IZ2)+1)*
     $      (AL(IFLQ)+BE(IFLQ))*(S-AMZ**2)/2./
     $      PROPZ*(REAL(WIJ*CONJG(BQZ(IFLQ,IZ1))*BQZ(IFLQ,IZ2))*
     $      SSGST(S,AMSQR,ZZ,IZ1,IZ2)+(-1.)**(ITHZ(IZ1)+ITHZ(IZ2))*
     $      REAL(WIJ*BQZ(IFLQ,IZ1)*CONJG(BQZ(IFLQ,IZ2)))*
     $      SSGST(S,AMSQR,-ZZ,IZ1,IZ2))
            SIG=KK*(SIGLL+SIGRR+SIGZZ+SIGLZ+SIGRZ)/3./PHAT
C          Below factor of 2 for id particles and jettyp switch
            SIG=SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)/2.
            IF(SIG.LT.0.AND.ABS(ZZ).GT.0.999) SIG=0
            CALL SIGFIL(SIG,IQ1,IQ2,JTYPZ1,JTYPZ2)
820       CONTINUE
810     CONTINUE
800   CONTINUE
      RETURN
      END
+EOD
+DECK,SIGTC2
      SUBROUTINE SIGTC2
C
C          Compute the techni-rho decay distribution cross section
C          D(SIGMA)/D(QMW**2)D(YW)D(OMEGA)
C          for the specified jet types. This is trivial but done for
C          compatibility with Drell-Yan and Higgs.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,CONST
+CDE,JETPAR
+CDE,JETSIG
+CDE,PJETS
+CDE,WSIG
+CDE,TCPAR
C
      REAL AM12,AM22,ANGFAC,S,T,U
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
C
C          Angfac is (1-z**2), and is determined in terms of S,T,U.
C          Note that both rho+- and rho0 are always elastic.
      AM12=PJETS(5,1)**2
      AM22=PJETS(5,2)**2
      ANGFAC=4.*(T*U-AM12*AM22)/((S-AM12-AM22)**2-4.*AM12*AM22)
C          Differential cross section
      SIGLLQ=SIGEVT*ANGFAC*3./(8.*PI)
      RETURN
      END
+EOD
+DECK,SIGTC3
      SUBROUTINE SIGTC3
C
C          Calculate angular distributions for W decays from technirho:
C          d(sigma)/d(qmw**2)d(yw)d(omega)d(omega1)d(omega2)
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PJETS
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,WSIG
+CDE,WWSIG
+CDE,WCON
+CDE,CONST
+CDE,WWPAR
+CDE,TCPAR
C
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      INTEGER I,K,IDADDR(4),IW(2)
      REAL T12(3,3),T34(3,3),FR(3,3),FI(3,3),CPHI12(3),SPHI12(3),
     $CPHI34(3),SPHI34(3),PFCM(5,4),PWCM(5,2),CHWW,SHWW,TMP,PTW1,
     $CPHIW1,SPHIW1,PW1,CTHW1,STHW1,CHW1,SHW1,SHWI,TH12,PHI12,TH34,
     $PHI34,AMV,GAMV,QMH,A12,B12,A34,B34,TVV12,TVA12,COS12,SIN12,
     $TVV34,TVA34,COS34,SIN34,TCPHI,TSPHI,TC2PHI,TS2PHI,F0,F1,TOTAL,
     $DIFF,T,U,S
C
      IF(NPAIR.NE.4) RETURN
C
C          Reconstruct W-->FF decay angles
C
C          Initialize PFCM and PWCM
      DO 10 I=1,4
      DO 10 K=1,5
        PFCM(K,I)=PPAIR(K,I)
10    CONTINUE
      DO 11 I=1,2
      DO 11 K=1,5
        PWCM(K,I)=PJETS(K,I)
11    CONTINUE
C
C          Z boost to WW center of mass
      CHWW=QWJET(4)/QWJET(5)
      SHWW=QWJET(3)/QWJET(5)
      DO 20 I=1,4
        TMP=CHWW*PFCM(4,I)-SHWW*PFCM(3,I)
        PFCM(3,I)=-SHWW*PFCM(4,I)+CHWW*PFCM(3,I)
        PFCM(4,I)=TMP
20    CONTINUE
      DO 21 I=1,2
        TMP=CHWW*PWCM(4,I)-SHWW*PWCM(3,I)
        PWCM(3,I)=-SHWW*PWCM(4,I)+CHWW*PWCM(3,I)
        PWCM(4,I)=TMP
21    CONTINUE
C
C          Rotate W1 to +z axis
      PTW1=SQRT(PWCM(1,1)**2+PWCM(2,1)**2)
      CPHIW1=PWCM(1,1)/PTW1
      SPHIW1=PWCM(2,1)/PTW1
      PW1=SQRT(PTW1**2+PWCM(3,1)**2)
      CTHW1=PWCM(3,1)/PW1
      STHW1=PTW1/PW1
C          Z rotation
      DO 30 I=1,4
        TMP=CPHIW1*PFCM(1,I)+SPHIW1*PFCM(2,I)
        PFCM(2,I)=-SPHIW1*PFCM(1,I)+CPHIW1*PFCM(2,I)
        PFCM(1,I)=TMP
30    CONTINUE
C          Y rotation
      DO 31 I=1,4
        TMP=CTHW1*PFCM(1,I)-STHW1*PFCM(3,I)
        PFCM(3,I)=STHW1*PFCM(1,I)+CTHW1*PFCM(3,I)
        PFCM(1,I)=TMP
31    CONTINUE
C
C          Boost to W rest frames
      CHW1=PWCM(4,1)/PWCM(5,1)
      SHW1=PW1/PWCM(5,1)
      DO 40 I=1,4
        IF(I.LE.2) THEN
          SHWI=SHW1
        ELSE
          SHWI=-SHW1
        ENDIF
        TMP=CHW1*PFCM(4,I)-SHWI*PFCM(3,I)
        PFCM(3,I)=-SHWI*PFCM(4,I)+CHW1*PFCM(3,I)
        PFCM(4,I)=TMP
40    CONTINUE
C
C          Compute angles
      TH12=ACOS(PFCM(3,1)/SQRT(PFCM(1,1)**2+PFCM(2,1)**2+PFCM(3,1)**2))
      PHI12=ATAN2(PFCM(2,1),PFCM(1,1))
      TH34=ACOS(PFCM(3,3)/SQRT(PFCM(1,3)**2+PFCM(2,3)**2+PFCM(3,3)**2))
      PHI34=ATAN2(PFCM(2,3),PFCM(1,3))
C
C          Compute decay angular distributions.
C
      DO 100 I=1,4
        IDADDR(I)=IABS(IDPAIR(I))
        IF(IDADDR(I).GE.11) IDADDR(I)=IDADDR(I)-4
100   CONTINUE
      IW(1)=JETTYP(1)-25
      IW(2)=JETTYP(2)-25
C
      AMV=PJETS(5,1)
      GAMV=WGAM(IW(1))
      QMH=QMW
C          COUPLINGS
      A12=AQ(IDADDR(1),IW(1))
      B12=BQ(IDADDR(1),IW(1))
      A34=AQ(IDADDR(3),IW(2))
      B34=BQ(IDADDR(3),IW(2))
C          DECAY DISTRIBUTIONS
      TVV12=8.*PI*ALFA*(A12**2+B12**2)
      TVA12=16.*PI*ALFA*A12*B12
      COS12=COS(TH12)
      SIN12=SIN(TH12)
      T12(1,1)=TVV12*SIN12**2
      T12(1,2)=TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2
      T12(1,3)=-TVV12*SIN12*COS12/SQRT2+TVA12*SIN12/SQRT2
      T12(2,1)=T12(1,2)
      T12(2,2)=TVV12*(.5+.5*COS12**2)+TVA12*COS12
      T12(2,3)=TVV12*.5*SIN12**2
      T12(3,1)=T12(1,3)
      T12(3,2)=T12(2,3)
      T12(3,3)=TVV12*(.5+.5*COS12**2)-TVA12*COS12
C
      TVV34=8.*PI*ALFA*(A34**2+B34**2)
      TVA34=16.*PI*ALFA*A34*B34
      COS34=COS(TH34)
      SIN34=SIN(TH34)
      T34(1,1)=TVV34*SIN34**2
      T34(1,2)=TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2
      T34(1,3)=-TVV34*SIN34*COS34/SQRT2+TVA34*SIN34/SQRT2
      T34(2,1)=T34(1,2)
      T34(2,2)=TVV34*(.5+.5*COS34**2)+TVA34*COS34
      T34(2,3)=TVV34*.5*SIN34**2
      T34(3,1)=T34(1,3)
      T34(3,2)=T34(2,3)
      T34(3,3)=TVV34*(.5+.5*COS34**2)-TVA34*COS34
C
      CPHI12(1)=1.
      CPHI12(2)=COS(PHI12)
      CPHI12(3)=COS(2.*PHI12)
      SPHI12(1)=0.
      SPHI12(2)=SIN(PHI12)
      SPHI12(3)=SIN(2.*PHI12)
      CPHI34(1)=1.
      CPHI34(2)=COS(PHI34)
      CPHI34(3)=COS(2.*PHI34)
      SPHI34(1)=0.
      SPHI34(2)=SIN(PHI34)
      SPHI34(3)=SIN(2.*PHI34)
C
      TCPHI=CPHI12(2)*CPHI34(2)-SPHI12(2)*SPHI34(2)
      TSPHI=SPHI12(2)*CPHI34(2)+CPHI12(2)*SPHI34(2)
      TC2PHI=CPHI12(3)*CPHI34(3)-SPHI12(3)*SPHI34(3)
      TS2PHI=SPHI12(3)*CPHI34(3)+CPHI12(3)*SPHI34(3)
C
C          Pure technirho --> WW. Calculate angular distribution for
C          decay and multiply by cross section.
C
      F0=.5*QMH**2/AMV**2-1.
      F1=1.
      TOTAL=(8.*PI/3.)**2*TVV12*TVV34*(F0**2+2.*F1**2)
      DIFF=F0**2*T12(1,1)*T34(1,1)
     $+F0*F1*(2.*T12(1,2)*T34(1,2)+2.*T12(1,3)*T34(1,3))*TCPHI
     $+F1**2*(T12(2,2)*T34(1,2)+T12(3,3)*T34(3,3)
     $  +2.*T12(2,3)*T34(2,3)*TC2PHI)
      WWSIG=SIGLLQ*DIFF/TOTAL
      RETURN
      END
+EOD
+DECK,SIGTC
      SUBROUTINE SIGTC
C
C          Compute the integrated technirho cross section
C          d(sigma)/d(qmw**2)d(yw) = d(sigma)/d(qmw**2)*f(x1)*f(x2)/scm
C          including W-technirho mixing from EHLQ 6.22 and 6.23 and 
C          elastic resonance in longitudinal WW fusion.
C
C          Use WTYPE for control with
C          WTYPE = 2     3     4
C                  rho+  rho-  rho0
C
C          SIGMA    = cross section summed over allowed types.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,JETSIG
+CDE,QSAVE
+CDE,WCON
+CDE,CONST
+CDE,JETLIM
+CDE,HCON
+CDE,TCPAR
C
      REAL AMQCUR(6),WTHELI(4),FINT(9),X(2)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT),(X(1),X1)
      INTEGER MATCHT(4,4)
      REAL ACOSH,Z,ATANH,AMASS,QMW2,QMZ,EHAT,ANEFF,Q2SAVE,YHAT,EY,AMW,
     $AMZ,STRUC,STRUCW,WM,ZM,PWWCM,SIG0,S,T,U,FACINV,RATZ,Q1L,Q1R,SIG1,
     $SIG,QZW
      INTEGER I,IH,IQ,IW,IQ1,IQ2,IQ3,IQ4,IRHO,LISTW(4)
C
      DATA AMQCUR/.005,.009,.175,1.25,4.50,30./
      DATA LISTW/10,80,-80,90/
      DATA MATCHT/0,0,0,0, 0,29,0,27, 0,0,29,28, 0,28,27,0/
C
C          Functions
      ACOSH(Z)=ALOG(Z+SQRT(Z**2-1.))
      ATANH(Z)=.5*ALOG((1.+Z)/(1.-Z))
C
C          Kinematics (identical to Drell-Yan)
C
      AMQCUR(6)=AMASS(6)
      QMW2=QMW**2
      QTMW=SQRT(QMW2+QTW**2)
      Q0W=QTMW*COSH(YW)
      QZW=QTMW*SINH(YW)
      QW=SQRT(QZW**2+QTW**2)
      IF(QW.NE.0.) THEN
        CTHW=QZW/QW
        STHW=QTW/QW
        IF(ABS(CTHW).LT.1.) THEN
          THW=ACOS(CTHW)
        ELSE
          CTHW=0.
          STHW=1.
          THW=.5*PI
        ENDIF
      ELSE
        CTHW=0.
        STHW=1.
        THW=.5*PI
      ENDIF
      EHAT=QMW
      SHAT=QMW**2
      QSQ=SHAT
      ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2)
      ALFQSQ=12.*PI/((33.-ANEFF)*ALOG(QSQ/ALAM2))
      Q2SAVE=QSQ
      YHAT=YW
      EY=EXP(YHAT)
      X1=EHAT/ECM*EY
      X2=EHAT/(ECM*EY)
C
C          Initialize
C
      SIGMA=0.
      NSIGS=0
      DO 100 I=1,MXSIGS
100   SIGS(I)=0
C
      IF(X1.GE.1..OR.X2.GE.1.) RETURN
      AMW=WMASS(2)
      AMZ=WMASS(4)
C
C          Compute structure functions
C
      DO 110 IH=1,2
        DO 120 IQ=1,13
120     QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
        DO 130 IQ=14,26
130     QSAVE(IQ,IH)=0.
        DO 140 IW=2,4
          AMW=AMASS(LISTW(IW))
          IF(QMW.GT.2.*AMW) THEN
            QSAVE(25+IW,IH)=STRUCW(X(IH),IW,IDIN(IH))/X(IH)
          ELSE
            QSAVE(25+IW,IH)=0.
          ENDIF
140     CONTINUE
110   CONTINUE
C
C          qk + qb --> technirho0
C
      IF(.NOT.((GOQ(27,1).AND.GOQ(28,2)).OR.(GOQ(28,1).AND.GOQ(27,2))))
     $GO TO 300
      WM=WMASS(2)
      ZM=WMASS(4)
      IF(QMW.LE.2.*AMW) GO TO 300
      PWWCM=.5*SQRT(QMW**2-4.*WM**2)
      SIG0=PI*ALFA**2/(72.*SIN2W*S)*(2.*PWWCM/QMW)**3*X1*X2*UNITS
      SIG0=SIG0*TCMRHO**2/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2)
C          Initial state sum
      DO 210 IQ1=2,13
        IQ2=MATCH(IQ1,4)
        IF(IQ2.EQ.0) GO TO 210
        FACINV=2.*SQRT(SIN2W*(1.-SIN2W))
        RATZ=S/(S-ZM**2)
        Q1L=AQ(IQ1/2,4)*FACINV
        Q1R=BQ(IQ1/2,4)*FACINV
        SIG1=.25*SIG0*(1.-RATZ*Q1L/(Q1R*(1.-SIN2W))
     $  +RATZ**2*(Q1L**2+Q1R**2)/(4.*(1-SIN2W)**2))
     $  *QSAVE(IQ1,1)*QSAVE(IQ2,2)
C          Final state sum
        DO 220 IQ3=27,28
          IQ4=MATCHT(IQ3-25,4)
          IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN
            SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2)
            CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4)
          ENDIF
220     CONTINUE
210   CONTINUE
C
C          W+ + W- -> technirho0 -> W+ + W-
C
      SIG0=12*PI/PWWCM**2*TCGRHO**2*X1*X2*UNITS
     $/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2)
C          Initial state sum
      DO 230 IQ1=27,28
        IQ2=MATCHT(IQ1-25,4)
        SIG1=.25*SIG0*QSAVE(IQ1,1)*QSAVE(IQ2,2)
C          Final state sum
        DO 240 IQ3=27,28
          IQ4=MATCHT(IQ3-25,4)
          IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN
            SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2)
            CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4)
          ENDIF
240     CONTINUE
230   CONTINUE
C
C          q + qbar -> technirho+-
C
300   IF(.NOT.((GOQ(27,1).AND.GOQ(29,2)).OR.(GOQ(28,1).AND.GOQ(29,2))
     $.OR.(GOQ(29,1).AND.GOQ(27,2)).OR.(GOQ(29,1).AND.GOQ(28,2))))
     $GO TO 400
      WM=WMASS(2)
      ZM=WMASS(4)
      IF(QMW.LE.WM+ZM) GO TO 400
      PWWCM=SQRT((S-WM**2-ZM**2)**2-4.*WM**2*ZM**2)/(2.*QMW)
      SIG0=PI*ALFA**2/(144.*SIN2W)*S/(S-WM**2)**2*(2.*PWWCM/QMW)**3
     $*X1*X2*UNITS
      SIG0=SIG0*TCMRHO**2/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2)
      DO 310 IRHO=2,3
C          Initial state sum
        DO 320 IQ1=2,13
          IQ2=MATCH(IQ1,IRHO)
          IF(IQ2.EQ.0) GO TO 320
          SIG1=.25*SIG0*QSAVE(IQ1,1)*QSAVE(IQ2,2)
C          Final state sum
          DO 330 IQ3=27,28
            IQ4=MATCHT(IQ3-25,IRHO)
            IF(IQ4.EQ.0) GO TO 330
            IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN
              SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2)
              CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4)
            ENDIF
330       CONTINUE
320     CONTINUE
310   CONTINUE
C
C          W+- + Z0 -> technirho+- -> W+- + Z0
C
      SIG0=12*PI/PWWCM**2*TCGRHO**2*X1*X2*UNITS
     $/((S-TCMRHO**2)**2+TCMRHO**2*TCGRHO**2)
      DO 340 IRHO=2,3
C          Initial state sum
        DO 350 IQ1=27,29
          IQ2=MATCHT(IQ1-25,IRHO)
          IF(IQ2.EQ.0) GO TO 350
          SIG1=.25*SIG0*QSAVE(IQ1,1)*QSAVE(IQ2,2)
C          Final state sum
          DO 360 IQ3=27,29
            IQ4=MATCHT(IQ3-25,IRHO)
            IF(IQ4.EQ.0) GO TO 360
            IF(GOQ(IQ3,1).AND.GOQ(IQ4,2)) THEN
              SIG=SIG1*TBRWW(IQ3-25,1)*TBRWW(IQ4-25,2)
              CALL SIGFIL(SIG,IQ1,IQ2,IQ3,IQ4)
            ENDIF
360       CONTINUE
350     CONTINUE
340   CONTINUE
C
400   RETURN
      END
+EOD
+DECK,SIGWH.
      SUBROUTINE SIGWH
C
C          Calculate d(sigma)/d(pt**2)d(y1)d(y2) for WH and ZH
C          associated production.
C
C          SIGMA    = cross section summed over types allowed by
C                     JETTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1
C
C          Extra factor of 1/2 needed for nonidentical final jets.
C          Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,CONST
+CDE,JETPAR
+CDE,JETSIG
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,QCDPAR
+CDE,WCON
+CDE,HCON
+CDE,XMSSM
C
      REAL X(2)
      EQUIVALENCE (X(1),X1)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      REAL SIG,S,T,U,FAC,AMW,AMZ,AMW2,AMZ2,E1,E2
      REAL QFCN,STRUC,SIGHW
      REAL PROPZ,PROPW,GV(2),GA(2),AMH,AMH2,GAMW,GAMZ
      INTEGER IS2UD(25),IQ,IH,I,IQ1,IQ2,IFLQ
      SAVE IS2UD
C
C          IS2UD: Susy jettype -> u/d code
      DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/

C          Functions
      QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
C
      IF (GOMSSM) THEN
        CALL SIGWHS
        RETURN
      END IF
C          Initialize
      DO 10 I=1,MXSIGS
10    SIGS(I)=0.
      SIGMA=0.
      NSIGS=0
C
      AMW=WMASS(2)
      AMW2=AMW**2
      AMZ=WMASS(4)
      AMZ2=AMZ**2
      AMH=HMASS
      AMH2=AMH**2
      GAMW=WGAM(2)
      GAMZ=WGAM(4)
      GV(1)=.25-2*SIN2W/3.
      GV(2)=-.25+SIN2W/3.
      GA(1)=-.25
      GA(2)=.25
C
C          WH production via W-*
C
      IF (GOQ(28,1).AND.GOQ(30,2)) THEN
          CALL TWOKIN(0.,0.,AMW,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 100
          E1=SQRT(P(1)**2+AMW**2)
          E2=SQRT(P(2)**2+AMH**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(3,1)
          SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2)
          CALL SIGFIL(SIG,3,4,28,30)
          SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2)
          CALL SIGFIL(SIG,4,3,28,30)
          SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2)
          CALL SIGFIL(SIG,9,6,28,30)
          SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2)
          CALL SIGFIL(SIG,6,9,28,30)
100       CONTINUE
      END IF
C
      IF (GOQ(30,1).AND.GOQ(28,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMW)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 110
          E1=SQRT(P(1)**2+AMH**2)
          E2=SQRT(P(2)**2+AMW**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(3,2)
          SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2)
          CALL SIGFIL(SIG,3,4,30,28)
          SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2)
          CALL SIGFIL(SIG,4,3,30,28)
          SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2)
          CALL SIGFIL(SIG,9,6,30,28)
          SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2)
          CALL SIGFIL(SIG,6,9,30,28)
110       CONTINUE
      END IF
C
C
C          WH production via W+*
C
      IF (GOQ(27,1).AND.GOQ(30,2)) THEN
          CALL TWOKIN(0.,0.,AMW,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 120
          E1=SQRT(P(1)**2+AMW**2)
          E2=SQRT(P(2)**2+AMH**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(2,1)
          SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2)
          CALL SIGFIL(SIG,2,5,27,30)
          SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2)
          CALL SIGFIL(SIG,5,2,27,30)
          SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2)
          CALL SIGFIL(SIG,8,7,27,30)
          SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2)
          CALL SIGFIL(SIG,7,8,27,30)
120       CONTINUE
      END IF
C
      IF (GOQ(30,1).AND.GOQ(27,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMW)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 130
          E1=SQRT(P(1)**2+AMH**2)
          E2=SQRT(P(2)**2+AMW**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(2,2)
          SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2)
          CALL SIGFIL(SIG,2,5,30,27)
          SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2)
          CALL SIGFIL(SIG,5,2,30,27)
          SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2)
          CALL SIGFIL(SIG,8,7,30,27)
          SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2)
          CALL SIGFIL(SIG,7,8,30,27)
130       CONTINUE
      END IF
C
C          ZH production via Z*
C          
      IF (GOQ(29,1).AND.GOQ(30,2)) THEN
          CALL TWOKIN(0.,0.,AMZ,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 200
          E1=SQRT(P(1)**2+AMZ2)
          E2=SQRT(P(2)**2+AMH2)
          FAC=1./(3.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 210 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 210
            SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)*
     $     (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,1)
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,29,30)
210         CONTINUE
200       CONTINUE
      END IF
C          HZ production via Z*
C          
      IF (GOQ(30,1).AND.GOQ(29,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMZ)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 220
          E1=SQRT(P(1)**2+AMH2)
          E2=SQRT(P(2)**2+AMZ2)
          FAC=1./(3.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 230 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 230
            SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)*
     $     (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,2)
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,30,29)
230         CONTINUE
220       CONTINUE
      END IF
      RETURN
      END
+EOD
+DECK,SIGWHS.
      SUBROUTINE SIGWHS
C
C          Calculate d(sigma)/d(pt**2)d(y1)d(y2) for 
C          Wh, WH, Zh, ZH, hA, HA and H+H- production in SUSY
C
C          SIGMA    = cross section summed over types allowed by
C                     JETTYPE cards.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 +I1
C
C          Extra factor of 1/2 needed for nonidentical final jets.
C          Y=-log(tan(theta/2)) gives jacobean P1*P2/E1*E2
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,CONST
+CDE,JETPAR
+CDE,JETSIG
+CDE,PRIMAR
+CDE,Q1Q2
+CDE,QCDPAR
+CDE,WCON
+CDE,SSPAR
C
      REAL X(2)
      EQUIVALENCE (X(1),X1)
      EQUIVALENCE (S,SHAT),(T,THAT),(U,UHAT)
      REAL SIG,S,T,U,FAC,AMW,AMZ,AMW2,AMZ2,E1,E2,EQ1
      REAL QFCN,STRUC,SIGHW,SCFAC,BETA,SINW,COS2W
      REAL PROPZ,PROPW,GV(2),GA(2),AMH,GAMW,GAMZ
      INTEGER IS2UD(25),IQ,IH,I,IQ1,IQ2,IFLQ
      SAVE IS2UD
C
C          IS2UD: Susy jettype -> u/d code
      DATA IS2UD/0,1,1,2,2,2,2,1,1,2,2,1,1,1,1,2,2,2,2,1,1,2,2,1,1/

C          Functions
      QFCN(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
C
C          Initialize
      DO 10 I=1,MXSIGS
10    SIGS(I)=0.
      SIGMA=0.
      NSIGS=0
C
      BETA=ATAN(1./RV2V1)
      AMW=WMASS(2)
      AMW2=AMW**2
      AMZ=WMASS(4)
      AMZ2=AMZ**2
      GAMW=WGAM(2)
      GAMZ=WGAM(4)
      GV(1)=.25-2*SIN2W/3.
      GV(2)=-.25+SIN2W/3.
      GA(1)=-.25
      GA(2)=.25
      SINW=SQRT(SIN2W)
      THW=ASIN(SINW)
      COS2W=COS(2*THW)
      DO IH=81,82
      IF (IH.EQ.81) THEN
        SCFAC=SIN(ALFAH+BETA)**2
        AMH=AMHL
      ELSE
        SCFAC=COS(ALFAH+BETA)**2
        AMH=AMHH
      END IF
C
C          Wh, WH production via W-*
C
      IF (GOQ(79,1).AND.GOQ(IH,2)) THEN
          CALL TWOKIN(0.,0.,AMW,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 100
          E1=SQRT(P(1)**2+AMW**2)
          E2=SQRT(P(2)**2+AMH**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(3,1)*SCFAC
          SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2)
          CALL SIGFIL(SIG,3,4,79,IH)
          SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2)
          CALL SIGFIL(SIG,4,3,79,IH)
          SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2)
          CALL SIGFIL(SIG,9,6,79,IH)
          SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2)
          CALL SIGFIL(SIG,6,9,79,IH)
100       CONTINUE
      END IF
C
      IF (GOQ(IH,1).AND.GOQ(79,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMW)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 110
          E1=SQRT(P(1)**2+AMH**2)
          E2=SQRT(P(2)**2+AMW**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(3,2)*SCFAC
          SIG=.5*SIGHW*FAC*QFCN(3,1)*QFCN(4,2)
          CALL SIGFIL(SIG,3,4,IH,79)
          SIG=.5*SIGHW*FAC*QFCN(4,1)*QFCN(3,2)
          CALL SIGFIL(SIG,4,3,IH,79)
          SIG=.5*SIGHW*FAC*QFCN(9,1)*QFCN(6,2)
          CALL SIGFIL(SIG,9,6,IH,79)
          SIG=.5*SIGHW*FAC*QFCN(6,1)*QFCN(9,2)
          CALL SIGFIL(SIG,6,9,IH,79)
110       CONTINUE
      END IF
C
C
C          Wh, WH production via W+*
C
      IF (GOQ(78,1).AND.GOQ(IH,2)) THEN
          CALL TWOKIN(0.,0.,AMW,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 120
          E1=SQRT(P(1)**2+AMW**2)
          E2=SQRT(P(2)**2+AMH**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(2,1)*SCFAC
          SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2)
          CALL SIGFIL(SIG,2,5,78,IH)
          SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2)
          CALL SIGFIL(SIG,5,2,78,IH)
          SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2)
          CALL SIGFIL(SIG,8,7,78,IH)
          SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2)
          CALL SIGFIL(SIG,7,8,78,IH)
120       CONTINUE
      END IF
C
      IF (GOQ(IH,1).AND.GOQ(78,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMW)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 130
          E1=SQRT(P(1)**2+AMH**2)
          E2=SQRT(P(2)**2+AMW**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPW=(S-AMW**2)**2+AMW**2*GAMW**2
          SIGHW=GF**2*AMW**8*(S/AMW2+(1.-T/AMW2)*(1.-U/AMW2))/
     $          PROPW*TBRWW(2,2)*SCFAC
          SIG=.5*SIGHW*FAC*QFCN(2,1)*QFCN(5,2)
          CALL SIGFIL(SIG,2,5,IH,78)
          SIG=.5*SIGHW*FAC*QFCN(5,1)*QFCN(2,2)
          CALL SIGFIL(SIG,5,2,IH,78)
          SIG=.5*SIGHW*FAC*QFCN(8,1)*QFCN(7,2)
          CALL SIGFIL(SIG,8,7,IH,78)
          SIG=.5*SIGHW*FAC*QFCN(7,1)*QFCN(8,2)
          CALL SIGFIL(SIG,7,8,IH,78)
130       CONTINUE
      END IF
C
C          Zh, ZH production via Z*
C          
      IF (GOQ(80,1).AND.GOQ(IH,2)) THEN
          CALL TWOKIN(0.,0.,AMZ,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 200
          E1=SQRT(P(1)**2+AMZ2)
          E2=SQRT(P(2)**2+AMH**2)
          FAC=1./(3.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 210 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 210
            SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)*
     $     (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,1)*SCFAC
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,80,IH)
210         CONTINUE
200       CONTINUE
      END IF
C          hZ, HZ production via Z*
C          
      IF (GOQ(IH,1).AND.GOQ(80,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMZ)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 220
          E1=SQRT(P(1)**2+AMH**2)
          E2=SQRT(P(2)**2+AMZ2)
          FAC=1./(3.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 230 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 230
            SIG=GF**2*AMZ**8*(GV(IFLQ)**2+GA(IFLQ)**2)*
     $     (S/AMZ2+(1.-T/AMZ2)*(1.-U/AMZ2))/PROPZ*TBRWW(4,2)*SCFAC
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,IH,80)
230         CONTINUE
220       CONTINUE
      END IF
C
C     Next, do Ah and AH production
C
      IF (GOQ(83,1).AND.GOQ(IH,2)) THEN
          CALL TWOKIN(0.,0.,AMHA,AMH)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 240
          E1=SQRT(P(1)**2+AMHA**2)
          E2=SQRT(P(2)**2+AMH**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 250 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 250
            SIG=GF**2*AMZ**4*(GV(IFLQ)**2+GA(IFLQ)**2)*
     $          ((AMHA**2+U-T-AMH**2)*(AMHA**2+T-U-AMH**2)-
     $          S*(2*AMHA**2+2*AMH**2-S))/PROPZ*SCFAC
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,83,IH)
250         CONTINUE
240       CONTINUE
      END IF
      IF (GOQ(IH,1).AND.GOQ(83,2)) THEN
          CALL TWOKIN(0.,0.,AMH,AMHA)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 260
          E1=SQRT(P(1)**2+AMH**2)
          E2=SQRT(P(2)**2+AMHA**2)
          FAC=1./(12.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 270 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 270
            SIG=GF**2*AMZ**4*(GV(IFLQ)**2+GA(IFLQ)**2)*
     $          ((AMHA**2+U-T-AMH**2)*(AMHA**2+T-U-AMH**2)-
     $          S*(2*AMHA**2+2*AMH**2-S))/PROPZ*SCFAC
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,IH,83)
270         CONTINUE
260       CONTINUE
      END IF
      END DO
C
C     Next, do H+H- production
C
      IF (GOQ(84,1).AND.GOQ(85,2)) THEN
          CALL TWOKIN(0.,0.,AMHC,AMHC)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 300
          E1=SQRT(P(1)**2+AMHC**2)
          E2=SQRT(P(2)**2+AMHC**2)
          FAC=1./(96.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 310 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 310
            SIG=((4*PI*ALFA)**2*EQ1**2/S/S+32*PI*ALFA*EQ1*GF*AMZ**2*
     $          COS2W*GV(IFLQ)*(S-AMZ**2)/S/PROPZ/SQRT2+8*GF**2*
     $          AMZ**4*COS2W**2*(GV(IFLQ)**2+GA(IFLQ)**2)/PROPZ)*
     $          ((U-T)*(T-U)-S*(4*AMHC**2-S))
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,84,85)
310         CONTINUE
300       CONTINUE
      END IF
      IF (GOQ(85,1).AND.GOQ(84,2)) THEN
          CALL TWOKIN(0.,0.,AMHC,AMHC)
          IF(X1.GE.1..OR.X2.GE.1.) GO TO 320
          E1=SQRT(P(1)**2+AMHC**2)
          E2=SQRT(P(2)**2+AMHC**2)
          FAC=1./(96.*PI*S**2)
          FAC=FAC*S/SCM*(P(1)*P(2)/(E1*E2))*UNITS
          PROPZ=(S-AMZ**2)**2+AMZ**2*GAMZ**2
          DO 330 IQ1=2,11
            IFLQ=IS2UD(IQ1)
            IQ2=MATCH(IQ1,4)
            IF (IFLQ.EQ.1) THEN
              EQ1=2./3.
            ELSE
              EQ1=-1./3.
            END IF
            IF (IQ2.EQ.0.OR.IQ2.GE.12) GO TO 330
            SIG=((4*PI*ALFA)**2*EQ1**2/S/S+32*PI*ALFA*EQ1*GF*AMZ**2*
     $          COS2W*GV(IFLQ)*(S-AMZ**2)/S/PROPZ/SQRT2+8*GF**2*
     $          AMZ**4*COS2W**2*(GV(IFLQ)**2+GA(IFLQ)**2)/PROPZ)*
     $          ((U-T)*(T-U)-S*(4*AMHC**2-S))
            SIG=.5*SIG*FAC*QFCN(IQ1,1)*QFCN(IQ2,2)
            CALL SIGFIL(SIG,IQ1,IQ2,85,84)
330         CONTINUE
320       CONTINUE
      END IF
      RETURN
      END
+EOD
+DECK,SIGWW2.
      SUBROUTINE SIGWW2
C
C          Calculate WPAIR decay distribution
C          D(SIGMA)/D(PT**2)D(Y1)D(Y2)D(OMEGA1)D(OMEGA2)
C          for modes selected in WPAIR.
C
C          Also fix the initial parton types to those selected.
C
C          Cross sections from SCHOONSCHIP (1980) neglecting W width
C          and quark masses. Hence use zero-mass vectors PZERO from
C          WPAIR to define kinematics.
C          QK(P1) + QB(P2) --> W1(P3) + W2(P4)
C                   W1(P3) --> QK(Q1) + QB(Q2)
C                   W2(P4) --> QK(Q3) + QB(Q4)
C          S=(P3+P4)**2,  T=(P3-P1)**2,  U=(P3-P2)**2
C          S1=(Q1+P4)**2, T1=(Q1-P1)**2, U1=(Q1-P2)**2
C          S3=(Q3+P3)**2, T3=(Q3-P2)**2, U3=(Q3-P1)**2
C          S13=(Q1+Q3)**2
C          Note that the W+- final couplings have been set equal to 1.
C          in the SCHOONSCHIP formulas and must be restored.
C
C          Need double precision for 32-bit machines.
C
C          Ver. 5.35 - correct symmetrization for DN DB -> W+ W-.
C          Ver. 6.22 - use W + GM decay distributions from
C                      Cortes, Hagiwara, and Herzog, NP B278, 26 (1986)
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,QCDPAR.
+CDE,JETPAR.
+CDE,PRIMAR.
+CDE,Q1Q2.
+CDE,CONST.
+CDE,QSAVE.
+CDE,WCON.
+CDE,PJETS.
+CDE,PINITS
+CDE,WWSIG.
+CDE,WWPAR.
C
      DIMENSION P1(5),P2(5),QSGN(6),PP1(4),PP2(4)
      EQUIVALENCE (S,SWW),(T,TWW),(U,UWW)
      EQUIVALENCE (P1(1),P1WW(1)),(P2(1),P2WW(1))
C          Double precision kinematics for 32-bit.
+SELF,IF=SINGLE.
      REAL S,T,U,T1,U1,T3,U3,P1,P2
     1,TX,UX,TT,UU,TT1,UU1,TT3,UU3,PP1,PP2
      REAL TERM,WWSS,WWST,WWTT,ZZALL,WZSS,WZST,WZSU,WZTU
     1,WGSS,WGST,WGSU,WGTU
+SELF,IF=DOUBLE.
      DOUBLE PRECISION S,T,U,T1,U1,T3,U3,P1,P2
     1,TX,UX,TT,UU,TT1,UU1,TT3,UU3,PP1,PP2
      DOUBLE PRECISION TERM,WWSS,WWST,WWTT,ZZALL,WZSS,WZST,WZSU,WZTU
     1,WGSS,WGST,WGSU,WGTU
+SELF.
      REAL P3IS3,P3IS4,FJAC,AMW1,AMW2,GAM1,GAM2,SGN,QSGN,AMASS3
      REAL P1DQ2,P2DQ1
      REAL A1,B1,A2,B2,ES,SMS,SMSZG,EQ3(12)
      REAL Q(5),QB(5),KK(5),E(5),EB(5)
      INTEGER K,JQ1,JQ3,JW1,JW2,IW1,IW2,IQ1,IQ2,IQ,ISWAPQ,JW,JZ,ISGN
      INTEGER IFLI,IFLJ,JG,IL,IW
      LOGICAL LQK1
C
      DATA QSGN/1.,-1.,-1.,1.,-1.,1./
      DATA EQ3/2.,-1.,-1.,2.,-1.,2.,0.,-3.,0.,-3.,0.,-3./
C
C          Entry
C
      ES=4*PI*ALFA
      WWSIG=0.
      IF(IDJETS(1).EQ.10.OR.IDJETS(2).EQ.10) GO TO 2
C          Normal case
      IF((IDJETS(1).EQ.80.AND.IDJETS(2).EQ.-80).OR.
     $(IDJETS(1).EQ.90.AND.IDJETS(2).EQ.90).OR.
     $(IABS(IDJETS(1)).EQ.80.AND.IDJETS(2).EQ.90)) THEN
        DO 10 K=1,4
          P3(K)=P3WW(K)
          Q1(K)=PZERO(K,1)
          Q3(K)=PZERO(K,3)
10      CONTINUE
        P3IS3=1.
        P3IS4=0.
        JQ1=1
        JQ3=3
        JW1=1
        JW2=2
        TX=T
        UX=U
C          Crossed case
      ELSE
        DO 20 K=1,4
          P3(K)=P4WW(K)
          Q1(K)=PZERO(K,3)
          Q3(K)=PZERO(K,1)
20      CONTINUE
        P3IS3=0.
        P3IS4=1.
        JQ1=3
        JQ3=1
        JW1=2
        JW2=1
        TX=U
        UX=T
      ENDIF
C          Variables
      T1=-2.*(Q1(4)*P1(4)-Q1(1)*P1(1)-Q1(2)*P1(2)-Q1(3)*P1(3))
      U1=-2.*(Q1(4)*P2(4)-Q1(1)*P2(1)-Q1(2)*P2(2)-Q1(3)*P2(3))
      T3=-2.*(Q3(4)*P2(4)-Q3(1)*P2(1)-Q3(2)*P2(2)-Q3(3)*P2(3))
      U3=-2.*(Q3(4)*P1(4)-Q3(1)*P1(1)-Q3(2)*P1(2)-Q3(3)*P1(3))
      S13=2.*(Q1(4)*Q3(4)-Q1(1)*Q3(1)-Q1(2)*Q3(2)-Q1(3)*Q3(3))
C          Jacobean for 4-body cross section in terms of squared
C          matrix exement in narrow resonance approximation--
C          1/((P**2-M**2)**2+M**2*GAM**2)=1/(2*M*GAM)*DELTA(P**2-M**2)
      FJAC=S/SCM*UNITS
      FJAC=FJAC*ALFA**4/(256.*PI*3.*S**2)
      AMW1=PJETS(5,1)
      AMW2=PJETS(5,2)
      GAM1=WGAM(JETTYP(1))
      GAM2=WGAM(JETTYP(2))
      FJAC=FJAC/(AMW1*GAM1*AMW2*GAM2)
      FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+AMW1**2)*(P(2)**2+AMW2**2))
C          Color factor
      IF(IABS(IDPAIR(1)).LT.10) FJAC=3.*FJAC
      IF(IABS(IDPAIR(3)).LT.10) FJAC=3.*FJAC
C
C          W+ W- pair decays
C          Standard order is UP + UB --> W+ + W-
C
      IF(.NOT.((JETTYP(1).EQ.2.AND.JETTYP(2).EQ.3).OR.(JETTYP(1).EQ.3
     1.AND.JETTYP(2).EQ.2))) GO TO 200
      FJAC=.5*FJAC*AQ(2,2)**4
C
C          Select W+ W- OR W- W+, swapping T and U for latter.
      IW1=JETTYP(1)
      IW2=JETTYP(2)
C
C          Select quarks
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IQ=IQ1/2
      CQ=AQDP(IQ,2)**2
      CV=AQDP(IQ,1)/S+EZDP*AQDP(IQ,4)/(S-ZM2)
      CA=EZDP*BQDP(IQ,4)/(S-ZM2)
      SGN=QSGN(IQ)
      ISWAPQ=1
      IF(SGN.LT.0.) ISWAPQ=-1
      IF(ISWAPQ.GT.0) THEN
        TT=TX
        UU=UX
        TT1=T1
        UU1=U1
        TT3=T3
        UU3=U3
        DO 122 K=1,4
          PP1(K)=P1(K)
          PP2(K)=P2(K)
          P3(K)=P3IS3*P3WW(K)+P3IS4*P4WW(K)
          Q1(K)=PZERO(K,JQ1)
          Q3(K)=PZERO(K,JQ3)
122     CONTINUE
      ELSE
        TT=UX
        UU=TX
        TT1=U3
        UU1=T3
        TT3=U1
        UU3=T1
        DO 123 K=1,4
          PP1(K)=P1(K)
          PP2(K)=P2(K)
          P3(K)=P3IS4*P3WW(K)+P3IS3*P4WW(K)
          Q1(K)=PZERO(K,JQ3)
          Q3(K)=PZERO(K,JQ1)
123     CONTINUE
      ENDIF
C
      IF(IQ1.EQ.2*IQ) THEN
        TERM=WWTT(TT,UU,TT1,UU1,TT3,UU3)
        TERM=TERM-SGN*WWST(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2)
        TERM=TERM+WWSS(TT,UU,TT1,UU1,TT3,UU3)
        WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC
      ELSE
        TERM=WWTT(UU,TT,UU1,TT1,UU3,TT3)
        TERM=TERM-SGN*WWST(UU,TT,UU1,TT1,UU3,TT3,PP2,PP1)
        TERM=TERM+WWSS(UU,TT,UU1,TT1,UU3,TT3)
        WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC
      ENDIF
C
      RETURN
C
C          Z0 Z0 pair decays
C          Standard order is UP + UB --> Z0 + Z0
C
200   IF(.NOT.(JETTYP(1).EQ.4.AND.JETTYP(2).EQ.4)) GO TO 300
      FJAC=.5*FJAC
C
C          Select quarks
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IQ=IQ1/2
      CV=AQDP(IQ,4)**2+BQDP(IQ,4)**2
      CA=2.*AQDP(IQ,4)*BQDP(IQ,4)
      CV1=AQDP(JQWW(1),4)**2+BQDP(JQWW(1),4)**2
      CA1=2.*AQDP(JQWW(1),4)*BQDP(JQWW(1),4)
      CV3=AQDP(JQWW(2),4)**2+BQDP(JQWW(2),4)**2
      CA3=2.*AQDP(JQWW(2),4)*BQDP(JQWW(2),4)
C
      TERM=ZZALL(TX,UX,T1,U1,T3,U3,P1,P2)
      IF(INITYP(1).EQ.2*IQ) THEN
        WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC
      ELSE
        WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC
      ENDIF
C
      RETURN
C
C          W+- Z0 pair decays
C          Standard order is DN + UB --> W- + Z0
C
300   JW=JW1
      JZ=JW2
      ISGN=-ISIGN(1,IDJETS(JW))
      SGN=ISGN
      CV3=AQDP(JQWW(JZ),4)**2+BQDP(JQWW(JZ),4)**2
      CA3=2.*AQDP(JQWW(JZ),4)*BQDP(JQWW(JZ),4)
      FJAC=.5*FJAC*AQ(1,2)**2
C
C          Select quarks. Formulas are for DN UB --> W- Z0.
C          Use symmetry for other cases.
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IQ=IQ1/2
C          Find whether IQ1 should be fermion or antifermion.
      IF(IQ1.EQ.2*(IQ1/2)) THEN
        ISWAPQ=+1
        IFLI=IQ1/2
        IFLJ=IQ2/2
      ELSE
        ISWAPQ=-1
        IFLI=IQ2/2
        IFLJ=IQ1/2
      ENDIF
C
      CS=AQDP(IQ,JETTYP(JW))*EZDP/(S-WM2)
      CT=AQDP(IQ,JETTYP(JW))*(AQDP(IFLJ,4)+BQDP(IFLJ,4))
      CU=AQDP(IQ,JETTYP(JW))*(AQDP(IFLI,4)+BQDP(IFLI,4))
C
C          SWAP T AND U AS NEEDED
      IF(ISWAPQ*ISGN.GT.0) THEN
        TT=TX
        UU=UX
        TT1=T1
        UU1=U1
        TT3=T3
        UU3=U3
        DO 321 K=1,4
          PP1(K)=P1(K)
          PP2(K)=P2(K)
321     CONTINUE
      ELSE
        TT=UX
        UU=TX
        TT1=U1
        UU1=T1
        TT3=U3
        UU3=T3
        DO 323 K=1,4
          PP1(K)=P2(K)
          PP2(K)=P1(K)
323     CONTINUE
      ENDIF
C
      TERM=WZSS(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2)
      TERM=TERM-SGN*WZST(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2)
      TERM=TERM-SGN*WZSU(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2)
      TERM=TERM+WZTU(TT,UU,TT1,UU1,TT3,UU3,PP1,PP2)
      WWSIG=TERM*QSAVE(IQ1,1)*QSAVE(IQ2,2)*FJAC
C
      RETURN
C
C     Do Z+gamma or W+gamma 3-body subprocesses
C
2     CONTINUE
C
C          Z+gamma
C          Standard order is UP + UB --> Z0 + gamma
C
      IF(.NOT.(JETTYP(1).EQ.4.AND.JETTYP(2).EQ.1)) GO TO 505
      FJAC=S/SCM*P(1)/SQRT(P(1)**2+WMASS(4)**2)*UNITS
C
C          Select quarks
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IQ=IQ1/2
      A1=-AQ(IQ,4)
      B1=BQ(IQ,4)
      A2=-AQ(JQWW(1),4)
      B2=BQ(JQWW(1),4)
      DO K=1,5
        Q(K)=SNGL(P1WW(K))
        QB(K)=SNGL(P2WW(K))
        KK(K)=SNGL(P4WW(K))
        E(K)=SNGL(PZERO(K,1))
        EB(K)=SNGL(PZERO(K,2))
      END DO
C
      IF(INITYP(1).EQ.2*IQ) THEN
        SMS=SMSZG(Q,QB,KK,E,EB,A1,B1,A2,B2)
        TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2
        WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC/2.
      ELSE
        SMS=SMSZG(QB,Q,KK,E,EB,A1,B1,A2,B2)
        TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2
        WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC/2.
      ENDIF
505   IF(.NOT.(JETTYP(1).EQ.1.AND.JETTYP(2).EQ.4)) GO TO 509
      FJAC=S/SCM*P(2)/SQRT(P(2)**2+WMASS(4)**2)*UNITS
C
C          Select quarks
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IQ=IQ1/2
      A1=-AQ(IQ,4)
      B1=BQ(IQ,4)
      A2=-AQ(JQWW(2),4)
      B2=BQ(JQWW(2),4)
      DO K=1,5
        Q(K)=SNGL(P1WW(K))
        QB(K)=SNGL(P2WW(K))
        KK(K)=SNGL(P3WW(K))
        E(K)=SNGL(PZERO(K,1))
        EB(K)=SNGL(PZERO(K,2))
      END DO
C
      IF(INITYP(1).EQ.2*IQ) THEN
        SMS=SMSZG(Q,QB,KK,E,EB,A1,B1,A2,B2)
        TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2
        WWSIG=TERM*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC/2.
      ELSE
        SMS=SMSZG(QB,Q,KK,E,EB,A1,B1,A2,B2)
        TERM=ES**3*(EQ3(IQ)/3.)**2*SMS/192./PI**4/WMASS(4)/WGAM(4)/S**2
        WWSIG=TERM*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC/2.
      ENDIF

C          W+- GM pair decays
C          Standard order is DN + UB --> W- + GM
C
C          Swap if W is jet 2
509   IF (ABS(IDJETS(1)).EQ.80.OR.ABS(IDJETS(2)).EQ.80) THEN
      IF(IDJETS(2).EQ.10) THEN
        DO 510 K=1,4
          P3(K)=P3WW(K)
          Q1(K)=PZERO(K,1)
510     CONTINUE
        AMASS3=PJETS(5,1)
        JW=1
        JG=2
        TX=T
        UX=U
      ELSE
        DO 520 K=1,4
          P3(K)=P4WW(K)
          Q1(K)=PZERO(K,1)
520     CONTINUE
        AMASS3=PJETS(5,2)
        JW=2
        JG=1
        TX=U
        UX=T
      ENDIF
      IF(IDJETS(JW).EQ.80) THEN
        IW=2
      ELSE
        IW=3
      ENDIF
C
      T1=-2.*(Q1(4)*P1(4)-Q1(1)*P1(1)-Q1(2)*P1(2)-Q1(3)*P1(3))
      U1=-2.*(Q1(4)*P2(4)-Q1(1)*P2(1)-Q1(2)*P2(2)-Q1(3)*P2(3))
C          Jacobean
      FJAC=S/SCM*UNITS
      FJAC=FJAC*P(JW)/SQRT(P(JW)**2+WM2)
C          Sum over quarks. Formulas are for DN UB --> W- GM.
C          Use symmetry for other cases.
      IQ1=INITYP(1)
      IQ2=INITYP(2)
      IQ=IQ1/2
      IF(2*IQ.EQ.IQ1) THEN
        LQK1=.TRUE.
      ELSE
        LQK1=.FALSE.
      ENDIF
C          Swap t and u as necessary
      IF((LQK1.AND.IW.EQ.3).OR.(.NOT.LQK1.AND.IW.EQ.2)) THEN
        TT=TX
        UU=UX
        TT1=T1
        UU1=U1
      ELSE
        TT=UX
        UU=TX
        TT1=U1
        UU1=T1
      ENDIF
C          Lepton or quark pointer
      IL=IABS(IDPAIR(1))
      IF(IL.GT.6) IL=IL-4
C
C          Matrix element - properly crossed variables.
C          Remember PZERO(K,1) is always the fermion.
      IF(LQK1) THEN
        P1DQ2=P1(4)*PZERO(4,2)-P1(1)*PZERO(1,2)-P1(2)*PZERO(2,2)
     $  -P1(3)*PZERO(3,2)
        P2DQ1=P2(4)*PZERO(4,1)-P2(1)*PZERO(1,1)-P2(2)*PZERO(2,1)
     $  -P2(3)*PZERO(3,1)
      ELSE
        P1DQ2=P2(4)*PZERO(4,2)-P2(1)*PZERO(1,2)-P2(2)*PZERO(2,2)
     $  -P2(3)*PZERO(3,2)
        P2DQ1=P1(4)*PZERO(4,1)-P1(1)*PZERO(1,1)-P1(2)*PZERO(2,1)
     $  -P1(3)*PZERO(3,1)
      ENDIF
      TERM=ALFA**2/(8.*SIN2W*S**2)*TBRWW(IW,JW)*RBRWW(IL,IW,JW)
     $*(-1./3.+UU/(TT+UU))**2/(TT*UU)*(4.*P2DQ1**2+4.*P1DQ2**2)
      WWSIG=TERM*QSAVE(IQ1,1)*QSAVE(IQ2,2)*FJAC
      END IF
C
      RETURN
      END
+EOD
+DECK,SIGWW.
      SUBROUTINE SIGWW
C
C          Calculate D(SIGMA)/D(PT**2)D(Y1)D(Y2) for QK+QB-->W+W
C          summed over W types allowed on JETTYPE cards and
C          including branching ratio implied by WMODE cards.
C
C          SIGMA    = cross section summed over quark types allowed by
C                     JETTYPE card.
C          SIGS(I)  = partial cross section for I1 + I2 --> I3 + I4.
C          INOUT(I) = IOPAK**3*I4 + IOPAK**2*I3 + IOPAK*I2 + I1
C                     using JETTYPE code.
C
C          Cross sections from Brown and Mikaelian,
C          Phys Rev D19, 922, D20, 1164.
C          Include extra factor of 1/2 for double counting.
C
C          Double precision needed for 32-bit machines.
C
C          Ver. 6.22: Modified to used W + GM decay distributions from
C                     Cortes, Hagiwara, and Herzog, NP B278, 26 (1986)
C
+SELF,IF=IMPNONE.
      IMPLICIT NONE
+SELF.
+CDE,ITAPES
+CDE,QCDPAR.
+CDE,JETPAR.
+CDE,PRIMAR.
+CDE,Q1Q2.
+CDE,JETSIG.
+CDE,CONST.
+CDE,QSAVE.
+CDE,WCON.
+CDE,WWPAR.
C
      DIMENSION X(2),LISTW(4),QSGN(6)
      EQUIVALENCE (X(1),X1)
      EQUIVALENCE (S,SWW),(T,TWW),(U,UWW)
+SELF,IF=SINGLE.
      REAL S,T,U,TX,UX,TT,UU
     $,WWA,WWI,WWE,WZA,WZI,WZE,TERM
     $,GA,GI,GE,GJ,GZ
+SELF,IF=DOUBLE.
      DOUBLE PRECISION S,T,U,TX,UX,TT,UU
     $,WWA,WWI,WWE,WZA,WZI,WZE,TERM
     $,GA,GI,GE,GJ,GZ
+SELF.
      REAL WM2S,ZM2S,X,STRUC,FJAC,SGN,QSGN,SIG,FACTOR,EQ3(12)
      INTEGER I,IH,IQ,IW1,IW2,JW,JZ,IW,IQ1,IQ2,JG,LISTW,IFOUR
      INTEGER IFLI,IFLJ
      LOGICAL LQK1
C
      DATA LISTW/10,80,-80,90/
      DATA QSGN/1.,-1.,-1.,1.,-1.,1./
      DATA EQ3/2.,-1.,-1.,2.,-1.,2.,0.,-3.,0.,-3.,0.,-3./
C
C          Functions for W+W-
      WWA(S,T,U)=(U*T/WM2**2-1.)*(.25-WM2/S+3.*(WM2/S)**2)+S/WM2-4.
      WWI(S,T,U)=(U*T/WM2**2-1.)*(.25-.5*WM2/S-WM2**2/(S*T))
     $+S/WM2-2.+2.*WM2/T
      WWE(S,T,U)=(U*T/WM2**2-1.)*(.25+(WM2/T)**2)+S/WM2
C          Functions for W+-Z0
      WZA(S,T,U)=(U*T/(WM2*ZM2)-1.)*(.25-(WM2+ZM2)/(2.*S)
     $+((WM2+ZM2)**2+8.*WM2*ZM2)/(4.*S**2))
     $+(WM2+ZM2)/(WM2*ZM2)*(.5*S-WM2-ZM2+(WM2-ZM2)**2/(2.*S))
      WZI(S,T,U)=.25*(U*T/(WM2*ZM2)-1.)*(1.-(WM2+ZM2)/S
     $-4.*WM2*ZM2/(S*T))
     $+(WM2+ZM2)/(2.*WM2*ZM2)*(S-WM2-ZM2+2.*WM2*ZM2/T)
      WZE(S,T,U)=.25*(U*T/(WM2*ZM2)-1.)+.5*S*(WM2+ZM2)/(WM2*ZM2)
C
C          Initialize
      DO 10 I=1,MXSIGS
10    SIGS(I)=0.
      SIGMA=0.
      NSIGS=0
C
C          Convention is that even for double precision single
C          precision mass is exact.
      WM2=WMASS(2)
      WM2=WM2**2
      ZM2=WMASS(4)
      ZM2=ZM2**2
C          Also need single precision mass**2.
      WM2S=WM2
      ZM2S=ZM2
C
C          W+ W- pairs
C
      IF(.NOT.((GOQ(2,1).AND.GOQ(3,2)).OR.(GOQ(3,1).AND.GOQ(2,2))))
     $GO TO 200
      CALL WWKIN(WMASS(2),WMASS(2))
      IF(X1.GE.1..OR.X2.GE.1.) GO TO 200
      DO 110 IH=1,2
      DO 110 IQ=2,9
110   QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      FJAC=S/SCM*UNITS
      FJAC=FJAC*PI*ALFA**2/(3.*S**2)
      FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+WM2S)*(P(2)**2+WM2S))
      FJAC=.5*FJAC
C          Sum over jet1 = W+ and jet2 = W+.
C          Swap t and u in latter case.
      DO 120 IW1=2,3
      IW2=5-IW1
      IF(.NOT.(GOQ(IW1,1).AND.GOQ(IW2,2))) GO TO 120
      IF(IW1.EQ.3) GO TO 121
      TX=T
      UX=U
      GO TO 122
121   TX=U
      UX=T
C
C          Sum over quarks, swapping t and u for negative charge.
122   DO 130 IQ=1,4
      GA=2.*(AQDP(IQ,1)+EZDP*AQDP(IQ,4)*S/(S-ZM2))**2
     $+2.*(EZDP*BQDP(IQ,4)*S/(S-ZM2))**2
      GI=8.*(AQDP(IQ,1)+EZDP*(AQDP(IQ,4)+BQDP(IQ,4))*S/(S-ZM2))
     $*(AQDP(IQ,2))**2
      GE=16.*(AQDP(IQ,2))**4
      SGN=QSGN(IQ)
      IF(SGN.LT.0.) GO TO 131
      TT=TX
      UU=UX
      GO TO 132
131   TT=UX
      UU=TX
132   SIG=QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)*FJAC*TBRWW(IW1,1)*TBRWW(IW2,2)
     $*(GA*WWA(S,TT,UU)-SGN*GI*WWI(S,TT,UU)+GE*WWE(S,TT,UU))
      CALL SIGFIL(SIG,2*IQ,2*IQ+1,IW1,IW2)
      SIG=QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)*FJAC*TBRWW(IW1,1)*TBRWW(IW2,2)
     $*(GA*WWA(S,UU,TT)-SGN*GI*WWI(S,UU,TT)+GE*WWE(S,UU,TT))
      CALL SIGFIL(SIG,2*IQ+1,2*IQ,IW1,IW2)
130   CONTINUE
120   CONTINUE
C
C          Z0 Z0 pairs
C
200   IF(.NOT.(GOQ(4,1).AND.GOQ(4,2))) GO TO 300
      CALL WWKIN(WMASS(4),WMASS(4))
      IF(X1.GE.1..OR.X2.GE.1.) RETURN
      DO 210 IH=1,2
      DO 210 IQ=2,9
210   QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
C          Jacobean -- including factor of 1/2 for identical particles.
      FJAC=.5*S/SCM*UNITS
      FJAC=FJAC*PI*ALFA**2/(3.*S**2)
      FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+ZM2S)*(P(2)**2+ZM2S))
      DO 220 IQ=1,4
      GZ=2.*(AQDP(IQ,4)**4+BQDP(IQ,4)**4
     $+6.*AQDP(IQ,4)**2*BQDP(IQ,4)**2)
      FACTOR=(T/U+U/T+4.*ZM2*S/(T*U)-ZM2**2*(1./T**2+1./U**2))
      FACTOR=FACTOR*FJAC*GZ*TBRWW(4,1)*TBRWW(4,2)
      SIG=FACTOR*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)
      CALL SIGFIL(SIG,2*IQ,2*IQ+1,4,4)
      SIG=FACTOR*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)
      CALL SIGFIL(SIG,2*IQ+1,2*IQ,4,4)
220   CONTINUE
C
C          W+- Z0 pairs
C
C          JW and JZ are W+- and Z0 jet numbers.
300   DO 310 JW=1,2
        JZ=3-JW
        IF(.NOT.((GOQ(2,JW).OR.GOQ(3,JW)).AND.GOQ(4,JZ))) GO TO 310
C
C          Must swap t and u if JW=2.
        IF(JW.EQ.1) THEN
          CALL WWKIN(WMASS(2),WMASS(4))
          TX=T
          UX=U
          FJAC=S/SCM*UNITS
          FJAC=FJAC*PI*ALFA**2/(3.*S**2)
          FJAC=.5*FJAC
          FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+WM2S)*(P(2)**2+ZM2S))
        ELSE
          CALL WWKIN(WMASS(4),WMASS(2))
          TX=U
          UX=T
          FJAC=S/SCM*UNITS
          FJAC=FJAC*PI*ALFA**2/(3.*S**2)
          FJAC=.5*FJAC
          FJAC=FJAC*P(1)*P(2)/SQRT((P(1)**2+ZM2S)*(P(2)**2+WM2S))
        ENDIF
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 310
        DO 320 IH=1,2
        DO 320 IQ=1,9
320     QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
C
C          Sum over W+ and W-
        DO 340 IW=2,3
          IF(IW.EQ.2) THEN
            SGN=+1
          ELSE
            SGN=+1
          ENDIF
C
C          Sum over quarks, swapping t and u as needed.
          DO 350 IQ1=2,9
            IQ2=MATCH(IQ1,IW)
            IF(IQ2.EQ.0) GO TO 350
            IQ=IQ1/2
            IF(2*IQ.EQ.IQ1) THEN
              LQK1=.TRUE.
            ELSE
              LQK1=.FALSE.
            ENDIF
            IF((LQK1.AND.IW.EQ.3).OR.(.NOT.LQK1.AND.IW.EQ.2)) THEN
              TT=TX
              UU=UX
              IFLI=IQ1/2
              IFLJ=IQ2/2
            ELSE
              TT=UX
              UU=TX
              IFLI=IQ2/2
              IFLJ=IQ1/2
            ENDIF
C
            GA=AQDP(IQ,IW)*EZDP*S/(S-WM2)
            GI=AQDP(IQ,IW)*(AQDP(IFLI,4)+BQDP(IFLI,4))
            GJ=AQDP(IQ,IW)*(AQDP(IFLJ,4)+BQDP(IFLJ,4))
            TERM=GA**2*WZA(S,TT,UU)
            TERM=TERM+2.*GA*SGN*(-GJ*WZI(S,TT,UU)+GI*WZI(S,UU,TT))
            TERM=TERM+(GI-GJ)**2*WZE(S,TT,UU)
            TERM=TERM+GI**2*(UU*TT-WM2*ZM2)/UU**2
     $      +2.*GI*GJ*S*(WM2+ZM2)/(TT*UU)+GJ**2*(UU*TT-WM2*ZM2)/TT**2
            TERM=TERM*4.*FJAC*QSAVE(IQ1,1)*QSAVE(IQ2,2)
            TERM=TERM*TBRWW(IW,JW)*TBRWW(4,JZ)
            SIG=TERM
            IF(JW.EQ.1) THEN
              CALL SIGFIL(SIG,IQ1,IQ2,IW,4)
            ELSE
              CALL SIGFIL(SIG,IQ1,IQ2,4,IW)
            ENDIF
350       CONTINUE
340     CONTINUE
310   CONTINUE
C
C          W+- GM pairs.
C
400   DO 410 JW=1,2
        JG=3-JW
        IF(.NOT.((GOQ(2,JW).OR.GOQ(3,JW)).AND.GOQ(1,JG))) GO TO 410
C
C          Must swap t and u if JW=2.
        IF(JW.EQ.1) THEN
          CALL WWKIN(WMASS(2),0.)
          TX=T
          UX=U
          FJAC=S/SCM*UNITS
          FJAC=FJAC*PI*ALFA**2/S**2
          FJAC=.5*FJAC
          FJAC=FJAC*P(1)/SQRT(P(1)**2+WM2S)
        ELSE
          CALL WWKIN(0.,WMASS(2))
          TX=U
          UX=T
          FJAC=S/SCM*UNITS
          FJAC=FJAC*PI*ALFA**2/S**2
          FJAC=.5*FJAC
          FJAC=FJAC*P(2)/SQRT(P(2)**2+WM2S)
        ENDIF
C
        IF(X1.GE.1..OR.X2.GE.1.) GO TO 410
        DO 420 IH=1,2
        DO 420 IQ=1,9
420     QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
C
C          Sum over W+ and W-
        DO 440 IW=2,3
C
C          Sum over quarks, swapping t and u as needed.
          DO 450 IQ1=2,9
            IQ2=MATCH(IQ1,IW)
            IF(IQ2.EQ.0) GO TO 450
            IQ=IQ1/2
            IF(2*IQ.EQ.IQ1) THEN
              LQK1=.TRUE.
            ELSE
              LQK1=.FALSE.
            ENDIF
            IF((LQK1.AND.IW.EQ.3).OR.(.NOT.LQK1.AND.IW.EQ.2)) THEN
              TT=TX
              UU=UX
            ELSE
              TT=UX
              UU=TX
            ENDIF
C
            SIG=TBRWW(IW,JW)/(6.*SIN2W)*(-1./3.+UU/(TT+UU))**2
     $      *(UU**2+TT**2+2.*S*WM2)/(TT*UU)
            SIG=SIG*FJAC*QSAVE(IQ1,1)*QSAVE(IQ2,2)
            IF(JW.EQ.1) CALL SIGFIL(SIG,IQ1,IQ2,IW,1)
            IF(JW.EQ.2) CALL SIGFIL(SIG,IQ1,IQ2,1,IW)
450       CONTINUE
440     CONTINUE
410   CONTINUE
C
C          Z0 GM pairs
C
      IF (GOQ(4,1).AND.GOQ(1,2)) THEN
      CALL WWKIN(WMASS(4),0.)
      IF(X1.GE.1..OR.X2.GE.1.) GO TO 500
      DO 510 IH=1,2
      DO 510 IQ=2,9
510   QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      FJAC=S/SCM*P(1)/SQRT(P(1)**2+ZM2S)*UNITS
      FJAC=FJAC*PI*ALFA**2/(3.*S**2)
      DO 520 IQ=1,4
      GZ=AQDP(IQ,4)**2+(AQDP(IQ,4)-BQDP(IQ,4))**2
      FACTOR=(S**2+ZM2**2)/2./T/U+1.
      FACTOR=(EQ3(IQ)/3.)**2*FACTOR*FJAC*GZ*TBRWW(4,1)
      SIG=FACTOR*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)
      CALL SIGFIL(SIG,2*IQ,2*IQ+1,4,1)
      SIG=FACTOR*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)
      CALL SIGFIL(SIG,2*IQ+1,2*IQ,4,1)
520   CONTINUE
500   CONTINUE
      END IF
C
      IF (GOQ(1,1).AND.GOQ(4,2)) THEN
      CALL WWKIN(0.,WMASS(4))
      IF(X1.GE.1..OR.X2.GE.1.) GO TO 600
      DO 610 IH=1,2
      DO 610 IQ=2,9
610   QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      FJAC=S/SCM*P(2)/SQRT(P(2)**2+ZM2S)*UNITS
      FJAC=FJAC*PI*ALFA**2/(3.*S**2)
      DO 620 IQ=1,4
      GZ=AQDP(IQ,4)**2+(AQDP(IQ,4)-BQDP(IQ,4))**2
      FACTOR=(S**2+ZM2**2)/2./T/U+1.
      FACTOR=(EQ3(IQ)/3.)**2*FACTOR*FJAC*GZ*TBRWW(4,2)
      SIG=FACTOR*QSAVE(2*IQ,1)*QSAVE(2*IQ+1,2)
      CALL SIGFIL(SIG,2*IQ,2*IQ+1,1,4)
      SIG=FACTOR*QSAVE(2*IQ+1,1)*QSAVE(2*IQ,2)
      CALL SIGFIL(SIG,2*IQ+1,2*IQ,1,4)
620   CONTINUE
600   CONTINUE
      END IF
C
      RETURN
      END
+EOD
+DECK,SMSZG
      FUNCTION SMSZG(Q,QB,K,E,EB,AQ,BQ,AE,BE)
      IMPLICIT NONE
C
C     This does squared matrix element for q+qb -> Z+gamma
C          where Z-> e+eb
C     I have factored out 128*e^6*Q_q^2*|D_Z(z^2)| from
C       the expression. Also 1/12 from spin/color ave. is out.
C
      REAL Q(5),QB(5),K(5),E(5),EB(5),AQ,BQ,AE,BE,SMSZG
      REAL M1S,M2S,M12
      REAL EDQ,EBDK,EBDQ,EDK,QBDK,EDQB,EBDQB,QDK,QDQB
      EDQ=E(4)*Q(4)-E(1)*Q(1)-E(2)*Q(2)-E(3)*Q(3)
      EBDK=EB(4)*K(4)-EB(1)*K(1)-EB(2)*K(2)-EB(3)*K(3)
      EBDQ=EB(4)*Q(4)-EB(1)*Q(1)-EB(2)*Q(2)-EB(3)*Q(3)
      EDK=E(4)*K(4)-E(1)*K(1)-E(2)*K(2)-E(3)*K(3)
      QBDK=QB(4)*K(4)-QB(1)*K(1)-QB(2)*K(2)-QB(3)*K(3)
      EDQB=E(4)*QB(4)-E(1)*QB(1)-E(2)*QB(2)-E(3)*QB(3)
      EBDQB=EB(4)*QB(4)-EB(1)*QB(1)-EB(2)*QB(2)-EB(3)*QB(3)
      QDK=Q(4)*K(4)-Q(1)*K(1)-Q(2)*K(2)-Q(3)*K(3)
      QDQB=Q(4)*QB(4)-Q(1)*QB(1)-Q(2)*QB(2)-Q(3)*QB(3)
      M1S=(((AQ**2+BQ**2)*(AE**2+BE**2)-4*AQ*BQ*AE*BE)*EDQ*EBDK+
     $((AQ**2+BQ**2)*(AE**2+BE**2)+4*AQ*BQ*AE*BE)*EBDQ*EDK)/
     $4./QBDK
      M2S=(((AQ**2+BQ**2)*(AE**2+BE**2)+4*AQ*BQ*AE*BE)*EDQB*EBDK+
     $((AQ**2+BQ**2)*(AE**2+BE**2)-4*AQ*BQ*AE*BE)*EBDQB*EDK)/
     $4./QDK
      M12=(2*(AQ**2+BQ**2)*(AE**2+BE**2)*(EDQ*EBDQ*QBDK+EDQB*EBDQB*QDK)
     $+((AQ**2+BQ**2)*(AE**2+BE**2)-4*AQ*BQ*AE*BE)*(2*EDQ*EBDQB*QDQB+
     $EDQ*EBDK*QDQB-EDK*EBDQB*QDQB+EDQ*EBDQB*QDK-EDQ*EBDQB*QBDK)+
     $((AQ**2+BQ**2)*(AE**2+BE**2)+4*AQ*BQ*AE*BE)*(2*EDQB*EBDQ*QDQB-
     $EDQB*EBDK*QDQB+EDK*EBDQ*QDQB+EDQB*EBDQ*QDK-EDQB*EBDQ*QBDK))/
     $4./QBDK/QDK
      SMSZG=M1S+M2S+M12
      RETURN
      END
+EOD
+DECK,SORTTF,IF=NOCERN.
      SUBROUTINE SORTTF(A,INDEX,N1)
C=======================================================================
C          Given real array and corresponding index INDEX, find new 
C          INDEX for which A is sorted into ascending order.
C
C          From CERN PROGLIB# M101
C=======================================================================
      DIMENSION A(N1),INDEX(N1)
C
      N = N1
      DO 3 I1=2,N
      I3 = I1
      I33 = INDEX(I3)
      AI = A(I33)
    1 I2 = I3/2
      IF (I2) 3,3,2
    2 I22 = INDEX(I2)
      IF (AI.LE.A (I22)) GO TO 3
      INDEX (I3) = I22
      I3 = I2
      GO TO 1
    3 INDEX (I3) = I33
    4 I3 = INDEX (N)
      INDEX (N) = INDEX (1)
      AI = A(I3)
      N = N-1
      IF (N-1) 12,12,5
    5 I1 = 1
    6 I2 = I1 + I1
      IF (I2.LE.N) I22= INDEX(I2)
      IF (I2-N) 7,9,11
    7 I222 = INDEX (I2+1)
      IF (A(I22)-A(I222)) 8,9,9
    8 I2 = I2+1
      I22 = I222
    9 IF (AI-A(I22)) 10,11,11
   10 INDEX(I1) = I22
      I1 = I2
      GO TO 6
   11 INDEX (I1) = I3
      GO TO 4
   12 INDEX (1) = I3
      RETURN
      END
+EOD
+DECK,SPLINE.
      SUBROUTINE SPLINE(X,C,N,IBCBEG,IBCEND)
C**********************************************************************
C* Computes the coefficient of a cubic interpolating spline. The X(i),*
C* i=1,...,N, are the knots or x-values of data points; C(1,i) are    *
C* the corresponding y-values. N is the number of data points (>3!).  *
C* IBCBEG = 0 means that the slope at X(1) is unknown, in which case  *
C* it is determined from requiring a smooth 3rd derivative at x(2);   *
C* IBCBEG = 1 means that the slope is known, in which case it has to  *
C* be stored in C(1,2). IBCEND has the same meaning for the end of    *
C* x-region; if IBCEND = 1, the slope is to be stored in C(2,N). The  *
C* routine then computes the coefficients C(l,i) of the i-th spline,  *
C* written in the form                                                *
C* f_i(x) = C(1,i) + h_i C(2,i) + h_i^2 C(3,i) + h_i^3 C(4,i), where  *
C* h_i = x - X(I).                                                    *
C  Modified from contributed subroutine by M. Drees, 1/14/99
C**********************************************************************
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER N,IBCBEG,IBCEND,I,L,M,J
      REAL C(4,N),X(N),G,DTAU,DIVDF1,DIVDF3
C
      L = N - 1
      DO 10 M = 2, N
      C(3,M) = X(M) - X(M-1)
   10 C(4,M) = (C(1,M) - C(1,M-1))/C(3,M)
C          First slope unknown
      IF(IBCBEG.EQ.0) THEN
        C(4,1) = C(3,3)
        C(3,1) = C(3,2) + C(3,3)
        C(2,1) = ( (C(3,2)+2.0*C(3,1))*C(4,2)*C(3,3) +
     &             C(3,2)**2*C(4,3) )/C(3,1)
C          First slope already known
      ELSE
        C(4,1) = 1.0
        C(3,1) = 0.0
      ENDIF
C          Forward pass of Gauss elimination
      DO 20 M = 2, L
        G = -C(3,M+1)/C(4,M-1)
        C(2,M) = G*C(2,M-1) + 3.0*(C(3,M)*C(4,M+1)+C(3,M+1)*C(4,M))
   20   C(4,M) = G*C(3,M-1) + 2.0*(C(3,M)+C(3,M+1))
 
      IF(IBCEND.EQ.0) THEN
        G = C(3,N-1) + C(3,N)
        C(2,N) = ( (C(3,N)+2.0*G)*C(4,N)*C(3,N-1) +
     &             C(3,N)**2*(C(1,N-1)-C(1,N-2))/C(3,N-1) )/G
        G = -G/C(4,N-1)
        C(4,N) = (G+1.0)*C(3,N-1) + C(4,N)
        C(2,N) = ( G*C(2,N-1) + C(2,N) )/C(4,N)
      ENDIF
C          Back substitution
      DO 30 J = L,1,-1
   30 C(2,J) = ( C(2,J) - C(3,J)*C(2,J+1) )/C(4,J)
C          Computation of coefficients
      DO 40 I = 2,N
        DTAU = C(3,I)
        DIVDF1 = (C(1,I)-C(1,I-1))/DTAU
        DIVDF3 = C(2,I-1) + C(2,I) - 2.0*DIVDF1
        C(3,I-1) = ( DIVDF1 - C(2,I-1) - DIVDF3 ) / DTAU
   40   C(4,I-1) = DIVDF3/DTAU/DTAU
C 
      RETURN
      END
+EOD
+DECK,SSFEL.
      FUNCTION SSFEL(X,INIT)
C***********************************************************************
C* Computes the electron spectrum as a convolution of the beam- and    *
C* bremsstrahlung-spectra, including leading-log summation for the lat-*
C* ter (in one-loop order), and Peskin's approximate expression for the*
C* former. X is the e energy in units of the nominal beam energy, and  *
C* BETA is 2 alpha_em / pi (log s/me^2 - 1). If more than 99.5% of all *
C* electrons are in the delta-peak, beamstrahlung is ignored. Other-   *
C* wise, beamstrahlung is included. In the latter case, the complete   *
C* spectrum is computed at the first call (with INIT=1), and fitted in *
C* a cubic spline; in later calls (with INIT=0), only the spline is    *
C* used. This reduces the necessary amount of CPU time considerably.   *
C* This subroutine needs the programs BEAMEL, SIMAU8, and SPLINE.      *
C***********************************************************************
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,EEPAR
+CDE,BREMBM
C
      REAL X,SSFEL
      INTEGER INIT
      REAL Y,XLMM,XL,GAM,RE,XKAPPA,NUCL,NUGAM,NGAM,DC,
     $DX,TAU(100),C(4,100),XM,Z,RES,SSXINT,Y2,H,S,ESTRUC,Y1
      INTEGER I
      SAVE DC,NGAM,C,TAU
      EXTERNAL FBRBM
C
      IF(INIT.NE.0) THEN
C       Compute delta function contribution
        Y=UPSLON
        XLMM=SIGZ
        XL = XLMM*1.E12/.197327
        GAM = EB/5.11E-4
        RE = 1./(137.*5.11E-4)
        XKAPPA = 2./(3.*Y)
        NUCL = 2.5*Y/(SQRT(3.)*137.**2*GAM*RE)
        NUGAM = NUCL/SQRT(1.+Y**.6666666)
        NGAM=sqrt(3.)*NUGAM*XL
        DC = EXP(-NGAM/2.)
        SSFEL=0.
C       No initialization needed if >.995 included in delta peak
        IF(DC.GT..995) RETURN

C  ***  Computation of 'knots'   ***

        DX = .05
        DO 100 I = 1, 19                              
 100    TAU(I) = FLOAT(I-1)*DX     
        DO 110 I = 1, 9                               
 110    TAU(19+I) = .9 + FLOAT(I)*1.E-2
        DO 120 I = 1, 5                               
 120    TAU(28+I) = .99 + FLOAT(I)*1.E-3
        DO 121 I = 1, 12                              
 121    TAU(33+I) = .995 + FLOAT(I)*2.5E-4
        DO 130 I = 1, 20                              
 130    TAU(45+I) = .998 + FLOAT(I)*1.E-4

C   ***  Computation of corresponding y-values (electron densities)  ***

        XM = TAU(65)
        DO 140 I = 1,65
        Z = TAU(I)
        XMIN = Z
        RES=SSXINT(Z,FBRBM,XM)
140     C(1,I) = RES +DC*ESTRUC(Z,QSQBM)

C   ***  Computation of derivative at zero   ***

        Z = 1.E-5
        XMIN = Z
        RES=SSXINT(Z,FBRBM,XM)
        Y1 = RES + DC*ESTRUC(Z,QSQBM)
        Z = 1.E-4
        XMIN = Z
        RES=SSXINT(Z,FBRBM,XM)
        Y2 = RES + DC*ESTRUC(Z,QSQBM)
        C(1,2) = (Y2-Y1)/(1.E-4 - 1.E-5)
147     CALL SPLINE(TAU,C,65,1,0)
        RETURN
      ENDIF
      IF(X.GT..999999) THEN
        Z = .999999
      ELSE
        Z = X
      ENDIF
      DC = EXP(-NGAM/2.)
      IF(DC.GT..995) THEN
        SSFEL = DC*ESTRUC(Z,QSQBM)
        RETURN
      ENDIF

      DO 2 I = 1, 64
    2 IF(Z.LT.TAU(I+1)) GOTO 3
    3 H = Z - TAU(I)
      S = C(1,I) + H * ( C(2,I) + H*(C(3,I)+H*C(4,I)) )
      SSFEL = S
      RETURN
      END
+EOD
+DECK,SSGST
        REAL FUNCTION SSGST(S,AMSQ,Z,I,J)
C-----------------------------------------------------------------------
C          Function for Sig(qqbar->z_i + z_j
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
        REAL S,AMSQ,K,Z,MZI,MZJ,RS,TP,BT
        INTEGER I,J,ITHI,ITHJ
C
        MZI=ABS(AMZISS(I))
        MZJ=ABS(AMZISS(J))
        IF (AMZISS(I).LT.0.) THEN
          ITHI=1
        ELSE
          ITHI=0
        END IF
        IF (AMZISS(J).LT.0.) THEN
          ITHJ=1
        ELSE
          ITHJ=0
        END IF
        RS=SQRT(S)
        K=SQRT(S*S+(MZI**2-MZJ**2)**2-2*S*(MZI**2+MZJ**2))/
     $   2./RS
        TP=S*S-(MZI**2-MZJ**2)**2-4*K*S**1.5*Z+4*K*K*S*Z*Z+
     $   4*(-1.)**(ITHI+ITHJ+1)*MZI*MZJ*S
        BT=(S-MZI**2-MZJ**2)/2.-RS*K*Z+AMSQ**2
        SSGST=TP/BT
        RETURN
        END
+EOD
+DECK,SSGT
        REAL FUNCTION SSGT(S,AMSQ,Z,I,J)
C-----------------------------------------------------------------------
C          Function for Sig(qqbar->z_i + z_j
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
        REAL S,AMSQ,K,Z,MZI,MZJ,RS,TPP,TPM,BTP,BTM
        INTEGER I,J,ITHI,ITHJ
C
        MZI=ABS(AMZISS(I))
        MZJ=ABS(AMZISS(J))
        IF (AMZISS(I).LT.0.) THEN
          ITHI=1
        ELSE
          ITHI=0
        END IF
        IF (AMZISS(J).LT.0.) THEN
          ITHJ=1
        ELSE
          ITHJ=0
        END IF
        RS=SQRT(S)
        K=SQRT(S*S+(MZI**2-MZJ**2)**2-2*S*(MZI**2+MZJ**2))/
     $   2./RS
        TPP=S*S-(MZI**2-MZJ**2)**2-4*K*S**1.5*Z+4*K*K*S*Z*Z
        TPM=S*S-(MZI**2-MZJ**2)**2+4*K*S**1.5*Z+4*K*K*S*Z*Z
        BTP=(S-MZI**2-MZJ**2)/2.-RS*K*Z+AMSQ**2
        BTM=(S-MZI**2-MZJ**2)/2.+RS*K*Z+AMSQ**2
        SSGT=(TPP/BTP**2+TPM/BTM**2-8*(-1.)**(ITHI+ITHJ)*
     $   MZI*MZJ*S/BTM/BTP)/16.
        RETURN
        END
+EOD
+DECK,STRUC.
      FUNCTION STRUC(X,QSQ,IQ,IH)
C
C          Compute structure functions X*F(X,QSQ)
C          ISTRUC=1,2  Deleted
C          ISTRUC=3    Eichten, Hinchliffe, Lane, and Quigg (1984)
C                      solution 1 (obsolete)
C          ISTRUC=4    Duke and Owens, Phys. Rev. D30, 49.
C                      solution 1 (obsolete)
C          ISTRUC=5    CTEQ Collaboration, Phys. Lett. 304B, 159
C                      fit CTEQ2L (lowest order QCD)
C          ISTRUC=6    CTEQ Collaboration, Phys. Rev. D51, 4763 (1995)
C                      fit CTEQ3L (lowest order QCD)
C          ISTRUC=7    CTEQ fit CTEQ5L, hep-ph/9903282.
C          ISTRUC=-999 PDFLIB interface. Parameters are passed by call
C                      to PDFSET in READIN.
C          Quark types--
C          IQ=1  2  3  4  5  6  7  8  9  10 11 12 13
C             GL UP UB DN DB ST SB CH CB BT BB TP TB
C          Hadron types--
C          IH=+1120  -1120  +1220  -1220
C                 P     AP      N     AN
C
C          For IBM compatibility require STRUC > SFMIN = 1.E-10
C          Ver. 7.23: Simplify type mapping and fix PDF error for pbar
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR
C          E1STRC contains all the coefficients for Eichten, etal,
C          solution 1. It is equivalenced to arrays for the 16 sets of
C          coefficients.
      DIMENSION E1STRC(6,6,16),E1POW(8),IE1FIT(13)
      DIMENSION E1UPHI(6,6),E1DNHI(6,6),E1UBHI(6,6),E1GLHI(6,6),
     $E1STHI(6,6),E1CHHI(6,6),E1BTHI(6,6),E1TPHI(6,6)
      DIMENSION E1UPLO(6,6),E1DNLO(6,6),E1UBLO(6,6),E1GLLO(6,6),
     $E1STLO(6,6),E1CHLO(6,6),E1BTLO(6,6),E1TPLO(6,6)
      EQUIVALENCE (E1UPHI(1,1),E1STRC(1,1,1))
      EQUIVALENCE (E1DNHI(1,1),E1STRC(1,1,2))
      EQUIVALENCE (E1UBHI(1,1),E1STRC(1,1,3))
      EQUIVALENCE (E1GLHI(1,1),E1STRC(1,1,4))
      EQUIVALENCE (E1STHI(1,1),E1STRC(1,1,5))
      EQUIVALENCE (E1CHHI(1,1),E1STRC(1,1,6))
      EQUIVALENCE (E1BTHI(1,1),E1STRC(1,1,7))
      EQUIVALENCE (E1TPHI(1,1),E1STRC(1,1,8))
      EQUIVALENCE (E1UPLO(1,1),E1STRC(1,1,9))
      EQUIVALENCE (E1DNLO(1,1),E1STRC(1,1,10))
      EQUIVALENCE (E1UBLO(1,1),E1STRC(1,1,11))
      EQUIVALENCE (E1GLLO(1,1),E1STRC(1,1,12))
      EQUIVALENCE (E1STLO(1,1),E1STRC(1,1,13))
      EQUIVALENCE (E1CHLO(1,1),E1STRC(1,1,14))
      EQUIVALENCE (E1BTLO(1,1),E1STRC(1,1,15))
      EQUIVALENCE (E1TPLO(1,1),E1STRC(1,1,16))
      DIMENSION CHEBX(6),CHEBQ(6)
C
      REAL X,QSQ,STRUC
      REAL BETA,CHEB1,CHEB2,CHEB3,CHEB4,CHEB5,AMASS,E1POW,FD,CHEBX,
     $E1STRC,E1UPHI,CHEBQ,AD,ETA3,GUD,ETA2,ETA4,FUD,AUD,GD,E1GLLO,
     $E1UBLO,E1DNLO,E1STLO,E1TPLO,E1BTLO,E1CHLO,E1UPLO,E1GLHI,E1UBHI,
     $E1DNHI,E1STHI,E1TPHI,E1BTHI,ETA1,T,TMAX,TMIN,AMQ,Q2MIN,W2,W1,
     $SFMIN,T1,A1,A0,SS,B1,C2,B2,A2,S,X1,TERM,E1CHHI,Q2,GAMMA
      INTEGER IQ,IH
      INTEGER IE1FIT,IFIT,IFIT2,JX,JQ,ISHFT,IIQ
C          CTEQ declarations
      REAL A3,A4,A5,SBL,QI,Q,SB,SB2,SB3
      INTEGER IFL
      INTEGER IQPB(13),IQN(13),IQNB(13)
+SELF,IF=SINGLE
      REAL SEA,VAL,P012,P34,P5
+SELF,IF=DOUBLE
      DOUBLE PRECISION SEA,VAL,P012,P34,P5
+SELF
C          CTEQ5L quantities
      DOUBLE PRECISION X5L,Q5L,CTEQ5L,SUM5L,RAT5L
C          PDFLIB declarations
+SELF,IF=PDFLIB,IF=SINGLE
      REAL DX,DSCALE,DXPDF(-6:6)
+SELF,IF=PDFLIB,IF=DOUBLE
      DOUBLE PRECISION DX,DSCALE,DXPDF(-6:6)
+SELF,IF=PDFLIB
      INTEGER IQMAP(13)
      DATA IQMAP/0,2,-2,1,-1,3,-3,4,-4,5,-5,6,-6/
+SELF
C
C          Map pbar, n, nbar types to p type
      DATA IQPB/1,3,2,5,4,7,6,9,8,11,10,13,12/
      DATA IQN /1,4,5,2,3,6,7,8,9,10,11,12,13/
      DATA IQNB/1,5,4,3,2,7,6,9,8,11,10,13,12/
C
C          Eichten etal solution 1 constants
C          corrected coefficients from Ian Hinchliffe, 3 June 1986.
      DATA E1UPHI/
     $  0.76772, -0.20874, -0.33026, -0.02517, -0.01570, -0.00010,
     $ -0.53259, -0.26612,  0.32007,  0.11918,  0.02434,  0.00762,
     $  0.21618,  0.18812, -0.08375, -0.06515, -0.01743, -0.00504,
     $ -0.09211, -0.09952,  0.01373,  0.02506,  0.00877,  0.00255,
     $  0.03670,  0.04409,  0.00096, -0.00796, -0.00342, -0.00105,
     $ -0.01549, -0.02026, -0.00306,  0.00222,  0.00124,  0.00041/
      DATA E1DNHI/
     $  0.38130, -0.08090, -0.16336, -0.02185, -0.00843, -0.00062,
     $ -0.29475, -0.14348,  0.16650,  0.06638,  0.01473,  0.00408,
     $  0.12518,  0.10422, -0.04722, -0.03683, -0.01038, -0.00286,
     $ -0.05478, -0.05678,  0.00890,  0.01484,  0.00534,  0.00152,
     $  0.02220,  0.02567, -0.00003, -0.00497, -0.00216, -0.00065,
     $ -0.00953, -0.01204, -0.00151,  0.00151,  0.00083,  0.00027/
      DATA E1UBHI/
     $  0.06870, -0.06861,  0.02973, -0.00540,  0.00378, -0.00097,
     $ -0.01802,  0.00014,  0.00649, -0.00854,  0.00122, -0.00175,
     $ -0.00465,  0.00148, -0.00593,  0.00060, -0.00103, -0.00008,
     $  0.00644,  0.00257,  0.00283,  0.00115,  0.00071,  0.00033,
     $ -0.00393, -0.00254, -0.00116, -0.00077, -0.00036, -0.00019,
     $  0.00234,  0.00193,  0.00053,  0.00037,  0.00016,  0.00009/
      DATA E1GLHI/
     $  0.94819, -0.95779,  0.10085, -0.10510,  0.03456, -0.03054,
     $ -0.96265,  0.53790,  0.33684, -0.09525,  0.01488, -0.02051,
     $  0.43004, -0.08306, -0.33719,  0.04902, -0.00916,  0.01041,
     $ -0.19249, -0.01790,  0.21830,  0.00749,  0.00414, -0.00186,
     $  0.08183,  0.01926, -0.10718, -0.01944, -0.00277, -0.00052,
     $ -0.03884, -0.01234,  0.05410,  0.01879,  0.00335,  0.00104/
      DATA E1STHI/
     $  0.04968, -0.04173,  0.02102, -0.00327,  0.00324, -0.00067,
     $ -0.00615, -0.01294,  0.00674, -0.00689,  0.00090, -0.00151,
     $ -0.00858,  0.00505, -0.00490, -0.00016, -0.00094, -0.00015,
     $  0.00784,  0.00151,  0.00222,  0.00140,  0.00070,  0.00035,
     $ -0.00441, -0.00222, -0.00089, -0.00085, -0.00036, -0.00020,
     $  0.00252,  0.00184,  0.00041,  0.00039,  0.00016,  0.00009/
      DATA E1CHHI/
     $  0.00927, -0.01817,  0.00959, -0.00639,  0.00169, -0.00154,
     $  0.00571, -0.01188,  0.00609, -0.00465,  0.00124, -0.00131,
     $ -0.00396,  0.00710, -0.00359,  0.00184, -0.00039,  0.00034,
     $  0.00112, -0.00196,  0.00112, -0.00048,  0.00010, -0.00004,
     $  0.00004, -0.00003, -0.00018,  0.00009, -0.00005, -0.00002,
     $ -0.00042,  0.00073, -0.00016,  0.00005,  0.00005,  0.00005/
      DATA E1BTHI/
     $  0.00901, -0.01401,  0.00715, -0.00413,  0.00126, -0.00104,
     $  0.00628, -0.00932,  0.00478, -0.00289,  0.00091, -0.00082,
     $ -0.00293,  0.00409, -0.00189,  0.00076, -0.00023,  0.00014,
     $  0.00039, -0.00120,  0.00044, -0.00025,  0.00002, -0.00002,
     $  0.00026,  0.00014, -0.00008,  0.00010,  0.00001,  0.00001,
     $ -0.00026,  0.00032,  0.00001, -0.00001,  0.00001, -0.00001/
      DATA E1TPHI/
     $  0.00441, -0.00748,  0.00377, -0.00258,  0.00073, -0.00071,
     $  0.00384, -0.00605,  0.00303, -0.00203,  0.00058, -0.00059,
     $ -0.00088,  0.00166, -0.00075,  0.00047, -0.00010,  0.00010,
     $ -0.00008, -0.00015,  0.00012, -0.00009,  0.00003,  0.00000,
     $  0.00013, -0.00022, -0.00002, -0.00002, -0.00002, -0.00002,
     $ -0.00007,  0.00019, -0.00004,  0.00002,  0.00000,  0.00000/
      DATA E1UPLO/
     $  0.23946,  0.29055,  0.09778,  0.02149,  0.00344,  0.00050,
     $  0.01751, -0.00609, -0.02687, -0.01916, -0.00797, -0.00275,
     $ -0.00576, -0.00504,  0.00108,  0.00249,  0.00153,  0.00075,
     $  0.00174,  0.00196,  0.00030, -0.00034, -0.00029, -0.00018,
     $ -0.00053, -0.00064, -0.00017,  0.00004,  0.00006,  0.00004,
     $  0.00017,  0.00022,  0.00008,  0.00001, -0.00001, -0.00001/
      DATA E1DNLO/
     $  0.12613,  0.13542,  0.03958,  0.00824,  0.00166,  0.00045,
     $  0.00389, -0.01159, -0.01625, -0.00961, -0.00371, -0.00126,
     $ -0.00191, -0.00056,  0.00159,  0.00159,  0.00084,  0.00039,
     $  0.00064,  0.00049, -0.00015, -0.00029, -0.00018, -0.00010,
     $ -0.00020, -0.00019,  0.00000,  0.00006,  0.00004,  0.00003,
     $  0.00007,  0.00008,  0.00002, -0.00001, -0.00001, -0.00001/
      DATA E1UBLO/
     $  1.01386, -1.10585,  0.33739, -0.07444,  0.00885, -0.00087,
     $  0.92334, -1.28541,  0.44755, -0.09786,  0.01419, -0.00112,
     $  0.04888, -0.12708,  0.08606, -0.02608,  0.00478, -0.00060,
     $ -0.02691,  0.04887, -0.01771,  0.00162,  0.00025, -0.00006,
     $  0.00704, -0.01113,  0.00159,  0.00070, -0.00020,  0.00000,
     $ -0.00171,  0.00229,  0.00038, -0.00035,  0.00004,  0.00001/
      DATA E1GLLO/
     $ 29.47734,-39.02468, 14.63570, -3.33516,  0.50538, -0.05915,
     $ 25.58960,-39.54527, 16.61420, -4.29861,  0.69036, -0.08243,
     $ -1.66291,  1.17624,  1.11844, -0.70986,  0.19481, -0.02404,
     $ -0.21679,  0.81705, -0.71688,  0.18507, -0.01924, -0.00325,
     $  0.20880, -0.43547,  0.22391, -0.02446, -0.00362,  0.00191,
     $ -0.09097,  0.16009, -0.05681, -0.00250,  0.00258, -0.00047/
      DATA E1STLO/
     $  0.92351, -1.08483,  0.34642, -0.07210,  0.00914, -0.00091,
     $  0.93146, -1.27376,  0.45122, -0.09775,  0.01380, -0.00131,
     $  0.04739, -0.12960,  0.08482, -0.02642,  0.00476, -0.00057,
     $ -0.02653,  0.04953, -0.01735,  0.00175,  0.00028, -0.00006,
     $  0.00694, -0.01132,  0.00148,  0.00065, -0.00021,  0.00000,
     $ -0.00168,  0.00234,  0.00042, -0.00034,  0.00005,  0.00001/
      DATA E1CHLO/
     $  0.80983, -1.04168,  0.33980, -0.06824,  0.00876, -0.00090,
     $  0.89606, -1.21708,  0.43386, -0.09287,  0.01304, -0.00129,
     $  0.03058, -0.10402,  0.07604, -0.02415,  0.00460, -0.00050,
     $ -0.02451,  0.04432, -0.01651,  0.00143,  0.00012, -0.00010,
     $  0.01122, -0.01457,  0.00268,  0.00058, -0.00012,  0.00003,
     $ -0.00773,  0.00733, -0.00076, -0.00024,  0.00001,  0.00000/
      DATA E1BTLO/
     $  0.80288, -1.07532,  0.37920, -0.07843,  0.01007, -0.00109,
     $  0.79033, -1.09887,  0.41532, -0.09301,  0.01317, -0.00141,
     $ -0.01704, -0.01130,  0.02882, -0.01341,  0.00304, -0.00036,
     $ -0.00072,  0.00723, -0.00516,  0.00108, -0.00005, -0.00004,
     $  0.00305, -0.00461,  0.00166, -0.00013, -0.00001,  0.00001,
     $ -0.00436,  0.00523, -0.00161,  0.00020, -0.00002,  0.00000/
      DATA E1TPLO/
     $  0.66233, -0.92481,  0.35193, -0.07930,  0.01110, -0.00118,
     $  0.63797, -0.90619,  0.35816, -0.08479,  0.01265, -0.00139,
     $ -0.02581,  0.02125,  0.00419, -0.00498,  0.00149, -0.00021,
     $  0.00071,  0.00053, -0.00127,  0.00039, -0.00005, -0.00001,
     $  0.00385, -0.00506,  0.00186, -0.00035,  0.00004,  0.00000,
     $ -0.00353,  0.00446, -0.00150,  0.00027, -0.00003,  0.00000/
C          E1POW gives powers of (1-x).
C          IE1FIT points to fit for each value of IQ.
      DATA E1POW/3.,4.,7.,5.,7.,7.,7.,7./
      DATA IE1FIT/4,1,3,2,3,5,5,6,6,7,7,8,8/
C          Minimum value for STRUC
      DATA SFMIN/1.E-10/
C
      BETA(W1,W2)=GAMMA(W1)*GAMMA(W2)/GAMMA(W1+W2)
C          Chebyshev polynomials
      CHEB1(X)=X
      CHEB2(X)=2.*X**2-1.
      CHEB3(X)=X*(-3.+4.*X**2)
      CHEB4(X)=1.+X**2*(-8.+8.*X**2)
      CHEB5(X)=X*(5.+X**2*(-20.+16.*X**2))
C
C          Entry -- check for unphysical X
C
      IF(X.LE.0..OR.X.GE..9999) THEN
        STRUC=0.
        GO TO 9999
      ENDIF
C
C          Determine equivalent quark type IIQ for proton
C
      IF(IH.EQ.1120) THEN
        IIQ=IQ
      ELSEIF(IH.EQ.-1120) THEN
        IIQ=IQPB(IQ)
      ELSEIF(IH.EQ.1220) THEN
        IIQ=IQN(IQ)
      ELSEIF(IH.EQ.-1220) THEN
        IIQ=IQNB(IQ)
      ELSE
C          This should never happen
        STRUC=0
        RETURN
      ENDIF
C
C          Select structure function fit.
C
      IF(ISTRUC.EQ.7) GO TO 4000
      IF(ISTRUC.EQ.6) GO TO 3100
      IF(ISTRUC.EQ.5) GO TO 3000
      IF(ISTRUC.EQ.4) GO TO 2000
      IF(ISTRUC.EQ.3) GO TO 1000
+SELF,IF=PDFLIB
      IF(ISTRUC.EQ.-999) GO TO 9000
+SELF
      STRUC=0.
      GO TO 9999
C
C          Calculate Eichten etal structure fcn for type IIQ
C
1000  STRUC=0.
      Q2=QSQ
      IF(Q2.LT.5.) Q2=5.
      T=ALOG(Q2/ALAM2)
      TMAX=ALOG(1.E8/ALAM2)
      IF(IIQ.GT.9) GO TO 1001
      Q2MIN=5.
      GO TO 1002
1001  AMQ=AMASS(IIQ/2)
      Q2MIN=4.*AMQ**2/(1.-X)
      IF(Q2.LT.Q2MIN) GO TO 9999
1002  TMIN=ALOG(Q2MIN/ALAM2)
      T1=(2.*T-(TMAX+TMIN))/(TMAX-TMIN)
      CHEBQ(1)=1.
      CHEBQ(2)=CHEB1(T1)
      CHEBQ(3)=CHEB2(T1)
      CHEBQ(4)=CHEB3(T1)
      CHEBQ(5)=CHEB4(T1)
      CHEBQ(6)=CHEB5(T1)
C          x.gt.0.1
      IF(X.LT.0.1) GO TO 1010
      X1=(2.*X-1.1)/.9
      ISHFT=0
      GO TO 1020
C          x.lt.0.1
1010  X1=(2.*ALOG(X)+11.51293)/6.90776
      ISHFT=8
C          IFIT is pointer for Eichten quark type.
C          IFIT2 is pointer for function -- shifted by 8 for x<0.1
1020  IFIT=IE1FIT(IIQ)
      IFIT2=IFIT+ISHFT
      CHEBX(1)=1.
      CHEBX(2)=CHEB1(X1)
      CHEBX(3)=CHEB2(X1)
      CHEBX(4)=CHEB3(X1)
      CHEBX(5)=CHEB4(X1)
      CHEBX(6)=CHEB5(X1)
      TERM=0.
      DO 1030 JQ=1,6
      DO 1030 JX=1,6
1030  TERM=TERM+E1STRC(JX,JQ,IFIT2)*CHEBQ(JQ)*CHEBX(JX)
      TERM=TERM*(1.-X)**E1POW(IFIT)
      STRUC=ABS(TERM)
      IF(IFIT.GT.2) GO TO 9999
C          Add sea term for valence quarks
      TERM=0.
      DO 1040 JQ=1,6
      DO 1040 JX=1,6
1040  TERM=TERM+E1STRC(JX,JQ,3+ISHFT)*CHEBQ(JQ)*CHEBX(JX)
      TERM=TERM*(1.-X)**E1POW(3)
      STRUC=STRUC+ABS(TERM)
      GO TO 9999
C
C          Calculate Duke-Owens structure function for type IIQ.
C
2000  STRUC=0.
      Q2=QSQ
      IF(Q2.LT.4.) Q2=4.
      S=ALOG(ALOG(Q2/ALAM2)/ALOG(4./ALAM2))
      SS=S*S
C          x*f(x) for gl
      IF(IIQ.EQ.1) THEN
        A0=1.56-1.71*S+.638*SS
        A1=-0.949*S+.325*SS
        B1=6.+1.44*S-1.05*SS
        A2=9.-7.19*S+.255*SS
        B2=-16.5*S+10.9*SS
        C2=15.3*S-10.1*SS
        STRUC=A0*X**A1*(1.-X)**B1*(1.+A2*X+B2*X**2+C2*X**3)
C          x*f(x) for up,ub,dn,db,st,sb
      ELSEIF(IIQ.LE.7) THEN
        A0=1.265-1.132*S+.293*SS
        A1=-.372*S-.029*SS
        B1=8.05+1.59*S-.153*SS
        A2=6.31*S-.273*SS
        B2=-10.5*S-3.17*SS
        C2=14.7*S+9.80*SS
        STRUC=A0*X**A1*(1.-X)**B1*(1.+A2*X+B2*X**2+C2*X**3)/6.
        IF(IIQ.EQ.2.OR.IIQ.EQ.4) THEN
          ETA1=.419+.004*S-.007*SS
          ETA2=3.46+.724*S-.066*SS
          GUD=4.40-4.86*S+1.33*SS
          ETA3=.763-.237*S+.026*SS
          ETA4=4.00+.627*S-.019*SS
          GD=-.421*S+.033*SS
          AUD=3./(BETA(ETA1,ETA2+1.)*(1.+GUD*ETA1/(ETA1+ETA2+1.)))
          FUD=AUD*X**ETA1*(1.-X)**ETA2*(1.+GUD*X)
          AD=1./(BETA(ETA3,ETA4+1.)*(1.+GD*ETA3/(ETA3+ETA4+1.)))
          FD=AD*X**ETA3*(1.-X)**ETA4*(1.+GD*X)
          IF(IIQ.EQ.2) STRUC=STRUC+FUD-FD
          IF(IIQ.EQ.4) STRUC=STRUC+FD
        ENDIF
C          x*f(x) for ch,cb
      ELSEIF(IIQ.LE.9) THEN
        A0=.135*S-.0075*SS
        A1=-.036-.222*S-.058*SS
        B1=6.35+3.26*S-.909*SS
        A2=-3.03*S+1.50*SS
        B2=17.4*S-11.3*SS
        C2=-17.9*S+15.6*SS
        STRUC=A0*X**A1*(1.-X)**B1*(1.+A2*X+B2*X**2+C2*X**3)
C          x*f(x)=0 for bt,bb,tp,tb
      ELSE
        STRUC=0.
      ENDIF
      GO TO 9999
C
C          Calculate CTEQ2L distribution for type IIQ
C
3000  STRUC=0
      IFL=IIQ/2
C          Set up thresholds
      Q=SQRT(QSQ)
      IF(IFL.LE.4) THEN
        QI=1.6
      ELSEIF(IFL.EQ.5) THEN
        QI=5.0
      ELSEIF(IFL.EQ.6) THEN
        QI=180
      ELSE
        RETURN
      ENDIF
      IF(Q.LT.QI) THEN
        Q=QI
        IF(IFL.GE.4) GO TO 9999
      ENDIF
C          Hard code lambda=0.190
      SBL=LOG(Q/0.190)/LOG(QI/0.190)
      SB=LOG (SBL)
      SB2=SB*SB
      SB3=SB2*SB
C          Calculate sea part
      IF(IFL.EQ.0) THEN
        A0=EXP(-0.6510E+00-0.1128E+01*SB-0.6239E-01*SB2-0.8838E-01*SB3)
        A1=-0.2590E+00+0.1822E+00*SB-0.2682E+00*SB2+0.9422E-01*SB3
        A2= 0.4607E+01+0.7792E+00*SB+0.8937E+00*SB2-0.5553E+00*SB3
        A3= 0.1627E+02-0.1114E+02*SB+0.4928E+01*SB2-0.1715E+01*SB3
        A4= 0.1236E+01+0.1945E+00*SB-0.3297E+00*SB2+0.6489E-01*SB3
        A5= 0.0000E+00+0.3346E+01*SB-0.2337E+01*SB2+0.7850E+00*SB3
      ELSEIF(IFL.EQ.1) THEN
        A0=EXP(-0.1508E+01-0.5560E+00*SB-0.3523E+00*SB2+0.6562E-01*SB3)
        A1=-0.3223E+00+0.2095E-01*SB-0.2049E-02*SB2-0.3475E-01*SB3
        A2= 0.9469E+01-0.3923E+01*SB+0.4333E+01*SB2-0.1654E+01*SB3
        A3= 0.1646E+02-0.1082E+02*SB+0.8941E+01*SB2-0.5494E+01*SB3
        A4= 0.2908E+01+0.2162E+01*SB-0.3233E+01*SB2+0.1267E+01*SB3
        A5=-0.5819E+00+0.3914E+00*SB+0.6460E+00*SB2-0.3239E+00*SB3
      ELSEIF(IFL.EQ.2) THEN
        A0=EXP(-0.1951E+01-0.3435E+01*SB+0.3424E+01*SB2-0.1249E+01*SB3)
        A1=-0.2942E+00+0.4408E+00*SB-0.5453E+00*SB2+0.1552E+00*SB3
        A2= 0.9782E+01-0.3454E+01*SB+0.4510E+01*SB2-0.1649E+01*SB3
        A3= 0.4999E+02-0.1993E+02*SB-0.2039E+01*SB2+0.5694E+00*SB3
        A4= 0.1938E+01-0.1351E+01*SB+0.1386E+01*SB2-0.5324E+00*SB3
        A5=-0.2410E+00+0.3434E+01*SB-0.3334E+01*SB2+0.1067E+01*SB3
      ELSEIF(IFL.EQ.3) THEN
        A0=EXP(-0.1804E+01-0.4381E+01*SB-0.3699E+00*SB2+0.3878E+00*SB3)
        A1=-0.1000E-02-0.9334E+00*SB+0.7156E+00*SB2-0.2029E+00*SB3
        A2= 0.6896E+01+0.2462E+01*SB-0.2885E+01*SB2+0.8701E+00*SB3
        A3= 0.0000E+00+0.5589E+01*SB+0.1047E+02*SB2+0.3000E+02*SB3
        A4= 0.1000E-02-0.5600E-02*SB+0.5618E-02*SB2+0.6598E-02*SB3
        A5= 0.0000E+00-0.3151E+01*SB+0.4025E+01*SB2-0.1232E+01*SB3
      ELSEIF(IFL.EQ.4) THEN
        A0=SB**0.7860E+00*EXP(-0.5041E+01-0.3357E+00*SB-0.4718E+00*SB2)
        A1=-0.4989E+00+0.9571E+00*SB-0.1359E+01*SB2+0.5384E+00*SB3
        A2= 0.5986E+01-0.8541E+01*SB+0.1274E+02*SB2-0.5275E+01*SB3
        A3= 0.8121E+01-0.1753E+02*SB+0.2194E+02*SB2-0.8538E+01*SB3
        A4= 0.9290E-01-0.4390E+00*SB+0.6162E+00*SB2-0.2231E+00*SB3
        A5=-0.1257E+01+0.5677E+01*SB-0.5977E+01*SB2+0.2387E+01*SB3
      ELSEIF(IFL.EQ.5) THEN
        A0=SB**0.4537E+00*EXP(-0.3269E+01-0.5398E+01*SB+0.2893E+01*SB2)
        A1=-0.1977E+00-0.4126E+00*SB+0.7058E+00*SB2-0.4038E+00*SB3
        A2= 0.4522E+01+0.6167E-01*SB-0.1849E+00*SB2+0.7345E+00*SB3
        A3=-0.1003E+01+0.1531E+01*SB+0.4515E+01*SB2-0.4368E+01*SB3
        A4= 0.3579E-01+0.1919E+00*SB-0.7268E+00*SB2+0.5192E+00*SB3
        A5= 0.5129E+00+0.2447E+01*SB-0.1989E+01*SB2+0.7529E+00*SB3
      ELSEIF(IFL.EQ.6) THEN
        A0=SB**0.7178E+00*EXP(-0.7327E+01+0.2277E+01*SB+0.3913E+01*SB2)
        A1=-0.9842E-01-0.2362E+01*SB+0.8851E+01*SB2-0.7208E+01*SB3
        A2= 0.5552E+01-0.8935E+01*SB+0.2676E+02*SB2-0.1344E+02*SB3
        A3= 0.1593E+01-0.3505E+01*SB-0.1234E+01*SB2-0.1867E+02*SB3
        A4=-0.1723E+00+0.1530E+01*SB+0.2323E+01*SB2-0.9344E+01*SB3
        A5= 0.2081E+01+0.1939E+01*SB-0.3273E+01*SB2+0.9935E+01*SB3
      ENDIF
      P012=A0*(X**A1)*((1.-X)**A2)
      P34=(1.+A3*(X**A4))
      P5=(LOG(1.+1./X))**A5
      SEA=P012*P34*P5
C          Add valence part
      IF(IIQ.NE.2.AND.IIQ.NE.4) THEN
        STRUC=SEA
        GO TO 9999
      ELSEIF(IIQ.EQ.2) THEN
        A0=EXP(-0.1806E+01-0.6672E-01*SB-0.2605E+00*SB2+0.2341E-01*SB3)
        A1= 0.1750E+00+0.3872E-01*SB-0.2189E-01*SB2+0.1415E-01*SB3
        A2= 0.3322E+01+0.7786E+00*SB-0.2902E+00*SB2+0.1517E+00*SB3
        A3= 0.4414E+02-0.1987E+02*SB+0.2597E+01*SB2+0.2670E+01*SB3
        A4= 0.9610E+00-0.2864E+00*SB-0.5524E-01*SB2+0.6229E-01*SB3
        A5= 0.0000E+00+0.2658E+00*SB-0.4728E-02*SB2+0.6048E-01*SB3
      ELSEIF(IIQ.EQ.4) THEN
        A0=EXP( 0.8000E-01+0.7364E+00*SB-0.2714E+01*SB2+0.1311E+01*SB3)
        A1= 0.4930E+00-0.2001E+00*SB+0.5784E+00*SB2-0.2915E+00*SB3
        A2= 0.3001E+01+0.3538E+01*SB-0.6155E+01*SB2+0.3083E+01*SB3
        A3=-0.1000E+01+0.3871E+01*SB-0.8334E+01*SB2+0.4219E+01*SB3
        A4= 0.2986E+01+0.1597E+01*SB-0.3368E+01*SB2+0.1644E+01*SB3
        A5= 0.0000E+00-0.9256E+00*SB+0.3570E+01*SB2-0.1777E+01*SB3
      ENDIF
      P012=A0*(X**A1)*((1.-X)**A2)
      P34=(1.+A3*(X**A4))
      P5=(LOG(1.+1./X))**A5
      VAL=P012*P34*P5
      STRUC=VAL+SEA
      GO TO 9999
C
C          Calculate CTEQ3L distribution for type IIQ
C
3100  STRUC=0
      IFL=IIQ/2
C          Set up thresholds
      Q=SQRT(QSQ)
      IF(IFL.LE.4) THEN
        QI=1.6
      ELSEIF(IFL.EQ.5) THEN
        QI=5.0
      ELSEIF(IFL.EQ.6) THEN
        QI=180
      ELSE
        RETURN
      ENDIF
      IF(Q.LT.QI) THEN
        Q=QI
        IF(IFL.GE.4) GO TO 9999
      ENDIF
C          Hard code lambda=0.177
      SBL=LOG(Q/0.177)/LOG(QI/0.177)
      SB=LOG (SBL)
      SB2=SB*SB
      SB3=SB2*SB
C          Calculate sea part
      IF(IFL.EQ.0) THEN
        A0=Exp(-0.7631E+00-0.7241E+00*SB -0.1170E+01*SB2+0.5343E+00*SB3)
        A1=-0.3573E+00+0.3469E+00*SB -0.3396E+00*SB2+0.9188E-01*SB3
        A2= 0.5604E+01+0.7458E+00*SB -0.5082E+00*SB2+0.1844E+00*SB3
        A3= 0.1549E+02-0.1809E+02*SB +0.1162E+02*SB2-0.3483E+01*SB3
        A4= 0.9881E+00+0.1364E+00*SB -0.4421E+00*SB2+0.2051E+00*SB3
        A5=-0.9505E-01+0.3259E+01*SB -0.1547E+01*SB2+0.2918E+00*SB3
      ELSEIF(IFL.EQ.1) THEN
        A0=Exp(-0.2740E+01-0.7987E-01*SB -0.9015E+00*SB2-0.9872E-01*SB3)
        A1=-0.3909E+00+0.1244E+00*SB -0.4487E-01*SB2+0.1277E-01*SB3
        A2= 0.9163E+01+0.2823E+00*SB -0.7720E+00*SB2-0.9360E-02*SB3
        A3= 0.1080E+02-0.3915E+01*SB -0.1153E+01*SB2+0.2649E+01*SB3
        A4= 0.9894E+00-0.1647E+00*SB -0.9426E-02*SB2+0.2945E-02*SB3
        A5=-0.3395E+00+0.6998E+00*SB +0.7000E+00*SB2-0.6730E-01*SB3
      ELSEIF(IFL.EQ.2) THEN
        A0=Exp(-0.2449E+01-0.3513E+01*SB +0.4529E+01*SB2-0.2031E+01*SB3)
        A1=-0.4050E+00+0.3411E+00*SB -0.3669E+00*SB2+0.1109E+00*SB3
        A2= 0.7470E+01-0.2982E+01*SB +0.5503E+01*SB2-0.2419E+01*SB3
        A3= 0.1503E+02+0.1638E+01*SB -0.8772E+01*SB2+0.3852E+01*SB3
        A4= 0.1137E+01-0.1006E+01*SB +0.1485E+01*SB2-0.6389E+00*SB3
        A5=-0.5299E+00+0.3160E+01*SB -0.3104E+01*SB2+0.1219E+01*SB3
      ELSEIF(IFL.EQ.3) THEN
        A0=Exp(-0.3640E+01+0.1250E+01*SB -0.2914E+01*SB2+0.8390E+00*SB3)
        A1=-0.3595E+00-0.5259E-01*SB +0.3122E+00*SB2-0.1642E+00*SB3
        A2= 0.7305E+01+0.9727E+00*SB -0.9788E+00*SB2-0.5193E-01*SB3
        A3= 0.1198E+02-0.1799E+02*SB +0.2614E+02*SB2-0.1091E+02*SB3
        A4= 0.9882E+00-0.6101E+00*SB +0.9737E+00*SB2-0.4935E+00*SB3
        A5=-0.1186E+00-0.3231E+00*SB +0.3074E+01*SB2-0.1274E+01*SB3
      ELSEIF(IFL.EQ.4) THEN
        A0=SB**0.1122E+01*Exp(-0.3718E+01-0.1335E+01*SB +0.1651E-01*SB2)
        A1=-0.4719E+00+0.7509E+00*SB -0.8420E+00*SB2+0.2901E+00*SB3
        A2= 0.6194E+01-0.1641E+01*SB +0.4907E+01*SB2-0.2523E+01*SB3
        A3= 0.4426E+01-0.4270E+01*SB +0.6581E+01*SB2-0.3474E+01*SB3
        A4= 0.2683E+00+0.9876E+00*SB -0.7612E+00*SB2+0.1780E+00*SB3
        A5=-0.4547E+00+0.4410E+01*SB -0.3712E+01*SB2+0.1245E+01*SB3
      ELSEIF(IFL.EQ.5) THEN
        A0=SB**0.9838E+00*Exp(-0.2548E+01-0.7660E+01*SB +0.3702E+01*SB2)
        A1=-0.3122E+00-0.2120E+00*SB +0.5716E+00*SB2-0.3773E+00*SB3
        A2= 0.6257E+01-0.8214E-01*SB -0.2537E+01*SB2+0.2981E+01*SB3
        A3=-0.6723E+00+0.2131E+01*SB +0.9599E+01*SB2-0.7910E+01*SB3
        A4= 0.9169E-01+0.4295E-01*SB -0.5017E+00*SB2+0.3811E+00*SB3
        A5= 0.2402E+00+0.2656E+01*SB -0.1586E+01*SB2+0.2880E+00*SB3
      ELSEIF(IFL.EQ.6) THEN
        A0=SB**0.1001E+01*Exp(-0.6934E+01+0.3050E+01*SB -0.6943E+00*SB2)
        A1=-0.1713E+00-0.5167E+00*SB +0.1241E+01*SB2-0.1703E+01*SB3
        A2= 0.6169E+01+0.3023E+01*SB -0.1972E+02*SB2+0.1069E+02*SB3
        A3= 0.4439E+01-0.1746E+02*SB +0.1225E+02*SB2+0.8350E+00*SB3
        A4= 0.5458E+00-0.4586E+00*SB +0.9089E+00*SB2-0.4049E+00*SB3
        A5= 0.3207E+01-0.3362E+01*SB +0.5877E+01*SB2-0.7659E+01*SB3
      ENDIF
      P012=A0*(X**A1)*((1.-X)**A2)
      P34=(1.+A3*(X**A4))
      P5=(LOG(1.+1./X))**A5
      SEA=P012*P34*P5
C          Add valence part
      IF(IIQ.NE.2.AND.IIQ.NE.4) THEN
        STRUC=SEA
        GO TO 9999
      ELSEIF(IIQ.EQ.2) THEN
        A0=Exp( 0.1907E+00+0.4205E-01*SB +0.2752E+00*SB2-0.3171E+00*SB3)
        A1= 0.4611E+00+0.2331E-01*SB -0.3403E-01*SB2+0.3174E-01*SB3
        A2= 0.3504E+01+0.5739E+00*SB +0.2676E+00*SB2-0.1553E+00*SB3
        A3= 0.7452E+01-0.6742E+01*SB +0.2849E+01*SB2-0.1964E+00*SB3
        A4= 0.1116E+01-0.3435E+00*SB +0.2865E+00*SB2-0.1288E+00*SB3
        A5= 0.6659E-01+0.2714E+00*SB -0.2688E+00*SB2+0.2763E+00*SB3
      ELSEIF(IIQ.EQ.4) THEN
        A0=Exp( 0.1141E+00+0.4764E+00*SB -0.1745E+01*SB2+0.7728E+00*SB3)
        A1= 0.4275E+00-0.1290E+00*SB +0.3609E+00*SB2-0.1689E+00*SB3
        A2= 0.3000E+01+0.2946E+01*SB -0.4117E+01*SB2+0.1989E+01*SB3
        A3=-0.1302E+01+0.2322E+01*SB -0.4258E+01*SB2+0.2109E+01*SB3
        A4= 0.2586E+01-0.1920E+00*SB -0.3754E+00*SB2+0.2731E+00*SB3
        A5=-0.2251E+00-0.5374E+00*SB +0.2245E+01*SB2-0.1034E+01*SB3
      ENDIF
      P012=A0*(X**A1)*((1.-X)**A2)
      P34=(1.+A3*(X**A4))
      P5=(LOG(1.+1./X))**A5
      VAL=P012*P34*P5
      STRUC=VAL+SEA
      GO TO 9999
C
C          Calculate CTEQ5L distribution for type IIQ
C          Uses auxiliary function CTEQ5L by Pumplin to do real work
C
4000  CONTINUE
      Q5L=SQRT(QSQ)
      X5L=X
      IFL=IIQ/2
      IF(IFL.GE.3.OR.2*IFL.NE.IIQ) IFL=-IFL
      IF(IFL.EQ.-1) THEN
        SUM5L=CTEQ5L(-1,X5L,Q5L)
        RAT5L=CTEQ5L(-2,X5L,Q5L)
        STRUC=X5L*SUM5L/(1.D0+RAT5L)
      ELSEIF(IFL.EQ.-2) THEN
        SUM5L=CTEQ5L(-1,X5L,Q5L)
        RAT5L=CTEQ5L(-2,X5L,Q5L)
        STRUC=X5L*SUM5L*RAT5L/(1.D0+RAT5L)
      ELSEIF(IFL.GE.-5.AND.IFL.LE.5) THEN
        STRUC=X5L*CTEQ5L(IFL,X5L,Q5L)
      ELSE
        STRUC=0
      ENDIF
      GO TO 9999
C
C          Calculate PDFLIB distributions and return one for type IIQ.
C
+SELF,IF=PDFLIB
9000  CONTINUE
      DX=X
      DSCALE=DSQRT(DBLE(QSQ))
      CALL PFTOPDG(DX,DSCALE,DXPDF)
      STRUC=DXPDF(IQMAP(IIQ))
+SELF
C
C          Require minimum value for STRUC
C
9999  IF(STRUC.LT.SFMIN) STRUC=SFMIN
      RETURN
      END
+EOD
+DECK,STRUCW
      FUNCTION STRUCW(XW,IW,IH)
C
C          LONGITUDINAL W STRUCTURE FUNCTIONS CALCULATED BY CONVOLUTION
C          OF EHLQ STRUCTURE FUNCTIONS AT Q**2=AMW**2 WITH F(W/Q) FROM
C          DAWSON, N.P. B249, 42 (1985).
C          IW = 1   2   3   4
C               GM  W+  W-  Z0
C          WARNING: DEFAULT VALUES ONLY FOR LAMBDA, SIN2W, ETC.
C
+SELF,IF=DOUBLE.
      DOUBLE PRECISION X,XLOG
+SELF.
C          FOLLOWING CONSTANTS ARE (CV**2+CA**2)/(4*PI**2)
      DATA CVAW/2.701E-3/,CVAZUU/1.017E-3/,CVAZDD/1.298E-3/
C
C          STATEMENT FUNCTIONS CALCULATED BY INTEGRATING EACH TERM IN
C          EHLQ PARAMETERIZATION USING SMP 1.5.0.
C
C          FROM STRUCW2.EX
      FUVAL(X) = 5.769575427 - 10.13681547*X + 3.042561145*XLOG -
     $ 0.2798411214*(1./X) - 0.3404284678*(XLOG/X) + 8.296794608*(X**2)
     $ - 6.017283047*(X**3) + 3.548706099*(X**4) - 1.560232679*(X**5)
     $ + 0.4342326806*(X**6) - 0.05513649922*(X**7)
C
      FDVAL(X) = 2.533753356 - 4.57001915*X + 0.9589133982*XLOG -
     $ 0.307417692*(1./X) - 0.1793690733*(XLOG/X) + 4.566485508*(X**2)
     $ - 3.937617129*(X**3) + 2.773480477*(X**4) - 1.540248513*(X**5)
     $ + 0.6183097947*(X**6) - 0.1542126064*(X**7) +
     $ 0.0174859553*(X**8)
C
      FUSEA(X) = -5.503869566 + 15.20985662*X - 5.166205929*XLOG -
     $ 1.728208206*(1./X) - 0.4215945253*(XLOG/X) - 18.82164974*(X**2)
     $ + 24.27679709*(X**3) - 27.22445715*(X**4) + 24.98752188*(X**5)
     $ - 18.12394891*(X**6) + 10.06144542*(X**7) - 4.106763252*(X**8)
     $ + 1.15847115*(X**9) - 0.2014529514*(X**10) +
     $ 0.01625760301*(X**11)
C
      FDSEA(X) = -5.478593775 + 15.1097528*X - 5.581750835*XLOG -
     $ 1.987547927*(1./X) - 0.4944113864*(XLOG/X) - 17.23528157*(X**2)
     $ + 20.59071315*(X**3) - 21.48775889*(X**4) + 18.40750425*(X**5)
     $ - 12.46901771*(X**6) + 6.45303238*(X**7) - 2.445316084*(X**8) +
     $ 0.6363027326*(X**9) - 0.1011660335*(X**10) +
     $ 0.007376682094*(X**11)
C
      GUVAL1(X) = 6.650062246 + 1.480836233*X - 3.536793901*XLOG -
     $ 5.08758928*(1./X) - 2.458893299*(XLOG/X) -
     $ 0.4159265541*(XLOG**2/X) - 0.03949356966*(XLOG**3/X) -
     $ 0.002175877338*(XLOG**4/X) - 6.382577207E-5*(XLOG**5/X) -
     $ 7.324244818E-7*(XLOG**6/X) + 0.575121435*(X*XLOG) +
     $ 0.09704190061*(X*XLOG**2) + 791./90953.*(X *XLOG**3)
      GUVAL2(X) =
     $ 3.962955366E-4*(X*XLOG**4) + 6.591820335E-6*(X *XLOG**5) -
     $ 0.07706665525*(X**2*XLOG) - 0.01260088982*(X**2*XLOG**2) -
     $ 0.001080476729*(X**2*XLOG**3) - 4.647425231E-5*(X**2*XLOG**4) -
     $ 7.324244829E-7*(X**2*XLOG**5) - 0.2027508558*(X**2) -
     $ 0.6721633358*(XLOG**2) - 0.07339139987*(XLOG**3) -
     $ 0.004744695259*(XLOG**4) - 1.651100349E-4*XLOG**5 -
     $ 2.197273446E-6*XLOG**6
C
      GDVAL1(X) = 2.403815112 + 1.359504335*X - 2.144999226*XLOG -
     $ 2.357471591*(1./X) - 1.13339787*(XLOG/X) -
     $ 0.2003574358*(XLOG**2/X) - 0.02221455952*(XLOG**3/X) -
     $ 0.001601991722*(XLOG**4/X) - 6.878677010E-5*(XLOG**5/X) -
     $ 1.323789434E-6*(XLOG**6/X) + 0.4984901703*(X*XLOG) +
     $ 0.09080940556*(X*XLOG**2) + 0.01045471879*(X *XLOG**3)
      GDVAL2(X) =
     $ 7.339489291E-4*(X*XLOG**4) + 2.382820980E-5*(X *XLOG**5) -
     $ 0.1348586553*(X**2*XLOG) - 0.02441501092*(X**2*XLOG**2) -
     $ 0.002734669503*(X**2*XLOG**3) - 1.807502877E-4*(X**2*XLOG**4) -
     $ 5.295157736E-6*(X**2*XLOG**5) + 0.01826324487*(X**3*XLOG) +
     $ 0.003291926818*(X**3*XLOG**2) + 3.636001057E-4*(X**3*XLOG**3) +
     $ 2.342115438E-5*(X**3*XLOG**4) + 6.618947159E-7*(X**3*XLOG**5) -
     $ 0.3679347826*(X**2) + 0.04985470259*(X**3) -
     $ 0.3928663839*(XLOG**2) - 0.04732954832*(XLOG**3) -
     $ 0.003974205548*( XLOG**4) - 2.116051876E-4*XLOG**5 -
     $ 5.295157736E-6*XLOG**6
C
      GUSEA1(X) = -0.8251281831 + 1.555766474*X - 0.476618796*XLOG -
     $ 0.157877015*(1./X) + 0.3273497735*(XLOG/X) +
     $ 0.1184829659*(XLOG**2/X) + 0.01147973292*(XLOG**3/X) +
     $ 0.001370332595*(XLOG**4/X) + 4.084139287E-5*(XLOG**5/X) +
     $ 2.284079310E-6*(XLOG**6/X) - 1.681676555*(X*XLOG) +
     $ 0.01771802464*(X*XLOG**2) - 0.04546554244*(X *XLOG**3) -
     $ 3.454606694E-4*(X*XLOG**4) - 1.438969965E-4*(X *XLOG**5) +
     $ 0.8875664376*(X**2*XLOG) + 0.04051742981*(X**2 *XLOG**2)
      GUSEA2(X) =
     $ 0.0254151271*(X**2*XLOG**3) + 4.583985126E-4*(X**2*XLOG**4) +
     $ 7.994277584E-5*(X**2*XLOG**5) - 0.4492144518*(X**3*XLOG) -
     $ 0.02965496152*(X**3*XLOG**2) - 0.01288679853*(X**3*XLOG**3) -
     $ 2.791634921E-4*(X**3*XLOG**4) - 3.997138792E-5*(X**3*XLOG**5) +
     $ 0.1638328221*(X**4*XLOG) + 0.01250393016*(X**4*XLOG**2) +
     $ 0.004685172364*(X**4*XLOG**3) + 1.100919901E-4*(X**4*XLOG**4) +
     $ 1.438969967E-5*(X**4*XLOG**5) - 0.0367848506*(X**5*XLOG) -
     $ 0.003035305139*(X**5*XLOG**2) - 0.001048416117*(X**5*XLOG**3) -
     $ 2.579726667E-5*(X**5*XLOG**4) - 3.197711036E-6*(X**5*XLOG**5) +
     $ 0.003783780648*(X**6*XLOG) + 3.278296157E-4*(X**6*XLOG**2) +
     $ 1.075296502E-4*(X**6*XLOG**3) + 2.725601849E-6*(X**6*XLOG**4)
      GUSEA3(X) =
     $ 3.262970444E-7*(X**6*XLOG**5) - 0.2259054436*(X**2) +
     $ 0.003364712414*(X**3) + 0.01992787001*(X**4) - 0.007399430903*
     $ (X**5) + 9.652150086E-4*X**6 + 0.554652844*(XLOG**2) +
     $ 0.011217842*(XLOG**3) + 0.007692743973*(XLOG**4) +
     $ 9.402708800E-5*XLOG**5 + 1.598855517E-5*XLOG**6
C
      GDSEA1(X) = -0.9201807217 + 2.243479849*X - 0.899698589*XLOG -
     $ 0.3970657521*(1./X) + 0.2818290666*(XLOG/X) +
     $ 0.120664241*(XLOG**2/X) + 0.01043451714 *(XLOG**3/X) +
     $ 0.001191246128*(XLOG**4/X) + 3.001102810E-5*(XLOG**5/X) +
     $ 2.039937816E-6*(XLOG**6/X) - 1.787863927*(X*XLOG) +
     $ 826./63247.*(X*XLOG**2) - 0.04263009293*(X*XLOG**3) +
     $ 3.087205491E-5*( X*XLOG**4) - 1.285160824E-4*(X*XLOG**5) +
     $ 0.9517638436*(X**2*XLOG) + 0.04047432532*(X**2*XLOG**2) +
     $ 0.02332032497*(X**2*XLOG**3) + 2.208416029E-4*(X**2*XLOG**4)
      GDSEA2(X) =
     $ 7.139782355E-5*(X**2*XLOG**5) - 0.4816526149*(X**3*XLOG) -
     $ 0.02893293689*(X**3*XLOG**2) - 0.01172595961*(X**3*XLOG**3) -
     $ 1.550444419E-4*(X**3*XLOG**4) - 3.569891178E-5*(X**3*XLOG**5) +
     $ 0.1755025883*(X**4*XLOG) + 0.01209064681*(X**4*XLOG**2) +
     $ 0.004244259809*(X**4*XLOG**3) + 6.438373778E-5*(X**4*XLOG**4) +
     $ 1.285160826E-5*(X**4*XLOG**5) - 0.03937044174*(X**5*XLOG) -
     $ 0.002920614679*(X**5*XLOG**2) - 9.471446970E-4*(X**5*XLOG**3) -
     $ 1.549746135E-5*(X**5*XLOG**4) - 2.855912944E-6*(X**5*XLOG**5)
      GDSEA3(X) =
     $ 0.004046756409*(X**6*XLOG) + 3.144555106E-4*(X**6*XLOG**2) +
     $ 9.696129739E-5*(X**6*XLOG**3) + 1.664636351E-6*(X**6*XLOG**4) +
     $ 2.914196881E-7*(X**6*XLOG**5) - 0.5703745807*(X**2) +
     $ 0.1676594704*(X**3) - 0.03765961644*(X**4) +
     $ 0.005180399826*(X**5) - 3.032419889E-4*X**6 +
     $ 0.5916013402*(XLOG**2) + 0.0113078292*(XLOG**3) +
     $ 0.007094724813*( XLOG**4) + 3.872242009E-5*XLOG**5 +
     $ 1.427956471E-5*XLOG**6
C
      EUVAL(X) = -3.398748694 + 0.6266420937*(1./X)
      EDVAL(X) = -1.300464877 + 0.2267175031*(1./X)
      EUSEA(X) = -0.4281951222 + 0.0600001177*(1./X)
      EDSEA(X) = -0.5744690066 + 0.08143317382*(1./X)
C
C          ENTRY
C
      IF(XW.LE.0..OR.XW.GE.1.) THEN
        STRUCW=0.
        RETURN
      ENDIF
      X=XW
      XLOG=LOG(X)
C
      IIW=IW
      IF(IH.EQ.-1120) THEN
        IF(IW.EQ.2) IIW=3
        IF(IW.EQ.3) IIW=2
      ELSEIF(IH.EQ.1220) THEN
        IF(IW.EQ.2) IIW=3
        IF(IW.EQ.3) IIW=2
      ENDIF
C
      IF(XW.GT..1) GO TO 1000
C
C          STRUCW = XW*F(XW) FOR IIW=W+ IN PROTON, XW<.1
      IF(IIW.EQ.2) THEN
        G1=GUVAL1(X)
        G1=G1+GUVAL2(X)
        G2=GUSEA1(X)
        G2=G2+GUSEA2(X)
        G2=G2+GUSEA3(X)
        G3=GDSEA1(X)
        G3=G3+GDSEA2(X)
        G3=G3+GDSEA3(X)
        SUM=G1+G2+G3+EUVAL(X)+EUSEA(X)+EDSEA(X)
        STRUCW=X*CVAW*SUM
C          STRUCW = XW*F(XW) FOR IIW=W- IN PROTON, XW<.1
      ELSEIF(IIW.EQ.3) THEN
        G1=GDVAL1(X)
        G1=G1+GDVAL2(X)
        G2=GDSEA1(X)
        G2=G2+GDSEA2(X)
        G2=G2+GDSEA3(X)
        G3=GUSEA1(X)
        G3=G3+GUSEA2(X)
        G3=G3+GUSEA3(X)
        SUM=G1+G2+G3+EDVAL(X)+EDSEA(X)+EUSEA(X)
        STRUCW=X*CVAW*SUM
C          STRUCW=XW*F(XW) FOR IIW=Z0 IN PROTON, XW<.1
      ELSEIF(IIW.EQ.4) THEN
        G1=GUVAL1(X)
        G1=G1+GUVAL2(X)
        G2=GUSEA1(X)
        G2=G2+GUSEA2(X)
        G2=G2+GUSEA3(X)
        SUMU=G1+2.*G2+EUVAL(X)+2.*EUSEA(X)
        G1=GDVAL1(X)
        G1=G1+GDVAL2(X)
        G2=GDSEA1(X)
        G2=G2+GDSEA2(X)
        G2=G2+GDSEA3(X)
        SUMD=G1+2.*G2+EDVAL(X)+2.*EDSEA(X)
        STRUCW=X*(CVAZUU*SUMU+CVAZDD*SUMD)
      ENDIF
      IF(STRUCW.LT.0.) STRUCW=0.
      RETURN
C
1000  CONTINUE
C
C            STRUCW=XW*F(XW) FOR IIW=W+ IN PROTON, XW>.1
      IF(IIW.EQ.2) THEN
        F1=FUVAL(X)
        F2=FUSEA(X)
        F3=FDSEA(X)
        SUM=F1+F2+F3
        STRUCW=X*CVAW*SUM
C          STRUCW=XW*F(XW) FOR IIW=W- IN PROTON, XW>.1
      ELSEIF(IIW.EQ.3) THEN
        F1=FDVAL(X)
        F2=FDSEA(X)
        F3=FUSEA(X)
        SUM=F1+F2+F3
        STRUCW=X*CVAW*SUM
C          STRUCW=XW*F(XW) FOR IIW=Z0 IN PROTON, XW>.1
      ELSEIF(IIW.EQ.4) THEN
        F1=FUVAL(X)
        F2=FUSEA(X)
        SUMU=F1+2.*F2
        F1=FDVAL(X)
        F2=FDSEA(X)
        SUMD=F1+2.*F2
        STRUCW=X*(CVAZUU*SUMU+CVAZDD*SUMD)
      ENDIF
      IF(STRUCW.LT.0.) STRUCW=0.
      RETURN
      END
+EOD
+DECK,SZJJ1
      REAL*8 FUNCTION SZJJ1(P1, P2, P3, P4, P5,IM1,IM2)
C
C Function generated by Madgraph + hand coding 
C Returns amplitude squared summed/avg over colors
C and helicities
C for the point in phase space P1,P2,P3,P4,...
C for process : q(im1) q~(im1)  -> z q(im2) q~(im2)
C with Madgraph codes IM1 != IM2  
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER IM1,IM2
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY                                         
      REAL*8 T
      REAL*8 ZJJ1                                                            
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ1 = 0D0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ1(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM1,IM2) 
             SZJJ1 = SZJJ1 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                  GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ1 = SZJJ1 /  4D0 
      END
+EOD       
+DECK,SZJJ2
      REAL*8 FUNCTION SZJJ2(P1, P2, P3, P4, P5, IM)
C
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/ave over colors
C for the point in phase space P1,P2,P3,P4,P5
C and helicity NHEL(1)...
C for the process: g g -> z q(im) qb(im)
C with Madgraph code IM
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      INTEGER IM                             
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY                                         
      REAL*8 T
      REAL*8 ZJJ2                                                             
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ2 = 0D0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ2(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM) 
             SZJJ2 = SZJJ2 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ2 = SZJJ2 /  4D0 
      END
+EOD
+DECK,SZJJ3
      REAL*8 FUNCTION SZJJ3(P1, P2, P3, P4, P5, IM)
C
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/ave over colors
C for the point in phase space P1,P2,P3,P4,P5
C and helicity NHEL(1)...
C for the process: q(im) qb(im) -> z g g
C with Madgraph code IM
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER IM
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY                                         
      REAL*8 T
      REAL*8 ZJJ3                                                                
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ3 = 0D0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ3(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM) 
             SZJJ3 = SZJJ3 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                  GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ3 = SZJJ3 /  4D0 
      END
+EOD
+DECK,SZJJ4
      REAL*8 FUNCTION SZJJ4(P1, P2, P3, P4, P5,IM)
C
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/ave over colors
C for the point in phase space P1,P2,P3,P4,P5
C and helicity NHEL(1)...
C for the process: q(im) qb(im) -> z q(im) qb(im)
C with Madgraph code IM
C
C  
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER IM
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY                                         
      REAL*8 T
      REAL*8 ZJJ4                                                                
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ4 = 0D0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ4(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM) 
             SZJJ4 = SZJJ4 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                  GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ4 = SZJJ4 /  4D0 
      END
+EOD
+DECK,SZJJ5
      REAL*8 FUNCTION SZJJ5(P1, P2, P3, P4, P5, IM1, IM2)
C  
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/avg over colors
C and helicities
C for the point in phase space p1,p2,p3,p4,...
C  
C for process : q(im1) q(im2)  -> z q(im1) q(im2)
C with Madgraph codes IM1 != IM2  
C  
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER IM1,IM2
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY                                         
      REAL*8 T
      REAL*8 ZJJ5                                                                
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ5 = 0d0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ5(P1, P2, P3, P4, P5,NHEL(1,IHEL), IM1,IM2) 
             SZJJ5 = SZJJ5 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                  GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ5 = SZJJ5 /  4D0 
      END
+EOD
+DECK,SZJJ6
      REAL*8 FUNCTION SZJJ6(P1, P2, P3, P4, P5, IM1)
C  
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/avg over colors
C and helicities
C for the point in phase space p1,p2,p3,p4,...
C  
C for process : q(im1) q(im1)  -> z q(im1) q(im1)
C  
      IMPLICIT NONE
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER IM1
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY                                         
      REAL*8 T
      REAL*8 ZJJ6                                                                
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ6 = 0d0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ6(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM1) 
             SZJJ6 = SZJJ6 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                  GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ6 = SZJJ6 /  4D0 
      END
+EOD
+DECK,SZJJ7
      REAL*8 FUNCTION SZJJ7(P1, P2, P3, P4, P5, IM1)
C  
C Function generated by Madgraph
C Returns amplitude squared summed/avg over colors
C and helicities
C for the point in phase space p1,p2,p3,p4,...
C  
C for process : g q(im1)  -> z g q(im1)  
C  
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NEXTERNAL,   NCOMB                     
      PARAMETER (NEXTERNAL=5, NCOMB= 48)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      INTEGER IM1
C  
C LOCAL VARIABLES 
C  
      INTEGER NHEL(NEXTERNAL,NCOMB),NTRY
      REAL*8 T
      REAL*8 ZJJ7
      INTEGER IHEL
      LOGICAL GOODHEL(NCOMB)
      DATA GOODHEL/NCOMB*.FALSE./
      DATA NTRY/0/
      DATA (NHEL(IHEL,  1),IHEL=1,5) / -1, -1, -1, -1, -1/
      DATA (NHEL(IHEL,  2),IHEL=1,5) / -1, -1, -1, -1,  1/
      DATA (NHEL(IHEL,  3),IHEL=1,5) / -1, -1, -1,  1, -1/
      DATA (NHEL(IHEL,  4),IHEL=1,5) / -1, -1, -1,  1,  1/
      DATA (NHEL(IHEL,  5),IHEL=1,5) / -1, -1,  0, -1, -1/
      DATA (NHEL(IHEL,  6),IHEL=1,5) / -1, -1,  0, -1,  1/
      DATA (NHEL(IHEL,  7),IHEL=1,5) / -1, -1,  0,  1, -1/
      DATA (NHEL(IHEL,  8),IHEL=1,5) / -1, -1,  0,  1,  1/
      DATA (NHEL(IHEL,  9),IHEL=1,5) / -1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 10),IHEL=1,5) / -1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 11),IHEL=1,5) / -1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 12),IHEL=1,5) / -1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 13),IHEL=1,5) / -1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 14),IHEL=1,5) / -1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 15),IHEL=1,5) / -1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 16),IHEL=1,5) / -1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 17),IHEL=1,5) / -1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 18),IHEL=1,5) / -1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 19),IHEL=1,5) / -1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 20),IHEL=1,5) / -1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 21),IHEL=1,5) / -1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 22),IHEL=1,5) / -1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 23),IHEL=1,5) / -1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 24),IHEL=1,5) / -1,  1,  1,  1,  1/
      DATA (NHEL(IHEL, 25),IHEL=1,5) /  1, -1, -1, -1, -1/
      DATA (NHEL(IHEL, 26),IHEL=1,5) /  1, -1, -1, -1,  1/
      DATA (NHEL(IHEL, 27),IHEL=1,5) /  1, -1, -1,  1, -1/
      DATA (NHEL(IHEL, 28),IHEL=1,5) /  1, -1, -1,  1,  1/
      DATA (NHEL(IHEL, 29),IHEL=1,5) /  1, -1,  0, -1, -1/
      DATA (NHEL(IHEL, 30),IHEL=1,5) /  1, -1,  0, -1,  1/
      DATA (NHEL(IHEL, 31),IHEL=1,5) /  1, -1,  0,  1, -1/
      DATA (NHEL(IHEL, 32),IHEL=1,5) /  1, -1,  0,  1,  1/
      DATA (NHEL(IHEL, 33),IHEL=1,5) /  1, -1,  1, -1, -1/
      DATA (NHEL(IHEL, 34),IHEL=1,5) /  1, -1,  1, -1,  1/
      DATA (NHEL(IHEL, 35),IHEL=1,5) /  1, -1,  1,  1, -1/
      DATA (NHEL(IHEL, 36),IHEL=1,5) /  1, -1,  1,  1,  1/
      DATA (NHEL(IHEL, 37),IHEL=1,5) /  1,  1, -1, -1, -1/
      DATA (NHEL(IHEL, 38),IHEL=1,5) /  1,  1, -1, -1,  1/
      DATA (NHEL(IHEL, 39),IHEL=1,5) /  1,  1, -1,  1, -1/
      DATA (NHEL(IHEL, 40),IHEL=1,5) /  1,  1, -1,  1,  1/
      DATA (NHEL(IHEL, 41),IHEL=1,5) /  1,  1,  0, -1, -1/
      DATA (NHEL(IHEL, 42),IHEL=1,5) /  1,  1,  0, -1,  1/
      DATA (NHEL(IHEL, 43),IHEL=1,5) /  1,  1,  0,  1, -1/
      DATA (NHEL(IHEL, 44),IHEL=1,5) /  1,  1,  0,  1,  1/
      DATA (NHEL(IHEL, 45),IHEL=1,5) /  1,  1,  1, -1, -1/
      DATA (NHEL(IHEL, 46),IHEL=1,5) /  1,  1,  1, -1,  1/
      DATA (NHEL(IHEL, 47),IHEL=1,5) /  1,  1,  1,  1, -1/
      DATA (NHEL(IHEL, 48),IHEL=1,5) /  1,  1,  1,  1,  1/
C ----------
C BEGIN CODE
C ----------
      SZJJ7 = 0d0
      NTRY=NTRY+1
      DO IHEL=1,NCOMB
          IF (GOODHEL(IHEL) .OR. NTRY .LT. 10) THEN
             T=ZJJ7(P1, P2, P3, P4, P5,NHEL(1,IHEL),IM1) 
             SZJJ7 = SZJJ7 + T
              IF (T .GT. 0D0 .AND. .NOT. GOODHEL(IHEL)) THEN
                  GOODHEL(IHEL)=.TRUE.
              ENDIF
          ENDIF
      ENDDO
      SZJJ7 = SZJJ7 /  4D0 
      END
+EOD
+DECK,TIMER.
      SUBROUTINE TIMER(IT)
C
C          CALL SYSTEM CPU CLOCK -- MACHINE DEPENDENT.
C          IT=1 FOR RUN START TIME.
C          IT=2 FOR RUN STOP TIME.
C
+CDE,ITAPES
+CDE,TIMES
      DIMENSION TIMES(2)
      EQUIVALENCE (TIMES(1),TIME1)
      DIMENSION TTT(2)
+SELF,IF=VAX.
      INTEGER CPUTIM(2),ITMLST(4),NHSEC
      EXTERNAL JPI$_CPUTIM
+SELF.
C
C          DEFAULT IS TO RETURN ZERO.
      TNOW=0.
+SELF,IF=CDC,IF=NOCERN.
C          SECOND GIVES CPU TIME ON CDC.
      CALL SECOND(TNOW)
+SELF,IF=ETA,IF=NOCERN.
C          SECOND GIVES CPU TIME ON ETA.
      TNOW=SECOND()
+SELF,IF=IBMRT,IF=NOCERN.
C          MCLOCK GIVES CPU TIME ON IBM RS/6000.
      TNOW=FLOAT(MCLOCK())/60.
+SELF,IF=SGI,IF=NOCERN.
C          ETIME GIVES CPU TIME ON SILICON GRAPHICS.
      TNOW=ETIME(TTT)
+SELF,IF=SUN,IF=NOCERN.
C          ETIME GIVES CPU TIME ON SUN.
      TNOW=ETIME(TTT)
+SELF,IF=VAX,IF=NOCERN.
C          VAX HAS NO FORTRAN FUNCTION FOR CPU TIME.
C          FOLLOWING PROVIDED BY T. KILLIAN
      ITMLST(1)=ISHFT(%LOC(JPI$_CPUTIM),16)+4
      ITMLST(2)=%LOC(NHSEC)
      ITMLST(3)=0
      ITMLST(4)=0
      CALL SYS$GETJPI(,,,ITMLST,,,)
      TNOW=.01*NHSEC
+SELF,IF=CERN.
      CALL TIMEST(1.E7)
      CALL TIMEX(TNOW)
+SELF.
      TIMES(IT)=TNOW
      RETURN
      END
+EOD
+DECK,TWOJET.
      SUBROUTINE TWOJET
C
C          Driving routine to generate initial parameters for jets,
C          assuming zero initial transverse momentum, ie PT(1)=PT(2).
C
C          Parameters are PT,YJ,PHI with P,YJ,XJ as dependent variables,
C          where YJ=RAPIDITY, XJ=Feynman X.
C          All parameters are stored in COMMON/JETPAR/.
C          Cross section is called from NOGOOD.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IDRUN
+CDE,ITAPES
+CDE,KEYS
+CDE,MBPAR
+CDE,PJETS
+CDE,PINITS
+CDE,JETLIM
+CDE,PTPAR
+CDE,JETPAR
+CDE,PRIMAR
+CDE,PARTCL
+CDE,CONST
+CDE,JETSIG
+CDE,TOTALS
+CDE,ISLOOP
+CDE,SSTYPE
+CDE,XMSSM
C
      REAL ACOSH,XXX,WTFCN,PPP,RANF,SIGN,SGN,AMQ1,AMASS,AMQ2
      REAL PPLUS,PMINUS,PSUM3,PSUM4,PPL,PMN,SQ1,SQ2,ROOT,P1PL,P1MN
      REAL P2PL,P2MN,AMI1,AMI2
      INTEGER NREJ,I,II,IS,IFL1,IFL2
      REAL X(2)
      EQUIVALENCE (X(1),X1)
      LOGICAL NOGOOD
      LOGICAL YGENJ
      INTEGER LISTJ(17),LISTW(4),LISTSS(85),LISTSM(30)
C
C          SUSY IDENT codes from /SSTYPE/. (Fortran 77 allows - signs
C          in parameter statements but not data statements.)
      INTEGER MSUPL,MSDNL,MSSTL,MSCHL,MSBT1,MSTP1,
     $MSUPR,MSDNR,MSSTR,MSCHR,MSBT2,MSTP2,MSW1,MSW2,
     $MSNEL,MSEL,MSNML,MSMUL,MSNTL,MSTAU1,MSER,MSMUR,MSTAU2
      PARAMETER (MSUPL=-ISUPL)
      PARAMETER (MSDNL=-ISDNL)
      PARAMETER (MSSTL=-ISSTL)
      PARAMETER (MSCHL=-ISCHL)
      PARAMETER (MSBT1=-ISBT1)
      PARAMETER (MSTP1=-ISTP1)
      PARAMETER (MSUPR=-ISUPR)
      PARAMETER (MSDNR=-ISDNR)
      PARAMETER (MSSTR=-ISSTR)
      PARAMETER (MSCHR=-ISCHR)
      PARAMETER (MSBT2=-ISBT2)
      PARAMETER (MSTP2=-ISTP2)
      PARAMETER (MSW1=-ISW1)
      PARAMETER (MSW2=-ISW2)
      PARAMETER (MSNEL=-ISNEL)
      PARAMETER (MSEL=-ISEL)
      PARAMETER (MSNML=-ISNML)
      PARAMETER (MSMUL=-ISMUL)
      PARAMETER (MSNTL=-ISNTL)
      PARAMETER (MSTAU1=-ISTAU1)
      PARAMETER (MSER=-ISER)
      PARAMETER (MSMUR=-ISMUR)
      PARAMETER (MSTAU2=-ISTAU2)
C
      DATA LISTSS/ISGL,
     $ISUPL,MSUPL,ISDNL,MSDNL,ISSTL,MSSTL,ISCHL,MSCHL,ISBT1,MSBT1,
     $ISTP1,MSTP1,
     $ISUPR,MSUPR,ISDNR,MSDNR,ISSTR,MSSTR,ISCHR,MSCHR,ISBT2,MSBT2,
     $ISTP2,MSTP2,
     $ISW1,MSW1,ISW2,MSW2,ISZ1,ISZ2,ISZ3,ISZ4,
     $ISNEL,MSNEL,ISEL,MSEL,ISNML,MSNML,ISMUL,MSMUL,ISNTL,MSNTL,
     $ISTAU1,MSTAU1,ISER,MSER,ISMUR,MSMUR,ISTAU2,MSTAU2,
     $9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13,
     $14,-14,15,-15,16,-16,10,80,-80,90,82,83,84,86,-86/
      DATA LISTSM/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,11,-11,12,-12,13,-13,
     $14,-14,15,-15,16,-16,10,80,-80,90,81/
      DATA LISTJ/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,7,-7,8,-8/
      DATA LISTW/10,80,-80,90/
C          Inverse hyperbolic cosine function
      ACOSH(XXX)=ALOG(XXX+SQRT(XXX**2-1.))
      WTFCN(PPP)=2.*PPP*PTGEN2*PTGEN3*PPP**((PTGEN3-1.)/PTGEN3)
C
C          Initialize
C
      NPTCL=0
      PHI(1)=PHIMIN(1)+(PHIMAX(1)-PHIMIN(1))*RANF()
      PHI(2)=AMOD(PHI(1)+PI,2.*PI)
      NREJ=-1
      SIGMA=0.
      WT=1.
      IF(.NOT.FIXPT(2)) GOTO 101
      FIXPT(1)=.TRUE.
      PT(1)=PT(2)
  101 CONTINUE
      IF(FIXPT(1)) GOTO 400
      DO 110 I=1,2
      IF(FIXP(I)) GOTO 200
      IF(FIXXJ(I)) GOTO 300
  110 CONTINUE
C
C          Genetate PT and YJ with no variables fixed
C
  111 NREJ=NREJ+1
      IF(NREJ.GT.NTRIES) GO TO 910
      SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN)
      NKINPT=NKINPT+1
      SIGMA=0.
      WT=1.
C            Generate PT with a power law distribution
      PT(1)=(PTGEN1+PTGEN2*RANF())**PTGEN3
      PT(2)=PT(1)
      SIGMAX=PTFUN1*PT(1)**PTFUN2
C          GENERATE FLAT IN YJ, CALCULATE CORRESPONDING TH
      DO 115 I=1,2
      IF(FIXYJ(I)) GOTO 115
      IF(.NOT.YGENJ(I)) GOTO 111
  115 CONTINUE
      DO 116 I=1,2
      P(I)=PT(I)/STH(I)
      IF(P(I).LT.PMIN(I).OR.P(I).GT.PMAX(I)) GOTO 111
      XJ(I)=P(I)*CTH(I)/HALFE
      IF(XJ(I).LT.XJMIN(I).OR.XJ(I).GT.XJMAX(I)) GOTO 111
  116 CONTINUE
      WT=WT*WTFCN(PT(1))
      IF(NOGOOD(1)) GOTO 111
      SUMWT=SUMWT+SIGMA*WT/(NEVOLV*NFRGMN)
      NKEEP=NKEEP+1
      GO TO 500
C
C          Generate PT and YJ fixing P
C
  200 CONTINUE
      II=3-I
  211 NREJ=NREJ+1
      IF(NREJ.GT.NTRIES) GO TO 910
      NKINPT=NKINPT+1
      WT=0.
      IF(FIXYJ(I)) GOTO 212
C          Generate PT with a power law distribution
      PT(1)=(PTGEN1+PTGEN2*RANF())**PTGEN3
      SIGMAX=PTFUN1*PT(1)**PTFUN2
      PT(2)=PT(1)
C          Given PT, TH is fixed except for a sign
      STH(I)=PT(I)/P(I)
      SIGN=1.0
      IF(RANF().GT.0.5) SIGN=-1.0
      CTH(I)=SIGN*SQRT(1.-STH(I)**2)
      TH(I)=ATAN2(STH(I),CTH(I))
      YJ(I)=-ALOG(TAN(TH(I)/2.))
      IF(YJ(I).LT.YJMIN(I).OR.YJ(I).GT.YJMAX(I)) GOTO 211
      GOTO 213
  212 PT(1)=P(I)*STH(I)
  213 CONTINUE
      XJ(I)=P(I)*CTH(I)/HALFE
      IF(XJ(I).LT.XJMIN(I).OR.XJ(I).GT.XJMAX(I)) GOTO 211
      IF(FIXP(II)) GOTO 220
      IF(FIXXJ(II)) GOTO 230
      IF(FIXYJ(II)) GOTO 215
      IF(.NOT.YGENJ(II)) GOTO 211
  215 CONTINUE
      P(II)=PT(II)/STH(II)
      IF(P(II).LT.PMIN(II).OR.P(II).GT.PMAX(II)) GOTO 211
      XJ(II)=P(II)*CTH(II)/HALFE
      IF(XJ(II).LT.XJMIN(II).OR.XJ(II).GT.XJMAX(II)) GOTO 211
      GOTO 250
220   STH(II)=PT(II)/P(II)
      SGN=1.0
      IF(RANF().GT.0.5) SGN=-1.0
      CTH(II)=SGN*SQRT(1.-STH(II)**2)
      TH(II)=ATAN2(STH(II),CTH(II))
      YJ(II)=-ALOG(TAN(TH(II)/2.))
      IF(YJ(II).LT.YJMIN(II).OR.YJ(II).GT.YJMAX(II)) GOTO 211
      XJ(II)=P(II)*CTH(II)/HALFE
      IF(XJ(II).LT.XJMIN(II).OR.XJ(II).GT.XJMAX(II)) GOTO 211
      GOTO 250
  230 TH(II)=ATAN2(PT(II),XJ(II)*HALFE)
      YJ(II)=-ALOG(TAN(TH(II)/2.))
      IF(YJ(II).LT.YJMIN(II).OR.YJ(II).GT.YJMAX(II)) GOTO 211
      CTH(II)=COS(TH(II))
      STH(II)=SIN(TH(II))
  250 CONTINUE
      IF(NOGOOD(1)) GOTO 211
      NKEEP=NKEEP+1
      GO TO 500
C
C          Generate PT and YJ at fixed XJ
C
  300 CONTINUE
      II=3-I
  311 NREJ=NREJ+1
      IF(NREJ.GT.NTRIES) GO TO 910
      NKINPT=NKINPT+1
      WT=0.
C          Generate PT with a power law distribution
      PT(1)=(PTGEN1+PTGEN2*RANF())**PTGEN3
      SIGMAX=PTFUN1*PT(1)**PTFUN2
      PT(2)=PT(1)
      TH(I)=ATAN2(PT(I),XJ(I)*HALFE)
      YJ(I)=-ALOG(TAN(TH(I)/2.))
      IF(YJ(I).LT.YJMIN(I).OR.YJ(I).GT.YJMAX(I)) GOTO 311
      CTH(I)=COS(TH(I))
      STH(I)=SIN(TH(I))
      P(I)=PT(I)/STH(I)
      IF(FIXYJ(II)) GOTO 315
      IF(FIXP(II)) GOTO 314
      YJ(II)=YJMIN(II)+(YJMAX(II)-YJMIN(II))*RANF()
      TH(II)=2.*ATAN(EXP(-YJ(II)))
      CTH(II)=COS(TH(II))
      STH(II)=SIN(TH(II))
      GOTO 315
  314 CONTINUE
      STH(II)=PT(II)/P(II)
      CTH(II)=SQRT(1.-STH(II)**2)
      IF(RANF().GT.0.5) CTH(II)=-CTH(II)
      TH(II)=ATAN2(STH(II),CTH(II))
      YJ(II)=-ALOG(TAN(TH(II)/2.))
  315 CONTINUE
      P(II)=PT(II)/STH(II)
      XJ(II)=P(II)*CTH(II)/HALFE
      IF(XJ(II).LT.XJMIN(II).OR.XJ(II).GT.XJMAX(II)) GOTO 311
      IF(NOGOOD(1)) GOTO 311
      NKEEP=NKEEP+1
      GO TO 500
C
C          Generate YJ at fixed PT
C
  400 CONTINUE
      PT(2)=PT(1)
  411 NREJ=NREJ+1
      IF(NREJ.GT.NTRIES) GO TO 910
      NKINPT=NKINPT+1
      WT=0.
      DO 415 I=1,2
      IF(FIXYJ(I)) GOTO 415
      IF(FIXP(I)) GOTO 413
      IF(.NOT.YGENJ(I)) GO TO 411
      GOTO 414
  413 CONTINUE
      IS=1
      IF(RANF().GT.0.5) IS=2
      CTH(I)=CTHS(IS,I)
      TH(I)=THS(IS,I)
      YJ(I)=YJS(IS,I)
  414 CONTINUE
      P(I)=PT(I)/STH(I)
      XJ(I)=P(I)*CTH(I)/HALFE
  415 CONTINUE
      IF(NOGOOD(1)) GOTO 411
      NKEEP=NKEEP+1
C
C          Reset /JETPAR/
C
  500 CONTINUE
      IF(KEYS(1)) THEN
        IFL1=LISTJ(JETTYP(1))
        IFL2=LISTJ(JETTYP(2))
        AMQ1=AMASS(IFL1)
        AMQ2=AMASS(IFL2)
        AMI1=AMASS(LISTJ(INITYP(1)))
        AMI2=AMASS(LISTJ(INITYP(2)))
        CALL TWOKIN(AMI1,AMI2,AMQ1,AMQ2)
      ELSEIF(KEYS(5).OR.(KEYS(10).AND.GOMSSM)) THEN
        IFL1=LISTSS(JETTYP(1))
        IFL2=LISTSS(JETTYP(2))
        AMQ1=AMASS(IFL1)
        AMQ2=AMASS(IFL2)
        CALL TWOKIN(0.,0.,AMQ1,AMQ2)
      ELSEIF(KEYS(6)) THEN
        IFL1=LISTW(JETTYP(1))
        IFL2=LISTW(JETTYP(2))
        AMQ1=AMASS(IFL1)
        AMQ2=AMASS(IFL2)
        CALL TWOKIN(0.,0.,AMQ1,AMQ2)
      ELSEIF(KEYS(8)) THEN
        IF(JETTYP(1).LE.13) THEN
          IFL1=LISTJ(JETTYP(1))
        ELSE
          IFL1=10
        ENDIF
        IF(JETTYP(2).LE.13) THEN
          IFL2=LISTJ(JETTYP(2))
        ELSE
          IFL2=10
        ENDIF
        AMQ1=AMASS(IFL1)
        AMQ2=AMASS(IFL2)
        CALL TWOKIN(0.,0.,AMQ1,AMQ2)
      ELSEIF(KEYS(10).AND.(.NOT.GOMSSM)) THEN
        IFL1=LISTSM(JETTYP(1))
        IFL2=LISTSM(JETTYP(2))
        AMQ1=AMASS(IFL1)
        AMQ2=AMASS(IFL2)
        CALL TWOKIN(0.,0.,AMQ1,AMQ2)
      ENDIF
C
C            Set PBEAM and PJETS
C
      PBEAM(1)=(1.-X1)*HALFE
      PBEAM(2)=(1.-X2)*HALFE
      DO 501 I=1,2
        PJETS(3,I)=P(I)*CTH(I)
        PJETS(1,I)=PT(I)*COS(PHI(I))
        PJETS(2,I)=PT(I)*SIN(PHI(I))
        IF(KEYS(1)) THEN
          IDJETS(I)=LISTJ(JETTYP(I))
        ELSEIF(KEYS(5).OR.(KEYS(10).AND.GOMSSM)) THEN
          IDJETS(I)=LISTSS(JETTYP(I))
        ELSEIF(KEYS(6)) THEN
          IDJETS(I)=LISTW(JETTYP(I))
        ELSEIF(KEYS(8)) THEN
          IDJETS(1)=IFL1
          IDJETS(2)=IFL2
        ELSEIF(KEYS(10)) THEN
          IDJETS(I)=LISTSM(JETTYP(I))
        ENDIF
        PJETS(5,I)=AMASS(IDJETS(I))
        PJETS(4,I)=SQRT(P(I)**2+PJETS(5,I)**2)
  501 CONTINUE
C
C          Set PINITS
C
      DO 600 I=1,2
      IDINIT(I)=LISTJ(INITYP(I))
      PINITS(5,I)=AMASS(IDINIT(I))
      PPLUS=X(I)*ECM
      PMINUS=PINITS(5,I)**2/PPLUS
      PINITS(4,I)=.5*(PPLUS+PMINUS)
      PINITS(3,I)=.5*(PPLUS-PMINUS)*(3-2*I)
      PINITS(2,I)=0.
      PINITS(1,I)=0.
600   CONTINUE
C          Calculate PINITS exactly.
      PSUM3=PJETS(3,1)+PJETS(3,2)
      PSUM4=PJETS(4,1)+PJETS(4,2)
      IF(PSUM3.GT.0.) THEN
        PPL=PSUM4+PSUM3
        PMN=SHAT/PPL
      ELSE
        PMN=PSUM4-PSUM3
        PPL=SHAT/PMN
      ENDIF
      SQ1=PINITS(5,1)**2
      SQ2=PINITS(5,2)**2
      ROOT=SQRT((PPL*PMN-SQ1-SQ2)**2-4.*SQ1*SQ2)
      P1PL=(PPL*PMN+SQ1-SQ2+ROOT)/(2.*PMN)
      P1MN=SQ1/P1PL
      P2MN=(PPL*PMN+SQ2-SQ1+ROOT)/(2.*PPL)
      P2PL=SQ2/P2MN
      PINITS(4,1)=.5*(P1PL+P1MN)
      PINITS(3,1)=.5*(P1PL-P1MN)
      PINITS(4,2)=.5*(P2PL+P2MN)
      PINITS(3,2)=.5*(P2PL-P2MN)
      RETURN
C
C          Error
C
910   CALL PRTEVT(0)
      WRITE(ITLIS,1000) NREJ
 1000 FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE AN',
     $' EVENT. CHECK LIMITS OR INCREASE NTRIES.')
      STOP 99
      END
+EOD
+DECK,TWOKIN.
      SUBROUTINE TWOKIN(AMI1,AMI2,AM1,AM2)
C
C          Given P,PT,TH,PHI, and initial and final masses AMI1, AMI2,
C          AM1,AM2, set X1, X2, SHAT, etc.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,PRIMAR
+CDE,JETPAR
+CDE,QCDPAR
+CDE,CONST
C
      REAL    AMI1,AMI2,AM1,AM2,P1PL,P1MN,P2PL,P2MN,E1,E2,PPL,PMN,
     $        PI1PL,PI1MN,PI2PL,PI2MN,ANEFF,AMASS,ALAMFN
C
      E1=SQRT(P(1)**2+AM1**2)
      E2=SQRT(P(2)**2+AM2**2)
C
C          For 32-bit machines must use large and small components
C          carefully, with pbig*psmall = pt**2+am**2.
C
      IF(CTH(1).GT.0.) THEN
        P1PL=E1+P(1)*CTH(1)
        P1MN=(PT(1)**2+AM1**2)/P1PL
      ELSE
        P1MN=E1-P(1)*CTH(1)
        P1PL=(PT(1)**2+AM1**2)/P1MN
      ENDIF
      IF(CTH(2).GT.0.) THEN
        P2PL=E2+P(2)*CTH(2)
        P2MN=(PT(2)**2+AM2**2)/P2PL
      ELSE
        P2MN=E2-P(2)*CTH(2)
        P2PL=(PT(2)**2+AM2**2)/P2MN
      ENDIF
C
C          Initial light cone momenta. Not symmetric if AMI1 /= AMI2.
C
      PPL=P1PL+P2PL
      PMN=P1MN+P2MN
      SHAT=PPL*PMN
      ALAMFN=SQRT((SHAT-AMI1**2-AMI2**2)**2-4.*(AMI1*AMI2)**2)
      PI1PL=(SHAT+AMI1**2-AMI2**2+ALAMFN)/(2.*PMN)
      PI1MN=AMI1**2/PI1PL
      PI2MN=(SHAT+AMI2**2-AMI1**2+ALAMFN)/(2.*PPL)
      PI2PL=AMI2**2/PI2MN
      X1=PI1PL/ECM
      X2=PI2MN/ECM
C
C          t=(p1-pi1)**2, u=(p1-pi2)**2
C
      THAT=AM1**2+AMI1**2-P1PL*PI1MN-P1MN*PI1PL
      UHAT=AM1**2+AMI2**2-P1PL*PI2MN-P1MN*PI2PL
C
C          Q**2 variable from Field, Fox, Wolfram
C
      QSQ=2.*SHAT*THAT*UHAT/(SHAT**2+THAT**2+UHAT**2)
      QSQ=AMAX1(QSQ,(AM1+AM2)**2)
      ANEFF=4.+QSQ/(QSQ+AMASS(5)**2)+QSQ/(QSQ+AMASS(6)**2)
      ALFQSQ=12.*PI/((33.-2.*ANEFF)*ALOG(QSQ/ALAM2))
      RETURN
      END
+EOD
+DECK,VISAJE
      CHARACTER*40 FUNCTION VISAJE()
+CDE,IDRUN
      VISAJE = ' ISAJET     V7.74   16-FEB-2006 14:23:44'
      IDVER = 774
      RETURN
      END
+EOD
+DECK,WHIGGS.
      SUBROUTINE WHIGGS
C
C          Finish generation of whiggs events started bY TWOJET.
C          Select W decay modes as allowed by WMODE1, WMODE2.
C          Generate W decay angles and put vectors in PPAIR.
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR.
+CDE,JETPAR.
+CDE,PRIMAR.
+CDE,Q1Q2.
+CDE,JETSIG.
+CDE,CONST.
+CDE,QSAVE.
+CDE,WCON.
+CDE,PJETS.
+CDE,PINITS
+CDE,KEYS
+CDE,HCON
+CDE,WWPAR
+CDE,XMSSM
C
      DIMENSION X(2),LIST(25),P1WCM(4),P2WCM(4),P1LAB(4),P2LAB(4)
     1,PBOOST(4)
      EQUIVALENCE (X(1),X1)
      DIMENSION JWWTYP(2)
      REAL GVQ(2),GAQ(2),GVL(2),GAL(2)
      REAL X,RND,RANF,CBRWW,AMASS,AM0,AM1,AM2,
     $E1CM,E2CM,P12CM,CTHCM,STHCM,PHICM,CPHICM,SPHICM,P1WCM,P2WCM,
     $PBOOST,P1LAB,P2LAB,ZHSIG,ZHMAX
      INTEGER JWWTYP,JET,JWT,JQ,IQ1,IQ2,LIST,NREJ,NJ0,K
      REAL BRANCH(12),SUMBR,BETAWH,GAMWH,PZWHCM,CTHD,WHSIG
      INTEGER IDABS,IDABS1,IDABSJ,IDIABS
C
      DATA LIST/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/
C
      GVQ(1)=.25-2*SIN2W/3.
      GVQ(2)=-.25+SIN2W/3.
      GAQ(1)=-.25
      GAQ(2)=.25
      GVL(1)=.25
      GVL(2)=-.25+SIN2W
      GAL(1)=-.25
      GAL(2)=.25
      NPAIR=0
      IF(KEYS(10).AND..NOT.GOMSSM) THEN
        JWWTYP(1)=JETTYP(1)-25
        JWWTYP(2)=JETTYP(2)-25
      ELSEIF(KEYS(10).AND.GOMSSM) THEN
        JWWTYP(1)=JETTYP(1)-76
        JWWTYP(2)=JETTYP(2)-76
      ENDIF
C
C          Select W decay modes and put in /JETSET/. First particle
C          is always the fermion.
 
      DO 200 JET=1,2
        IDABS=IABS(IDJETS(JET))
        IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 200
        RND=RANF()
        JWT=JWWTYP(JET)
C          Must only consider allowed decays for this mass
        SUMBR=0.
        DO 201 JQ=1,12
          IQ1=2*JQ
          IQ2=MATCH(IQ1,JWT)
          IF(IQ2.EQ.0) THEN
            BRANCH(JQ)=0.
            GO TO 201
          ENDIF
          AM1=AMASS(LIST(IQ1))
          AM2=AMASS(LIST(IQ2))
          IF(AM1+AM2.LT.PJETS(5,JET)) THEN
            BRANCH(JQ)=RBRWW(JQ,JWT,JET)
            SUMBR=SUMBR+BRANCH(JQ)
          ELSE
            BRANCH(JQ)=0.
          ENDIF
201     CONTINUE
        IF(SUMBR.LE.0.) GO TO 998
        DO 202 JQ=1,12
202     BRANCH(JQ)=BRANCH(JQ)/SUMBR
C
        CBRWW=0.
        DO 210 JQ=1,12
          CBRWW=CBRWW+BRANCH(JQ)
          IF(RND.GT.CBRWW) GO TO 210
          IQ1=2*JQ
          IQ2=MATCH(IQ1,JWT)
          IDPAIR(NPAIR+1)=LIST(IQ1)
          IDPAIR(NPAIR+2)=LIST(IQ2)
          PPAIR(5,NPAIR+1)=AMASS(LIST(IQ1))
          PPAIR(5,NPAIR+2)=AMASS(LIST(IQ2))
          JPAIR(NPAIR+1)=JET
          JPAIR(NPAIR+2)=JET
          NPAIR=NPAIR+2
          JQWW(JET)=JQ
          GO TO 200
210     CONTINUE
200   CONTINUE
C
C          Generate decay uniformly in angle and put in PPAIR.
C          Will check cross section later.
C
      NREJ=0
300   NJ0=2
      DO 310 JET=1,2
        IDABS=IABS(IDJETS(JET))
        IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 310
C          Construct W com momenta.
        IDABSJ=IDABS
        AM0=PJETS(5,JET)
        AM1=PPAIR(5,NJ0-1)
        AM2=PPAIR(5,NJ0)
        E1CM=(AM0**2+AM1**2-AM2**2)/(2.*AM0)
        E2CM=(AM0**2+AM2**2-AM1**2)/(2.*AM0)
        P12CM=(AM0**2-AM1**2-AM2**2)**2-4.*(AM1*AM2)**2
        P12CM=SQRT(P12CM)/(2.*AM0)
        CTHCM=2.*RANF()-1.
        STHCM=SQRT(1.-CTHCM**2)
        PHICM=2.*PI*RANF()
        CPHICM=COS(PHICM)
        SPHICM=SIN(PHICM)
        P1WCM(1)=P12CM*STHCM*CPHICM
        P2WCM(1)=-P1WCM(1)
        P1WCM(2)=P12CM*STHCM*SPHICM
        P2WCM(2)=-P1WCM(2)
        P1WCM(3)=P12CM*CTHCM
        P2WCM(3)=-P1WCM(3)
        P1WCM(4)=E1CM
        P2WCM(4)=E2CM
C          Boost to lab frame.
        DO 320 K=1,3
320     PBOOST(K)=-PJETS(K,JET)
        PBOOST(4)=PJETS(4,JET)
        CALL LBOOST(PBOOST,1,P1WCM,P1LAB)
        CALL LBOOST(PBOOST,1,P2WCM,P2LAB)
        DO 330 K=1,4
          PPAIR(K,NJ0-1)=P1LAB(K)
          PPAIR(K,NJ0)=P2LAB(K)
330     CONTINUE
      NJ0=NJ0+2
310   CONTINUE
C
C          Impose simple (1+-cos(theta))**2 decay distribution for WH
C          Must use P1 in WH CoM frame
      IF (IDABSJ.NE.80.AND.IDABSJ.NE.90) GO TO 400
      BETAWH=(PJETS(3,1)+PJETS(3,2))/(PJETS(4,1)+PJETS(4,2))
      GAMWH=1./SQRT(1.-BETAWH**2)
      PZWHCM=GAMWH*(P1LAB(3)-BETAWH*P1LAB(4))
      CTHD=PZWHCM/SQRT(P1LAB(1)**2+P1LAB(2)**2+PZWHCM**2)
      IF (IDINIT(1).LT.0) CTHD=-CTHD      
      IDIABS=IABS(IDINIT(1))
      IDABS1=IABS(IDPAIR(1))
      IF (IDABSJ.EQ.80) THEN
        WHSIG=(1.+CTHD)**2
        IF(WHSIG.GT.4*RANF()) GO TO 400
      END IF
      IF (IDABSJ.EQ.90) THEN
        IF (IDIABS.EQ.1.OR.IDIABS.EQ.4) THEN
          IF (IDABS1.EQ.1.OR.IDABS1.EQ.4) THEN
            ZHSIG=(GVQ(1)**2+GAQ(1)**2)**2*(1.+CTHD**2)
     $             +8*GVQ(1)*GAQ(1)*GVQ(1)*GAQ(1)*CTHD
            ZHMAX=2*(GVQ(1)**2+GAQ(1)**2)**2
     $             +8*GVQ(1)*GAQ(1)*GVQ(1)*GAQ(1)
          ELSEIF (IDABS1.EQ.2.OR.IDABS1.EQ.3.OR.IDABS1.EQ.5) THEN
            ZHSIG=(GVQ(1)**2+GAQ(1))*(GVQ(2)**2+GAQ(2)**2)*(1.+CTHD**2)
     $             +8*GVQ(1)*GAQ(1)*GVQ(2)*GAQ(2)*CTHD
            ZHMAX=(GVQ(1)**2+GAQ(1))*(GVQ(2)**2+GAQ(2)**2)*2
     $             +8*GVQ(1)*GAQ(1)*GVQ(2)*GAQ(2)
          ELSEIF (IDABS1.EQ.11.OR.IDABS1.EQ.13.OR.IDABS1.EQ.15) THEN
            ZHSIG=(GVQ(1)**2+GAQ(1))*(GVL(1)**2+GAL(1)**2)*(1.+CTHD**2)
     $             +8*GVQ(1)*GAQ(1)*GVL(1)*GAL(1)*CTHD
            ZHMAX=(GVQ(1)**2+GAQ(1))*(GVL(1)**2+GAL(1)**2)*2
     $             +8*GVQ(1)*GAQ(1)*GVL(1)*GAL(1)
          ELSEIF (IDABS1.EQ.12.OR.IDABS1.EQ.14.OR.IDABS1.EQ.16) THEN
            ZHSIG=(GVQ(1)**2+GAQ(1))*(GVL(2)**2+GAL(2)**2)*(1.+CTHD**2)
     $             +8*GVQ(1)*GAQ(1)*GVL(2)*GAL(2)*CTHD
            ZHMAX=(GVQ(1)**2+GAQ(1))*(GVL(2)**2+GAL(2)**2)*2
     $             +8*GVQ(1)*GAQ(1)*GVL(2)*GAL(2)
          END IF
        ELSE IF (IDIABS.EQ.2.OR.IDIABS.EQ.3.OR.IDIABS.EQ.5) THEN
          IF (IDABS1.EQ.1.OR.IDABS1.EQ.4) THEN
            ZHSIG=(GVQ(2)**2+GAQ(2)**2)**2*(1.+CTHD**2)
     $             +8*GVQ(2)*GAQ(2)*GVQ(1)*GAQ(1)*CTHD
            ZHMAX=(GVQ(2)**2+GAQ(2)**2)**2*2
     $             +8*GVQ(2)*GAQ(2)*GVQ(1)*GAQ(1)
          ELSEIF (IDABS1.EQ.2.OR.IDABS1.EQ.3.OR.IDABS1.EQ.5) THEN
            ZHSIG=(GVQ(2)**2+GAQ(2))*(GVQ(2)**2+GAQ(2)**2)*(1.+CTHD**2)
     $             +8*GVQ(2)*GAQ(2)*GVQ(2)*GAQ(2)*CTHD
            ZHMAX=(GVQ(2)**2+GAQ(2))*(GVQ(2)**2+GAQ(2)**2)*2
     $             +8*GVQ(2)*GAQ(2)*GVQ(2)*GAQ(2)
          ELSEIF (IDABS1.EQ.11.OR.IDABS1.EQ.13.OR.IDABS1.EQ.15) THEN
            ZHSIG=(GVQ(2)**2+GAQ(2))*(GVL(1)**2+GAL(1)**2)*(1.+CTHD**2)
     $             +8*GVQ(2)*GAQ(2)*GVL(1)*GAL(1)*CTHD
            ZHMAX=(GVQ(2)**2+GAQ(2))*(GVL(1)**2+GAL(1)**2)*2
     $             +8*GVQ(2)*GAQ(2)*GVL(1)*GAL(1)
          ELSEIF (IDABS1.EQ.12.OR.IDABS1.EQ.14.OR.IDABS1.EQ.16) THEN
            ZHSIG=(GVQ(2)**2+GAQ(2))*(GVL(2)**2+GAL(2)**2)*(1.+CTHD**2)
     $             +8*GVQ(2)*GAQ(2)*GVL(2)*GAL(2)*CTHD
            ZHMAX=(GVQ(2)**2+GAQ(2))*(GVL(2)**2+GAL(2)**2)*2
     $             +8*GVQ(2)*GAQ(2)*GVL(2)*GAL(2)
          END IF
        END IF      
        IF(ZHSIG.GT.RANF()*ZHMAX) GO TO 400
      END IF
      NREJ=NREJ+1
      IF(NREJ.LT.NTRIES) GO TO 300
      GO TO 999
C
C          Good event
C
400   CONTINUE
      RETURN
C
999   CALL PRTEVT(0)
      WRITE(ITLIS,9991) NREJ
9991  FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE ',
     1'A GOOD WHIGGS EVENT.'/' CHECK LIMITS OR INCREASE NTRIES.')
      STOP 99
998   CALL PRTEVT(0)
      WRITE(ITLIS,9981) JET
9981  FORMAT(//' ERROR IN WHIGGS ... NO DECAY POSSIBLE FOR JET',I3)
      STOP 99
      END
+EOD
+DECK,WPAIR.
      SUBROUTINE WPAIR
C
C          Finish generation of wpair events started bY TWOJET.
C          Select W decay modes as allowed by WMODE1, WMODE2.
C          Generate W decay angles and put vectors in PPAIR.
C
C          Also generate massless decay vectors PZERO for matrix
C          element -- double precision for 32-bit machines.
C
C          Ver 6.26: Check kinematics for W -> ff decay, since Z0 from
C                    Higgs decay can be virtual.
C          Ver. 6.30: Added check in loop 201.
C          Ver. 7.14: Add MSSM Higgs hooks
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,QCDPAR.
+CDE,JETPAR.
+CDE,PRIMAR.
+CDE,Q1Q2.
+CDE,JETSIG.
+CDE,WWSIG.
+CDE,WWPAR.
+CDE,CONST.
+CDE,QSAVE.
+CDE,WCON.
+CDE,PJETS.
+CDE,PINITS
+CDE,KEYS
+CDE,WSIG
+CDE,HCON
+CDE,XMSSM
C
      DIMENSION X(2),LIST(25),P1WCM(4),P2WCM(4),P1LAB(4),P2LAB(4)
     $,P1CM0(4),P2CM0(4),P1LAB0(4),P2LAB0(4)
     1,PBOOST(4)
      EQUIVALENCE (X(1),X1)
      DIMENSION PWW(5,2)
      EQUIVALENCE (PWW(1,1),P3WW(1))
      DIMENSION JWWTYP(2),THWFF(2),PHIWFF(2)
+SELF,IF=SINGLE
      REAL P1CM0,P2CM0,DPHI,DCTH,DSTH,DAM0,PWW,BOOST
+SELF,IF=DOUBLE.
      DOUBLE PRECISION P1CM0,P2CM0,DPHI,DCTH,DSTH,DAM0,PWW,BOOST
+SELF.
      REAL AMWW1,AMWW2,X,STRUC,STRUCW,RND,RANF,CBRWW,AMASS,AM0,AM1,AM2,
     $E1CM,E2CM,P12CM,CTHCM,STHCM,PHICM,CPHICM,SPHICM,P1WCM,P2WCM,
     $PBOOST,P1LAB,P2LAB,AFX,SGWWMX,P1LAB0,P2LAB0,THWFF,PHIWFF
      INTEGER IH,IQ,JWWTYP,JET,JWT,JQ,IQ1,IQ2,LIST,NREJ,NJ0,K
      REAL BRANCH(12),SUMBR
      INTEGER IDABS,IDABS1,IDABS2
C
      DATA LIST/9,1,-1,2,-2,3,-3,4,-4,5,-5,6,-6,
     $11,-11,12,-12,13,-13,14,-14,15,-15,16,-16/
C
C          Initialize for given W type.
      AMWW1=PJETS(5,1)
      AMWW2=PJETS(5,2)
      CALL WWKIN(AMWW1,AMWW2)
      NPAIR=0
C
C          Calculate and save structure functions.
      DO 120 IH=1,2
      DO 121 IQ=1,13
121   QSAVE(IQ,IH)=STRUC(X(IH),QSQ,IQ,IDIN(IH))/X(IH)
      DO 122 IQ=14,26
122   QSAVE(IQ,IH)=0.
      IF(KEYS(7).OR.KEYS(9)) THEN
        DO 123 IQ=27,29
123     QSAVE(IQ,IH)=STRUCW(X(IH),IQ-25,IDIN(IH))/X(IH)
      ENDIF
120   CONTINUE
C          JWWTYP points to W types 1,2,3,4
      IF(KEYS(6)) THEN
        JWWTYP(1)=JETTYP(1)
        JWWTYP(2)=JETTYP(2)
      ELSEIF((KEYS(7).AND..NOT.GOMSSM).OR.KEYS(9)) THEN
        JWWTYP(1)=JETTYP(1)-25
        JWWTYP(2)=JETTYP(2)-25
      ELSEIF(KEYS(7).AND.GOMSSM) THEN
        JWWTYP(1)=JETTYP(1)-76
        JWWTYP(2)=JETTYP(2)-76
      ENDIF
C
C          Select W decay modes and put in /JETSET/. First particle
C          is always the fermion.
 
      DO 200 JET=1,2
        IDABS=IABS(IDJETS(JET))
        IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 200
        RND=RANF()
        JWT=JWWTYP(JET)
C          Must only consider allowed decays for this mass
        SUMBR=0.
        DO 201 JQ=1,12
          IQ1=2*JQ
          IQ2=MATCH(IQ1,JWT)
          IF(IQ2.EQ.0) THEN
            BRANCH(JQ)=0.
            GO TO 201
          ENDIF
          AM1=AMASS(LIST(IQ1))
          AM2=AMASS(LIST(IQ2))
          IF(AM1+AM2.LT.PJETS(5,JET)) THEN
            BRANCH(JQ)=RBRWW(JQ,JWT,JET)
            SUMBR=SUMBR+BRANCH(JQ)
          ELSE
            BRANCH(JQ)=0.
          ENDIF
201     CONTINUE
        IF(SUMBR.LE.0.) GO TO 998
        DO 202 JQ=1,12
202     BRANCH(JQ)=BRANCH(JQ)/SUMBR
C
        CBRWW=0.
        DO 210 JQ=1,12
          CBRWW=CBRWW+BRANCH(JQ)
          IF(RND.GT.CBRWW) GO TO 210
          IQ1=2*JQ
          IQ2=MATCH(IQ1,JWT)
          IDPAIR(NPAIR+1)=LIST(IQ1)
          IDPAIR(NPAIR+2)=LIST(IQ2)
          PPAIR(5,NPAIR+1)=AMASS(LIST(IQ1))
          PPAIR(5,NPAIR+2)=AMASS(LIST(IQ2))
          JPAIR(NPAIR+1)=JET
          JPAIR(NPAIR+2)=JET
          NPAIR=NPAIR+2
          JQWW(JET)=JQ
          GO TO 200
210     CONTINUE
200   CONTINUE
C
C          Generate decay uniformly in angle and put in PPAIR.
C          Will check cross section later.
C
      NREJ=0
300   NJ0=2
      DO 310 JET=1,2
        IDABS=IABS(IDJETS(JET))
        IF(IDABS.NE.80.AND.IDABS.NE.90) GO TO 310
C          Construct W com momenta.
        AM0=PJETS(5,JET)
        AM1=PPAIR(5,NJ0-1)
        AM2=PPAIR(5,NJ0)
        E1CM=(AM0**2+AM1**2-AM2**2)/(2.*AM0)
        E2CM=(AM0**2+AM2**2-AM1**2)/(2.*AM0)
        P12CM=(AM0**2-AM1**2-AM2**2)**2-4.*(AM1*AM2)**2
        P12CM=SQRT(P12CM)/(2.*AM0)
        CTHCM=2.*RANF()-1.
        STHCM=SQRT(1.-CTHCM**2)
        PHICM=2.*PI*RANF()
        CPHICM=COS(PHICM)
        SPHICM=SIN(PHICM)
        P1WCM(1)=P12CM*STHCM*CPHICM
        P2WCM(1)=-P1WCM(1)
        P1WCM(2)=P12CM*STHCM*SPHICM
        P2WCM(2)=-P1WCM(2)
        P1WCM(3)=P12CM*CTHCM
        P2WCM(3)=-P1WCM(3)
        P1WCM(4)=E1CM
        P2WCM(4)=E2CM
C          Also construct zero mass vectors at same angle
+SELF,IF=SINGLE.
C          Single precision.
        P1CM0(1)=.5*AM0*STHCM*CPHICM
        P2CM0(1)=-P1CM0(1)
        P1CM0(2)=.5*AM0*STHCM*SPHICM
        P2CM0(2)=-P1CM0(2)
        P1CM0(3)=.5*AM0*CTHCM
        P2CM0(3)=-P1CM0(3)
        P1CM0(4)=.5*AM0
        P2CM0(4)=P1CM0(4)
+SELF,IF=DOUBLE.
C          Double precision.
        DAM0=AM0
        DCTH=CTHCM
        DSTH=DSQRT(1.D0-DCTH**2)
        DPHI=PHICM
        P1CM0(1)=.5*AM0*DSTH*DCOS(DPHI)
        P2CM0(1)=-P1CM0(1)
        P1CM0(2)=.5*AM0*DSTH*DSIN(DPHI)
        P2CM0(2)=-P1CM0(2)
        P1CM0(3)=.5*AM0*DCTH
        P2CM0(3)=-P1CM0(3)
        P1CM0(4)=.5*AM0
        P2CM0(4)=P1CM0(4)
+SELF.
C          Boost to lab frame.
        DO 320 K=1,3
320     PBOOST(K)=-PJETS(K,JET)
        PBOOST(4)=PJETS(4,JET)
        CALL LBOOST(PBOOST,1,P1WCM,P1LAB)
        CALL LBOOST(PBOOST,1,P2WCM,P2LAB)
        DO 330 K=1,4
          PPAIR(K,NJ0-1)=P1LAB(K)
          PPAIR(K,NJ0)=P2LAB(K)
330     CONTINUE
C          Boost zero mass vectors -- double precision for 32 bits.
        PZERO(4,NJ0-1)=(P1CM0(4)*PWW(4,JET)+P1CM0(1)*PWW(1,JET)
     $  +P1CM0(2)*PWW(2,JET)+P1CM0(3)*PWW(3,JET))/PWW(5,JET)
        BOOST=(P1CM0(4)+PZERO(4,NJ0-1))/(PWW(4,JET)+PWW(5,JET))
        DO 340 K=1,3
340     PZERO(K,NJ0-1)=P1CM0(K)+BOOST*PWW(K,JET)
        PZERO(4,NJ0)=(P2CM0(4)*PWW(4,JET)+P2CM0(1)*PWW(1,JET)
     $  +P2CM0(2)*PWW(2,JET)+P2CM0(3)*PWW(3,JET))/PWW(5,JET)
        BOOST=(P2CM0(4)+PZERO(4,NJ0))/(PWW(4,JET)+PWW(5,JET))
        DO 350 K=1,3
350     PZERO(K,NJ0)=P2CM0(K)+BOOST*PWW(K,JET)
        NJ0=NJ0+2
310   CONTINUE
C
C          Calculate cross section SIGWW2 containing TBRWW*RBRWW.
C          Compare with WW cross section containing TBRWW. Ratio
C          must be bounded by 3/(4*PI) for each W.
C
      AFX=3./(2.*PI)
      IF(KEYS(6)) THEN
        CALL SIGWW2
        SGWWMX=SIGEVT
        IF(IDJETS(1).NE.10) SGWWMX=SGWWMX*RBRWW(JQWW(1),JWWTYP(1),1)*AFX
        IF(IDJETS(2).NE.10) SGWWMX=SGWWMX*RBRWW(JQWW(2),JWWTYP(2),2)*AFX
      ELSEIF(KEYS(7)) THEN
C          Note that except for WW -> WW processes, SIGH3 just computes
C          the decay angular distribution, so it can be used for both 
C          for SM and SUSY HL0/HH0 decays; HA0 -> WW is forbidden.
C          For Z + HL0 decays, we just return, ie use phase space.
        IDABS1=IABS(IDJETS(1))
        IDABS2=IABS(IDJETS(2))
        IF(.NOT.(IDABS1.EQ.10.OR.IDABS1.EQ.80.OR.IDABS1.EQ.90)) RETURN
        IF(.NOT.(IDABS2.EQ.10.OR.IDABS2.EQ.80.OR.IDABS2.EQ.90)) RETURN
        CALL SIGH3
        SGWWMX=SIGLLQ*AFX**2
      ELSEIF(KEYS(9)) THEN
        CALL SIGTC3
        SGWWMX=SIGLLQ*AFX**2
      ENDIF
      IF(WWSIG.GT.SGWWMX*RANF()) GO TO 400
      NREJ=NREJ+1
      IF(NREJ.LT.NTRIES) GO TO 300
      GO TO 999
C
C          Good event
C
400   CONTINUE
      RETURN
C
999   CALL PRTEVT(0)
      WRITE(ITLIS,9991) NREJ
9991  FORMAT(//' IT IS TAKING MORE THAN',I5,' TRIES TO GENERATE ',
     1'A GOOD WPAIR EVENT.'/' CHECK LIMITS OR INCREASE NTRIES.')
      STOP 99
998   CALL PRTEVT(0)
      WRITE(ITLIS,9981) JET
9981  FORMAT(//' ERROR IN WPAIR ... NO DECAY POSSIBLE FOR JET',I3)
      STOP 99
      END
+EOD
+DECK,WWKIN.
      SUBROUTINE WWKIN(AM1,AM2)
C          WPAIR KINEMATICS, INCLUDING DOUBLE PRECISION CONVERSION FOR
C          32-BIT MACHINES. CONVENTION IS THAT SINGLE PRECISION MASSES
C          AM1,AM2 ARE EXACT.
+CDE,ITAPES
+CDE,WWPAR.
+CDE,JETPAR.
C          BASIC KINEMATICS FROM TWOKIN
      CALL TWOKIN(0.,0.,AM1,AM2)
C          WPAIR KINEMATICS -- JUST A COPY FOR CDC BUT CONSTRUCTS A
C          CONSISTENT SET OF DOUBLE PRECISION VARIABLES FOR 32-BIT
C          MACHINES.
      P3WW(1)=PT(1)*COS(PHI(1))
      P3WW(2)=PT(1)*SIN(PHI(1))
      P3WW(3)=P(1)*CTH(1)
      P3WW(5)=AM1
      P4WW(1)=-P3WW(1)
      P4WW(2)=-P3WW(2)
      P4WW(3)=P(2)*CTH(2)
      P4WW(5)=AM2
+SELF,IF=SINGLE.
      P3WW(4)=SQRT(P3WW(1)**2+P3WW(2)**2+P3WW(3)**2+P3WW(5)**2)
      P4WW(4)=SQRT(P4WW(1)**2+P4WW(2)**2+P4WW(3)**2+P4WW(5)**2)
+SELF,IF=DOUBLE.
      P3WW(4)=DSQRT(P3WW(1)**2+P3WW(2)**2+P3WW(3)**2+P3WW(5)**2)
      P4WW(4)=DSQRT(P4WW(1)**2+P4WW(2)**2+P4WW(3)**2+P4WW(5)**2)
+SELF.
      P1WW(1)=0.
      P1WW(2)=0.
      P1WW(4)=.5*(P3WW(4)+P3WW(3)+P4WW(4)+P4WW(3))
      P1WW(3)=P1WW(4)
      P2WW(1)=0.
      P2WW(2)=0.
      P2WW(4)=.5*(P3WW(4)-P3WW(3)+P4WW(4)-P4WW(3))
      P2WW(3)=-P2WW(4)
C          INVARIANTS
      SWW=+2.*(P1WW(4)*P2WW(4)-P1WW(3)*P2WW(3))
      TWW=-2.*(P1WW(4)*P3WW(4)-P1WW(3)*P3WW(3))+P3WW(5)**2
      UWW=-2.*(P2WW(4)*P3WW(4)-P2WW(3)*P3WW(3))+P3WW(5)**2
      RETURN
      END
+EOD
+DECK,WWSS.
      FUNCTION WWSS(T,U,T1,U1,T3,U3)
C          DECAY DISTRIBUTION FOR W+ W- PAIRS FROM SCHOONSCHIP(1980).
C          SQUARE OF S GRAPH.
+CDE,ITAPES
+CDE,WWPAR.
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WWSS
      DOUBLE PRECISION T,U,T1,U1,T3,U3
      DOUBLE PRECISION CV2A2
+SELF.
      CV2A2=CV**2+CA**2
      WWSS=
     1 +CV*CA*T*(-64.*T1*U1*T3+64.*T1*U1*U3+64.*T1*T3*U3+64.*T1*T3**2-6
     1 4.*T1**2*T3-64.*U1*T3*U3-64.*U1*U3**2+64.*U1**2*U3)
     1 +CV*CA*T*U*(-128.*T1*U3-64.*T1*S13+128.*U1*T3+64.*U1*S13+64.*T3*
     1 S13-64.*U3*S13)
     1 +CV*CA*T*WM2*(128.*T1*U3+64.*T1*S13-64.*T1**2-128.*U1*T3+64.*U1*
     1 S13+64.*U1**2-64.*T3*S13+64.*T3**2-64.*U3*S13-64.*U3**2)
     1 +CV*CA*T**2*(-64.*T1*U3-64.*T1*S13+64.*U1*T3+64.*T3*S13)
     1 +CV*CA*U*(-64.*T1*U1*T3+64.*T1*U1*U3+64.*T1*T3*U3+64.*T1*T3**2-6
     1 4.*T1**2*T3-64.*U1*T3*U3-64.*U1*U3**2+64.*U1**2*U3)
      WWSS=WWSS
     1 +CV*CA*U*WM2*(128.*T1*U3-64.*T1*S13-64.*T1**2-128.*U1*T3-64.*U1*
     1 S13+64.*U1**2+64.*T3*S13+64.*T3**2+64.*U3*S13-64.*U3**2)
     1 +CV*CA*U**2*(-64.*T1*U3+64.*U1*T3+64.*U1*S13-64.*U3*S13)
     1 +CV*CA*WM2*(128.*T1*U1*T3-128.*T1*U1*U3-128.*T1*T3*U3-128.*T1*T3
     1 **2+128.*T1**2*T3+128.*U1*T3*U3+128.*U1*U3**2-128.*U1**2*U3)
     1 +CV*CA*WM2**2*(128.*T1*S13+128.*T1**2-128.*U1*S13-128.*U1**2-128
     1 .*T3*S13-128.*T3**2+128.*U3*S13+128.*U3**2)
     1 +CV2A2*(128.*T1*U1*T3*U3-64.*T1**2*T3**2-64.*U1**2*U3**2)
      WWSS=WWSS
     1 +CV2A2*T*(-32.*T1*U1*T3-32.*T1*U1*U3-32.*T1*T3*U3-64.*T1*T3*S13+
     1 32.*T1*T3**2+32.*T1**2*T3-32.*U1*T3*U3+64.*U1*U3*S13+32.*U1*U3**
     1 2+32.*U1**2*U3)
     1 +CV2A2*T*U*(64.*T1*U3+32.*T1*S13+64.*U1*T3+32.*U1*S13+32.*T3*S13
     1 +32.*U3*S13+64.*S13**2)
     1 +CV2A2*T*WM2*(-64.*T1*U3-32.*T1*S13+32.*T1**2-64.*U1*T3+32.*U1*S
     1 13+32.*U1**2-32.*T3*S13+32.*T3**2+32.*U3*S13+32.*U3**2)
     1 +CV2A2*T**2*(32.*T1*U3+32.*T1*S13+32.*U1*T3+32.*T3*S13)
      WWSS=WWSS
     1 +CV2A2*U*(-32.*T1*U1*T3-32.*T1*U1*U3-32.*T1*T3*U3+64.*T1*T3*S13+
     1 32.*T1*T3**2+32.*T1**2*T3-32.*U1*T3*U3-64.*U1*U3*S13+32.*U1*U3**
     1 2+32.*U1**2*U3)
     1 +CV2A2*U*WM2*(-64.*T1*U3+32.*T1*S13+32.*T1**2-64.*U1*T3-32.*U1*S
     1 13+32.*U1**2+32.*T3*S13+32.*T3**2-32.*U3*S13+32.*U3**2)
     1 +CV2A2*U**2*(32.*T1*U3+32.*U1*T3+32.*U1*S13+32.*U3*S13)
     1 +CV2A2*WM2*(64.*T1*U1*T3+64.*T1*U1*U3+64.*T1*T3*U3-64.*T1*T3**2-
     1 64.*T1**2*T3+64.*U1*T3*U3-64.*U1*U3**2-64.*U1**2*U3)
      WWSS=WWSS
     1 +CV2A2*WM2**2*(-64.*T1*S13-64.*T1**2-64.*U1*S13-64.*U1**2-64.*T3
     1 *S13-64.*T3**2-64.*U3*S13-64.*U3**2-64.*S13**2)
      WWSS=2.*WWSS
      RETURN
      END
+EOD
+DECK,WWST.
      FUNCTION WWST(T,U,T1,U1,T3,U3,P1,P2)
C          DECAY DISTRIBUTION FOR W+ W- PAIRS FROM SCHOONSCHIP(1980).
C          INTERFERENCE OF T AND S GRAPHS.
+CDE,ITAPES
+CDE,WWPAR.
      DIMENSION P1(4),P2(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WWST
      DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2
      DOUBLE PRECISION CVACQ,EPF
+SELF.
      CVACQ=(CV+CA)*CQ
      WWST=
     1 +CVACQ*(-256.*T1*U1*T3*U3+256.*T1**2*T3**2)
     1 +CVACQ*T*(256.*T1*U1*T3+256.*T1*T3*S13-256.*T1*T3**2+128.*U1*T3*
     1 U3-128.*U1*U3*S13-128.*U1**2*U3)
     1 +CVACQ*T*U*(-256.*U1*T3-128.*U1*S13-128.*T3*S13-128.*S13**2)
     1 +CVACQ*T*WM2*(384.*U1*T3-128.*U1*S13-128.*U1**2+256.*T3*S13-256.
     1 *T3**2)
     1 +CVACQ*T**2*(-256.*U1*T3-256.*T3*S13)
     1 +CVACQ*U*(128.*T1*U1*T3-128.*T1*T3*S13-128.*T1*T3**2)
      WWST=WWST
     1 +CVACQ*U*WM2*(128.*U1*T3-128.*T3*S13-128.*T3**2)
     1 +CVACQ*WM2*(-256.*T1*U1*T3+512.*T1*T3**2-256.*U1*T3*U3)
     1 +CVACQ*WM2**2*(256.*U1*S13+128.*U1**2+256.*T3*S13+384.*T3**2+128
     1 .*S13**2)
     1 +EPF(P1,P2,P3,Q1)*CVACQ*(128.*T3*U3+128.*T3*S13+64.*T3**2+128.*U
     1 3*S13+64.*U3**2)
     1 +EPF(P1,P2,P3,Q1)*CVACQ*T*(-32.*T3-32.*U3-64.*S13)
     1 -32.*EPF(P1,P2,P3,Q1)*CVACQ*T*WM2
      WWST=WWST
     1 +EPF(P1,P2,P3,Q1)*CVACQ*U*(-32.*T3-32.*U3-64.*S13)
     1 -32.*EPF(P1,P2,P3,Q1)*CVACQ*U*WM2
     1 +EPF(P1,P2,P3,Q1)*CVACQ*WM2*(128.*T3+128.*U3+128.*S13)
     1 +64.*EPF(P1,P2,P3,Q1)*CVACQ*WM2**2
     1 -32.*EPF(P1,P2,P3,Q3)*CVACQ*T*WM2
     1 -32.*EPF(P1,P2,P3,Q3)*CVACQ*U*WM2
     1 +EPF(P1,P2,P3,Q3)*CVACQ*WM2*(64.*T3+64.*U3)
     1 +64.*EPF(P1,P2,P3,Q3)*CVACQ*WM2**2
      WWST=WWST
     1 +EPF(P1,P3,Q1,Q3)*CVACQ*(128.*U1*T3+128.*U1*U3)
     1 +EPF(P1,P3,Q1,Q3)*CVACQ*T*(-64.*U1)
     1 +32.*EPF(P1,P3,Q1,Q3)*CVACQ*T*U
     1 -32.*EPF(P1,P3,Q1,Q3)*CVACQ*T*WM2
     1 +EPF(P1,P3,Q1,Q3)*CVACQ*U*(-64.*U1-64.*T3-64.*U3)
     1 -96.*EPF(P1,P3,Q1,Q3)*CVACQ*U*WM2
     1 +32.*EPF(P1,P3,Q1,Q3)*CVACQ*U**2
     1 +EPF(P1,P3,Q1,Q3)*CVACQ*WM2*(128.*U1+64.*T3+64.*U3)
      WWST=WWST
     1 +64.*EPF(P1,P3,Q1,Q3)*CVACQ*WM2**2
     1 +EPF(P2,P3,Q1,Q3)*CVACQ*(-128.*T1*T3-128.*T1*U3)
     1 +EPF(P2,P3,Q1,Q3)*CVACQ*T*(64.*T1+64.*T3+64.*U3)
     1 -32.*EPF(P2,P3,Q1,Q3)*CVACQ*T*U
     1 +96.*EPF(P2,P3,Q1,Q3)*CVACQ*T*WM2
     1 -32.*EPF(P2,P3,Q1,Q3)*CVACQ*T**2
     1 +EPF(P2,P3,Q1,Q3)*CVACQ*U*(64.*T1)
     1 +32.*EPF(P2,P3,Q1,Q3)*CVACQ*U*WM2
     1 +EPF(P2,P3,Q1,Q3)*CVACQ*WM2*(-128.*T1-64.*T3-64.*U3)
     1 -64.*EPF(P2,P3,Q1,Q3)*CVACQ*WM2**2
      WWST=WWST/T
      WWST=2.*WWST
      RETURN
      END
+EOD
+DECK,WWTT.
      FUNCTION WWTT(T,U,T1,U1,T3,U3)
C          DECAY DISTRIBUTION FOR W+ W- PAIRS FROM SCHOONSCHIP(1980).
C          SQUARE OF T GRAPH.
+CDE,ITAPES
+CDE,WWPAR.
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WWTT
      DOUBLE PRECISION T,U,T1,U1,T3,U3
+SELF.
      WWTT=
     1(+CQ**2*(-512.*T1**2*T3**2)
     1 +CQ**2*T*(-512.*T1*U1*T3-512.*T1*T3*S13+512.*T1*T3**2)
     1 +CQ**2*T*WM2*(-512.*U1*T3-512.*T3*S13+512.*T3**2)
     1 +CQ**2*T**2*(512.*U1*T3+512.*T3*S13)
     1 +CQ**2*WM2*(-1024.*T1*T3**2)
     1 +CQ**2*WM2**2*(-512.*T3**2))/T**2
      WWTT=2.*WWTT
      RETURN
      END
+EOD
+DECK,WZSS.
      FUNCTION WZSS(T,U,T1,U1,T3,U3,P1,P2)
C          DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980).
C          SQUARE OF S GRAPH.
+CDE,ITAPES
+CDE,WWPAR.
      DIMENSION P1(4),P2(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WZSS
      DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2
      DOUBLE PRECISION WM4,ZM4,WZM2,CSXCS
+SELF.
      WM4=WM2**2
      ZM4=ZM2**2
      WZM2=WM2*ZM2
      CSXCS=CS**2
      WZSS=
     1 +CSXCS*CV3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-128.*WM2*T1*T3**2-1
     1 28.*WM2*T1*ZM4+128.*WM2*U1*T3*U3-64.*WM2*T3*ZM4-64.*WM2*S13*ZM4+
     1 64.*ZM2*T1*U1*T3+64.*ZM2*T1*U1*U3-64.*ZM2*T1*WM4-64.*ZM2*T1**2*T
     1 3-64.*ZM2*U1**2*U3-128.*ZM2*T3*WM4-64.*ZM2*S13*WM4+128.*T1*U1*T3
     1 *U3-192.*T1*T3*WZM2-64.*T1*S13*WZM2-64.*T1**2*T3**2-32.*T1**2*WZ
     1 M2-32.*T1**2*ZM4+64.*U1*U3*WZM2-64.*U1*S13*WZM2-64.*U1**2*U3**2-
     1 32.*U1**2*WZM2-32.*U1**2*ZM4-128.*T3*S13*WZM2-64.*T3**2*WZM2-64.
     1 *T3**2*WM4-64.*S13**2*WZM2-96.*WM4*ZM4)
      WZSS=WZSS
     1 +CSXCS*CV3*T*(64.*WM2*T1*T3-32.*WM2*U1*T3-32.*WM2*U1*U3-64.*WM2*
     1 T3*S13+64.*WM2*T3**2+96.*WM2*ZM4+64.*ZM2*T1*T3-32.*ZM2*T1*S13+32
     1 .*ZM2*T1**2-32.*ZM2*U1*T3-32.*ZM2*U1*U3+32.*ZM2*U1*S13+32.*ZM2*U
     1 1**2+96.*ZM2*WM4-32.*T1*U1*T3-32.*T1*U1*U3-64.*T1*T3*S13+64.*T1*
     1 T3**2+128.*T1*WZM2+32.*T1*ZM4+32.*T1**2*T3-64.*U1*T3*U3+64.*U1*U
     1 3*S13+32.*U1**2*U3+128.*T3*WZM2+32.*T3*WM4+32.*S13*WZM2)

      WZSS=WZSS
     1 +CSXCS*CV3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3
     1 2.*T1*T3+32.*T1*S13+64.*U1*T3+32.*U1*U3+32.*U1*S13+64.*T3*S13+64
     1 .*S13**2-32.*WZM2)
     1 +CSXCS*CV3*T**2*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-
     1 32.*T1*T3+32.*T1*S13+32.*U1*T3+32.*U1*U3+64.*T3*S13-64.*WZM2)
     1 +CSXCS*CV3*T**2*U*(-32.*S13)
     1 +CSXCS*CV3*T**3*(-32.*S13)
      WZSS=WZSS
     1 +CSXCS*CV3*U*(64.*WM2*T1*T3-32.*WM2*U1*T3-32.*WM2*U1*U3+64.*WM2*
     1 T3*S13+64.*WM2*T3**2+32.*WM2*ZM4+64.*ZM2*T1*T3+32.*ZM2*T1*S13+32
     1 .*ZM2*T1**2-32.*ZM2*U1*T3-32.*ZM2*U1*U3-32.*ZM2*U1*S13+32.*ZM2*U
     1 1**2+32.*ZM2*WM4-32.*T1*U1*T3-32.*T1*U1*U3+64.*T1*T3*S13+64.*T1*
     1 T3**2+64.*T1*WZM2+32.*T1*ZM4+32.*T1**2*T3-64.*U1*T3*U3-64.*U1*U3
     1 *S13+32.*U1**2*U3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM2)
     1 +CSXCS*CV3*U**2*(32.*U1*T3+32.*U1*S13)
      WZSS=WZSS
     1 +CSXCS*CA3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+128.*WM2*T1*ZM4+64.*
     1 WM2*T3*ZM4+64.*WM2*S13*ZM4+64.*ZM2*T1*U1*T3-64.*ZM2*T1*U1*U3+64.
     1 *ZM2*T1*WM4+64.*ZM2*T1**2*T3-64.*ZM2*U1**2*U3+128.*ZM2*T3*WM4+64
     1 .*ZM2*S13*WM4+192.*T1*T3*WZM2+64.*T1*S13*WZM2+32.*T1**2*WZM2+32.
     1 *T1**2*ZM4-64.*U1*U3*WZM2-64.*U1*S13*WZM2-32.*U1**2*WZM2-32.*U1*
     1 *2*ZM4+96.*WM4*ZM4)
      WZSS=WZSS
     1 +CSXCS*CA3*T*(-64.*WM2*T1*T3-32.*WM2*U1*T3+32.*WM2*U1*U3-96.*WM2
     1 *ZM4-64.*ZM2*T1*T3+32.*ZM2*T1*S13-32.*ZM2*T1**2-32.*ZM2*U1*T3+32
     1 .*ZM2*U1*U3+32.*ZM2*U1*S13+32.*ZM2*U1**2-96.*ZM2*WM4-32.*T1*U1*T
     1 3+32.*T1*U1*U3-128.*T1*WZM2-32.*T1*ZM4-32.*T1**2*T3+32.*U1**2*U3
     1 -128.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2)
     1 +CSXCS*CA3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32
     1 .*T1*T3-32.*T1*S13+64.*U1*T3-32.*U1*U3+32.*U1*S13+32.*WZM2)
      WZSS=WZSS
     1 +CSXCS*CA3*T**2*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+3
     1 2.*T1*T3-32.*T1*S13+32.*U1*T3-32.*U1*U3+64.*WZM2)
     1 +CSXCS*CA3*T**2*U*(32.*S13)
     1 +CSXCS*CA3*T**3*(32.*S13)
      WZSS=WZSS
     1 +CSXCS*CA3*U*(-64.*WM2*T1*T3-32.*WM2*U1*T3+32.*WM2*U1*U3-32.*WM2
     1 *ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-32.*ZM2*U1*T3+32
     1 .*ZM2*U1*U3-32.*ZM2*U1*S13+32.*ZM2*U1**2-32.*ZM2*WM4-32.*T1*U1*T
     1 3+32.*T1*U1*U3-64.*T1*WZM2-32.*T1*ZM4-32.*T1**2*T3+32.*U1**2*U3-
     1 64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2)
     1 +CSXCS*CA3*U**2*(32.*U1*T3+32.*U1*S13)
      RETURN
      END
+EOD
+DECK,WZST.
      FUNCTION WZST(T,U,T1,U1,T3,U3,P1,P2)
C          DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980).
C          INTERFERENCE OF S AND T GRAPHS.
+CDE,ITAPES
+CDE,WWPAR.
      DIMENSION P1(4),P2(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WZST
      DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2
      DOUBLE PRECISION WM4,ZM4,WZM2,CSXCT,EPF
+SELF.
      WM4=WM2**2
      ZM4=ZM2**2
      WZM2=WM2*ZM2
      CSXCT=CS*CT/T
      WZST=
     1 +CSXCT*CV3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+256.*WM2*T1*T3**2+19
     1 2.*WM2*T1*ZM4-128.*WM2*U1*T3*U3+64.*WM2*T3*ZM4+64.*WM2*S13*ZM4-6
     1 4.*ZM2*T1*U1*T3-64.*ZM2*T1*U1*U3+64.*ZM2*T1*WM4+128.*ZM2*T1**2*T
     1 3+192.*ZM2*T3*WM4+64.*ZM2*S13*WM4-128.*T1*U1*T3*U3+320.*T1*T3*WZ
     1 M2+64.*T1*S13*WZM2+128.*T1**2*T3**2+32.*T1**2*WZM2+64.*T1**2*ZM4
     1 -64.*U1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**2*WZM2+128.*T3*S13*WZM2+
     1 64.*T3**2*WZM2+128.*T3**2*WM4+64.*S13**2*WZM2+128.*WM4*ZM4)
      WZST=WZST
     1 +CSXCT*CV3*T*(-128.*WM2*T1*T3+64.*WM2*U1*T3+32.*WM2*U1*U3+128.*W
     1 M2*T3*S13-128.*WM2*T3**2-128.*WM2*ZM4-128.*ZM2*T1*T3+64.*ZM2*T1*
     1 S13-64.*ZM2*T1**2+32.*ZM2*U1*T3+32.*ZM2*U1*U3-32.*ZM2*U1*S13-32.
     1 *ZM2*U1**2-128.*ZM2*WM4+64.*T1*U1*T3+32.*T1*U1*U3+128.*T1*T3*S13
     1 -128.*T1*T3**2-192.*T1*WZM2-64.*T1*ZM4-64.*T1**2*T3+64.*U1*T3*U3
     1 -64.*U1*U3*S13-32.*U1**2*U3-192.*T3*WZM2-64.*T3*WM4)
      WZST=WZST
     1 +CSXCT*CV3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32
     1 .*T1*T3-32.*T1*S13-64.*U1*T3-32.*U1*S13-64.*T3*S13-64.*S13**2+32
     1 .*WZM2)
     1 +CSXCT*CV3*T**2*(64.*WM2*T3-64.*WM2*S13+64.*ZM2*T1-64.*ZM2*S13+6
     1 4.*T1*T3-64.*T1*S13-64.*U1*T3-32.*U1*U3-128.*T3*S13+96.*WZM2)
     1 +CSXCT*CV3*T**2*U*(32.*S13)
      WZST=WZST
     1 +CSXCT*CV3*T**3*(64.*S13)
     1 +CSXCT*CV3*U*(-64.*WM2*T1*T3+32.*WM2*U1*T3-64.*WM2*T3*S13-64.*WM
     1 2*T3**2-32.*WM2*ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-3
     1 2.*ZM2*WM4+32.*T1*U1*T3-64.*T1*T3*S13-64.*T1*T3**2-64.*T1*WZM2-3
     1 2.*T1*ZM4-32.*T1**2*T3-64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2)
      WZST=WZST
     1 +CSXCT*CA3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-192.*WM2*T1*ZM4-64.
     1 *WM2*T3*ZM4-64.*WM2*S13*ZM4-64.*ZM2*T1*U1*T3+64.*ZM2*T1*U1*U3-64
     1 .*ZM2*T1*WM4-128.*ZM2*T1**2*T3-192.*ZM2*T3*WM4-64.*ZM2*S13*WM4-3
     1 20.*T1*T3*WZM2-64.*T1*S13*WZM2-32.*T1**2*WZM2-64.*T1**2*ZM4+64.*
     1 U1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**2*WZM2-128.*WM4*ZM4)
      WZST=WZST
     1 +CSXCT*CA3*T*(128.*WM2*T1*T3+64.*WM2*U1*T3-32.*WM2*U1*U3+128.*WM
     1 2*ZM4+128.*ZM2*T1*T3-64.*ZM2*T1*S13+64.*ZM2*T1**2+32.*ZM2*U1*T3-
     1 32.*ZM2*U1*U3-32.*ZM2*U1*S13-32.*ZM2*U1**2+128.*ZM2*WM4+64.*T1*U
     1 1*T3-32.*T1*U1*U3+192.*T1*WZM2+64.*T1*ZM4+64.*T1**2*T3-32.*U1**2
     1 *U3+192.*T3*WZM2+64.*T3*WM4)
      WZST=WZST
     1 +CSXCT*CA3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3
     1 2.*T1*T3+32.*T1*S13-64.*U1*T3-32.*U1*S13-32.*WZM2)
     1 +CSXCT*CA3*T**2*(-64.*WM2*T3+64.*WM2*S13-64.*ZM2*T1+64.*ZM2*S13-
     1 64.*T1*T3+64.*T1*S13-64.*U1*T3+32.*U1*U3-96.*WZM2)
     1 +CSXCT*CA3*T**2*U*(-32.*S13)
     1 +CSXCT*CA3*T**3*(-64.*S13)
      WZST=WZST
     1 +CSXCT*CA3*U*(64.*WM2*T1*T3+32.*WM2*U1*T3+32.*WM2*ZM4+64.*ZM2*T1
     1 *T3+32.*ZM2*T1*S13+32.*ZM2*T1**2+32.*ZM2*WM4+32.*T1*U1*T3+64.*T1
     1 *WZM2+32.*T1*ZM4+32.*T1**2*T3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM
     1 2)
     1 +EPF(P1,P2,P3,Q1)*CSXCT*CV3*(64.*ZM2*T3+64.*ZM2*U3+64.*ZM2*S13+6
     1 4.*T3*U3+64.*T3*S13+32.*T3**2+64.*U3*S13+32.*U3**2+32.*ZM4)
      WZST=WZST
     1 +EPF(P1,P2,P3,Q1)*CSXCT*CV3*T*(-16.*ZM2-16.*T3-16.*U3-32.*S13)
     1 +EPF(P1,P2,P3,Q1)*CSXCT*CV3*U*(-16.*ZM2-16.*T3-16.*U3-32.*S13)
     1 +EPF(P1,P2,P3,Q3)*CSXCT*CV3*(32.*WM2*T3+32.*WM2*U3+32.*WZM2)
     1 +EPF(P1,P2,P3,Q3)*CSXCT*CV3*T*(-16.*WM2)
     1 +EPF(P1,P2,P3,Q3)*CSXCT*CV3*U*(-16.*WM2)
     1 +EPF(P1,P3,Q1,Q3)*CSXCT*CV3*(32.*WM2*T3+32.*WM2*U3+64.*ZM2*U1+64
     1 .*U1*T3+64.*U1*U3+32.*WZM2)
      WZST=WZST
     1 +EPF(P1,P3,Q1,Q3)*CSXCT*CV3*T*(-16.*WM2-32.*U1)
     1 +16.*EPF(P1,P3,Q1,Q3)*CSXCT*CV3*T*U
     1 +EPF(P1,P3,Q1,Q3)*CSXCT*CV3*U*(-16.*WM2-32.*ZM2-32.*U1-32.*T3-32
     1 .*U3)
     1 +16.*EPF(P1,P3,Q1,Q3)*CSXCT*CV3*U**2
     1 +EPF(P2,P3,Q1,Q3)*CSXCT*CV3*(-32.*WM2*T3-32.*WM2*U3-64.*ZM2*T1-6
     1 4.*T1*T3-64.*T1*U3-32.*WZM2)
      WZST=WZST
     1 +EPF(P2,P3,Q1,Q3)*CSXCT*CV3*T*(16.*WM2+32.*ZM2+32.*T1+32.*T3+32.
     1 *U3)
     1 -16.*EPF(P2,P3,Q1,Q3)*CSXCT*CV3*T*U
     1 -16.*EPF(P2,P3,Q1,Q3)*CSXCT*CV3*T**2
     1 +EPF(P2,P3,Q1,Q3)*CSXCT*CV3*U*(16.*WM2+32.*T1)
      RETURN
      END
+EOD
+DECK,WZSU.
      FUNCTION WZSU(T,U,T1,U1,T3,U3,P1,P2)
C          DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980).
C          INTERFERENCE OF S AND U GRAPHS.
+CDE,ITAPES
+CDE,WWPAR.
      DIMENSION P1(4),P2(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WZSU
      DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2
      DOUBLE PRECISION WM4,ZM4,WZM2,CSXCU,EPF
+SELF.
      WM4=WM2**2
      ZM4=ZM2**2
      WZM2=WM2*ZM2
      CSXCU=CS*CU/U
      WZSU=
     1 +CSXCU*CV3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-64.*WM2*T1*ZM4+128.
     1 *WM2*U1*T3*U3-64.*WM2*T3*ZM4-64.*WM2*S13*ZM4+64.*ZM2*T1*U1*T3+64
     1 .*ZM2*T1*U1*U3-64.*ZM2*T1*WM4-128.*ZM2*U1**2*U3-64.*ZM2*T3*WM4-6
     1 4.*ZM2*S13*WM4+128.*T1*U1*T3*U3-64.*T1*T3*WZM2-64.*T1*S13*WZM2-3
     1 2.*T1**2*WZM2+64.*U1*U3*WZM2-64.*U1*S13*WZM2-128.*U1**2*U3**2-32
     1 .*U1**2*WZM2-64.*U1**2*ZM4-128.*T3*S13*WZM2-64.*T3**2*WZM2-64.*S
     1 13**2*WZM2-64.*WM4*ZM4)
      WZSU=WZSU
     1 +CSXCU*CV3*T*(-32.*WM2*U1*U3+64.*WM2*ZM4-32.*ZM2*U1*T3-32.*ZM2*U
     1 1*U3+32.*ZM2*U1*S13+32.*ZM2*U1**2+64.*ZM2*WM4-32.*T1*U1*U3+64.*T
     1 1*WZM2-64.*U1*T3*U3+64.*U1*U3*S13+32.*U1**2*U3+64.*T3*WZM2+64.*S
     1 13*WZM2)
     1 +CSXCU*CV3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3
     1 2.*T1*T3+32.*T1*S13+64.*U1*T3+64.*U1*U3+32.*U1*S13+64.*T3*S13+64
     1 .*S13**2-32.*WZM2)
      WZSU=WZSU
     1 +CSXCU*CV3*T**2*(32.*U1*U3-32.*WZM2)
     1 +CSXCU*CV3*T**2*U*(-32.*S13)
      WZSU=WZSU
     1 +CSXCU*CV3*U*(64.*WM2*T1*T3-32.*WM2*U1*T3-64.*WM2*U1*U3+64.*WM2*
     1 T3*S13+64.*WM2*T3**2+32.*WM2*ZM4+64.*ZM2*T1*T3+32.*ZM2*T1*S13+32
     1 .*ZM2*T1**2-64.*ZM2*U1*T3-64.*ZM2*U1*U3-64.*ZM2*U1*S13+64.*ZM2*U
     1 1**2+32.*ZM2*WM4-32.*T1*U1*T3-64.*T1*U1*U3+64.*T1*T3*S13+64.*T1*
     1 T3**2+64.*T1*WZM2+32.*T1*ZM4+32.*T1**2*T3-128.*U1*T3*U3-128.*U1*
     1 U3*S13+64.*U1**2*U3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM2)
      WZSU=WZSU
     1 +CSXCU*CV3*U**2*(64.*U1*T3+64.*U1*S13)
     1 +CSXCU*CA3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+64.*WM2*T1*ZM4+64.*W
     1 M2*T3*ZM4+64.*WM2*S13*ZM4+64.*ZM2*T1*U1*T3-64.*ZM2*T1*U1*U3+64.*
     1 ZM2*T1*WM4-128.*ZM2*U1**2*U3+64.*ZM2*T3*WM4+64.*ZM2*S13*WM4+64.*
     1 T1*T3*WZM2+64.*T1*S13*WZM2+32.*T1**2*WZM2-64.*U1*U3*WZM2-64.*U1*
     1 S13*WZM2-32.*U1**2*WZM2-64.*U1**2*ZM4+64.*WM4*ZM4)
      WZSU=WZSU
     1 +CSXCU*CA3*T*(32.*WM2*U1*U3-64.*WM2*ZM4-32.*ZM2*U1*T3+32.*ZM2*U1
     1 *U3+32.*ZM2*U1*S13+32.*ZM2*U1**2-64.*ZM2*WM4+32.*T1*U1*U3-64.*T1
     1 *WZM2+32.*U1**2*U3-64.*T3*WZM2-64.*S13*WZM2)
     1 +CSXCU*CA3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32
     1 .*T1*T3-32.*T1*S13+64.*U1*T3-64.*U1*U3+32.*U1*S13+32.*WZM2)
     1 +CSXCU*CA3*T**2*(-32.*U1*U3+32.*WZM2)
      WZSU=WZSU
     1 +CSXCU*CA3*T**2*U*(32.*S13)
     1 +CSXCU*CA3*U*(-64.*WM2*T1*T3-32.*WM2*U1*T3+64.*WM2*U1*U3-32.*WM2
     1 *ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-64.*ZM2*U1*T3+64
     1 .*ZM2*U1*U3-64.*ZM2*U1*S13+64.*ZM2*U1**2-32.*ZM2*WM4-32.*T1*U1*T
     1 3+64.*T1*U1*U3-64.*T1*WZM2-32.*T1*ZM4-32.*T1**2*T3+64.*U1**2*U3-
     1 64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2)
      WZSU=WZSU
     1 +CSXCU*CA3*U**2*(64.*U1*T3+64.*U1*S13)
     1 +EPF(P1,P2,P3,Q1)*CSXCU*CV3*(32.*ZM2*T1+32.*ZM2*U1+32.*WZM2)
     1 +EPF(P1,P2,P3,Q1)*CSXCU*CV3*T*(-16.*ZM2)
     1 +EPF(P1,P2,P3,Q1)*CSXCU*CV3*U*(-16.*ZM2)
     1 +EPF(P1,P2,P3,Q3)*CSXCU*CV3*(64.*WM2*T1+64.*WM2*U1+64.*WM2*S13+6
     1 4.*T1*U1+64.*T1*S13+32.*T1**2+64.*U1*S13+32.*U1**2+32.*WM4)
      WZSU=WZSU
     1 +EPF(P1,P2,P3,Q3)*CSXCU*CV3*T*(-16.*WM2-16.*T1-16.*U1-32.*S13)
     1 +EPF(P1,P2,P3,Q3)*CSXCU*CV3*U*(-16.*WM2-16.*T1-16.*U1-32.*S13)
     1 +EPF(P1,P2,Q1,Q3)*CSXCU*CV3*(64.*WM2*T3+64.*WM2*U3+64.*ZM2*T1+64
     1 .*ZM2*U1+64.*T1*T3+64.*T1*U3+64.*U1*T3+64.*U1*U3+64.*WZM2)
     1 +EPF(P1,P2,Q1,Q3)*CSXCU*CV3*T*(-32.*WM2-32.*ZM2-32.*T1-32.*U1-32
     1 .*T3-32.*U3)
      WZSU=WZSU
     1 +32.*EPF(P1,P2,Q1,Q3)*CSXCU*CV3*T*U
     1 +16.*EPF(P1,P2,Q1,Q3)*CSXCU*CV3*T**2
     1 +EPF(P1,P2,Q1,Q3)*CSXCU*CV3*U*(-32.*WM2-32.*ZM2-32.*T1-32.*U1-32
     1 .*T3-32.*U3)
     1 +16.*EPF(P1,P2,Q1,Q3)*CSXCU*CV3*U**2
     1 +EPF(P1,P3,Q1,Q3)*CSXCU*CV3*(-64.*WM2*T3-32.*ZM2*T1-32.*ZM2*U1-6
     1 4.*T1*T3-64.*U1*T3-32.*WZM2)
      WZSU=WZSU
     1 +EPF(P1,P3,Q1,Q3)*CSXCU*CV3*T*(32.*WM2+16.*ZM2+32.*T1+32.*U1+32.
     1 *T3)
     1 -16.*EPF(P1,P3,Q1,Q3)*CSXCU*CV3*T*U
     1 -16.*EPF(P1,P3,Q1,Q3)*CSXCU*CV3*T**2
     1 +EPF(P1,P3,Q1,Q3)*CSXCU*CV3*U*(16.*ZM2+32.*T3)
     1 +EPF(P2,P3,Q1,Q3)*CSXCU*CV3*(64.*WM2*U3+32.*ZM2*T1+32.*ZM2*U1+64
     1 .*T1*U3+64.*U1*U3+32.*WZM2)
      WZSU=WZSU
     1 +EPF(P2,P3,Q1,Q3)*CSXCU*CV3*T*(-16.*ZM2-32.*U3)
     1 +16.*EPF(P2,P3,Q1,Q3)*CSXCU*CV3*T*U
     1 +EPF(P2,P3,Q1,Q3)*CSXCU*CV3*U*(-32.*WM2-16.*ZM2-32.*T1-32.*U1-32
     1 .*U3)
     1 +16.*EPF(P2,P3,Q1,Q3)*CSXCU*CV3*U**2
      RETURN
      END
+EOD
+DECK,WZTU.
      FUNCTION WZTU(T,U,T1,U1,T3,U3,P1,P2)
C          DECAY DISTRIBUTION FOR W- Z0 PAIRS FROM SCHOONSCHIP(1980).
C          ALL T AND U GRAPH TERMS.
+CDE,ITAPES
+CDE,WWPAR.
      DIMENSION P1(4),P2(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WZTU
      DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2
      DOUBLE PRECISION WM4,ZM4,WZM2,CTXCT,CTXCU,CUXCU,EPF
+SELF.
      WM4=WM2**2
      ZM4=ZM2**2
      WZM2=WM2*ZM2
      CTXCT=CT**2/T**2
      CTXCU=CT*CU/(T*U)
      CUXCU=CU**2/U**2
      WZTU=
     1 +CTXCT*CV3*(-128.*WM2*T1*T3**2-64.*WM2*T1*ZM4-64.*ZM2*T1**2*T3-6
     1 4.*ZM2*T3*WM4-128.*T1*T3*WZM2-64.*T1**2*T3**2-32.*T1**2*ZM4-64.*
     1 T3**2*WM4-32.*WM4*ZM4)
      WZTU=WZTU
     1 +CTXCT*CV3*T*(64.*WM2*T1*T3-32.*WM2*U1*T3-64.*WM2*T3*S13+64.*WM2
     1 *T3**2+32.*WM2*ZM4+64.*ZM2*T1*T3-32.*ZM2*T1*S13+32.*ZM2*T1**2+32
     1 .*ZM2*WM4-32.*T1*U1*T3-64.*T1*T3*S13+64.*T1*T3**2+64.*T1*WZM2+32
     1 .*T1*ZM4+32.*T1**2*T3+64.*T3*WZM2+32.*T3*WM4-32.*S13*WZM2)
     1 +CTXCT*CV3*T**2*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-
     1 32.*T1*T3+32.*T1*S13+32.*U1*T3+64.*T3*S13-32.*WZM2)
      WZTU=WZTU
     1 +CTXCT*CV3*T**3*(-32.*S13)
     1 +CTXCT*CA3*(64.*WM2*T1*ZM4+64.*ZM2*T1**2*T3+64.*ZM2*T3*WM4+128.*
     1 T1*T3*WZM2+32.*T1**2*ZM4+32.*WM4*ZM4)
     1 +CTXCT*CA3*T*(-64.*WM2*T1*T3-32.*WM2*U1*T3-32.*WM2*ZM4-64.*ZM2*T
     1 1*T3+32.*ZM2*T1*S13-32.*ZM2*T1**2-32.*ZM2*WM4-32.*T1*U1*T3-64.*T
     1 1*WZM2-32.*T1*ZM4-32.*T1**2*T3-64.*T3*WZM2-32.*T3*WM4+32.*S13*WZ
     1 M2)
      WZTU=WZTU
     1 +CTXCT*CA3*T**2*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+3
     1 2.*T1*T3-32.*T1*S13+32.*U1*T3+32.*WZM2)
     1 +CTXCT*CA3*T**3*(32.*S13)
      WZTU=WZTU
     1 +CTXCU*CV3*(32.*WM2*ZM2*WM4+32.*WM2*ZM2*ZM4+64.*WM2*T1*ZM4-128.*
     1 WM2*U1*T3*U3+64.*WM2*T3*ZM4+64.*WM2*S13*ZM4-64.*ZM2*T1*U1*T3-64.
     1 *ZM2*T1*U1*U3+64.*ZM2*T1*WM4+64.*ZM2*T3*WM4+64.*ZM2*S13*WM4-128.
     1 *T1*U1*T3*U3+64.*T1*T3*WZM2+64.*T1*S13*WZM2+32.*T1**2*WZM2-64.*U
     1 1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**2*WZM2+128.*T3*S13*WZM2+64.*T3
     1 **2*WZM2+64.*S13**2*WZM2+64.*WM4*ZM4)
      WZTU=WZTU
     1 +CTXCU*CV3*T*(32.*WM2*U1*U3-64.*WM2*ZM4+32.*ZM2*U1*T3+32.*ZM2*U1
     1 *U3-32.*ZM2*U1*S13-32.*ZM2*U1**2-64.*ZM2*WM4+32.*T1*U1*U3-64.*T1
     1 *WZM2+64.*U1*T3*U3-64.*U1*U3*S13-32.*U1**2*U3-64.*T3*WZM2-64.*S1
     1 3*WZM2)
     1 +CTXCU*CV3*T*U*(32.*WM2*T3-32.*WM2*S13+32.*ZM2*T1-32.*ZM2*S13+32
     1 .*T1*T3-32.*T1*S13-64.*U1*T3-32.*U1*S13-64.*T3*S13-64.*S13**2+32
     1 .*WZM2)
      WZTU=WZTU
     1 +CTXCU*CV3*T**2*(-32.*U1*U3+32.*WZM2)
     1 +CTXCU*CV3*T**2*U*(32.*S13)
     1 +CTXCU*CV3*U*(-64.*WM2*T1*T3+32.*WM2*U1*T3-64.*WM2*T3*S13-64.*WM
     1 2*T3**2-32.*WM2*ZM4-64.*ZM2*T1*T3-32.*ZM2*T1*S13-32.*ZM2*T1**2-3
     1 2.*ZM2*WM4+32.*T1*U1*T3-64.*T1*T3*S13-64.*T1*T3**2-64.*T1*WZM2-3
     1 2.*T1*ZM4-32.*T1**2*T3-64.*T3*WZM2-32.*T3*WM4-32.*S13*WZM2)
      WZTU=WZTU
     1 +CTXCU*CA3*(-32.*WM2*ZM2*WM4-32.*WM2*ZM2*ZM4-64.*WM2*T1*ZM4-64.*
     1 WM2*T3*ZM4-64.*WM2*S13*ZM4-64.*ZM2*T1*U1*T3+64.*ZM2*T1*U1*U3-64.
     1 *ZM2*T1*WM4-64.*ZM2*T3*WM4-64.*ZM2*S13*WM4-64.*T1*T3*WZM2-64.*T1
     1 *S13*WZM2-32.*T1**2*WZM2+64.*U1*U3*WZM2+64.*U1*S13*WZM2+32.*U1**
     1 2*WZM2-64.*WM4*ZM4)
      WZTU=WZTU
     1 +CTXCU*CA3*T*(-32.*WM2*U1*U3+64.*WM2*ZM4+32.*ZM2*U1*T3-32.*ZM2*U
     1 1*U3-32.*ZM2*U1*S13-32.*ZM2*U1**2+64.*ZM2*WM4-32.*T1*U1*U3+64.*T
     1 1*WZM2-32.*U1**2*U3+64.*T3*WZM2+64.*S13*WZM2)
     1 +CTXCU*CA3*T*U*(-32.*WM2*T3+32.*WM2*S13-32.*ZM2*T1+32.*ZM2*S13-3
     1 2.*T1*T3+32.*T1*S13-64.*U1*T3-32.*U1*S13-32.*WZM2)
     1 +CTXCU*CA3*T**2*(32.*U1*U3-32.*WZM2)
      WZTU=WZTU
     1 +CTXCU*CA3*T**2*U*(-32.*S13)
     1 +CTXCU*CA3*U*(64.*WM2*T1*T3+32.*WM2*U1*T3+32.*WM2*ZM4+64.*ZM2*T1
     1 *T3+32.*ZM2*T1*S13+32.*ZM2*T1**2+32.*ZM2*WM4+32.*T1*U1*T3+64.*T1
     1 *WZM2+32.*T1*ZM4+32.*T1**2*T3+64.*T3*WZM2+32.*T3*WM4+32.*S13*WZM
     1 2)
     1 +CUXCU*CV3*(-64.*ZM2*U1**2*U3-64.*U1**2*U3**2-32.*U1**2*ZM4)
      WZTU=WZTU
     1 +CUXCU*CV3*T*U*(32.*U1*U3)
     1 +CUXCU*CV3*U*(-32.*WM2*U1*U3-32.*ZM2*U1*T3-32.*ZM2*U1*U3-32.*ZM2
     1 *U1*S13+32.*ZM2*U1**2-32.*T1*U1*U3-64.*U1*T3*U3-64.*U1*U3*S13+32
     1 .*U1**2*U3)
     1 +CUXCU*CV3*U**2*(32.*U1*T3+32.*U1*S13)
     1 +CUXCU*CA3*(-64.*ZM2*U1**2*U3-32.*U1**2*ZM4)
      WZTU=WZTU
     1 +CUXCU*CA3*T*U*(-32.*U1*U3)
     1 +CUXCU*CA3*U*(32.*WM2*U1*U3-32.*ZM2*U1*T3+32.*ZM2*U1*U3-32.*ZM2*
     1 U1*S13+32.*ZM2*U1**2+32.*T1*U1*U3+32.*U1**2*U3)
     1 +CUXCU*CA3*U**2*(32.*U1*T3+32.*U1*S13)
     1 +EPF(P1,P2,P3,Q1)*CTXCU*CV3*(-32.*ZM2*T1-16.*WZM2)
     1 +EPF(P1,P2,P3,Q1)*CTXCU*CV3*T*(16.*ZM2)
      WZTU=WZTU
     1 +EPF(P1,P2,P3,Q3)*CTXCU*CV3*(-48.*WM2*T1-16.*WM2*U1-32.*WM2*S13-
     1 32.*T1*U1-64.*T1*S13-32.*T1**2-16.*WM4)
     1 +EPF(P1,P2,P3,Q3)*CTXCU*CV3*T*(16.*WM2+16.*T1+16.*U1+32.*S13)
     1 +EPF(P1,P2,Q1,Q3)*CTXCU*CV3*(-32.*WM2*T3-32.*WM2*U3-64.*ZM2*T1-6
     1 4.*T1*T3-64.*T1*U3-32.*WZM2)
     1 +EPF(P1,P2,Q1,Q3)*CTXCU*CV3*T*(16.*WM2+32.*ZM2+32.*T1+32.*T3+32.
     1 *U3)
      WZTU=WZTU
     1 -16.*EPF(P1,P2,Q1,Q3)*CTXCU*CV3*T*U
     1 -16.*EPF(P1,P2,Q1,Q3)*CTXCU*CV3*T**2
     1 +EPF(P1,P2,Q1,Q3)*CTXCU*CV3*U*(16.*WM2+32.*T1)
     1 +EPF(P1,P3,Q1,Q3)*CTXCU*CV3*(32.*WM2*T3+32.*ZM2*T1+64.*T1*T3+16.
     1 *WZM2)
     1 +EPF(P1,P3,Q1,Q3)*CTXCU*CV3*T*(-16.*WM2-16.*ZM2-32.*T1-32.*T3)
      WZTU=WZTU
     1 +16.*EPF(P1,P3,Q1,Q3)*CTXCU*CV3*T**2
     1 +EPF(P2,P3,Q1,Q3)*CTXCU*CV3*(-32.*WM2*U3-32.*ZM2*T1-64.*T1*U3-16
     1 .*WZM2)
     1 +EPF(P2,P3,Q1,Q3)*CTXCU*CV3*T*(16.*ZM2+32.*U3)
     1 -16.*EPF(P2,P3,Q1,Q3)*CTXCU*CV3*T*U
     1 +EPF(P2,P3,Q1,Q3)*CTXCU*CV3*U*(16.*WM2+32.*T1)+0.
      RETURN
      END
+EOD
+DECK,XWWWW.
      SUBROUTINE XWWWW
C
C          SET UP W+ W- -> W+ W- AMPLITUDES AS RATIONAL FUNCTIONS OF Z
C
C          RE(F(Z,L)) = SUM(I,J)(ANWWWW(I+1,J,L)*Z**I
C                                  /(ADWWWW(1,J)+ADWWWW(2,J)*Z))
C          IM(F(Z,L)) = AIWWWW(L)   (INDEPENDENT OF Z)
C          J LABELS PIECES WITH SAME DENOMINATOR.
C          L=1 FOR 0,0; L=2 FOR 1,-1; L=3 FOR 1,1; L=4 FOR 0,1
C
C          *NOTE* A FACTOR OF SIN(THETA)/SQRT(2) IS REMOVED FROM F01
C
+CDE,CONST
+CDE,JETPAR
+CDE,WCON
+CDE,HCON
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WM,ZM,ZM2,ZM3,ZM4,ZM5,ZM6,HM,HM2,HM3,HM4,HG,HG2
     $,PROPH,RTS,S,S2,S3,SW,QQ0,QQI,QQF
+SELF.
C
C          USE UNITS OF WM TO AVOID LARGE NUMBERS - NOTE ANWWWW/ADWWWW
C          AND AIWWWW ARE DIMENSIONLESS
      WM=WMASS(2)
      ZM=WMASS(4)/WM
      ZM2=ZM**2
      ZM3=ZM**3
      ZM4=ZM**4
      ZM5=ZM**5
      ZM6=ZM**6
      HM=HMASS/WM
      HM2=HM**2
      HM3=HM**3
      HM4=HM**4
      HG=HGAM/WM
      HG2=HG**2
      RTS=QMW/WM
      S=RTS**2
      S2=S**2
      S3=S**3
      PROPH=(S-HM2)**2+(HM*HG)**2
C
      CW=1./ZM
      CW2=CW**2
      SW2=1.-CW2
      SW=SQRT(SW2)
      QQ0=.5*RTS
      QQI=.5*SQRT(S-4.)
      QQF=.5*SQRT(S-4.)
      GSQ=4.*PI*ALFA/SW2
C
C          FROM WWWW3.EX
      ANWWWW(1,1,1) = 8.00E+00 * S - 3.00E+00 * S2 - 1.60E+01
     $ * ( HM2 / PROPH) + 1.60E+01 * (S / PROPH) - 1.60E+01 * (S2
     $ / PROPH) + 4.00E+00 * (S3 / PROPH) + 1.60E+01 * ((HM2 * S)
     $ / PROPH) - 4.00E+00 * ((HM2 * S2) / PROPH)
      ANWWWW(1,1,2) = 2.00E+00 * S
      ANWWWW(1,1,3) = -1.60E+01 + 6.00E+00 * S - 1.60E+01 * (HM2
     $ / PROPH) + 1.60E+01 * (S / PROPH) - 8.00E+00 * (S2 / PROPH)
     $ + 8.00E+00 * ((HM2 * S) / PROPH)
      ANWWWW(1,1,4) = -2.40E+01 * RTS + 6.40E+01 * (RTS / (S
     $ - 1.00E+00 * ZM2)) + 1.60E+01 * ((RTS * S) / (S - 1.00E+00
     $ * ZM2)) - 8.00E+00 * ((RTS * S2) / (S - 1.00E+00 * ZM2))
     $ + 6.40E+01 * ((RTS * SW2) / S) - 6.40E+01 * ((RTS * SW2) / (S
     $ - 1.00E+00 * ZM2)) - 1.60E+01 * ((RTS * S * SW2) / (S
     $ - 1.00E+00 * ZM2)) + 8.00E+00 * ((RTS * S2 * SW2) / (S
     $ - 1.00E+00 * ZM2)) + 6.00E+00 * RTS * S + 1.60E+01 * RTS
     $ * SW2 - 8.00E+00 * RTS * S * SW2
      ANWWWW(1,2,1) = -6.40E+01 + 1.60E+01 * S - 1.20E+01 * S2
     $ + 3.00E+00 * S3 + 6.40E+01 * SW2 - 1.60E+01 * S * SW2
     $ + 1.20E+01 * S2 * SW2 - 3.00E+00 * S3 * SW2
      ANWWWW(1,2,2) = 6.40E+01 + 8.00E+00 * S - 2.00E+00 * S2
     $ - 6.40E+01 * SW2 - 8.00E+00 * S * SW2 + 2.00E+00 * S2 * SW2
      ANWWWW(1,2,3) = -6.40E+01 + 2.40E+01 * S - 6.00E+00 * S2
     $ + 6.40E+01 * SW2 - 2.40E+01 * S * SW2 + 6.00E+00 * S2 * SW2
      ANWWWW(1,2,4) = -9.60E+01 * RTS + 1.60E+01 * RTS * S + 2.00E+00
     $ * RTS * S2 + 9.60E+01 * RTS * SW2 - 1.60E+01 * RTS * S * SW2
     $ - 2.00E+00 * RTS * S2 * SW2
      ANWWWW(1,3,1) = -6.40E+01 * SW2 + 1.60E+01 * S * SW2 - 1.20E+01
     $ * S2 * SW2 + 3.00E+00 * S3 * SW2
      ANWWWW(1,3,2) = 6.40E+01 * SW2 + 8.00E+00 * S * SW2 - 2.00E+00
     $ * S2 * SW2
      ANWWWW(1,3,3) = -6.40E+01 * SW2 + 2.40E+01 * S * SW2 - 6.00E+00
     $ * S2 * SW2
      ANWWWW(1,3,4) = -9.60E+01 * RTS * SW2 + 1.60E+01 * RTS * S * SW2
     $  + 2.00E+00 * RTS * S2 * SW2
      ANWWWW(1,4,1) = -3.20E+01 + 1.60E+01 * S - 2.00E+00 * S2
      ANWWWW(1,4,2) = -4.00E+00 * S
      ANWWWW(1,4,3) = 4.00E+00 * S
      ANWWWW(1,4,4) = -1.60E+01 * RTS + 4.00E+00 * RTS * S
      ANWWWW(2,1,1) = -2.40E+01 * S + 6.00E+00 * S2 + 4.80E+01 * SW2
     $ + 6.40E+01 * (1.00E+00 / (S - 1.00E+00 * ZM2)) + 4.80E+01 * (S
     $ / (S - 1.00E+00 * ZM2)) - 4.00E+00 * (S3 / (S - 1.00E+00
     $ * ZM2)) + 6.40E+01 * (SW2 / S) - 6.40E+01 * (SW2 / (S
     $ - 1.00E+00 * ZM2)) - 4.80E+01 * ((S * SW2) / (S - 1.00E+00
     $ * ZM2)) + 4.00E+00 * ((S3 * SW2) / (S - 1.00E+00 * ZM2))
     $ - 4.00E+00 * S2 * SW2
      ANWWWW(2,1,2) = 0.00E+00
      ANWWWW(2,1,3) = 1.60E+01 * SW2 + 6.40E+01 * (1.00E+00 / (S
     $ - 1.00E+00 * ZM2)) + 1.60E+01 * (S / (S - 1.00E+00 * ZM2))
     $ - 8.00E+00 * (S2 / (S - 1.00E+00 * ZM2)) + 6.40E+01 * (SW2
     $ / S) - 6.40E+01 * (SW2 / (S - 1.00E+00 * ZM2)) - 1.60E+01
     $ * ((S * SW2) / (S - 1.00E+00 * ZM2)) + 8.00E+00 * ((S2 * SW2)
     $ / (S - 1.00E+00 * ZM2)) - 8.00E+00 * S * SW2
      ANWWWW(2,1,4) = 2.00E+00 * RTS * S
      ANWWWW(2,2,1) = -6.40E+01 - 1.12E+02 * S + 5.20E+01 * S2
     $ - 5.00E+00 * S3 + 6.40E+01 * SW2 + 1.12E+02 * S * SW2
     $ - 5.20E+01 * S2 * SW2 + 5.00E+00 * S3 * SW2
      ANWWWW(2,2,2) = -8.00E+00 * S + 2.00E+00 * S2 + 8.00E+00 * S
     $ * SW2 - 2.00E+00 * S2 * SW2
      ANWWWW(2,2,3) = -5.60E+01 * S + 1.40E+01 * S2 + 5.60E+01 * S
     $ * SW2 - 1.40E+01 * S2 * SW2
      ANWWWW(2,2,4) = 1.60E+02 * RTS - 8.00E+00 * RTS * S - 4.00E+00
     $ * RTS * S2 - 1.60E+02 * RTS * SW2 + 8.00E+00 * RTS * S * SW2
     $ + 4.00E+00 * RTS * S2 * SW2
      ANWWWW(2,3,1) = -6.40E+01 * SW2 - 1.12E+02 * S * SW2 + 5.20E+01
     $ * S2 * SW2 - 5.00E+00 * S3 * SW2
      ANWWWW(2,3,2) = -8.00E+00 * S * SW2 + 2.00E+00 * S2 * SW2
      ANWWWW(2,3,3) = -5.60E+01 * S * SW2 + 1.40E+01 * S2 * SW2
      ANWWWW(2,3,4) = 1.60E+02 * RTS * SW2 - 8.00E+00 * RTS * S * SW2
     $ - 4.00E+00 * RTS * S2 * SW2
      ANWWWW(2,4,1) = -1.60E+01 * S + 4.00E+00 * S2
      ANWWWW(2,4,2) = 0.00E+00
      ANWWWW(2,4,3) = 0.00E+00
      ANWWWW(2,4,4) = -4.00E+00 * RTS * S
      ANWWWW(3,1,1) = S2
      ANWWWW(3,1,2) = -2.00E+00 * S
      ANWWWW(3,1,3) = 2.00E+00 * S
      ANWWWW(3,1,4) = 0.00E+00
      ANWWWW(3,2,1) = 1.60E+02 * S - 3.60E+01 * S2 + S3 - 1.60E+02
     $ * S * SW2 + 3.60E+01 * S2 * SW2 - 1.00E+00 * S3 * SW2
      ANWWWW(3,2,2) = -6.40E+01 - 8.00E+00 * S + 2.00E+00 * S2
     $ + 6.40E+01 * SW2 + 8.00E+00 * S * SW2 - 2.00E+00 * S2 * SW2
      ANWWWW(3,2,3) = 6.40E+01 + 4.00E+01 * S - 1.00E+01 * S2
     $ - 6.40E+01 * SW2 - 4.00E+01 * S * SW2 + 1.00E+01 * S2 * SW2
      ANWWWW(3,2,4) = -8.00E+00 * RTS * S + 2.00E+00 * RTS * S2
     $ + 8.00E+00 * RTS * S * SW2 - 2.00E+00 * RTS * S2 * SW2
      ANWWWW(3,3,1) = 1.60E+02 * S * SW2 - 3.60E+01 * S2 * SW2 + S3
     $ * SW2
      ANWWWW(3,3,2) = -6.40E+01 * SW2 - 8.00E+00 * S * SW2 + 2.00E+00
     $ * S2 * SW2
      ANWWWW(3,3,3) = 6.40E+01 * SW2 + 4.00E+01 * S * SW2 - 1.00E+01
     $ * S2 * SW2
      ANWWWW(3,3,4) = -8.00E+00 * RTS * S * SW2 + 2.00E+00 * RTS * S2
     $ * SW2
      ANWWWW(3,4,1) = -2.00E+00 * S2
      ANWWWW(3,4,2) = 4.00E+00 * S
      ANWWWW(3,4,3) = -4.00E+00 * S
      ANWWWW(3,4,4) = 0.00E+00
      ANWWWW(4,1,1) = 0.00E+00
      ANWWWW(4,1,2) = 0.00E+00
      ANWWWW(4,1,3) = 0.00E+00
      ANWWWW(4,1,4) = 0.00E+00
      ANWWWW(4,2,1) = -4.00E+00 * S2 + S3 + 4.00E+00 * S2 * SW2
     $ - 1.00E+00 * S3 * SW2
      ANWWWW(4,2,2) = 8.00E+00 * S - 2.00E+00 * S2 - 8.00E+00 * S
     $ * SW2 + 2.00E+00 * S2 * SW2
      ANWWWW(4,2,3) = -8.00E+00 * S + 2.00E+00 * S2 + 8.00E+00 * S
     $ * SW2 - 2.00E+00 * S2 * SW2
      ANWWWW(4,2,4) = 0.00E+00
      ANWWWW(4,3,1) = -4.00E+00 * S2 * SW2 + S3 * SW2
      ANWWWW(4,3,2) = 8.00E+00 * S * SW2 - 2.00E+00 * S2 * SW2
      ANWWWW(4,3,3) = -8.00E+00 * S * SW2 + 2.00E+00 * S2 * SW2
      ANWWWW(4,3,4) = 0.00E+00
      ANWWWW(4,4,1) = 0.00E+00
      ANWWWW(4,4,2) = 0.00E+00
      ANWWWW(4,4,3) = 0.00E+00
      ANWWWW(4,4,4) = 0.00E+00
C
      ADWWWW(1,1) = 1.00E+00
      ADWWWW(1,2) = -4.00E+00 + S + 2.00E+00 * ZM2
      ADWWWW(1,3) = -4.00E+00 + S
      ADWWWW(1,4) = -4.00E+00 + 2.00E+00 * HM2 + S
      ADWWWW(2,1) = 0.00E+00
      ADWWWW(2,2) = 4.00E+00 - 1.00E+00 * S
      ADWWWW(2,3) = 4.00E+00 - 1.00E+00 * S
      ADWWWW(2,4) = 4.00E+00 - 1.00E+00 * S
C
      AIWWWW(1) = 1.60E+01 * ((HG * HM) / PROPH) - 1.60E+01 * ((HG
     $ * HM * S) / PROPH) + 4.00E+00 * ((HG * HM * S2) / PROPH)
      AIWWWW(2) = 0.00E+00
      AIWWWW(3) = 1.60E+01 * ((HG * HM) / PROPH) - 8.00E+00 * ((HG
     $ * HM * S) / PROPH)
      AIWWWW(4) = 0.00E+00
C
C          RESTORE MISSING FACTORS
      DO 100 J=1,4
      AIWWWW(J)=AIWWWW(J)*GSQ/(16.)
      DO 100 I=1,4
      DO 110 K=1,4
110   ANWWWW(K,I,J)=ANWWWW(K,I,J)*GSQ/(16.)
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,XWWZZ
      SUBROUTINE XWWZZ
C
C          SET UP W+ W- -> Z0 Z0 AMPLITUDES AS RATIONAL FUNCTIONS OF Z
C
C          RE(F(Z,L)) = SUM(I,J)(ANWWWW(I+1,J,L)*Z**I
C                                  /(ADWWWW(1,J)+ADWWWW(2,J)*Z))
C          IM(F(Z,L)) = AIWWWW(L)   (INDEPENDENT OF Z)
C          J LABELS PIECES WITH SAME DENOMINATOR.
C          L=1 FOR 0,0; L=2 FOR 1,-1; L=3 FOR 1,1; L=4 FOR 0,1
C
C          *NOTE* A FACTOR OF SIN(THETA)/SQRT(2) IS REMOVED FROM F01
C
+CDE,CONST
+CDE,JETPAR
+CDE,WCON
+CDE,HCON
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WM,ZM,ZM2,ZM3,ZM4,ZM5,ZM6,HM,HM2,HM3,HM4,HG,HG2
     $,PROPH,RTS,S,S2,S3,SW,QQ0,QQI,QQF
+SELF.
C
C          USE UNITS OF WM TO AVOID LARGE NUMBERS - NOTE ANWWWW/ADWWWW
C          AND AIWWWW ARE DIMENSIONLESS
      WM=WMASS(2)
      ZM=WMASS(4)/WM
      ZM2=ZM**2
      ZM3=ZM**3
      ZM4=ZM**4
      ZM5=ZM**5
      ZM6=ZM**6
      HM=HMASS/WM
      HM2=HM**2
      HM3=HM**3
      HM4=HM**4
      HG=HGAM/WM
      HG2=HG**2
      RTS=QMW/WM
      S=RTS**2
      S2=S**2
      S3=S**3
      PROPH=(S-HM2)**2+(HM*HG)**2
C          CORRECT SIGN OF HIGGS AMPLITUDE.
      PROPH=-PROPH
C
      CW=1./ZM
      CW2=CW**2
      SW2=1.-CW2
      SW=SQRT(SW2)
      QQ0=.5*RTS
      QQI=.5*SQRT(S-4.)
      QQF=.5*SQRT(S-4.*ZM2)
      GSQ=4.*PI*ALFA/SW2
C
C          FROM WWZZ3.EX
      ANWWWW(1,1,1) = -1.60E+01 * ((HM2 * ZM3) / (CW * PROPH))
     $ + 1.60E+01 * ((S * ZM3) / (CW * PROPH) ) - 8.00E+00 * ((S2
     $ * ZM) / (CW * PROPH)) - 8.00E+00 * ((S2 * ZM3) / (CW * PROPH))
     $ + 4.00E+00 * ((S3 * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S
     $ * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S * ZM3) / (CW
     $ * PROPH)) - 4.00E+00 * ((HM2 * S2 * ZM) / (CW * PROPH))
     $ + 8.00E+00 * CW2 * S - 6.00E+00 * CW2 * S2 + 8.00E+00 * CW2
     $ * S * ZM2
      ANWWWW(1,1,2) = 4.00E+00 * CW2 * S * ZM2
      ANWWWW(1,1,3) = -1.60E+01 * ((HM2 * ZM3) / (CW * PROPH))
     $ + 1.60E+01 * ((S * ZM3) / (CW * PROPH) ) - 8.00E+00 * ((S2
     $ * ZM3) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S * ZM3) / (CW
     $ * PROPH)) - 3.20E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2
      ANWWWW(1,1,4) = 0.00E+00
      ANWWWW(1,2,1) = -4.00E+00 * CW2 * S2 + 3.00E+00 * CW2 * S3
     $ - 9.60E+01 * CW2 * ZM4 + 3.20E+01 * CW2 * ZM6 + 8.00E+00 * CW2
     $ * S * ZM2 + 1.60E+01 * CW2 * S * ZM4 - 8.00E+00 * CW2 * S
     $ * ZM6 - 1.00E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(1,2,2) = 6.40E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2
     $ - 4.00E+00 * CW2 * S * ZM4 - 2.00E+00 * CW2 * S2 * ZM2
      ANWWWW(1,2,3) = -6.40E+01 * CW2 * ZM2 + 2.00E+01 * CW2 * S * ZM2
     $ + 4.00E+00 * CW2 * S * ZM4 - 6.00E+00 * CW2 * S2 * ZM2
      ANWWWW(1,2,4) = 1.92E+02 * CW2 * QQ0 * QQF * QQI * ZM
     $ - 3.20E+01 * CW2 * QQ0 * QQF * QQI * ZM3 + 3.20E+01 * CW2
     $ * QQ0 * QQF * QQI * ZM5 + 1.60E+01 * CW2 * QQ0 * QQF * QQI * S
     $ * ZM
      ANWWWW(1,3,1) = -4.00E+00 * CW2 * S2 + 3.00E+00 * CW2 * S3
     $ - 9.60E+01 * CW2 * ZM4 + 3.20E+01 * CW2 * ZM6 + 8.00E+00 * CW2
     $ * S * ZM2 + 1.60E+01 * CW2 * S * ZM4 - 8.00E+00 * CW2 * S
     $ * ZM6 - 1.00E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(1,3,2) = 6.40E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2
     $ - 4.00E+00 * CW2 * S * ZM4 - 2.00E+00 * CW2 * S2 * ZM2
      ANWWWW(1,3,3) = -6.40E+01 * CW2 * ZM2 + 2.00E+01 * CW2 * S * ZM2
     $ + 4.00E+00 * CW2 * S * ZM4 - 6.00E+00 * CW2 * S2 * ZM2
      ANWWWW(1,3,4) = -1.92E+02 * CW2 * QQ0 * QQF * QQI * ZM
     $ + 3.20E+01 * CW2 * QQ0 * QQF * QQI * ZM3 - 3.20E+01 * CW2
     $ * QQ0 * QQF * QQI * ZM5 - 1.60E+01 * CW2 * QQ0 * QQF * QQI * S
     $ * ZM
      ANWWWW(1,4,1) = 0.00E+00
      ANWWWW(1,4,2) = 0.00E+00
      ANWWWW(1,4,3) = 0.00E+00
      ANWWWW(1,4,4) = 0.00E+00
      ANWWWW(2,1,1) = 0.00E+00
      ANWWWW(2,1,2) = 0.00E+00
      ANWWWW(2,1,3) = 0.00E+00
      ANWWWW(2,1,4) = 8.00E+00 * CW2 * QQ0 * S * ZM
      ANWWWW(2,2,1) = 4.80E+01 * CW2 * QQF * QQI * S - 2.00E+01 * CW2
     $ * QQF * QQI * S2 + 6.40E+01 * CW2 * QQF * QQI * ZM2 + 9.60E+01
     $ * CW2 * QQF * QQI * S * ZM2 - 1.60E+01 * CW2 * QQF * QQI * S
     $ * ZM4
      ANWWWW(2,2,2) = 8.00E+00 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(2,2,3) = 5.60E+01 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(2,2,4) = 1.28E+02 * CW2 * QQ0 * ZM + 1.92E+02 * CW2 * QQ0
     $ * ZM3 - 3.20E+01 * CW2 * QQ0 * S * ZM + 2.40E+01 * CW2 * QQ0
     $ * S * ZM3 - 8.00E+00 * CW2 * QQ0 * S * ZM5 - 8.00E+00 * CW2
     $ * QQ0 * S2 * ZM
      ANWWWW(2,3,1) = -4.80E+01 * CW2 * QQF * QQI * S + 2.00E+01 * CW2
     $ * QQF * QQI * S2 - 6.40E+01 * CW2 * QQF * QQI * ZM2
     $ - 9.60E+01 * CW2 * QQF * QQI * S * ZM2 + 1.60E+01 * CW2 * QQF
     $ * QQI * S * ZM4
      ANWWWW(2,3,2) = -8.00E+00 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(2,3,3) = -5.60E+01 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(2,3,4) = 1.28E+02 * CW2 * QQ0 * ZM + 1.92E+02 * CW2 * QQ0
     $ * ZM3 - 3.20E+01 * CW2 * QQ0 * S * ZM + 2.40E+01 * CW2 * QQ0
     $ * S * ZM3 - 8.00E+00 * CW2 * QQ0 * S * ZM5 - 8.00E+00 * CW2
     $ * QQ0 * S2 * ZM
      ANWWWW(2,4,1) = 0.00E+00
      ANWWWW(2,4,2) = 0.00E+00
      ANWWWW(2,4,3) = 0.00E+00
      ANWWWW(2,4,4) = 0.00E+00
      ANWWWW(3,1,1) = 2.00E+00 * CW2 * S2
      ANWWWW(3,1,2) = -4.00E+00 * CW2 * S * ZM2
      ANWWWW(3,1,3) = 4.00E+00 * CW2 * S * ZM2
      ANWWWW(3,1,4) = 0.00E+00
      ANWWWW(3,2,1) = 3.20E+01 * CW2 * S - 1.60E+01 * CW2 * S2 + CW2
     $ * S3 + 9.60E+01 * CW2 * S * ZM2 + 3.20E+01 * CW2 * S * ZM4
     $ - 2.20E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(3,2,2) = -6.40E+01 * CW2 * ZM2 - 1.20E+01 * CW2 * S
     $ * ZM2 + 4.00E+00 * CW2 * S * ZM4 + 2.00E+00 * CW2 * S2 * ZM2
      ANWWWW(3,2,3) = 6.40E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2
     $ + 2.80E+01 * CW2 * S * ZM4 - 1.00E+01 * CW2 * S2 * ZM2
      ANWWWW(3,2,4) = 1.60E+01 * CW2 * QQ0 * QQF * QQI * S * ZM
      ANWWWW(3,3,1) = 3.20E+01 * CW2 * S - 1.60E+01 * CW2 * S2 + CW2
     $ * S3 + 9.60E+01 * CW2 * S * ZM2 + 3.20E+01 * CW2 * S * ZM4
     $ - 2.20E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(3,3,2) = -6.40E+01 * CW2 * ZM2 - 1.20E+01 * CW2 * S
     $ * ZM2 + 4.00E+00 * CW2 * S * ZM4 + 2.00E+00 * CW2 * S2 * ZM2
      ANWWWW(3,3,3) = 6.40E+01 * CW2 * ZM2 + 1.20E+01 * CW2 * S * ZM2
     $ + 2.80E+01 * CW2 * S * ZM4 - 1.00E+01 * CW2 * S2 * ZM2
      ANWWWW(3,3,4) = -1.60E+01 * CW2 * QQ0 * QQF * QQI * S * ZM
      ANWWWW(3,4,1) = 0.00E+00
      ANWWWW(3,4,2) = 0.00E+00
      ANWWWW(3,4,3) = 0.00E+00
      ANWWWW(3,4,4) = 0.00E+00
      ANWWWW(4,1,1) = 0.00E+00
      ANWWWW(4,1,2) = 0.00E+00
      ANWWWW(4,1,3) = 0.00E+00
      ANWWWW(4,1,4) = 0.00E+00
      ANWWWW(4,2,1) = 4.00E+00 * CW2 * QQF * QQI * S2
      ANWWWW(4,2,2) = -8.00E+00 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(4,2,3) = 8.00E+00 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(4,2,4) = 0.00E+00
      ANWWWW(4,3,1) = -4.00E+00 * CW2 * QQF * QQI * S2
      ANWWWW(4,3,2) = 8.00E+00 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(4,3,3) = -8.00E+00 * CW2 * QQF * QQI * S * ZM2
      ANWWWW(4,3,4) = 0.00E+00
      ANWWWW(4,4,1) = 0.00E+00
      ANWWWW(4,4,2) = 0.00E+00
      ANWWWW(4,4,3) = 0.00E+00
      ANWWWW(4,4,4) = 0.00E+00
C
      ADWWWW(1,1) = 1.00E+00
      ADWWWW(1,2) = S - 2.00E+00 * ZM2
      ADWWWW(1,3) = S - 2.00E+00 * ZM2
      ADWWWW(1,4) = 1.00E+00
      ADWWWW(2,1) = 0.00E+00
      ADWWWW(2,2) = -1.00E+00 * S + 4.00E+00 * (S / (S + 4.00E+00
     $ * QQF * QQI)) - 1.60E+01 * (ZM2 / (S + 4.00E+00 * QQF * QQI))
     $ + 4.00E+00 * ((S * ZM2) / (S + 4.00E+00 * QQF * QQI))
      ADWWWW(2,3) = S - 4.00E+00 * (S / (S + 4.00E+00 * QQF * QQI))
     $ + 1.60E+01 * (ZM2 / (S + 4.00E+00 * QQF * QQI)) - 4.00E+00
     $ * ((S * ZM2) / (S + 4.00E+00 * QQF * QQI))
      ADWWWW(2,4) = 0.00E+00
C
      AIWWWW(1) = 1.60E+01 * ((HG * HM * ZM3) / (CW * PROPH))
     $ - 8.00E+00 * ((HG * HM * S * ZM) / (CW * PROPH)) - 8.00E+00
     $ * ((HG * HM * S * ZM3) / (CW * PROPH)) + 4.00E+00 * ((HG * HM
     $ * S2 * ZM) / (CW * PROPH))
      AIWWWW(2) = 0.00E+00
      AIWWWW(3) = 1.60E+01 * ((HG * HM * ZM3) / (CW * PROPH))
     $ - 8.00E+00 * ((HG * HM * S * ZM3) / (CW * PROPH))
      AIWWWW(4) = 0.00E+00
C
C          RESTORE MISSING FACTORS
      DO 100 J=1,4
      AIWWWW(J)=AIWWWW(J)*GSQ/(16.*ZM2)
      DO 100 I=1,4
      DO 110 K=1,4
110   ANWWWW(K,I,J)=ANWWWW(K,I,J)*GSQ/(16.*ZM2)
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,XZZWW
      SUBROUTINE XZZWW
C
C          SET UP Z0 Z0 -> W+ W- AMPLITUDES AS RATIONAL FUNCTIONS OF Z
C
C          RE(F(Z,L)) = SUM(I,J)(ANWWWW(I+1,J,L)*Z**I
C                                  /(ADWWWW(1,J)+ADWWWW(2,J)*Z))
C          IM(F(Z,L)) = AIWWWW(L)   (INDEPENDENT OF Z)
C          J LABELS PIECES WITH SAME DENOMINATOR.
C          L=1 FOR 0,0; L=2 FOR 1,-1; L=3 FOR 1,1; L=4 FOR 0,1
C
C          *NOTE* A FACTOR OF SIN(THETA)/SQRT(2) IS REMOVED FROM F01
C
+CDE,CONST
+CDE,JETPAR
+CDE,WCON
+CDE,HCON
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WM,ZM,ZM2,ZM3,ZM4,ZM5,ZM6,HM,HM2,HM3,HM4,HG,HG2
     $,PROPH,RTS,S,S2,S3,SW,QQ0,QQI,QQF
+SELF.
C
C          USE UNITS OF WM TO AVOID LARGE NUMBERS - NOTE ANWWWW/ADWWWW
C          AND AIWWWW ARE DIMENSIONLESS
      WM=WMASS(2)
      ZM=WMASS(4)/WM
      ZM2=ZM**2
      ZM3=ZM**3
      ZM4=ZM**4
      ZM5=ZM**5
      ZM6=ZM**6
      HM=HMASS/WM
      HM2=HM**2
      HM3=HM**3
      HM4=HM**4
      HG=HGAM/WM
      HG2=HG**2
      RTS=QMW/WM
      S=RTS**2
      S2=S**2
      S3=S**3
      PROPH=(S-HM2)**2+(HM*HG)**2
C          CORRECT SIGN OF HIGGS AMPLITUDE.
      PROPH=-PROPH
C
      CW=1./ZM
      CW2=CW**2
      SW2=1.-CW2
      SW=SQRT(SW2)
      QQ0=.5*RTS
      QQI=.5*SQRT(S-4.*ZM2)
      QQF=.5*SQRT(S-4.)
      GSQ=4.*PI*ALFA/SW2
C
C          FROM ZZWW3.EX
      ANWWWW(1,1,1) = -1.60E+01 * ((HM2 * ZM3) / (CW * PROPH))
     $ + 1.60E+01 * ((S * ZM3) / (CW * PROPH) ) - 8.00E+00 * ((S2
     $ * ZM) / (CW * PROPH)) - 8.00E+00 * ((S2 * ZM3) / (CW * PROPH))
     $ + 4.00E+00 * ((S3 * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S
     $ * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S * ZM3) / (CW
     $ * PROPH)) - 4.00E+00 * ((HM2 * S2 * ZM) / (CW * PROPH))
     $ + 8.00E+00 * CW2 * S - 6.00E+00 * CW2 * S2 + 8.00E+00 * CW2
     $ * S * ZM2
      ANWWWW(1,1,2) = 4.00E+00 * CW2 * S
      ANWWWW(1,1,3) = -1.60E+01 * ((HM2 * ZM3) / (CW * PROPH))
     $ + 1.60E+01 * ((S * ZM3) / (CW * PROPH) ) - 8.00E+00 * ((S2
     $ * ZM) / (CW * PROPH)) + 8.00E+00 * ((HM2 * S * ZM) / (CW
     $ * PROPH)) + 1.20E+01 * CW2 * S - 3.20E+01 * CW2 * ZM2
      ANWWWW(1,1,4) = 0.00E+00
      ANWWWW(1,2,1) = -4.00E+00 * CW2 * S2 + 3.00E+00 * CW2 * S3
     $ - 9.60E+01 * CW2 * ZM4 + 3.20E+01 * CW2 * ZM6 + 8.00E+00 * CW2
     $ * S * ZM2 + 1.60E+01 * CW2 * S * ZM4 - 8.00E+00 * CW2 * S
     $ * ZM6 - 1.00E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(1,2,2) = -4.00E+00 * CW2 * S - 2.00E+00 * CW2 * S2
     $ + 6.40E+01 * CW2 * ZM4 + 1.20E+01 * CW2 * S * ZM2
      ANWWWW(1,2,3) = 4.00E+00 * CW2 * S - 6.00E+00 * CW2 * S2
     $ - 6.40E+01 * CW2 * ZM4 + 2.00E+01 * CW2 * S * ZM2
      ANWWWW(1,2,4) = 6.40E+01 * CW2 * QQ0 * QQF * QQI + 1.60E+01
     $ * CW2 * QQ0 * QQF * QQI * S + 9.60E+01 * CW2 * QQ0 * QQF * QQI
     $ * ZM2 + 3.20E+01 * CW2 * QQ0 * QQF * QQI * ZM4
      ANWWWW(1,3,1) = -4.00E+00 * CW2 * S2 + 3.00E+00 * CW2 * S3
     $ - 9.60E+01 * CW2 * ZM4 + 3.20E+01 * CW2 * ZM6 + 8.00E+00 * CW2
     $ * S * ZM2 + 1.60E+01 * CW2 * S * ZM4 - 8.00E+00 * CW2 * S
     $ * ZM6 - 1.00E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(1,3,2) = -4.00E+00 * CW2 * S - 2.00E+00 * CW2 * S2
     $ + 6.40E+01 * CW2 * ZM4 + 1.20E+01 * CW2 * S * ZM2
      ANWWWW(1,3,3) = 4.00E+00 * CW2 * S - 6.00E+00 * CW2 * S2
     $ - 6.40E+01 * CW2 * ZM4 + 2.00E+01 * CW2 * S * ZM2
      ANWWWW(1,3,4) = -6.40E+01 * CW2 * QQ0 * QQF * QQI - 1.60E+01
     $ * CW2 * QQ0 * QQF * QQI * S - 9.60E+01 * CW2 * QQ0 * QQF * QQI
     $ * ZM2 - 3.20E+01 * CW2 * QQ0 * QQF * QQI * ZM4
      ANWWWW(1,4,1) = 0.00E+00
      ANWWWW(1,4,2) = 0.00E+00
      ANWWWW(1,4,3) = 0.00E+00
      ANWWWW(1,4,4) = 0.00E+00
      ANWWWW(2,1,1) = 0.00E+00
      ANWWWW(2,1,2) = 0.00E+00
      ANWWWW(2,1,3) = 0.00E+00
      ANWWWW(2,1,4) = 8.00E+00 * CW2 * QQ0 * S
      ANWWWW(2,2,1) = 4.80E+01 * CW2 * QQF * QQI * S - 2.00E+01 * CW2
     $ * QQF * QQI * S2 + 6.40E+01 * CW2 * QQF * QQI * ZM2 + 9.60E+01
     $ * CW2 * QQF * QQI * S * ZM2 - 1.60E+01 * CW2 * QQF * QQI * S
     $ * ZM4
      ANWWWW(2,2,2) = 8.00E+00 * CW2 * QQF * QQI * S
      ANWWWW(2,2,3) = 5.60E+01 * CW2 * QQF * QQI * S
      ANWWWW(2,2,4) = -8.00E+00 * CW2 * QQ0 * S2 + 1.92E+02 * CW2
     $ * QQ0 * ZM2 + 1.28E+02 * CW2 * QQ0 * ZM4 - 8.00E+00 * CW2
     $ * QQ0 * S * ZM2 - 8.00E+00 * CW2 * QQ0 * S * ZM4
      ANWWWW(2,3,1) = -4.80E+01 * CW2 * QQF * QQI * S + 2.00E+01 * CW2
     $ * QQF * QQI * S2 - 6.40E+01 * CW2 * QQF * QQI * ZM2
     $ - 9.60E+01 * CW2 * QQF * QQI * S * ZM2 + 1.60E+01 * CW2 * QQF
     $ * QQI * S * ZM4
      ANWWWW(2,3,2) = -8.00E+00 * CW2 * QQF * QQI * S
      ANWWWW(2,3,3) = -5.60E+01 * CW2 * QQF * QQI * S
      ANWWWW(2,3,4) = -8.00E+00 * CW2 * QQ0 * S2 + 1.92E+02 * CW2
     $ * QQ0 * ZM2 + 1.28E+02 * CW2 * QQ0 * ZM4 - 8.00E+00 * CW2
     $ * QQ0 * S * ZM2 - 8.00E+00 * CW2 * QQ0 * S * ZM4
      ANWWWW(2,4,1) = 0.00E+00
      ANWWWW(2,4,2) = 0.00E+00
      ANWWWW(2,4,3) = 0.00E+00
      ANWWWW(2,4,4) = 0.00E+00
      ANWWWW(3,1,1) = 2.00E+00 * CW2 * S2
      ANWWWW(3,1,2) = -4.00E+00 * CW2 * S
      ANWWWW(3,1,3) = 4.00E+00 * CW2 * S
      ANWWWW(3,1,4) = 0.00E+00
      ANWWWW(3,2,1) = 3.20E+01 * CW2 * S - 1.60E+01 * CW2 * S2 + CW2
     $ * S3 + 9.60E+01 * CW2 * S * ZM2 + 3.20E+01 * CW2 * S * ZM4
     $ - 2.20E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(3,2,2) = 4.00E+00 * CW2 * S + 2.00E+00 * CW2 * S2
     $ - 6.40E+01 * CW2 * ZM4 - 1.20E+01 * CW2 * S * ZM2
      ANWWWW(3,2,3) = 2.80E+01 * CW2 * S - 1.00E+01 * CW2 * S2
     $ + 6.40E+01 * CW2 * ZM4 + 1.20E+01 * CW2 * S * ZM2
      ANWWWW(3,2,4) = 1.60E+01 * CW2 * QQ0 * QQF * QQI * S
      ANWWWW(3,3,1) = 3.20E+01 * CW2 * S - 1.60E+01 * CW2 * S2 + CW2
     $ * S3 + 9.60E+01 * CW2 * S * ZM2 + 3.20E+01 * CW2 * S * ZM4
     $ - 2.20E+01 * CW2 * S2 * ZM2 + 2.00E+00 * CW2 * S2 * ZM4
      ANWWWW(3,3,2) = 4.00E+00 * CW2 * S + 2.00E+00 * CW2 * S2
     $ - 6.40E+01 * CW2 * ZM4 - 1.20E+01 * CW2 * S * ZM2
      ANWWWW(3,3,3) = 2.80E+01 * CW2 * S - 1.00E+01 * CW2 * S2
     $ + 6.40E+01 * CW2 * ZM4 + 1.20E+01 * CW2 * S * ZM2
      ANWWWW(3,3,4) = -1.60E+01 * CW2 * QQ0 * QQF * QQI * S
      ANWWWW(3,4,1) = 0.00E+00
      ANWWWW(3,4,2) = 0.00E+00
      ANWWWW(3,4,3) = 0.00E+00
      ANWWWW(3,4,4) = 0.00E+00
      ANWWWW(4,1,1) = 0.00E+00
      ANWWWW(4,1,2) = 0.00E+00
      ANWWWW(4,1,3) = 0.00E+00
      ANWWWW(4,1,4) = 0.00E+00
      ANWWWW(4,2,1) = 4.00E+00 * CW2 * QQF * QQI * S2
      ANWWWW(4,2,2) = -8.00E+00 * CW2 * QQF * QQI * S
      ANWWWW(4,2,3) = 8.00E+00 * CW2 * QQF * QQI * S
      ANWWWW(4,2,4) = 0.00E+00
      ANWWWW(4,3,1) = -4.00E+00 * CW2 * QQF * QQI * S2
      ANWWWW(4,3,2) = 8.00E+00 * CW2 * QQF * QQI * S
      ANWWWW(4,3,3) = -8.00E+00 * CW2 * QQF * QQI * S
      ANWWWW(4,3,4) = 0.00E+00
      ANWWWW(4,4,1) = 0.00E+00
      ANWWWW(4,4,2) = 0.00E+00
      ANWWWW(4,4,3) = 0.00E+00
      ANWWWW(4,4,4) = 0.00E+00
C
      ADWWWW(1,1) = 1.00E+00
      ADWWWW(1,2) = S - 2.00E+00 * ZM2
      ADWWWW(1,3) = S - 2.00E+00 * ZM2
      ADWWWW(1,4) = 1.00E+00
      ADWWWW(2,1) = 0.00E+00
      ADWWWW(2,2) = -1.00E+00 * S + 4.00E+00 * (S / (S + 4.00E+00
     $ * QQF * QQI)) - 1.60E+01 * (ZM2 / (S + 4.00E+00 * QQF * QQI))
     $ + 4.00E+00 * ((S * ZM2) / (S + 4.00E+00 * QQF * QQI))
      ADWWWW(2,3) = S - 4.00E+00 * (S / (S + 4.00E+00 * QQF * QQI))
     $ + 1.60E+01 * (ZM2 / (S + 4.00E+00 * QQF * QQI)) - 4.00E+00
     $ * ((S * ZM2) / (S + 4.00E+00 * QQF * QQI))
      ADWWWW(2,4) = 0.00E+00
C
      AIWWWW(1) = 1.60E+01 * ((HG * HM * ZM3) / (CW * PROPH))
     $ - 8.00E+00 * ((HG * HM * S * ZM) / (CW * PROPH))
     $ - 8.00E+00 * ((HG * HM * S * ZM3) / (CW * PROPH)) + 4.00E+00
     $ * ((HG * HM * S2 * ZM) / (CW * PROPH))
      AIWWWW(2) = 0.00E+00
      AIWWWW(3) = 1.60E+01 * ((HG * HM * ZM3) / (CW * PROPH))
     $ - 8.00E+00 * ((HG * HM * S * ZM) / (CW * PROPH))
      AIWWWW(4) = 0.00E+00
C
C          RESTORE MISSING FACTORS
      DO 100 J=1,4
      AIWWWW(J)=AIWWWW(J)*GSQ/(16.*ZM2)
      DO 100 I=1,4
      DO 110 K=1,4
110   ANWWWW(K,I,J)=ANWWWW(K,I,J)*GSQ/(16.*ZM2)
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,XZZZZ
      SUBROUTINE XZZZZ
C
C          SET UP Z0 Z0 -> Z0 Z0 AMPLITUDES AS RATIONAL FUNCTIONS OF Z
C
C          RE(F(Z,L)) = SUM(I,J)(ANWWWW(I+1,J,L)*Z**I
C                                  /(ADWWWW(1,J)+ADWWWW(2,J)*Z))
C          IM(F(Z,L)) = AIWWWW(L)   (INDEPENDENT OF Z)
C          J LABELS PIECES WITH SAME DENOMINATOR.
C          L=1 FOR 0,0; L=2 FOR 1,-1; L=3 FOR 1,1; L=4 FOR 0,1
C
C          *NOTE* A FACTOR OF SIN(THETA)/SQRT(2) IS REMOVED FROM F01
C
+CDE,CONST
+CDE,JETPAR
+CDE,WCON
+CDE,HCON
+SELF,IF=DOUBLE.
      DOUBLE PRECISION WM,ZM,ZM2,ZM3,ZM4,ZM5,ZM6,HM,HM2,HM3,HM4,HG,HG2
     $,PROPH,RTS,S,S2,S3,SW,QQ0,QQI,QQF
+SELF.
C
C          USE UNITS OF WM TO AVOID LARGE NUMBERS - NOTE ANWWWW/ADWWWW
C          AND AIWWWW ARE DIMENSIONLESS
      WM=WMASS(2)
      ZM=WMASS(4)/WM
      ZM2=ZM**2
      ZM3=ZM**3
      ZM4=ZM**4
      ZM5=ZM**5
      ZM6=ZM**6
      HM=HMASS/WM
      HM2=HM**2
      HM3=HM**3
      HM4=HM**4
      HG=HGAM/WM
      HG2=HG**2
      RTS=QMW/WM
      S=RTS**2
      S2=S**2
      S3=S**3
      PROPH=(S-HM2)**2+(HM*HG)**2
C
      CW=1./ZM
      CW2=CW**2
      SW2=1.-CW2
      SW=SQRT(SW2)
      QQ0=.5*RTS
      QQI=.5*SQRT(S-4.*ZM2)
      QQF=.5*SQRT(S-4.*ZM2)
      GSQ=4.*PI*ALFA/SW2
C
C          FROM ZZZZ3.EX
      ANWWWW(1,1,1) = -1.60E+01 * ((HM2 * ZM6) / (CW2 * PROPH))
     $ + 1.60E+01 * ((S * ZM6) / (CW2 * PROPH )) - 1.60E+01 * ((S2
     $ * ZM4) / (CW2 * PROPH)) + 4.00E+00 * ((S3 * ZM2) / (CW2
     $ * PROPH)) + 1.60E+01 * ((HM2 * S * ZM4) / (CW2 * PROPH))
     $ - 4.00E+00 * ((HM2 * S2 * ZM2) / (CW2 * PROPH))
      ANWWWW(1,1,2) = 0.00E+00
      ANWWWW(1,1,3) = -1.60E+01 * ((HM2 * ZM6) / (CW2 * PROPH))
     $ + 1.60E+01 * ((S * ZM6) / (CW2 * PROPH )) - 8.00E+00 * ((S2
     $ * ZM4) / (CW2 * PROPH)) + 8.00E+00 * ((HM2 * S * ZM4) / (CW2
     $ * PROPH))
      ANWWWW(1,1,4) = 0.00E+00
      ANWWWW(1,2,1) = -3.20E+01 * (ZM6 / CW2) + 1.60E+01 * ((S * ZM4)
     $ / CW2) - 2.00E+00 * ((S2 * ZM2) / CW2)
      ANWWWW(1,2,2) = -4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(1,2,3) = 4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(1,2,4) = -3.20E+01 * ((QQ0 * ZM5) / CW2) + 8.00E+00
     $ * ((QQ0 * S * ZM3) / CW2)
      ANWWWW(1,3,1) = -3.20E+01 * (ZM6 / CW2) + 1.60E+01 * ((S * ZM4)
     $ / CW2) - 2.00E+00 * ((S2 * ZM2) / CW2)
      ANWWWW(1,3,2) = -4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(1,3,3) = 4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(1,3,4) = 3.20E+01 * ((QQ0 * ZM5) / CW2) - 8.00E+00
     $ * ((QQ0 * S * ZM3) / CW2)
      ANWWWW(1,4,1) = 0.00E+00
      ANWWWW(1,4,2) = 0.00E+00
      ANWWWW(1,4,3) = 0.00E+00
      ANWWWW(1,4,4) = 0.00E+00
      ANWWWW(2,1,1) = 0.00E+00
      ANWWWW(2,1,2) = 0.00E+00
      ANWWWW(2,1,3) = 0.00E+00
      ANWWWW(2,1,4) = 0.00E+00
      ANWWWW(2,2,1) = -1.60E+01 * ((S * ZM4) / CW2) + 4.00E+00 * ((S2
     $ * ZM2) / CW2)
      ANWWWW(2,2,2) = 0.00E+00
      ANWWWW(2,2,3) = 0.00E+00
      ANWWWW(2,2,4) = -8.00E+00 * ((QQ0 * S * ZM3) / CW2 )
      ANWWWW(2,3,1) = 1.60E+01 * ((S * ZM4) / CW2) - 4.00E+00 * ((S2
     $ * ZM2) / CW2)
      ANWWWW(2,3,2) = 0.00E+00
      ANWWWW(2,3,3) = 0.00E+00
      ANWWWW(2,3,4) = -8.00E+00 * ((QQ0 * S * ZM3) / CW2 )
      ANWWWW(2,4,1) = 0.00E+00
      ANWWWW(2,4,2) = 0.00E+00
      ANWWWW(2,4,3) = 0.00E+00
      ANWWWW(2,4,4) = 0.00E+00
      ANWWWW(3,1,1) = 0.00E+00
      ANWWWW(3,1,2) = 0.00E+00
      ANWWWW(3,1,3) = 0.00E+00
      ANWWWW(3,1,4) = 0.00E+00
      ANWWWW(3,2,1) = -2.00E+00 * ((S2 * ZM2) / CW2)
      ANWWWW(3,2,2) = 4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(3,2,3) = -4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(3,2,4) = 0.00E+00
      ANWWWW(3,3,1) = -2.00E+00 * ((S2 * ZM2) / CW2)
      ANWWWW(3,3,2) = 4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(3,3,3) = -4.00E+00 * ((S * ZM4) / CW2)
      ANWWWW(3,3,4) = 0.00E+00
      ANWWWW(3,4,1) = 0.00E+00
      ANWWWW(3,4,2) = 0.00E+00
      ANWWWW(3,4,3) = 0.00E+00
      ANWWWW(3,4,4) = 0.00E+00
      ANWWWW(4,1,1) = 0.00E+00
      ANWWWW(4,1,2) = 0.00E+00
      ANWWWW(4,1,3) = 0.00E+00
      ANWWWW(4,1,4) = 0.00E+00
      ANWWWW(4,2,1) = 0.00E+00
      ANWWWW(4,2,2) = 0.00E+00
      ANWWWW(4,2,3) = 0.00E+00
      ANWWWW(4,2,4) = 0.00E+00
      ANWWWW(4,3,1) = 0.00E+00
      ANWWWW(4,3,2) = 0.00E+00
      ANWWWW(4,3,3) = 0.00E+00
      ANWWWW(4,3,4) = 0.00E+00
      ANWWWW(4,4,1) = 0.00E+00
      ANWWWW(4,4,2) = 0.00E+00
      ANWWWW(4,4,3) = 0.00E+00
      ANWWWW(4,4,4) = 0.00E+00
C
      ADWWWW(1,1) = 1.00E+00
      ADWWWW(1,2) = 2.00E+00 * HM2 + S - 4.00E+00 * ZM2
      ADWWWW(1,3) = 2.00E+00 * HM2 + S - 4.00E+00 * ZM2
      ADWWWW(1,4) = 1.00E+00
      ADWWWW(2,1) = 0.00E+00
      ADWWWW(2,2) = -1.00E+00 * S + 4.00E+00 * ZM2
      ADWWWW(2,3) = S - 4.00E+00 * ZM2
      ADWWWW(2,4) = 0.00E+00
C
      AIWWWW(1) = 1.60E+01 * ((HG * HM * ZM6) / (CW2 * PROPH))
     $ - 1.60E+01 * ((HG * HM * S * ZM4) / (CW2 * PROPH))
     $ + 4.00E+00 * ((HG * HM * S2 * ZM2) / (CW2 * PROPH))
      AIWWWW(2) = 0.00E+00
      AIWWWW(3) = 1.60E+01 * ((HG * HM * ZM6) / (CW2 * PROPH))
     $ - 8.00E+00 * ((HG * HM * S * ZM4) / (CW2 * PROPH))
      AIWWWW(4) = 0.00E+00
C
C          RESTORE MISSING FACTORS
      DO 100 J=1,4
      AIWWWW(J)=AIWWWW(J)*GSQ/(16.*ZM4)
      DO 100 I=1,4
      DO 110 K=1,4
110   ANWWWW(K,I,J)=ANWWWW(K,I,J)*GSQ/(16.*ZM4)
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,YGENJ.
      LOGICAL FUNCTION YGENJ(I)
C
C            GENERATE Y FOR TWOJET
C
+CDE,ITAPES
+CDE,JETLIM
+CDE,JETPAR
+CDE,PRIMAR
+CDE,PTPAR
+CDE,TOTALS
      ACOSH(X)=ALOG(X+SQRT(X**2-1.0))
      YGENJ=.TRUE.
      YMAX=ACOSH(HALFE/PT(I))
      YMIN=-YMAX
      IF(YMAX.LT.YJMIN(I).OR.YMIN.GT.YJMAX(I)) GOTO 10
      YJ(I)=YJMIN(I)+(YJMAX(I)-YJMIN(I))*RANF()
      IF(YJ(I).LT.YMIN.OR.YJ(I).GT.YMAX) GOTO 10
      TH(I)=2.*ATAN(EXP(-YJ(I)))
      CTH(I)=COS(TH(I))
      STH(I)=SIN(TH(I))
      WT=WT*(YJMAX(I)-YJMIN(I))
      RETURN
   10 YGENJ=.FALSE.
      RETURN
      END
+EOD
+DECK,ZJJ0
      SUBROUTINE ZJJ0
C-----------------------------------------------------------------------
C
C          Initialize MadGraph/Helas to generate Z + 2 jets.
C          Cross section routines from MadGraph:
C          ZJJ1:   q1 q1b -> Z q2 q2b, q1 != q2
C          ZJJ2:   g  g   -> Z q2 q2b
C          ZJJ3:   q1 q1b -> Z g  g
C          ZJJ4:   q1 q1b -> Z q1 q1b
C          ZJJ5:   q1 q2  -> Z q1 q2
C          ZJJ6:   q1 q1  -> Z q1 q1
C          ZJJ7:   g  q   -> Z g  q
C
C          Note: The Z is always jet1, but the other two jets are 
C          symmetrized so a symmetry factor of 1/2 is needed for every
C          subprocess. This is included by MadGraph for identical
C          particles!
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,CONST
+CDE,Q1Q2
+CDE,ITAPES
+CDE,JETLIM
+CDE,PRIMAR
+CDE,SSTYPE
+CDE,MGKIN
+CDE,MGCOMS
+CDE,MGSIGS
C
      INTEGER IMAD(6)
      INTEGER IQ1,IQ2,IQ4,IQ5,IFL1,IFL2,IM1,IM2,I,NEV,KK,II,J
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      EQUIVALENCE (P1(0),PJETS8(0,1))
      EQUIVALENCE (P2(0),PJETS8(0,2))
      EQUIVALENCE (P3(0),PJETS8(0,3))
      EQUIVALENCE (P4(0),PJETS8(0,4))
      EQUIVALENCE (P5(0),PJETS8(0,5))
      REAL*8 WT,TERM,FJAC,SZJJ1,SZJJ2,SZJJ3,SZJJ4,SUM
      REAL*8 SZJJ5,SZJJ6,SZJJ7
      REAL X1,X2,XX,QQ,TMP(MXSIG8),QFCN,STRUC,ALQCD
      INTEGER IQ,IH,NPT,NNN,ISUM
C
C          Map Jettype/2 to MadGraph
      DATA IMAD/3,4,8,7,12,11/
C
C          Parton distributions
      QFCN(XX,IQ,IH)=STRUC(XX,QQ,IQ,IDIN(IH))/XX
C
C          Begin
C
      NPT=MAX(NSIGMA,100)
      WRITE(ITLIS,1000) NTRIES,NPT
1000  FORMAT(//' INITIALIZING CROSS SECTIONS WITH',I6,
     $' TRIES FOR',I6,' POINTS EACH:')
      FJAC=UNITS/SCM
      WTTOT8=0
      NSIG8=0
C
C          Cases 1,4: q1 q1b -> z q2 q2b
C
      AMJET8(3)=ZMASS
      DO 100 IFL1=1,5
        IM1=IMAD(IFL1)
        IQ1=2*IFL1
        IQ2=IQ1+1
        AMJET8(1)=FMASS(IM1)
        AMJET8(2)=FMASS(IM1)
        DO 110 IFL2=1,6
          IM2=IMAD(IFL2)
          IQ4=2*IFL2
          IQ5=IQ4+1
          AMJET8(4)=FMASS(IM2)
          AMJET8(5)=FMASS(IM2)
C
C          Subcase 1a: 3=z, 4=q, 5=qb
C
          IF(GOQ(IQ4,2).AND.GOQ(IQ5,3)) THEN
            IF(NSIG8+2.GT.MXSIG8) GO TO 999
            DO 120 I=1,2
              WTSUM8(NSIG8+I)=0
              WTMAX8(NSIG8+I)=0
              NWT8(NSIG8+I)=0
              IDENT8(1,NSIG8+I)=(3-2*I)*IFL1
              IDENT8(2,NSIG8+I)=-(3-2*I)*IFL1
              IDENT8(3,NSIG8+I)=IDZ
              IDENT8(4,NSIG8+I)=IFL2
              IDENT8(5,NSIG8+I)=-IFL2
              IF(IFL1.EQ.IFL2) THEN
                IFUNC8(NSIG8+I)=4
              ELSE
                IFUNC8(NSIG8+I)=1
              ENDIF
              NNN=0
              DO 125 NEV=1,NTRIES
                IF(NNN.GT.NPT) GO TO 120
                CALL MULJET(WT)
                NWT8(NSIG8+I)=NWT8(NSIG8+I)+1
                NWTTOT=NWTTOT+1
                IF(WT.GT.0) THEN
                  NNN=NNN+1
                  X1=(P1(0)+P1(3))/ECM
                  X2=(P2(0)-P2(3))/ECM
                  QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $            P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
                  IF(I.EQ.1) THEN
                    IF(IFL2.EQ.IFL1) THEN
                      TERM=SZJJ4(P1,P2,P3,P4,P5,IM1)
                    ELSE
                      TERM=SZJJ1(P1,P2,P3,P4,P5,IM1,IM2)
                    ENDIF
                    TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                    TERM=TERM*WT*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
                  ELSE
                    IF(IFL2.EQ.IFL1) THEN
                      TERM=SZJJ4(P2,P1,P3,P4,P5,IM1)
                    ELSE
                      TERM=SZJJ1(P2,P1,P3,P4,P5,IM1,IM2)
                    ENDIF
                    TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                    TERM=TERM*WT*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
                  ENDIF
                  TERM=0.5*TERM
                  WTTOT8=WTTOT8+TERM
                  WTSUM8(NSIG8+I)=WTSUM8(NSIG8+I)+TERM
                  WTMAX8(NSIG8+I)=MAX(WTMAX8(NSIG8+I),TERM)
                ENDIF
125           CONTINUE
              WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $        (IDENT8(KK,NSIG8+I),KK=1,5)
120         CONTINUE
            NSIG8=NSIG8+2
          ENDIF
C
C          Subcase 1b: 3=z, 4=qb, 5=q
C
          IF(GOQ(IQ5,2).AND.GOQ(IQ4,3)) THEN
            IF(NSIG8+2.GT.MXSIG8) GO TO 999
            DO 130 I=1,2
              WTSUM8(NSIG8+I)=0
              WTMAX8(NSIG8+I)=0
              NWT8(NSIG8+I)=0
              IDENT8(1,NSIG8+I)=(3-2*I)*IFL1
              IDENT8(2,NSIG8+I)=-(3-2*I)*IFL1
              IDENT8(3,NSIG8+I)=IDZ
              IDENT8(4,NSIG8+I)=-IFL2
              IDENT8(5,NSIG8+I)=IFL2
              IF(IFL1.EQ.IFL2) THEN
                IFUNC8(NSIG8+I)=4
              ELSE
                IFUNC8(NSIG8+I)=1
              ENDIF
              NNN=0
              DO 135 NEV=1,NTRIES
                IF(NNN.GT.NPT) GO TO 130
                CALL MULJET(WT)
                NWT8(NSIG8+I)=NWT8(NSIG8+I)+1
                NWTTOT=NWTTOT+1
                IF(WT.GT.0) THEN
                  NNN=NNN+1
                  X1=(P1(0)+P1(3))/ECM
                  X2=(P2(0)-P2(3))/ECM
                  QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $            P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
                  IF(I.EQ.1) THEN
                    IF(IFL1.EQ.IFL2) THEN
                      TERM=SZJJ4(P1,P2,P3,P5,P4,IM1)
                    ELSE
                      TERM=SZJJ1(P1,P2,P3,P5,P4,IM1,IM2)
                    ENDIF
                    TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                    TERM=TERM*WT*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
                  ELSE
                    IF(IFL1.EQ.IFL2) THEN
                      TERM=SZJJ4(P2,P1,P3,P5,P4,IM1)
                    ELSE
                      TERM=SZJJ1(P2,P1,P3,P5,P4,IM1,IM2)
                    ENDIF
                    TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                    TERM=TERM*WT*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
                  ENDIF
                  TERM=0.5*TERM
                  WTTOT8=WTTOT8+TERM
                  WTSUM8(NSIG8+I)=WTSUM8(NSIG8+I)+TERM
                  WTMAX8(NSIG8+I)=MAX(WTMAX8(NSIG8+I),TERM)
                ENDIF
135           CONTINUE
              WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $        (IDENT8(KK,NSIG8+I),KK=1,5)
130         CONTINUE
            NSIG8=NSIG8+2
          ENDIF
110     CONTINUE
100   CONTINUE
C
C          Case 2: g g -> z q2 q2b
C
      AMJET8(3)=ZMASS
      IFL1=9
      AMJET8(1)=0
      AMJET8(2)=0
      DO 210 IFL2=1,6
        IM2=IMAD(IFL2)
        IQ4=2*IFL2
        IQ5=IQ4+1
        AMJET8(4)=FMASS(IM2)
        AMJET8(5)=FMASS(IM2)
C
C          Subcase 2a: 3=z, 4=q, 5=qb
C
        IF(GOQ(IQ4,2).AND.GOQ(IQ5,3)) THEN
          IF(NSIG8+1.GT.MXSIG8) GO TO 999
          WTSUM8(NSIG8+1)=0
          WTMAX8(NSIG8+1)=0
          NWT8(NSIG8+1)=0
          IDENT8(1,NSIG8+1)=IDGL
          IDENT8(2,NSIG8+1)=IDGL
          IDENT8(3,NSIG8+1)=IDZ
          IDENT8(4,NSIG8+1)=IFL2
          IDENT8(5,NSIG8+1)=-IFL2
          IFUNC8(NSIG8+1)=2
          NNN=0
          DO 225 NEV=1,NTRIES
            IF(NNN.GT.NPT) GO TO 220
            CALL MULJET(WT)
            NWT8(NSIG8+1)=NWT8(NSIG8+1)+1
            NWTTOT=NWTTOT+1
            IF(WT.GT.0) THEN
              NNN=NNN+1
              X1=(P1(0)+P1(3))/ECM
              X2=(P2(0)-P2(3))/ECM
              QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $        P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
              TERM=SZJJ2(P1,P2,P3,P4,P5,IM2)
              TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
              TERM=TERM*WT*FJAC*QFCN(X1,1,1)*QFCN(X2,1,2)
              TERM=0.5*TERM
              WTTOT8=WTTOT8+TERM
              WTSUM8(NSIG8+1)=WTSUM8(NSIG8+1)+TERM
              WTMAX8(NSIG8+1)=MAX(WTMAX8(NSIG8+1),TERM)
            ENDIF
225       CONTINUE
          WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $    (IDENT8(KK,NSIG8+1),KK=1,5)
220       CONTINUE
          NSIG8=NSIG8+1
        ENDIF
C
C          Subcase 2b: 3=z, 4=qb, 5=q
C
        IF(GOQ(IQ5,2).AND.GOQ(IQ4,3)) THEN
          IF(NSIG8+1.GT.MXSIG8) GO TO 999
          WTSUM8(NSIG8+1)=0
          WTMAX8(NSIG8+1)=0
          NWT8(NSIG8+1)=0
          IDENT8(1,NSIG8+1)=IDGL
          IDENT8(2,NSIG8+1)=IDGL
          IDENT8(3,NSIG8+1)=IDZ
          IDENT8(4,NSIG8+1)=-IFL2
          IDENT8(5,NSIG8+1)=IFL2
          IFUNC8(NSIG8+1)=2
          NNN=0
          DO 235 NEV=1,NTRIES
            IF(NNN.GT.NPT) GO TO 230
            CALL MULJET(WT)
            NWT8(NSIG8+1)=NWT8(NSIG8+1)+1
            NWTTOT=NWTTOT+1
            IF(WT.GT.0) THEN
              NNN=NNN+1
              X1=(P1(0)+P1(3))/ECM
              X2=(P2(0)-P2(3))/ECM
              QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $        P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
              TERM=SZJJ2(P1,P2,P3,P5,P4,IM2)
              TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
              TERM=TERM*WT*FJAC*QFCN(X1,1,1)*QFCN(X2,1,2)
              TERM=0.5*TERM
              WTTOT8=WTTOT8+TERM
              WTSUM8(NSIG8+1)=WTSUM8(NSIG8+1)+TERM
              WTMAX8(NSIG8+1)=MAX(WTMAX8(NSIG8+1),TERM)
            ENDIF
235       CONTINUE
          WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $    (IDENT8(KK,NSIG8+1),KK=1,5)
230       CONTINUE
          NSIG8=NSIG8+1
        ENDIF
210   CONTINUE
C
C          Case 3: q1 q1b -> z g g
C
      AMJET8(3)=ZMASS
      AMJET8(4)=0
      AMJET8(5)=0
      DO 310 IFL1=1,5
        IM1=IMAD(IFL1)
        IQ1=2*IFL1
        IQ2=IQ1+1
        AMJET8(1)=FMASS(IM1)
        AMJET8(2)=FMASS(IM1)
C
        IF(GOQ(1,2).AND.GOQ(1,3)) THEN
          IF(NSIG8+2.GT.MXSIG8) GO TO 999
          DO 320 I=1,2
            WTSUM8(NSIG8+I)=0
            WTMAX8(NSIG8+I)=0
            NWT8(NSIG8+I)=0
            IDENT8(1,NSIG8+I)=(3-2*I)*IFL1
            IDENT8(2,NSIG8+I)=-(3-2*I)*IFL1
            IDENT8(3,NSIG8+I)=IDZ
            IDENT8(4,NSIG8+I)=IDGL
            IDENT8(5,NSIG8+I)=IDGL
            IFUNC8(NSIG8+I)=3
            NNN=0
            DO 325 NEV=1,NTRIES
              IF(NNN.GT.NPT) GO TO 320
              CALL MULJET(WT)
              NWT8(NSIG8+I)=NWT8(NSIG8+I)+1
              NWTTOT=NWTTOT+1
              IF(WT.GT.0) THEN
                NNN=NNN+1
                X1=(P1(0)+P1(3))/ECM
                X2=(P2(0)-P2(3))/ECM
                QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $          P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
                IF(I.EQ.1) THEN
                  TERM=SZJJ3(P1,P2,P3,P4,P5,IM1)
                  TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                  TERM=TERM*WT*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
                ELSE
                  TERM=SZJJ3(P2,P1,P3,P4,P5,IM1)
                  TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                  TERM=TERM*WT*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
                ENDIF
                WTTOT8=WTTOT8+TERM
                WTSUM8(NSIG8+I)=WTSUM8(NSIG8+I)+TERM
                WTMAX8(NSIG8+I)=MAX(WTMAX8(NSIG8+I),TERM)
              ENDIF
325         CONTINUE
            WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $      (IDENT8(KK,NSIG8+I),KK=1,5)
320       CONTINUE
          NSIG8=NSIG8+2
        ENDIF
310   CONTINUE
C
C          Cases 5,6: q1 q2 -> Z q1 q2, q1 != q2
C          Since we integrate over the Z decay, we can use the same
C          cross sections for quarks (I=1) and antiquarks (I=2).
C
      DO 400 IFL1=1,5
        IM1=IMAD(IFL1)
        DO 410 IFL2=1,5
          IM2=IMAD(IFL2)
          AMJET8(1)=FMASS(IM1)
          AMJET8(2)=FMASS(IM2)
          AMJET8(3)=ZMASS
          AMJET8(4)=FMASS(IM1)
          AMJET8(5)=FMASS(IM2)
          DO 420 I=1,2
            IQ1=2*IFL1+I-1
            IQ2=2*IFL2+I-1
            IF(GOQ(IQ1,1).AND.GOQ(IQ2,2)) THEN
              WTSUM8(NSIG8+1)=0
              WTMAX8(NSIG8+1)=0
              NWT8(NSIG8+1)=0
              IDENT8(1,NSIG8+1)=(3-2*I)*IFL1
              IDENT8(2,NSIG8+1)=(3-2*I)*IFL2
              IDENT8(3,NSIG8+1)=IDZ
              IDENT8(4,NSIG8+1)=(3-2*I)*IFL1
              IDENT8(5,NSIG8+1)=(3-2*I)*IFL2
              IF(IFL1.EQ.IFL2) THEN
                IFUNC8(NSIG8+1)=6
              ELSE
                IFUNC8(NSIG8+1)=5
              ENDIF
              NNN=0
              DO 425 NEV=1,NTRIES
                IF(NNN.GT.NPT) THEN
                  NSIG8=NSIG8+1
                  GO TO 420
                ENDIF
                CALL MULJET(WT)
                NWT8(NSIG8+1)=NWT8(NSIG8+1)+1
                NWTTOT=NWTTOT+1
                IF(WT.GT.0) THEN
                  NNN=NNN+1
                  X1=(P1(0)+P1(3))/ECM
                  X2=(P2(0)-P2(3))/ECM
                  QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $            P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
                  IF(IFL1.EQ.IFL2) THEN
                    TERM=SZJJ6(P1,P2,P3,P4,P5,IM1)
                    TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                    TERM=TERM*WT*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
                  ELSE
                    TERM=SZJJ5(P2,P1,P3,P4,P5,IM1,IM2)
                    TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                    TERM=TERM*WT*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
                    TERM=0.5*TERM
                  ENDIF
                  WTTOT8=WTTOT8+TERM
                  WTSUM8(NSIG8+1)=WTSUM8(NSIG8+1)+TERM
                  WTMAX8(NSIG8+1)=MAX(WTMAX8(NSIG8+1),TERM)
                ENDIF
425           CONTINUE
              WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $        (IDENT8(KK,NSIG8+1),KK=1,5)
              NSIG8=NSIG8+1
            ENDIF
420       CONTINUE
410     CONTINUE
400   CONTINUE
C
C          Case 7: g q -> z g q
C          Since we integrate over the Z decay, we can use the same
C          cross sections for quarks (I=1) and antiquarks (I=2).
C
      DO 500 IFL2=1,5
        IM2=IMAD(IFL2)
        DO 510 I=1,2
          IQ5=2*IFL2+I-1
C
C          Subcase 7a: 3=z, 4=g, 5=q (J=1,2 for initial states)
C
          IF(GOQ(1,2).AND.GOQ(IQ5,3)) THEN
            IF(NSIG8+2.GT.MXSIG8) GO TO 999
            AMJET8(3)=ZMASS
            AMJET8(4)=0
            AMJET8(5)=FMASS(IM2)
            DO 520 J=1,2
              WTSUM8(NSIG8+J)=0
              WTMAX8(NSIG8+J)=0
              NWT8(NSIG8+J)=0
              IF(J.EQ.1) THEN
                IDENT8(1,NSIG8+J)=IDGL
                IDENT8(2,NSIG8+J)=(3-2*I)*IFL2
                IQ1=1
                IQ2=IQ5
                AMJET8(1)=0
                AMJET8(2)=FMASS(IM2)
              ELSE
                IDENT8(2,NSIG8+J)=IDGL
                IDENT8(1,NSIG8+J)=(3-2*I)*IFL2
                IQ1=IQ5
                IQ2=1
                AMJET8(2)=0
                AMJET8(1)=FMASS(IM2)
              ENDIF
              IDENT8(3,NSIG8+J)=IDZ
              IDENT8(4,NSIG8+J)=IDGL
              IDENT8(5,NSIG8+J)=(3-2*I)*IFL2
              IFUNC8(NSIG8+J)=7
              NNN=0
              DO 525 NEV=1,NTRIES
                IF(NNN.GT.NPT) GO TO 520
                CALL MULJET(WT)
                NWT8(NSIG8+J)=NWT8(NSIG8+J)+1
                NWTTOT=NWTTOT+1
                IF(WT.GT.0) THEN
                  NNN=NNN+1
                  X1=(P1(0)+P1(3))/ECM
                  X2=(P2(0)-P2(3))/ECM
                  QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $            P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
                  IF(J.EQ.1) THEN
                    TERM=SZJJ7(P1,P2,P3,P4,P5,IM2)
                  ELSE
                    TERM=SZJJ7(P2,P1,P3,P4,P5,IM2)
                  ENDIF
                  TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                  TERM=TERM*WT*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
                  TERM=0.5*TERM
                  WTTOT8=WTTOT8+TERM
                  WTSUM8(NSIG8+J)=WTSUM8(NSIG8+J)+TERM
                  WTMAX8(NSIG8+J)=MAX(WTMAX8(NSIG8+J),TERM)
                ENDIF
525           CONTINUE
              WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $        (IDENT8(KK,NSIG8+1),KK=1,5)
520         CONTINUE
            NSIG8=NSIG8+2
          ENDIF
C
C          Subcase 7b: 3=z, 4=q, 5=g
C
          IF(GOQ(IQ5,2).AND.GOQ(1,3)) THEN
            IF(NSIG8+2.GT.MXSIG8) GO TO 999
            AMJET8(3)=ZMASS
            AMJET8(4)=FMASS(IM2)
            AMJET8(5)=0
            DO 530 J=1,2
              WTSUM8(NSIG8+J)=0
              WTMAX8(NSIG8+J)=0
              NWT8(NSIG8+J)=0
              IF(J.EQ.1) THEN
                IDENT8(1,NSIG8+J)=IDGL
                IDENT8(2,NSIG8+J)=(3-2*I)*IFL2
                IQ1=1
                IQ2=IQ5
                AMJET8(1)=0
                AMJET8(2)=FMASS(IM2)
              ELSE
                IDENT8(2,NSIG8+J)=IDGL
                IDENT8(1,NSIG8+J)=(3-2*I)*IFL2
                IQ1=IQ5
                IQ2=1
                AMJET8(2)=0
                AMJET8(1)=FMASS(IM2)
              ENDIF
              IDENT8(3,NSIG8+J)=IDZ
              IDENT8(4,NSIG8+J)=(3-2*I)*IFL2
              IDENT8(5,NSIG8+J)=IDGL
              IFUNC8(NSIG8+J)=7
              NNN=0
              DO 535 NEV=1,NTRIES
                IF(NNN.GT.NPT) GO TO 530
                CALL MULJET(WT)
                NWT8(NSIG8+J)=NWT8(NSIG8+J)+1
                NWTTOT=NWTTOT+1
                IF(WT.GT.0) THEN
                  NNN=NNN+1
                  X1=(P1(0)+P1(3))/ECM
                  X2=(P2(0)-P2(3))/ECM
                  QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $            P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
                  IF(J.EQ.1) THEN
                    TERM=SZJJ2(P1,P2,P3,P5,P4,IM2)
                  ELSE
                    TERM=SZJJ2(P2,P1,P3,P5,P4,IM2)
                  ENDIF
                  TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
                  TERM=TERM*WT*FJAC*QFCN(X1,1,1)*QFCN(X2,1,2)
                  TERM=0.5*TERM
                  WTTOT8=WTTOT8+TERM
                  WTSUM8(NSIG8+J)=WTSUM8(NSIG8+J)+TERM
                  WTMAX8(NSIG8+J)=MAX(WTMAX8(NSIG8+J),TERM)
                ENDIF
535           CONTINUE
              WRITE(ITLIS,*) ' ZJJ0 WARNING: INSUFFICIENT TRIES FOR ',
     $        (IDENT8(KK,NSIG8+1),KK=1,5)
530         CONTINUE
            NSIG8=NSIG8+2
          ENDIF
510     CONTINUE
500   CONTINUE
C
C          Sort using initial cross sections
C
      SUM=0
      ISUM=0
      DO 991 I=1,NSIG8
        ISORT8(I)=NSIG8+1-I
        TMP(I)=WTSUM8(I)/NWT8(I)
        SUM=SUM+WTSUM8(I)
        ISUM=ISUM+NWT8(I)
991   CONTINUE
      IF(NSIG8.GT.1) CALL SORTTF(TMP,ISORT8,NSIG8)
      WRITE(ITLIS,*)
      WRITE(ITLIS,9001)
9001  FORMAT(6X,'INITIAL MULTIJET CROSS SECTIONS'/
     $6X,'PROCESS',18X,'SIGMA',10X,'MAX(SIGMA)')
      DO 992 I=1,NSIG8
        II=ISORT8(I)
        WRITE(ITLIS,9002) (IDENT8(KK,II),KK=1,5),TMP(II),WTMAX8(II)
9002    FORMAT(2X,5I5,2E15.5)
992   CONTINUE
      RETURN
C
C          Errors
C
999   WRITE(ITLIS,*) 'ERROR IN ZJJ0, NSIG8 = ',NSIG8
      STOP 99
      END
+EOD
+DECK,ZJJ1       
      REAL*8 FUNCTION ZJJ1(P1, P2, P3, P4, P5,NHEL,IM1,IM2)
C  
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/avg over colors
C for the point in phase space P1,P2,P3,P4,...
C and helicity NHEL(1),NHEL(2),....
C for process : q(im1) q~(im1)  -> z q(im2) q~(im2)
C with Madgraph codes IM1 != IM2  
C  
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  4,NEIGEN=  1,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER NHEL(NEXTERNAL)                                                    
      INTEGER IM1,IM2
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) 
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C  
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       8.8888888888888884D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/  -5.0000000000000000D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/  -5.0000000000000000D-01 /                  
      DATA EIGEN_VEC(3  ,1  )/  -5.0000000000000000D-01 /                  
      DATA EIGEN_VEC(4  ,1  )/  -5.0000000000000000D-01 /                  
C ----------
C BEGIN CODE
C ----------
      CALL IXXXXX(P1  ,FMASS(IM1),NHEL(1  ), 1,W1  )                       
      CALL OXXXXX(P2  ,FMASS(IM1),NHEL(2  ),-1,W2  )                       
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL OXXXXX(P4  ,FMASS(IM2),NHEL(4  ), 1,W4  )                       
      CALL IXXXXX(P5  ,FMASS(IM2),NHEL(5  ),-1,W5  )                       
      IF(IM1.EQ.3.OR.IM1.EQ.7.OR.IM1.EQ.11) THEN
        CALL FVOXXX(W2  ,W3  ,GZD,FMASS(IM1),FWIDTH(IM1),W6  )               
      ELSE
        CALL FVOXXX(W2  ,W3  ,GZU,FMASS(IM1),FWIDTH(IM1),W6  )               
      ENDIF
      CALL JIOXXX(W1  ,W6  ,GG,ZERO,ZERO,W7  )                             
      CALL IOVXXX(W5  ,W4  ,W7  ,GG,AMP(1  ))                              
      CALL FVIXXX(W1  ,W3  ,GZD,FMASS(IM1),FWIDTH(IM2),W8  )               
      CALL JIOXXX(W8  ,W2  ,GG,ZERO,ZERO,W9  )                             
      CALL IOVXXX(W5  ,W4  ,W9  ,GG,AMP(2  ))                              
      CALL JIOXXX(W1  ,W2  ,GG,ZERO,ZERO,W10 )                             
      CALL FVOXXX(W4  ,W10 ,GG,FMASS(IM2),FWIDTH(IM2),W11 )                
      CALL IOVXXX(W5  ,W11 ,W3  ,GZD,AMP(3  ))                             
      IF(IM2.EQ.3.OR.IM2.EQ.7.OR.IM2.EQ.11) THEN
        CALL FVOXXX(W4  ,W3  ,GZD,FMASS(IM2),FWIDTH(IM2),W12 )               
      ELSE
        CALL FVOXXX(W4  ,W3  ,GZU,FMASS(IM2),FWIDTH(IM2),W12 )
      ENDIF
      CALL IOVXXX(W5  ,W12 ,W10 ,GG,AMP(4  ))                              
      ZJJ1 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ1 =ZJJ1+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
C      CALL GAUGECHECK(AMP,ZTEMP,EIGEN_VEC,EIGEN_VAL,NGRAPHS,NEIGEN)
      END
+EOD
+DECK,ZJJ2
      REAL*8 FUNCTION ZJJ2(P1, P2, P3, P4, P5,NHEL,IM)
C
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/ave over colors
C for the point in phase space P1,P2,P3,P4,P5
C and helicity NHEL(1)...
C for the process: g g -> z q(im) qb(im)
C with Madgraph code IM
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  8,NEIGEN=  2,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER NHEL(NEXTERNAL)
      INTEGER IM
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) , W13(6)
      REAL*8 GZUD(2) 
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       2.1875000000000006D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/  -4.0824829046386291D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/  -4.0824829046386291D-01 /                  
      DATA EIGEN_VEC(3  ,1  )/  -4.0824829046386307D-01 /                  
      DATA EIGEN_VEC(4  ,1  )/  -4.0824829046386307D-01 /                  
      DATA EIGEN_VEC(5  ,1  )/  -4.0824829046386307D-01 /                  
      DATA EIGEN_VEC(6  ,1  )/  -4.0824829046386291D-01 /                  
      DATA EIGEN_VEC(7  ,1  )/   0.0000000000000000D+00 /                  
      DATA EIGEN_VEC(8  ,1  )/   0.0000000000000000D+00 /                  
      DATA EIGEN_VAL(2  )/       6.5624999999999967D-01 /                  
      DATA EIGEN_VEC(1  ,2  )/  -2.6726124191242451D-01 /                  
      DATA EIGEN_VEC(2  ,2  )/  -2.6726124191242451D-01 /                  
      DATA EIGEN_VEC(3  ,2  )/   2.6726124191242440D-01 /                  
      DATA EIGEN_VEC(4  ,2  )/   2.6726124191242440D-01 /                  
      DATA EIGEN_VEC(5  ,2  )/   2.6726124191242440D-01 /                  
      DATA EIGEN_VEC(6  ,2  )/  -2.6726124191242451D-01 /                  
      DATA EIGEN_VEC(7  ,2  )/  -5.3452248382484857D-01 /                  
      DATA EIGEN_VEC(8  ,2  )/  -5.3452248382484857D-01 /                  
C ----------
C BEGIN CODE
C ----------
      IF(IM.EQ.4.OR.IM.EQ.8.OR.IM.EQ.12) THEN
        GZUD(1)=GZD(1)
        GZUD(2)=GZD(2)
      ELSE
        GZUD(1)=GZU(1)
        GZUD(2)=GZU(2)
      ENDIF
C
      CALL VXXXXX(P1  , ZERO,NHEL(1  ),-1,W1  )                            
      CALL VXXXXX(P2  , ZERO,NHEL(2  ),-1,W2  )                            
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL OXXXXX(P4  ,FMASS(IM),NHEL(4  ), 1,W4  )                       
      CALL IXXXXX(P5  ,FMASS(IM),NHEL(5  ),-1,W5  )                       
      CALL FVOXXX(W4  ,W1  ,GG,FMASS(IM),FWIDTH(IM),W6  )                
      CALL FVIXXX(W5  ,W2  ,GG,FMASS(IM),FWIDTH(IM),W7  )                
      CALL IOVXXX(W7  ,W6  ,W3  ,GZUD,AMP(1  ))                             
      CALL FVIXXX(W5  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W8  )               
      CALL IOVXXX(W8  ,W6  ,W2  ,GG,AMP(2  ))                              
      CALL FVOXXX(W4  ,W2  ,GG,FMASS(IM),FWIDTH(IM),W9  )                
      CALL FVIXXX(W5  ,W1  ,GG,FMASS(IM),FWIDTH(IM),W10 )                
      CALL IOVXXX(W10 ,W9  ,W3  ,GZUD,AMP(3  ))                             
      CALL IOVXXX(W8  ,W9  ,W1  ,GG,AMP(4  ))                              
      CALL FVOXXX(W4  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W11 )               
      CALL IOVXXX(W10 ,W11 ,W2  ,GG,AMP(5  ))                              
      CALL IOVXXX(W7  ,W11 ,W1  ,GG,AMP(6  ))                              
      CALL JGGXXX(W1  ,W2  ,G,W12 )                                        
      CALL FVOXXX(W4  ,W12 ,GG,FMASS(IM),FWIDTH(IM),W13 )                
      CALL IOVXXX(W5  ,W13 ,W3  ,GZUD,AMP(7  ))                             
      CALL IOVXXX(W5  ,W11 ,W12 ,GG,AMP(8  ))                              
      ZJJ2 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ2 =ZJJ2+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
C      CALL GAUGECHECK(AMP,ZTEMP,EIGEN_VEC,EIGEN_VAL,NGRAPHS,NEIGEN)
      END
+EOD
+DECK,ZJJ3
      REAL*8 FUNCTION ZJJ3(P1, P2, P3, P4, P5,NHEL,IM)
C
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/ave over colors
C for the point in phase space P1,P2,P3,P4,P5
C and helicity NHEL(1)...
C for the process: q(im) qb(im) -> z g g
C with Madgraph code IM
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  8,NEIGEN=  2,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER NHEL(NEXTERNAL),IM
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) , W13(6) , W14(6) , W15(6) 
      REAL*8 GZUD(2)
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C  
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       7.7777777777777746D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/  -4.0824829046386302D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/  -4.0824829046386307D-01 /                  
      DATA EIGEN_VEC(3  ,1  )/   0.0000000000000000D+00 /                  
      DATA EIGEN_VEC(4  ,1  )/  -4.0824829046386307D-01 /                  
      DATA EIGEN_VEC(5  ,1  )/  -4.0824829046386302D-01 /                  
      DATA EIGEN_VEC(6  ,1  )/  -4.0824829046386307D-01 /                  
      DATA EIGEN_VEC(7  ,1  )/   0.0000000000000000D+00 /                  
      DATA EIGEN_VEC(8  ,1  )/  -4.0824829046386302D-01 /                  
      DATA EIGEN_VAL(2  )/       2.3333333333333321D+00 /                  
      DATA EIGEN_VEC(1  ,2  )/   2.6726124191242445D-01 /                  
      DATA EIGEN_VEC(2  ,2  )/  -2.6726124191242440D-01 /                  
      DATA EIGEN_VEC(3  ,2  )/  -5.3452248382484879D-01 /                  
      DATA EIGEN_VEC(4  ,2  )/  -2.6726124191242440D-01 /                  
      DATA EIGEN_VEC(5  ,2  )/   2.6726124191242445D-01 /                  
      DATA EIGEN_VEC(6  ,2  )/  -2.6726124191242440D-01 /                  
      DATA EIGEN_VEC(7  ,2  )/  -5.3452248382484879D-01 /                  
      DATA EIGEN_VEC(8  ,2  )/   2.6726124191242445D-01 /                  
C ----------
C BEGIN CODE
C ----------
      IF(IM.EQ.4.OR.IM.EQ.8.OR.IM.EQ.12) THEN
        GZUD(1)=GZD(1)
        GZUD(2)=GZD(2)
      ELSE
        GZUD(1)=GZU(1)
        GZUD(2)=GZU(2)
      ENDIF
C
      CALL IXXXXX(P1  ,FMASS(IM),NHEL(1  ), 1,W1  )                       
      CALL OXXXXX(P2  ,FMASS(IM),NHEL(2  ),-1,W2  )                       
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL VXXXXX(P4  , ZERO,NHEL(4  ), 1,W4  )                            
      CALL VXXXXX(P5  , ZERO,NHEL(5  ), 1,W5  )                            
      CALL FVOXXX(W2  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W6  )               
      CALL FVOXXX(W6  ,W4  ,GG,FMASS(IM),FWIDTH(IM),W7  )                
      CALL IOVXXX(W1  ,W7  ,W5  ,GG,AMP(1  ))                              
      CALL FVIXXX(W1  ,W4  ,GG,FMASS(IM),FWIDTH(IM),W8  )                
      CALL FVOXXX(W2  ,W5  ,GG,FMASS(IM),FWIDTH(IM),W9  )                
      CALL IOVXXX(W8  ,W9  ,W3  ,GZUD,AMP(2  ))                             
      CALL JIOXXX(W1  ,W6  ,GG,ZERO,ZERO,W10 )                             
      CALL GGGXXX(W5  ,W4  ,W10 ,G,AMP(3  ))                               
      CALL IOVXXX(W8  ,W6  ,W5  ,GG,AMP(4  ))                              
      CALL FVOXXX(W2  ,W4  ,GG,FMASS(IM),FWIDTH(IM),W11 )                
      CALL FVIXXX(W1  ,W5  ,GG,FMASS(IM),FWIDTH(IM),W12 )                
      CALL IOVXXX(W12 ,W11 ,W3  ,GZUD,AMP(5  ))                             
      CALL FVIXXX(W1  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W13 )               
      CALL FVIXXX(W13 ,W4  ,GG,FMASS(IM),FWIDTH(IM),W14 )                
      CALL IOVXXX(W14 ,W2  ,W5  ,GG,AMP(6  ))                              
      CALL JIOXXX(W13 ,W2  ,GG,ZERO,ZERO,W15 )                             
      CALL GGGXXX(W5  ,W4  ,W15 ,G,AMP(7  ))                               
      CALL IOVXXX(W13 ,W11 ,W5  ,GG,AMP(8  ))                              
      ZJJ3 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ3 =ZJJ3+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
      END
+EOD
+DECK,ZJJ4
      REAL*8 FUNCTION ZJJ4(P1, P2, P3, P4, P5,NHEL,IM)
C
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/ave over colors
C for the point in phase space P1,P2,P3,P4,P5
C and helicity NHEL(1)...
C for the process: q(im) qb(im) -> z q(im) qb(im)
C with Madgraph code IM
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  8,NEIGEN=  2,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      INTEGER NHEL(NEXTERNAL),IM
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) , W13(6) , W14(6) , W15(6)       
      COMPLEX*16 W16(6) 
      REAL*8 GZUD(2)
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C  
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       5.9259259259259234D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(3  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(4  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(5  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(6  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(7  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(8  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VAL(2  )/       1.1851851851851847D+00 /                  
      DATA EIGEN_VEC(1  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(2  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(3  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(4  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(5  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(6  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(7  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(8  ,2  )/  -3.5355339059327379D-01 /                  
C ----------
C BEGIN CODE
C ----------
      IF(IM.EQ.4.OR.IM.EQ.8.OR.IM.EQ.12) THEN
        GZUD(1)=GZD(1)
        GZUD(2)=GZD(2)
      ELSE
        GZUD(1)=GZU(1)
        GZUD(2)=GZU(2)
      ENDIF
C
      CALL IXXXXX(P1  ,FMASS(IM),NHEL(1  ), 1,W1  )                       
      CALL OXXXXX(P2  ,FMASS(IM),NHEL(2  ),-1,W2  )                       
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL OXXXXX(P4  ,FMASS(IM),NHEL(4  ), 1,W4  )                       
      CALL IXXXXX(P5  ,FMASS(IM),NHEL(5  ),-1,W5  )                       
      CALL JIOXXX(W1  ,W4  ,GG,ZERO,ZERO,W6  )                             
      CALL FVIXXX(W5  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W7  )               
      CALL IOVXXX(W7  ,W2  ,W6  ,GG,AMP(1  ))                              
      CALL FVOXXX(W2  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W8  )               
      CALL JIOXXX(W1  ,W8  ,GG,ZERO,ZERO,W9  )                             
      CALL IOVXXX(W5  ,W4  ,W9  ,GG,AMP(2  ))                              
      CALL IOVXXX(W5  ,W8  ,W6  ,GG,AMP(3  ))                              
      CALL FVIXXX(W1  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W10 )               
      CALL JIOXXX(W10 ,W4  ,GG,ZERO,ZERO,W11 )                             
      CALL IOVXXX(W5  ,W2  ,W11 ,GG,AMP(4  ))                              
      CALL JIOXXX(W10 ,W2  ,GG,ZERO,ZERO,W12 )                             
      CALL IOVXXX(W5  ,W4  ,W12 ,GG,AMP(5  ))                              
      CALL FVOXXX(W4  ,W3  ,GZUD,FMASS(IM),FWIDTH(IM),W13 )               
      CALL JIOXXX(W5  ,W2  ,GG,ZERO,ZERO,W14 )                             
      CALL IOVXXX(W1  ,W13 ,W14 ,GG,AMP(6  ))                              
      CALL JIOXXX(W1  ,W2  ,GG,ZERO,ZERO,W15 )                             
      CALL FVOXXX(W4  ,W15 ,GG,FMASS(IM),FWIDTH(IM),W16 )                
      CALL IOVXXX(W5  ,W16 ,W3  ,GZUD,AMP(7  ))                             
      CALL IOVXXX(W5  ,W13 ,W15 ,GG,AMP(8  ))                              
      ZJJ4 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ4 =ZJJ4+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
C      CALL GAUGECHECK(AMP,ZTEMP,EIGEN_VEC,EIGEN_VAL,NGRAPHS,NEIGEN)
      END
+EOD
+DECK,ZJJ5
      REAL*8 FUNCTION ZJJ5(P1, P2, P3, P4, P5,NHEL,IM1,IM2)
C  
C Function generated by Madgraph
C Returns amplitude squared summed/avg over colors
C for the point in phase space p1,p2,p3,p4,...
C and helicity NHEL(1),NHEL(2),....
C  
C for process : q(im1) q(im2)  -> z q(im1) q(im2)
C with IM1 != IM2
C  
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  4,NEIGEN=  1,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)                             
      INTEGER NHEL(NEXTERNAL)                                                    
      INTEGER IM1,IM2
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) 
      REAL*8 GZUD1(2),GZUD2(2)
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C  
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       8.8888888888888884D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/  -5.0000000000000000D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/  -5.0000000000000000D-01 /                  
      DATA EIGEN_VEC(3  ,1  )/  -5.0000000000000000D-01 /                  
      DATA EIGEN_VEC(4  ,1  )/  -5.0000000000000000D-01 /                  
C ----------
C BEGIN CODE
C ----------
      IF(IM1.EQ.3.OR.IM1.EQ.7.OR.IM1.EQ.11) THEN
        GZUD1(1)=GZD(1)
        GZUD1(2)=GZD(2)
      ELSE
        GZUD1(1)=GZU(1)
        GZUD1(2)=GZU(2)
      ENDIF
      IF(IM2.EQ.3.OR.IM2.EQ.7.OR.IM2.EQ.11) THEN
        GZUD2(1)=GZD(1)
        GZUD2(2)=GZD(2)
      ELSE
        GZUD2(1)=GZU(1)
        GZUD2(2)=GZU(2)
      ENDIF
C
      CALL IXXXXX(P1  ,FMASS(IM1),NHEL(1  ), 1,W1  )                       
      CALL IXXXXX(P2  ,FMASS(IM2),NHEL(2  ), 1,W2  )                       
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL OXXXXX(P4  ,FMASS(IM1),NHEL(4  ), 1,W4  )                       
      CALL OXXXXX(P5  ,FMASS(IM2),NHEL(5  ), 1,W5  )                       
      CALL JIOXXX(W1  ,W4  ,GG,ZERO,ZERO,W6  )                             
      CALL FVOXXX(W5  ,W3  ,GZUD2,FMASS(IM2),FWIDTH(IM2),W7  )               
      CALL IOVXXX(W2  ,W7  ,W6  ,GG,AMP(1  ))                              
      CALL FVIXXX(W2  ,W3  ,GZUD2,FMASS(IM2),FWIDTH(IM2),W8  )               
      CALL IOVXXX(W8  ,W5  ,W6  ,GG,AMP(2  ))                              
      CALL FVIXXX(W1  ,W3  ,GZUD1,FMASS(IM1),FWIDTH(IM1),W9  )               
      CALL JIOXXX(W9  ,W4  ,GG,ZERO,ZERO,W10 )                             
      CALL IOVXXX(W2  ,W5  ,W10 ,GG,AMP(3  ))                              
      CALL FVOXXX(W4  ,W3  ,GZUD1,FMASS(IM1),FWIDTH(IM1),W11 )               
      CALL JIOXXX(W2  ,W5  ,GG,ZERO,ZERO,W12 )                             
      CALL IOVXXX(W1  ,W11 ,W12 ,GG,AMP(4  ))                              
      ZJJ5 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ5 =ZJJ5+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
C      CALL GAUGECHECK(AMP,ZTEMP,EIGEN_VEC,EIGEN_VAL,NGRAPHS,NEIGEN)
      END
+EOD
+DECK,ZJJ6
      REAL*8 FUNCTION ZJJ6(P1, P2, P3, P4, P5,NHEL,IM1)
C  
C Function generated by Madgraph + hand coding
C Returns amplitude squared summed/avg over colors
C for the point in phase space p1,p2,p3,p4,...
C and helicity NHEL(1),NHEL(2),....
C  
C FOR PROCESS : q(im1) q(im1)  -> z q(im1) q(im1)  
C  
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C  
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  8,NEIGEN=  2,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      INTEGER NHEL(NEXTERNAL)
      INTEGER IM1
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) , W13(6) , W14(6) , W15(6) 
      REAL*8 GZUD(2)
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C  
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       2.9629629629629617D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(3  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(4  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(5  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(6  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(7  ,1  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(8  ,1  )/   3.5355339059327379D-01 /                  
      DATA EIGEN_VAL(2  )/       5.9259259259259234D-01 /                  
      DATA EIGEN_VEC(1  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(2  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(3  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(4  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(5  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(6  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(7  ,2  )/  -3.5355339059327379D-01 /                  
      DATA EIGEN_VEC(8  ,2  )/  -3.5355339059327379D-01 /                  
C ----------
C BEGIN CODE
C ----------
      IF(IM1.EQ.3.OR.IM1.EQ.7.OR.IM1.EQ.11) THEN
        GZUD(1)=GZD(1)
        GZUD(2)=GZD(2)
      ELSE
        GZUD(1)=GZU(1)
        GZUD(2)=GZU(2)
      ENDIF
C
      CALL IXXXXX(P1  ,FMASS(IM1),NHEL(1  ), 1,W1  )                       
      CALL IXXXXX(P2  ,FMASS(IM1),NHEL(2  ), 1,W2  )                       
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL OXXXXX(P4  ,FMASS(IM1),NHEL(4  ), 1,W4  )                       
      CALL OXXXXX(P5  ,FMASS(IM1),NHEL(5  ), 1,W5  )                       
      CALL FVIXXX(W2  ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W6  )               
      CALL JIOXXX(W6  ,W4  ,GG,ZERO,ZERO,W7  )                             
      CALL IOVXXX(W1  ,W5  ,W7  ,GG,AMP(1  ))                              
      CALL JIOXXX(W1  ,W4  ,GG,ZERO,ZERO,W8  )                             
      CALL FVOXXX(W5  ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W9  )               
      CALL IOVXXX(W2  ,W9  ,W8  ,GG,AMP(2  ))                              
      CALL IOVXXX(W6  ,W5  ,W8  ,GG,AMP(3  ))                              
      CALL FVIXXX(W1  ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W10 )               
      CALL JIOXXX(W10 ,W4  ,GG,ZERO,ZERO,W11 )                             
      CALL IOVXXX(W2  ,W5  ,W11 ,GG,AMP(4  ))                              
      CALL JIOXXX(W2  ,W4  ,GG,ZERO,ZERO,W12 )                             
      CALL IOVXXX(W1  ,W9  ,W12 ,GG,AMP(5  ))                              
      CALL IOVXXX(W10 ,W5  ,W12 ,GG,AMP(6  ))                              
      CALL FVOXXX(W4  ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W13 )               
      CALL JIOXXX(W1  ,W5  ,GG,ZERO,ZERO,W14 )                             
      CALL IOVXXX(W2  ,W13 ,W14 ,GG,AMP(7  ))                              
      CALL JIOXXX(W2  ,W5  ,GG,ZERO,ZERO,W15 )                             
      CALL IOVXXX(W1  ,W13 ,W15 ,GG,AMP(8  ))                              
      ZJJ6 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ6 =ZJJ6+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
C      CALL GAUGECHECK(AMP,ZTEMP,EIGEN_VEC,EIGEN_VAL,NGRAPHS,NEIGEN)
      END
+EOD
+DECK,ZJJ7       
      REAL*8 FUNCTION ZJJ7(P1, P2, P3, P4, P5,NHEL,IM1)
C  
C FUNCTION GENERATED BY MADGRAPH
C RETURNS AMPLITUDE SQUARED SUMMED/AVG OVER COLORS
C FOR THE POINT IN PHASE SPACE P1,P2,P3,P4,...
C AND HELICITY NHEL(1),NHEL(2),....
C  
C FOR PROCESS : g u  -> z g u  
C  
      IMPLICIT NONE
C  
C CONSTANTS
C  
      INTEGER    NGRAPHS,    NEIGEN,    NEXTERNAL       
      PARAMETER (NGRAPHS=  8,NEIGEN=  2,NEXTERNAL=5)    
      REAL*8     ZERO
      PARAMETER (ZERO=0D0)
C  
C ARGUMENTS 
C  
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      INTEGER NHEL(NEXTERNAL)
      INTEGER IM1
C  
C LOCAL VARIABLES 
C  
      INTEGER I,J
      REAL*8 EIGEN_VAL(NEIGEN), EIGEN_VEC(NGRAPHS,NEIGEN)
      COMPLEX*16 ZTEMP
      COMPLEX*16 AMP(NGRAPHS)
      COMPLEX*16 W1(6)  , W2(6)  , W3(6)  , W4(6)  , W5(6)        
      COMPLEX*16 W6(6)  , W7(6)  , W8(6)  , W9(6)  , W10(6)       
      COMPLEX*16 W11(6) , W12(6) , W13(6) , W14(6) , W15(6) 
      REAL*8 GZUD(2)
C  
C GLOBAL VARIABLES
C  
+CDE,MGCOMS
C  
C COLOR DATA
C  
      DATA EIGEN_VAL(1  )/       5.8333333333333270D-01 /                  
      DATA EIGEN_VEC(1  ,1  )/   4.0824829046386285D-01 /                  
      DATA EIGEN_VEC(2  ,1  )/   0.0000000000000000D+00 /                  
      DATA EIGEN_VEC(3  ,1  )/   4.0824829046386318D-01 /                  
      DATA EIGEN_VEC(4  ,1  )/   0.0000000000000000D+00 /                  
      DATA EIGEN_VEC(5  ,1  )/   4.0824829046386285D-01 /                  
      DATA EIGEN_VEC(6  ,1  )/   4.0824829046386285D-01 /                  
      DATA EIGEN_VEC(7  ,1  )/   4.0824829046386318D-01 /                  
      DATA EIGEN_VEC(8  ,1  )/   4.0824829046386318D-01 /                  
      DATA EIGEN_VAL(2  )/       1.7499999999999991D+00 /                  
      DATA EIGEN_VEC(1  ,2  )/   2.6726124191242445D-01 /                  
      DATA EIGEN_VEC(2  ,2  )/  -5.3452248382484879D-01 /                  
      DATA EIGEN_VEC(3  ,2  )/  -2.6726124191242434D-01 /                  
      DATA EIGEN_VEC(4  ,2  )/  -5.3452248382484879D-01 /                  
      DATA EIGEN_VEC(5  ,2  )/   2.6726124191242445D-01 /                  
      DATA EIGEN_VEC(6  ,2  )/   2.6726124191242445D-01 /                  
      DATA EIGEN_VEC(7  ,2  )/  -2.6726124191242434D-01 /                  
      DATA EIGEN_VEC(8  ,2  )/  -2.6726124191242434D-01 /                  
C ----------
C BEGIN CODE
C ----------
      IF(IM1.EQ.3.OR.IM1.EQ.7.OR.IM1.EQ.11) THEN
        GZUD(1)=GZD(1)
        GZUD(2)=GZD(2)
      ELSE
        GZUD(1)=GZU(1)
        GZUD(2)=GZU(2)
      ENDIF
C
      CALL VXXXXX(P1  , ZERO,NHEL(1  ),-1,W1  )                            
      CALL IXXXXX(P2  ,FMASS(IM1),NHEL(2  ), 1,W2  )                       
      CALL VXXXXX(P3  ,ZMASS,NHEL(3  ), 1,W3  )                            
      CALL VXXXXX(P4  , ZERO,NHEL(4  ), 1,W4  )                            
      CALL OXXXXX(P5  ,FMASS(IM1),NHEL(5  ), 1,W5  )                       
      CALL FVIXXX(W2  ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W6  )               
      CALL FVIXXX(W6  ,W4  ,GG,FMASS(IM1),FWIDTH(IM1),W7  )                
      CALL IOVXXX(W7  ,W5  ,W1  ,GG,AMP(1  ))                              
      CALL JGGXXX(W4  ,W1  ,G,W8  )                                        
      CALL FVOXXX(W5  ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W9  )               
      CALL IOVXXX(W2  ,W9  ,W8  ,GG,AMP(2  ))                              
      CALL FVIXXX(W6  ,W1  ,GG,FMASS(IM1),FWIDTH(IM1),W10 )                
      CALL IOVXXX(W10 ,W5  ,W4  ,GG,AMP(3  ))                              
      CALL IOVXXX(W6  ,W5  ,W8  ,GG,AMP(4  ))                              
      CALL FVIXXX(W2  ,W4  ,GG,FMASS(IM1),FWIDTH(IM1),W11 )                
      CALL FVOXXX(W5  ,W1  ,GG,FMASS(IM1),FWIDTH(IM1),W12 )                
      CALL IOVXXX(W11 ,W12 ,W3  ,GZUD,AMP(5  ))                             
      CALL IOVXXX(W11 ,W9  ,W1  ,GG,AMP(6  ))                              
      CALL FVIXXX(W2  ,W1  ,GG,FMASS(IM1),FWIDTH(IM1),W13 )                
      CALL FVIXXX(W13 ,W4  ,GG,FMASS(IM1),FWIDTH(IM1),W14 )                
      CALL IOVXXX(W14 ,W5  ,W3  ,GZUD,AMP(7  ))                             
      CALL FVIXXX(W13 ,W3  ,GZUD,FMASS(IM1),FWIDTH(IM1),W15 )               
      CALL IOVXXX(W15 ,W5  ,W4  ,GG,AMP(8  ))                              
      ZJJ7 = 0.D0 
      DO I = 1, NEIGEN
          ZTEMP = (0.D0,0.D0)
          DO J = 1, NGRAPHS
              ZTEMP = ZTEMP + EIGEN_VEC(J,I)*AMP(J)
          ENDDO
          ZJJ7 =ZJJ7+ZTEMP*EIGEN_VAL(I)*CONJG(ZTEMP) 
      ENDDO
C      CALL GAUGECHECK(AMP,ZTEMP,EIGEN_VEC,EIGEN_VAL,NGRAPHS,NEIGEN)
      END
+EOD
+DECK,ZJJ
      SUBROUTINE ZJJ
C-----------------------------------------------------------------------
C
C          Use MadGraph/Helas to generate Z + 2 jets after setup by
C          ZJJ0 using cross section routines from MadGraph:
C          ZJJ1:   q1 q1b -> Z q2 q2b, q1 != q2
C          ZJJ2:   g  g   -> Z q2 q2b
C          ZJJ3:   q1 q1b -> Z g  g
C          ZJJ4:   q1 q1b -> Z q1 q1b
C          ZJJ5:   q1 q2  -> Z q1 q2
C          ZJJ6:   q1 q1  -> Z q1 q1
C          ZJJ7:   g  q   -> Z g  q
C
C          Note: The Z is always jet1, but the other two jets are 
C          symmetrized so a symmetry factor of 1/2 is needed for every
C          subprocess. This is included by MadGraph for identical
C          particles!
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,CONST
+CDE,Q1Q2
+CDE,ITAPES
+CDE,JETLIM
+CDE,JETPAR
+CDE,JETSET
+CDE,PARTCL
+CDE,PINITS
+CDE,PJETS
+CDE,PRIMAR
+CDE,SSTYPE
+CDE,TOTALS
+CDE,MGKIN
+CDE,MGCOMS
+CDE,MGSIGS
C
      INTEGER IMAD(6)
      REAL*8 P1(0:3),P2(0:3),P3(0:3),P4(0:3),P5(0:3)
      EQUIVALENCE (P1(0),PJETS8(0,1))
      EQUIVALENCE (P2(0),PJETS8(0,2))
      EQUIVALENCE (P3(0),PJETS8(0,3))
      EQUIVALENCE (P4(0),PJETS8(0,4))
      EQUIVALENCE (P5(0),PJETS8(0,5))
      REAL QFCN,XX,QQ,RND,RANF,SIG,FJAC,STRUC,ALQCD
      REAL*8 SZJJ1,WT8,TERM,SUM,SZJJ2,SZJJ3,SZJJ4,SIG8,SIGI8
      REAL*8 SZJJ5,SZJJ6,SZJJ7
      INTEGER IQ,IH,ISIG8,IFL1,IFL2,IM1,IM2,IQ1,IQ2,NTRY,I,II,K,IWT8
C
C          Map Jettype/2 to MadGraph
      DATA IMAD/3,4,8,7,12,11/
C
C          Parton distributions
      QFCN(XX,IQ,IH)=STRUC(XX,QQ,IQ,IDIN(IH))/XX
C
C          Begin
C
      NTRY=0
      NJSET=0
      NPTCL=0
C
C          Select process
C
      RND=RANF()
      ISIG8=0
      SIG=0
      DO 10 I=1,NSIG8
        SIG=SIG+WTSUM8(I)/NWT8(I)
10    CONTINUE
      SUM=0
      DO 20 I=1,NSIG8
        II=ISORT8(NSIG8+1-I)
        SUM=SUM+WTSUM8(II)/NWT8(II)
        IF(SUM.GE.RND*SIG) THEN
          ISIG8=II
          GO TO 100
        ENDIF
20    CONTINUE
      WRITE(ITLIS,*) 'ERROR IN ZJJ: NO MODE FOUND'
      STOP99
C
100   CONTINUE
      SIG8=0
      FJAC=UNITS/SCM
      NTRY=NTRY+1
      IF(NTRY.GT.NTRIES) THEN
        WRITE(ITLIS,*) 'ERROR IN ZJJ: NTRY = ',NTRY
        WRITE(ITLIS,*) 'PROCESS WAS ',(IDENT8(K,ISIG8),K=1,5)
        SIGI8=WTSUM8(ISIG8)/NWT8(ISIG8)
        WRITE(ITLIS,*) 'PROCESS SIGMA/MAX = ',SIGI8,WTMAX8(ISIG8)
        WRITE(ITLIS,*) 'CHECK YOUR LIMITS OR INCREASE NTRIES'
        STOP99
      ENDIF
C
C          Cases 1,4: q1 q1b -> z q2 q2b
C
      IF(IFUNC8(ISIG8).EQ.1.OR.IFUNC8(ISIG8).EQ.4) THEN
        AMJET8(3)=ZMASS
        IFL1=IABS(IDENT8(1,ISIG8))
        IM1=IMAD(IFL1)
        IQ1=2*IFL1
        IQ2=IQ1+1
        AMJET8(1)=FMASS(IM1)
        AMJET8(2)=FMASS(IM1)
        IFL2=IABS(IDENT8(4,ISIG8))
        IM2=IMAD(IFL2)
        AMJET8(4)=FMASS(IM2)
        AMJET8(5)=FMASS(IM2)
        DO 210 I=1,NTRIES
          IWT8=I
          CALL MULJET(WT8)
          IF(WT8.GT.0) GO TO 220
210     CONTINUE
        WRITE(ITLIS,*) 'ERROR IN ZJJ: NO PHASE SPACE POINT IN ',
     $  NTRIES,' TRIES'
        STOP99
220     NWTTOT=NWTTOT+IWT8-1
        NWT8(ISIG8)=NWT8(ISIG8)+IWT8-1
        X1=(P1(0)+P1(3))/ECM
        X2=(P2(0)-P2(3))/ECM
        QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $  P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
C
C          Subcases
C
        IF(IDENT8(1,ISIG8).GT.0.AND.IDENT8(4,ISIG8).GT.0) THEN
          IF(IFUNC8(ISIG8).EQ.1) THEN
            TERM=SZJJ1(P1,P2,P3,P4,P5,IM1,IM2)
          ELSE
            TERM=SZJJ4(P1,P2,P3,P4,P5,IM1)
          ENDIF
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(1,ISIG8).GT.0.AND.IDENT8(4,ISIG8).LT.0) THEN
          IF(IFUNC8(ISIG8).EQ.1) THEN
            TERM=SZJJ1(P1,P2,P3,P5,P4,IM1,IM2)
          ELSE
            TERM=SZJJ4(P1,P2,P3,P5,P4,IM1)
          ENDIF
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(1,ISIG8).LT.0.AND.IDENT8(4,ISIG8).GT.0) THEN
          IF(IFUNC8(ISIG8).EQ.1) THEN
            TERM=SZJJ1(P1,P2,P3,P4,P5,IM1,IM2)
          ELSE
            TERM=SZJJ4(P1,P2,P3,P4,P5,IM1)
          ENDIF
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
        ELSEIF(IDENT8(1,ISIG8).LT.0.AND.IDENT8(4,ISIG8).LT.0) THEN
          IF(IFUNC8(ISIG8).EQ.1) THEN
            TERM=SZJJ1(P1,P2,P3,P5,P4,IM1,IM2)
          ELSE
            TERM=SZJJ4(P1,P2,P3,P5,P4,IM1)
          ENDIF
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
        ELSE
          WRITE(ITLIS,*) 'ERROR IN ZJJ...INVALID FLAVOR FOR ZJJ1'
          STOP99
        ENDIF
        SIG8=0.5*TERM
        GO TO 900
      ENDIF
C
C          Case 2: g g -> z q2 q2b
C
      IF(IFUNC8(ISIG8).EQ.2) THEN
        AMJET8(3)=ZMASS
        IFL1=IABS(IDENT8(1,ISIG8))
        AMJET8(1)=0
        AMJET8(2)=0
        IFL2=IABS(IDENT8(4,ISIG8))
        IM2=IMAD(IFL2)
        AMJET8(4)=FMASS(IM2)
        AMJET8(5)=FMASS(IM2)
        DO 310 I=1,NTRIES
          IWT8=I
          CALL MULJET(WT8)
          IF(WT8.GT.0) GO TO 320
310     CONTINUE
        WRITE(ITLIS,*) 'ERROR IN ZJJ: NO PHASE SPACE POINT IN ',
     $  NTRIES,' TRIES'
        STOP99
320     NWTTOT=NWTTOT+IWT8-1
        NWT8(ISIG8)=NWT8(ISIG8)+IWT8-1
        X1=(P1(0)+P1(3))/ECM
        X2=(P2(0)-P2(3))/ECM
        QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $  P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
C
C          Subcases
C
        IF(IDENT8(4,ISIG8).GT.0) THEN
          TERM=SZJJ2(P1,P2,P3,P4,P5,IM2)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,1,1)*QFCN(X2,1,2)
        ELSEIF(IDENT8(4,ISIG8).LT.0) THEN
          TERM=SZJJ2(P1,P2,P3,P5,P4,IM2)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,1,1)*QFCN(X2,1,2)
        ELSE
          WRITE(ITLIS,*) 'ERROR IN ZJJ...INVALID FLAVOR FOR ZJJ2'
          STOP99
        ENDIF
        SIG8=0.5*TERM
        GO TO 900
      ENDIF
C
C          Case 3: q1 q1b -> z g g
C
      IF(IFUNC8(ISIG8).EQ.3) THEN
        AMJET8(3)=ZMASS
        IFL1=IABS(IDENT8(1,ISIG8))
        IQ1=2*IFL1
        IQ2=IQ1+1
        IM1=IMAD(IFL1)
        AMJET8(1)=FMASS(IM1)
        AMJET8(2)=FMASS(IM1)
        IFL2=9
        AMJET8(4)=0
        AMJET8(5)=0
        DO 410 I=1,NTRIES
          IWT8=I
          CALL MULJET(WT8)
          IF(WT8.GT.0) GO TO 420
410     CONTINUE
        WRITE(ITLIS,*) 'ERROR IN ZJJ: NO PHASE SPACE POINT IN ',
     $  NTRIES,' TRIES'
        STOP99
420     NWTTOT=NWTTOT+IWT8-1
        NWT8(ISIG8)=NWT8(ISIG8)+IWT8-1
        X1=(P1(0)+P1(3))/ECM
        X2=(P2(0)-P2(3))/ECM
        QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $  P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
C
C          Subcases
C
        IF(IDENT8(1,ISIG8).GT.0) THEN
          TERM=SZJJ3(P1,P2,P3,P4,P5,IM1)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(1,ISIG8).LT.0) THEN
          TERM=SZJJ3(P2,P1,P3,P4,P5,IM1)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ2,1)*QFCN(X2,IQ1,2)
        ELSE
          WRITE(ITLIS,*) 'ERROR IN ZJJ...INVALID FLAVOR FOR ZJJ3'
          STOP99
        ENDIF
        SIG8=TERM
        GO TO 900
      ENDIF
C
C          Cases 5,6: q1 q2 -> z q1 q2
C
      IF(IFUNC8(ISIG8).EQ.5.OR.IFUNC8(ISIG8).EQ.6) THEN
        IFL1=IABS(IDENT8(1,ISIG8))
        IM1=IMAD(IFL1)
        IFL2=IABS(IDENT8(2,ISIG8))
        IM2=IMAD(IFL2)
        IQ1=2*IFL1
        IQ2=2*IFL2
        IF(IDENT8(1,ISIG8).LT.0) IQ1=IQ1+1
        IF(IDENT8(2,ISIG8).LT.0) IQ2=IQ2+1
        AMJET8(1)=FMASS(IM1)
        AMJET8(2)=FMASS(IM2)
        AMJET8(3)=ZMASS
        AMJET8(4)=FMASS(IM1)
        AMJET8(5)=FMASS(IM2)
        DO 510 I=1,NTRIES
          IWT8=I
          CALL MULJET(WT8)
          IF(WT8.GT.0) GO TO 520
510     CONTINUE
        WRITE(ITLIS,*) 'ERROR IN ZJJ: NO PHASE SPACE POINT IN ',
     $  NTRIES,' TRIES'
        STOP99
520     NWTTOT=NWTTOT+IWT8-1
        NWT8(ISIG8)=NWT8(ISIG8)+IWT8-1
        X1=(P1(0)+P1(3))/ECM
        X2=(P2(0)-P2(3))/ECM
        QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $  P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
C
C          Subcases
C
        IF(IDENT8(1,ISIG8).EQ.IDENT8(4,ISIG8)) THEN
          IF(IFUNC8(ISIG8).EQ.5) THEN
            TERM=SZJJ5(P1,P2,P3,P4,P5,IM1,IM2)
          ELSE
            TERM=SZJJ6(P1,P2,P3,P4,P5,IM1)
          ENDIF
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(1,ISIG8).EQ.IDENT8(5,ISIG8)) THEN
          TERM=SZJJ5(P1,P2,P3,P5,P4,IM1,IM2)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSE
          WRITE(ITLIS,*) 'ERROR IN ZJJ...INVALID FLAVOR FOR ZJJ1'
          STOP99
        ENDIF
        SIG8=TERM
        IF(IFL1.NE.IFL2) SIG8=0.5*SIG8
        GO TO 900
      ENDIF
C
C          Case 7: g q -> z g q
C
      IF(IFUNC8(ISIG8).EQ.7) THEN
        IF(IDENT8(1,ISIG8).EQ.9) THEN
          IFL1=IABS(IDENT8(2,ISIG8))
          IM1=IMAD(IFL1)
          AMJET8(1)=0
          AMJET8(2)=FMASS(IM1)
          IQ1=1
          IQ2=2*IFL1
          IF(IDENT8(2,ISIG8).LT.0) IQ2=IQ2+1
        ELSE
          IFL1=IABS(IDENT8(1,ISIG8))
          IM1=IMAD(IFL1)
          AMJET8(1)=FMASS(IM1)
          AMJET8(2)=0
          IQ2=1
          IQ1=2*IFL1
          IF(IDENT8(1,ISIG8).LT.0) IQ1=IQ1+1
        ENDIF
        AMJET8(3)=ZMASS
        IF(IDENT8(4,ISIG8).EQ.9) THEN
          AMJET8(4)=0
          AMJET8(5)=FMASS(IM1)
        ELSE
          AMJET8(4)=FMASS(IM1)
          AMJET8(5)=0
        ENDIF
        DO 610 I=1,NTRIES
          IWT8=I
          CALL MULJET(WT8)
          IF(WT8.GT.0) GO TO 620
610     CONTINUE
        WRITE(ITLIS,*) 'ERROR IN ZJJ: NO PHASE SPACE POINT IN ',
     $  NTRIES,' TRIES'
        STOP99
620     NWTTOT=NWTTOT+IWT8-1
        NWT8(ISIG8)=NWT8(ISIG8)+IWT8-1
        X1=(P1(0)+P1(3))/ECM
        X2=(P2(0)-P2(3))/ECM
        QQ=P3(1)**2+P3(2)**2+P4(1)**2+P4(2)**2+P5(1)**2+
     $  P5(2)**2+AMJET8(3)**2+AMJET8(4)**2+AMJET8(5)**2
C
C          Subcases
C
        IF(IDENT8(1,ISIG8).EQ.9.AND.IDENT8(4,ISIG8).EQ.9) THEN
          TERM=SZJJ7(P1,P2,P3,P4,P5,IM1)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(2,ISIG8).EQ.9.AND.IDENT8(4,ISIG8).EQ.9) THEN
          TERM=SZJJ7(P2,P1,P3,P4,P5,IM1)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(1,ISIG8).EQ.9.AND.IDENT8(5,ISIG8).EQ.9) THEN
          TERM=SZJJ7(P1,P2,P3,P5,P4,IM1)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSEIF(IDENT8(2,ISIG8).EQ.9.AND.IDENT8(5,ISIG8).EQ.9) THEN
          TERM=SZJJ7(P2,P1,P3,P5,P4,IM1)
          TERM=TERM*(4*PI*ALQCD(REAL(QQ)))**2
          TERM=TERM*WT8*FJAC*QFCN(X1,IQ1,1)*QFCN(X2,IQ2,2)
        ELSE
          WRITE(ITLIS,*) 'ERROR IN ZJJ...INVALID FLAVOR FOR ZJJ1'
          STOP99
        ENDIF
        SIG8=0.5*TERM
        GO TO 900
      ENDIF
C
C          Increment totals and test
C
900   WTTOT8=WTTOT8+SIG8
      NWTTOT=NWTTOT+1
      WTSUM8(ISIG8)=WTSUM8(ISIG8)+SIG8
      WTMAX8(ISIG8)=MAX(WTMAX8(ISIG8),SIG8)
      NWT8(ISIG8)=NWT8(ISIG8)+1
      IF(SIG8.LT.RANF()*WTMAX8(ISIG8)) GO TO 100
C
C          Good event
C
      DO 910 I=1,3
        DO 911 K=1,3
          PJETS(K,I)=PJETS8(K,I+2)
911     CONTINUE
        PJETS(4,I)=PJETS8(0,I+2)
        PJETS(5,I)=AMJET8(I+2)
        IDJETS(I)=IDENT8(I+2,ISIG8)
910   CONTINUE
      DO 920 I=1,2
        DO 921 K=1,3
          PINITS(K,I)=PJETS8(K,I)
921     CONTINUE
        PINITS(4,I)=PJETS8(0,I)
        PINITS(5,I)=AMJET8(I)
        IDINIT(I)=IDENT8(I,ISIG8)
920   CONTINUE
C
      QSQ=QQ
      SHAT=(P1(0)+P2(0))**2-(P1(3)+P2(3))**2
      PBEAM(1)=(1.-X1)*HALFE
      PBEAM(2)=(1.-X2)*HALFE
C
C          Set /TOTALS/
C
      NKINPT=NWTTOT
      SUMWT=WTTOT8
C
      RETURN
      END
+EOD
+DECK,ZZALL.
      FUNCTION ZZALL(T,U,T1,U1,T3,U3,P1,P2)
C          DECAY DISTRIBUTION FOR Z0 Z0 PAIRS FROM SCHOONSCHIP(1980).
C          INCLUDES TT, TU, AND UU TERMS.
+CDE,ITAPES
+CDE,WWPAR.
      DIMENSION P1(4),P2(4)
+SELF,IF=DOUBLE.
      DOUBLE PRECISION ZZALL
      DOUBLE PRECISION T,U,T1,U1,T3,U3,P1,P2
      DOUBLE PRECISION CVAVA,DVAVA,CVVVV,CVVAA,TT,TU,UU,EPF
+SELF.
      TTUU=(T*U)**2
      CVAVA=CV*CA*(CV1*CA3+CA1*CV3)/TTUU
      DVAVA=CV*CA*(CV1*CA3-CA1*CV3)/TTUU
      CVVVV=(CV**2+CA**2)*CV1*CV3/TTUU
      CVVAA=(CV**2+CA**2)*CA1*CA3/TTUU
      TT=T**2
      TU=T*U
      UU=U**2
      ZZALL=
     1 +CVAVA*T*U*(-16.*ZM2*T1*U1*T3+16.*ZM2*T1*U1*U3+16.*ZM2*T1*T3*U3-
     1 16.*ZM2*U1*T3*U3-16.*ZM2**2*T1*S13-8.*ZM2**2*T1**2+16.*ZM2**2*U1
     1 *S13+8.*ZM2**2*U1**2+16.*ZM2**2*T3*S13+8.*ZM2**2*T3**2-16.*ZM2**
     1 2*U3*S13-8.*ZM2**2*U3**2)
     1 +CVAVA*T*U**2*(16.*ZM2*T1*S13-16.*ZM2*T3*S13)
     1 +CVAVA*T**2*(16.*ZM2*U1*U3**2-16.*ZM2*U1**2*U3-8.*ZM2**2*U1**2+8
     1 .*ZM2**2*U3**2)
     1 +CVAVA*T**2*U*(-16.*ZM2*U1*S13+16.*ZM2*U3*S13)
     1 +CVAVA*U**2*(-16.*ZM2*T1*T3**2+16.*ZM2*T1**2*T3+8.*ZM2**2*T1**2-
     1 8.*ZM2**2*T3**2)
      ZZALL=ZZALL
     1 +DVAVA*T*U*(-16.*ZM2*T1*U1*T3+16.*ZM2*T1*U1*U3-16.*ZM2*T1*T3*U3+
     1 16.*ZM2*U1*T3*U3-32.*ZM2**2*T1*T3-16.*ZM2**2*T1*S13-8.*ZM2**2*T1
     1 **2+32.*ZM2**2*U1*U3+16.*ZM2**2*U1*S13+8.*ZM2**2*U1**2-16.*ZM2**
     1 2*T3*S13-8.*ZM2**2*T3**2+16.*ZM2**2*U3*S13+8.*ZM2**2*U3**2-32.*Z
     1 M2**3*T1+32.*ZM2**3*U1-32.*ZM2**3*T3+32.*ZM2**3*U3)
     1 +DVAVA*T*U**2*(16.*ZM2*T1*S13+16.*ZM2*T3*S13-16.*ZM2**2*U1-16.*Z
     1 M2**2*U3-32.*ZM2**3)
     1 +DVAVA*T*U**3*(8.*ZM2**2)
      ZZALL=ZZALL
     1 +DVAVA*T**2*(-16.*ZM2*U1*U3**2-16.*ZM2*U1**2*U3-32.*ZM2**2*U1*U3
     1 -8.*ZM2**2*U1**2-8.*ZM2**2*U3**2-16.*ZM2**3*U1-16.*ZM2**3*U3-8.*
     1 ZM2**4)
     1 +DVAVA*T**2*U*(-16.*ZM2*U1*S13-16.*ZM2*U3*S13+16.*ZM2**2*T1+16.*
     1 ZM2**2*T3+32.*ZM2**3)
     1 +DVAVA*T**3*U*(-8.*ZM2**2)
     1 +DVAVA*U**2*(16.*ZM2*T1*T3**2+16.*ZM2*T1**2*T3+32.*ZM2**2*T1*T3+
     1 8.*ZM2**2*T1**2+8.*ZM2**2*T3**2+16.*ZM2**3*T1+16.*ZM2**3*T3+8.*Z
     1 M2**4)
      ZZALL=ZZALL
     1 +CVVVV*T*U*(-16.*ZM2*T1*U1*T3-16.*ZM2*T1*U1*U3-16.*ZM2*T1*T3*U3-
     1 16.*ZM2*U1*T3*U3+16.*ZM2**2*T1*S13+8.*ZM2**2*T1**2+16.*ZM2**2*U1
     1 *S13+8.*ZM2**2*U1**2+16.*ZM2**2*T3*S13+8.*ZM2**2*T3**2+16.*ZM2**
     1 2*U3*S13+8.*ZM2**2*U3**2+16.*ZM2**2*S13**2+16.*ZM2**3*T1+16.*ZM2
     1 **3*U1+16.*ZM2**3*T3+16.*ZM2**3*U3+32.*ZM2**3*S13+32.*ZM2**4-32.
     1 *T1*U1*T3*U3)
     1 +CVVVV*T*U**2*(-16.*ZM2*T1*S13-16.*ZM2*T3*S13-8.*ZM2**2*U1-8.*ZM
     1 2**2*U3-16.*ZM2**2*S13-16.*ZM2**3-32.*T1*T3*S13)
      ZZALL=ZZALL
     1 +CVVVV*T*U**3*(4.*ZM2**2)
     1 +CVVVV*T**2*(-16.*ZM2*U1*U3**2-16.*ZM2*U1**2*U3-16.*ZM2**2*U1*U3
     1 -8.*ZM2**2*U1**2-8.*ZM2**2*U3**2-8.*ZM2**3*U1-8.*ZM2**3*U3-4.*ZM
     1 2**4-16.*U1**2*U3**2)
     1 +CVVVV*T**2*U*(-16.*ZM2*U1*S13-16.*ZM2*U3*S13-8.*ZM2**2*T1-8.*ZM
     1 2**2*T3-16.*ZM2**2*S13-16.*ZM2**3-32.*U1*U3*S13)
     1 +CVVVV*T**2*U**2*(-16.*S13**2)
     1 +CVVVV*T**3*U*(4.*ZM2**2)
      ZZALL=ZZALL
     1 +CVVVV*U**2*(-16.*ZM2*T1*T3**2-16.*ZM2*T1**2*T3-16.*ZM2**2*T1*T3
     1 -8.*ZM2**2*T1**2-8.*ZM2**2*T3**2-8.*ZM2**3*T1-8.*ZM2**3*T3-4.*ZM
     1 2**4-16.*T1**2*T3**2)
     1 +CVVAA*T*U*(-16.*ZM2**3*T1-16.*ZM2**3*U1-16.*ZM2**3*T3-16.*ZM2**
     1 3*U3-32.*ZM2**3*S13-32.*ZM2**4)
     1 +CVVAA*T*U**2*(8.*ZM2**2*U1+8.*ZM2**2*U3+16.*ZM2**2*S13+16.*ZM2*
     1 *3)
     1 +CVVAA*T*U**3*(-4.*ZM2**2)
      ZZALL=ZZALL
     1 +CVVAA*T**2*(16.*ZM2**2*U1*U3+8.*ZM2**3*U1+8.*ZM2**3*U3+4.*ZM2**
     1 4)
     1 +CVVAA*T**2*U*(8.*ZM2**2*T1+8.*ZM2**2*T3+16.*ZM2**2*S13+16.*ZM2*
     1 *3)
     1 +CVVAA*T**3*U*(-4.*ZM2**2)
     1 +CVVAA*U**2*(16.*ZM2**2*T1*T3+8.*ZM2**3*T1+8.*ZM2**3*T3+4.*ZM2**
     1 4)
C          THE EPF TERMS FROM SCHOONSCHIP DID NOT CONTAIN CVAVA, ETC.,
C          BUT DID CONTAIN AN EXPLICIT T*U. THIS WAS REPLACED BY HAND
C          BY 1./TU.
      ZZALL=ZZALL
     1 +EPF(P1,P2,P3,Q3)/TU*(-32.*CV*CA*CV1*CV3*T1*S13)
     1 +EPF(P1,P2,Q1,Q3)/TU*(-32.*ZM2*CV*CA*CV1*CV3*T1-32.*CV*CA*CV1*C
     1 V3*T1*T3-32.*CV*CA*CV1*CV3*T1*U3)
     1 +EPF(P1,P3,Q1,Q3)/TU*(32.*CV*CA*CV1*CV3*T1*T3)
     1 +EPF(P2,P3,Q1,Q3)/TU*(-32.*CV*CA*CV1*CV3*T1*U3)+0.
      ZZALL=2.*ZZALL
      RETURN
      END
+EOD
+DECK,ZZSTAR
      FUNCTION ZZSTAR(HM,IW)
C
C          Generate W* or Z* mass for H -> W W* or H -> Z Z* decay,
C          including the W or Z width in the propagator.
C          Ref: Marciano and Sirlin, Phys. Rev. D30, 248 (1984).
C
C          HM = generated Higgs mass, i.e. QMW**2
C          IW = 2   3   4
C               W+  W-  Z0
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ITAPES
+CDE,HCON
+CDE,WCON
+CDE,PRIMAR
C
      REAL    HM,WM,WG,ZZSTAR,EPS,FBAR,R1,R2,RANF,X,F,DELTA,R,XM1
      INTEGER I,IW
C          WM and WG are the W or Z mass and width
      WM=WMASS(IW)
      WG=WGAM(IW)
      EPS=WM/HM
      DELTA=WM*WG/HM**2
C          FBAR is maximum of F below
      FBAR=12.*EPS**2*(1.-EPS)**2*(1.-EPS**2)
      R1=(2.*EPS-1.)/DELTA
      R2=EPS**2/DELTA
      R1=ATAN(R1)
      R2=ATAN(R2)
C          Generate Breit-Wigner and test remainder F against FBAR
      DO 100 I=1,NTRIES
        R=R1-RANF()*(R1-R2)
        XM1=DELTA*TAN(R)
        X=XM1+1.
        F=SQRT((X-2.*EPS)*(X+2.*EPS))
     $  *(X**2-12.*EPS**2*X+8.*EPS**2+12.*EPS**4)
        XM1=SQRT(XM1)
        ZZSTAR=HM*SQRT((EPS-XM1)*(EPS+XM1))
        IF(F.GT.FBAR*RANF()) RETURN
100   CONTINUE
C
      WRITE(ITLIS,9999) NTRIES
9999  FORMAT(' ERROR IN ZZSTAR ... NO MASS FOUND')
      STOP 99
      END
+PATCH,ISASSRUN.
+EOD
+DECK,SSID
      CHARACTER*5 FUNCTION SSID(ID)
C-----------------------------------------------------------------------
C
C     Return character name for ID, assuming the default IDENT codes
C     are used in /SSTYPE/.
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
      CHARACTER*5 LABEL(-120:120)
      SAVE LABEL
      INTEGER ID,J
C
      DATA LABEL(0)/'     '/
C
      DATA (LABEL(J),J=1,10)
     $/'UP   ','DN   ','ST   ','CH   ','BT   ','TP   '
     $,'ERROR','ERROR','GL   ','GM   '/
      DATA (LABEL(J),J=-1,-10,-1)
     $/'UB   ','DB   ','SB   ','CB   ','BB   ','TB   '
     $,'ERROR','ERROR','ERROR','ERROR'/
C
      DATA (LABEL(J),J=11,20)
     $/'NUE  ','E-   ','NUM  ','MU-  ','NUT  ','TAU- '
     $,'ERROR','ERROR','ERROR','ERROR'/
      DATA (LABEL(J),J=-11,-20,-1)
     $/'ANUE ','E+   ','ANUM ','MU+  ','ANUT ','TAU+ '
     $,'ERROR','ERROR','ERROR','ERROR'/
C
      DATA (LABEL(J),J=21,30)
     $/'UPL  ','DNL  ','STL  ','CHL  ','BT1  ','TP1  '
     $,'ERROR','ERROR','GLSS ','Z1SS '/
      DATA (LABEL(J),J=-21,-30,-1)
     $/'UBL  ','DBL  ','SBL  ','CBL  ','BB1  ','TB1  '
     $,'ERROR','ERROR','ERROR','ERROR'/
C
      DATA (LABEL(J),J=31,40)
     $/'NUEL ','EL-  ','NUML ','MUL- ','NUTL ','TAU1-'
     $,'ERROR','ERROR','W1SS+','Z2SS '/
      DATA (LABEL(J),J=-31,-40,-1)
     $/'ANUEL','EL+  ','ANUML','MUL+ ','ANUTL','TAU1+'
     $,'ERROR','ERROR','W1SS-','ERROR'/
C
      DATA (LABEL(J),J=41,50)
     $/'UPR  ','DNR  ','STR  ','CHR  ','BT2  ','TP2  '
     $,'ERROR','ERROR','W2SS+','Z3SS '/
      DATA (LABEL(J),J=-41,-50,-1)
     $/'UBR  ','DBR  ','SBR  ','CBR  ','BB2  ','TB2  '
     $,'ERROR','ERROR','W2SS-','ERROR'/
C
      DATA (LABEL(J),J=51,60)
     $/'NUER ','ER-  ','NUMR ','MUR- ','NUTR ','TAU2-'
     $,'ERROR','ERROR','ERROR','Z4SS '/
      DATA (LABEL(J),J=-51,-60,-1)
     $/'ANUEL','ER+  ','ANUMR','MUR+ ','ANUTR','TAU2+'
     $,'ERROR','ERROR','ERROR','ERROR'/
C
      DATA (LABEL(J),J=82,86)
     $/'HL0  ','HH0  ','HA0  ','ERROR','H+   '/
      DATA LABEL(-86)/'H-   '/
C
      DATA LABEL(80)/'W+   '/,LABEL(-80)/'W-   '/,LABEL(90)/'Z0   '/
      DATA LABEL(91)/'GVSS '/
      DATA LABEL(110)/'PI0  '/
      DATA LABEL(120)/'PI+  '/,LABEL(-120)/'PI-  '/
C
      IF(IABS(ID).GT.120) THEN
        WRITE(LOUT,*) 'SSID: ID = ',ID
        STOP99
      ENDIF
      SSID=LABEL(ID)
      RETURN
      END
+EOD
+DECK,SSPRT
      SUBROUTINE SSPRT(ID)
C-----------------------------------------------------------------------
C
C     Print decay modes for ID. Note these need not be contiguous,
C     so the loop is over all modes in /SSMODE/.
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
C
      INTEGER ID,I,K,NOUT
      CHARACTER*5 SSID,LBLIN,LBLOUT(4)
C
      NOUT=0
      DO 100 I=1,NSSMOD
        IF(ISSMOD(I).NE.ID) GO TO 100
        NOUT=NOUT+1
        LBLIN=SSID(ISSMOD(I))
        DO 110 K=1,4
110     LBLOUT(K)=SSID(JSSMOD(K,I))
        WRITE(LOUT,1000) LBLIN,(LBLOUT(K),K=1,4),GSSMOD(I),BSSMOD(I)
1000    FORMAT(1X,A5,'  -->  ',4(A5,2X),2E15.5)
100   CONTINUE
C
      IF(NOUT.GT.0) WRITE(LOUT,*) ' '
C
      RETURN
      END
+EOD
+DECK,SSRUN
      PROGRAM SSRUN
C-----------------------------------------------------------------------
C
C     Main program for ISASUSY
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
+CDE,SSMODE
+CDE,SSTYPE
+CDE,ISAPW
C
      REAL XMG,XMU,XMHA,XTANB,XMQ1,XMDR,XMUR,XML1,XMER
     $,XMQ2,XMSR,XMCR,XML2,XMMR,XMQ3,XMBR,XMTR,XML3,XMLR
     $,XAT,XAB,XAL,XM1,XM2,XMT
      REAL QSUSY,ASMB,MBMB,ASMT,MTMT,SUALFS,PI,GG
      REAL AMASS
      DOUBLE PRECISION SSMQCD
      INTEGER J,K
      CHARACTER*60 FNAME
      CHARACTER*5 LBLIN,LBLOUT(5),SSID
      CHARACTER*40 V,VISAJE
      INTEGER NOUT,IALLOW,IITEST
      PARAMETER (NOUT=33)
      INTEGER IDOUT(NOUT)
      CHARACTER*30 ISAPW2
      SAVE ISAPW2
C
      DATA IDOUT/
     $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR,
     $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL,
     $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,
     $ISHL,ISHH,ISHA,ISHC/
C          ISAPW2 is used to check whether ALDATA is loaded
      DATA ISAPW2/'ALDATA REQUIRED BY FORTRAN G,H'/
C
C          Initialize
C
      IF(ISAPW1.NE.ISAPW2) THEN
        PRINT*, ' ERROR: BLOCK DATA ALDATA HAS NOT BEEN LOADED.'
        PRINT*, ' ISAJET CANNOT RUN WITHOUT IT.'
        PRINT*, ' PLEASE READ THE FINE MANUAL FOR ISAJET.'
        STOP99
      ENDIF
C
      LOUT=1
      PRINT 1000
1000  FORMAT(' ENTER output file name (in single quotes)')
      READ*, FNAME
      OPEN(1,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
C          Print version
      V=VISAJE()
      WRITE(LOUT,1001) V
1001  FORMAT(' ',44('*')/' *',42X,'*'/
     C  ' * ',A40,' *'/
     C  ' *',42X,'*'/' ',44('*')/)
C
      PRINT 1100
1100  FORMAT(' ENTER M(TP)')
      READ*, XMT
      PRINT 1200
1200  FORMAT(' ENTER M(GLSS), MU, M(A), TAN(BETA)')
      READ*, XMG,XMU,XMHA,XTANB
      PRINT 1250
1250  FORMAT(' ENTER M(Q1), M(DR), M(UR), M(L1), M(ER)')
      READ*, XMQ1,XMDR,XMUR,XML1,XMER
      PRINT 1300
1300  FORMAT(' ENTER M(Q3), M(BR), M(TR), M(L3), M(LR), A_T, A_B, A_L')
      READ*, XMQ3,XMBR,XMTR,XML3,XMLR,XAT,XAB,XAL
      XMQ2=1.E20
      XMSR=1.E20
      XMCR=1.E20
      XML2=1.E20
      XMMR=1.E20
      PRINT 1400
1400  FORMAT(' ENTER OPTIONAL 2ND GEN MASSES (/ FOR DEFAULT):')
      PRINT 1401 
1401  FORMAT(' ENTER M(Q2), M(SR), M(CR), M(L2), M(MR)')
      READ*, XMQ2,XMSR,XMCR,XML2,XMMR
      XM1=1.E20
      XM2=1.E20
      PRINT 1500
1500  FORMAT(' ENTER OPTIONAL GAUGINO MASSES M1, M2 (/ FOR DEFAULT):')
      READ*, XM1,XM2
      AMGVSS=1.E20
      PRINT 1501
1501  FORMAT(' ENTER OPTIONAL GRAVITINO MASS (/ FOR DEFAULT):')
      READ*, AMGVSS
C
C          Calculate...
C
C          First calculate fermion masses at QSUSY
      PI=4.*ATAN(1.)
      QSUSY=SQRT(XMQ3*XMTR)
      ALQCD4=0.177
      AMBT=AMASS(5)
      AMTP=XMT
      ASMB=SUALFS(AMBT**2,.36,AMTP,3)
      MBMB=AMBT*(1.-4*ASMB/3./PI)
      MBQ=SNGL(SSMQCD(DBLE(MBMB),DBLE(QSUSY)))
      ASMT=SUALFS(AMTP**2,.36,AMTP,3)
      MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))*
     $(ASMT/PI)**2)
      MTQ=SNGL(SSMQCD(DBLE(MTMT),DBLE(QSUSY)))
      MLQ=1.7463
C     For MSSM solution TANBQ=TANB; for SUGRA, TANBQ=/ TANB
      ALFAEM=1./128.
      SN2THW=.232
      AMW=80.423
      GG=SQRT(4*PI*ALFAEM/SN2THW)
      VUQ=SQRT(2*AMW**2/GG**2/(1.+1./XTANB**2))
      VDQ=VUQ/XTANB
C
      CALL SSMSSM(XMG,XMU,XMHA,XTANB,XMQ1,XMDR,XMUR,
     $XML1,XMER,XMQ2,XMSR,XMCR,XML2,XMMR,XMQ3,XMBR,XMTR,XML3,
     $XMLR,XAT,XAB,XAL,XM1,XM2,XMT,IALLOW,0)
C
C          Test parameters
C
      IF(IALLOW.NE.0) THEN
        WRITE(LOUT,2001)
2001    FORMAT(//' MSSM WARNING: Z1SS IS NOT LSP')
      ENDIF
C
      CALL SSTEST(IALLOW)
      IITEST=IALLOW/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2002)
2002    FORMAT(' MSSM WARNING: Z -> Z1SS Z1SS EXCEEDS BOUND')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2004)
2004    FORMAT(' MSSM WARNING: Z -> CHARGINOS ALLOWED')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2008)
2008    FORMAT(' MSSM WARNING: Z -> Z1SS Z2SS TO BIG')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2016)
2016    FORMAT(' MSSM WARNING: Z -> SQUARKS, SLEPTONS ALLOWED')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2032)
2032    FORMAT(' MSSM WARNING: Z -> Z* HL0 EXCEEDS BOUND')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2064)
2064    FORMAT(' MSSM WARNING: Z -> HL0 HA0 ALLOWED')
      ENDIF
C
C          Print results. Note decay modes need not be together, so
C          need to select each parent particle separately.
C
      WRITE(LOUT,3000) XMT,XMG,XMU,XMHA,XTANB,XMQ1,XMDR,XMUR,XML1,
     $XMER,XMQ3,XMBR,XMTR,XML3,XMLR,XAT,XAB,XAL,ALFAEM,SN2THW,ALFA3
3000  FORMAT(
     $' INPUTS FOR ISASUSY:'/
     $' M(TP)     =',F10.3/
     $' M(GLSS)   =',F10.3,'   MU        =',F10.3,'   M(HA)  =',F10.3/
     $' TAN(BETA) =',F10.3/
     $' M(Q1  )   =',F10.3,'   M(DR)     =',F10.3,'   M(UR)  =',F10.3/
     $' M(L1)     =',F10.3,'   M(ER)     =',F10.3,'   M(Q3)  =',F10.3/
     $' M(BR)     =',F10.3,'   M(TR)     =',F10.3,'   M(L3)  =',F10.3/
     $' M(LR)     =',F10.3,'   A_T       =',F10.3,'   A_B    =',F10.3/
     $' A_TAU     =',F10.3/
     $' ALPHAEM   =',F10.5,'   SIN2(THW) =',F10.5,'   ALPHA3 =',F10.5/)
      IF(ABS(XML2).LE.1.E19) THEN
        WRITE(LOUT,3005) XMQ2,XMSR,XMCR,XML2,XMMR
3005    FORMAT(
     $' M(Q2)     =',F10.3,'   M(SR)     =',F10.3,'   M(CR)  =',F10.3/
     $' M(L2)     =',F10.3,'   M(MR)     =',F10.3/)
      ENDIF
      IF(ABS(XM1).LE.1.E19.AND.ABS(XM2).LE.1.E19) THEN
        WRITE(LOUT,3010) XM1,XM2
3010    FORMAT(
     $  ' M_1       =',F10.3,'   M_2       =',F10.3/)
      ENDIF
C
      WRITE(LOUT,3100) AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS
3100  FORMAT(' NEUTRALINO MASSES (SIGNED) =',4F10.3)
      DO 100 J=1,4
        WRITE(LOUT,3200) J,(ZMIXSS(K,J),K=1,4)
3200    FORMAT(' EIGENVECTOR ',I1,'       =',4F10.5)
100   CONTINUE
      WRITE(LOUT,3300) AMW1SS,AMW2SS
3300  FORMAT(/' CHARGINO MASSES (SIGNED)  =',2F10.3)
      WRITE(LOUT,3400) GAMMAL,GAMMAR
3400  FORMAT(' GAMMAL, GAMMAR             =',2F10.5/)
      WRITE(LOUT,3500) AMHL,AMHH,AMHC,ALFAH
3500  FORMAT(' M(HL) =',F10.3,' M(HH) =',F10.3,
     $' M(H+) =',F10.3,'   ALFAH=',F6.4/)
      WRITE(LOUT,3550) AMT1SS,AMT2SS,THETAT
3550  FORMAT(
     $' M(T1)   =',F10.3,'   M(T2)   =',F10.3,'   THETA(T)=',F10.3/)
      WRITE(LOUT,3551) AMB1SS,AMB2SS,THETAB
3551  FORMAT(
     $' M(B1)   =',F10.3,'   M(B2)   =',F10.3,'   THETA(B)=',F10.3/)
      WRITE(LOUT,3552) AML1SS,AML2SS,THETAL
3552  FORMAT(
     $' M(TAU1) =',F10.3,'   M(TAU2) =',F10.3,' THETA(TAU)=',F10.3/)
C
      WRITE(LOUT,3600)
3600  FORMAT(' PARENT --> DAUGHTERS',18X,'WIDTH',10X,
     $'BRANCHING RATIO'/)
C          Write all modes
      DO 200 J=1,NOUT
        CALL SSPRT(IDOUT(J))
200   CONTINUE
C
      STOP
      END
+EOD
+DECK,SUGPRT
C--------------------------------------------------------------------
      SUBROUTINE SUGPRT(IMODEL,IMODIN)
C--------------------------------------------------------------------
C
C     Print SUGRA parameters and results
C     IMODEL = model type for SUGRA
C     IMODIN = input model type to control formatting
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SUGPAS
+CDE,SSPAR
+CDE,SUGNU
      REAL PI,GPX,SIN2W,ALEMI,AS,TANBQ
      INTEGER IMODEL,J,K,IMODIN
C
C          Entry
C
      PI=4.*ATAN(1.)
      GPX=SQRT(.6)*GSS(1)
      SIN2W=GPX**2/(GSS(2)**2+GPX**2)
      ALEMI=4*PI/GSS(2)**2/SIN2W
      AS=GSS(3)**2/4./PI
      TANBQ=VUQ/VDQ
C
C          Print inputs and GUT couplings for SUGRA/AMSB models
C
      IF(IMODEL.EQ.1.OR.IMODEL.EQ.7) THEN
        IF(IMODEL.EQ.1) THEN
          WRITE(LOUT,1000) XSUGIN(1),XSUGIN(2),XSUGIN(3),XSUGIN(4),
     $    XSUGIN(5),XSUGIN(6)
1000      FORMAT(
     $    ' M_0,  M_(1/2),  A_0,  tan(beta),  sgn(mu),  M_t ='
     $    /4F10.3,2X,F6.1,F10.3)
        ELSE IF (IMODEL.EQ.7) THEN
          WRITE(LOUT,1018) XSUGIN(1),XSUGIN(2),XSUGIN(4),XSUGIN(5),
     $    XSUGIN(6)
1018      FORMAT(
     $    ' M_0,  M_(3/2),  tan(beta),  sgn(mu),  M_t ='
     $    /3F10.3,2X,F6.1,2F10.3)
        END IF
C
C          Write out non-universal GUT scale parameters
        IF (INUHM.EQ.1) THEN
          WRITE(LOUT,1023)
          WRITE(LOUT,1021) MHDSQ,MHUSQ
          WRITE(LOUT,1022) MHDSMG,MHUSMG
1021      FORMAT(/,' M_Hd^2(Q)= ',E10.3,3X,'M_Hu^2(Q)= ',E10.3)
1022      FORMAT(' M_Hd^2(MGUT)= ',E10.3,3X,'M_Hu^2(MGUT)= ',E10.3)
1023      FORMAT(/,' NUHM model has been selected:')
        END IF
        IF(XNUSUG(1).LT.1.E19.OR.XNUSUG(2).LT.1.E19.OR.XNUSUG(3)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1010) XNUSUG(1),XNUSUG(2),XNUSUG(3)
1010      FORMAT(/' M_1(GUT)= ',F8.2,'    M_2(GUT)= ',F8.2,
     $    '    M_3(GUT)= ',F8.2) 
        END IF
        IF(XNUSUG(4).LT.1.E19.OR.XNUSUG(5).LT.1.E19.OR.XNUSUG(6)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1011) XNUSUG(4),XNUSUG(5),XNUSUG(6)
1011      FORMAT(/' A_tau(GUT)= ',F8.2,'    A_b(GUT)= ',F8.2,
     $    '    A_t(GUT)= ',F8.2)
        END IF
        IF(XNUSUG(7).LT.1.E19.OR.XNUSUG(8).LT.1.E19) THEN
          WRITE(LOUT,1012) XNUSUG(7),XNUSUG(8)
1012      FORMAT(/' M_Hd(GUT)= ',F8.2,'    M_Hu(GUT)= ',F8.2)
        END IF
        IF (XNUSUG(9).LT.1.E19.OR.XNUSUG(10).LT.1.E19) THEN
          WRITE(LOUT,1013) XNUSUG(9),XNUSUG(10)
1013      FORMAT(/' M_eR(GUT)= ',F8.2,'    M_eL(GUT)= ',F8.2)
        END IF
        IF(XNUSUG(11).LT.1.E19.OR.XNUSUG(12).LT.1.E19.OR.XNUSUG(13)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1014) XNUSUG(11),XNUSUG(12),XNUSUG(13)
1014      FORMAT(' M_dR(GUT)= ',F8.2,'    M_uR(GUT)= ',F8.2,
     $    '    M_uL(GUT)=',F8.2)
        END IF
        IF(XNUSUG(14).LT.1.E19.OR.XNUSUG(15).LT.1.E19) THEN
          WRITE(LOUT,1015) XNUSUG(14),XNUSUG(15)
1015      FORMAT(/' M_tauR(GUT)= ',F8.2,'    M_tauL(GUT)= ',F8.2)
        END IF
        IF(XNUSUG(16).LT.1.E19.OR.XNUSUG(17).LT.1.E19.OR.XNUSUG(18)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1016) XNUSUG(16),XNUSUG(17),XNUSUG(18)
1016      FORMAT(' M_bR(GUT)= ',F8.2,'    M_tR(GUT)= ',F8.2,
     $    '    M_tL(GUT)=',F8.2)
        END IF
        IF(XSUGIN(7).NE.0) THEN
          WRITE(LOUT,1026) XSUGIN(7)
1026      FORMAT(' Q_max= ',E12.4)
        ENDIF
C
C          Right-handed neutrino parameters
        IF (XNRIN(2).LT.1.E19) THEN
          WRITE(LOUT,1017) XNRIN(1),XNRIN(2),XNRIN(3),XNRIN(4),
     $    FNMZ,FNGUT
1017      FORMAT(' Right-handed neutrino parameters:'/
     $    ' M(nu_tau)=',E10.3,'   M(N_R) =',E10.3,
     $    '   A_N=',F8.2,'   M(NRSS)=',F8.2/
     $    ' FN(M_Z)  =',F8.4, '   FN(M_GUT) =',F8.4)
        END IF
C
C          Unification results
        WRITE(LOUT,1001) MGUTSS,GGUTSS,AGUTSS
1001    FORMAT(/' ISASUGRA unification:'/' M_GUT      =',E10.3,
     $  '   g_GUT          =',F5.3,3X,'   alpha_GUT =',F5.3)
        WRITE(LOUT,999) FTGUT,FBGUT,FTAGUT
999     FORMAT(' FT_GUT     =',F6.3,
     $  '       FB_GUT         =',F6.3,3X,'  FL_GUT =',F6.3)
C
C          Print inputs for GMSB models
C
      ELSE IF (IMODEL.EQ.2) THEN
        WRITE(LOUT,1002) (XGMIN(J),J=1,7)
1002    FORMAT(
     $  ' Lambda,  M_mes,  N_5,  tan(beta),  sgn(mu),  M_t,  C_grav='
     $  /2E10.3,2F10.3,2X,F6.1,F10.3,1X,E10.3)
        WRITE(LOUT,1020) (XGMIN(J),J=8,14)
1020    FORMAT(/' GMSB2 model input:'/
     $  ' Rsl,    dmH_d^2,   dmH_u^2,     d_Y,     N5_1,  N5_2,  N5_3='
     $  /F7.3,1X,E10.3,1X,E10.3,1X,E10.3,2X,3F7.3)
        WRITE(LOUT,1003) AMGVSS
1003    FORMAT(/' M(gravitino)=',E10.3)
      END IF
C
C          Weak scale couplings
C
      WRITE(LOUT,1004) ALEMI,SIN2W,AS
1004  FORMAT(/' 1/alpha_em =',F8.2,2X,
     $'   sin**2(thetaw) =',F6.4,2X,'   a_s^DRB   =  ',F5.3)
      WRITE(LOUT,1005) GSS(7),GSS(8),GSS(9)
1005  FORMAT(' M_1        =',F8.2,2X,
     $'   M_2            =',F8.2,'   M_3       =',F8.2)
      WRITE(LOUT,1006) MU,B,HIGFRZ
1006  FORMAT(' mu(Q)      =',F8.2,2X,
     $'   B(Q)           =',F8.2,'   Q         =',F8.2)
      WRITE(LOUT,1007) GSS(13),GSS(14),TANBQ
1007  FORMAT(' M_Hd^2     =',E10.3,'   M_Hu^2         =',E10.3,
     $' TANBQ     =   ',F6.3)
C
C          Print mass spectrum from ISASUGRA 
C
      WRITE(LOUT,2000) MSS(1),MSS(2),MSS(3),MSS(4),MSS(5),MSS(10),
     $MSS(11),MSS(12),MSS(13),MSS(14),MSS(17),MSS(18),MSS(16),
     $MSS(21),MSS(22),MSS(23),MSS(24),MSS(25),MSS(26),MSS(27),
     $MSS(28),MSS(29),MSS(30),MSS(31),MSS(32)
2000  FORMAT(/' ISAJET masses (with signs):'/
     $' M(GL)  =',F9.2/
     $' M(UL)  =',F9.2,'   M(UR)  =',F9.2,'   M(DL)  =',F9.2,
     $'   M(DR) =',F9.2/
     $' M(B1)  =',F9.2,'   M(B2)  =',F9.2,'   M(T1)  =',F9.2,
     $'   M(T2) =',F9.2/
     $' M(SN)  =',F9.2,'   M(EL)  =',F9.2,'   M(ER)  =',F9.2/
     $' M(NTAU)=',F9.2,'   M(TAU1)=',F9.2,'   M(TAU2)=',F9.2/
     $' M(Z1)  =',F9.2,'   M(Z2)  =',F9.2,'   M(Z3)  =',F9.2,
     $'   M(Z4) =',F9.2/
     $' M(W1)  =',F9.2,'   M(W2)  =',F9.2/
     $' M(HL)  =',F9.2,'   M(HH)  =',F9.2,'   M(HA)  =',F9.2,
     $'   M(H+) =',F9.2)
      WRITE(LOUT,2001) THETAT,THETAB,THETAL,ALFAH
2001  FORMAT(/,' theta_t=',F9.4,'   theta_b=',F9.4,
     $'   theta_l=',F9.4,'   alpha_h=',F9.4)
C
C     Write out chargino /neutralino masses/eigenvectors
C
      WRITE(LOUT,3100) AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS
3100  FORMAT(/' NEUTRALINO MASSES (SIGNED) =',4F10.3)
      DO 100 J=1,4
        WRITE(LOUT,3200) J,(ZMIXSS(K,J),K=1,4)
3200    FORMAT(' EIGENVECTOR ',I1,'       =',4F10.5)
100   CONTINUE
      WRITE(LOUT,3300) AMW1SS,AMW2SS
3300  FORMAT(/' CHARGINO MASSES (SIGNED)  =',2F10.3)
      WRITE(LOUT,3400) GAMMAL,GAMMAR
3400  FORMAT(' GAMMAL, GAMMAR             =',2F10.5/)

C
C          Print ISAJET MSSMi equivalent input
C
      WRITE(LOUT,3000)
3000  FORMAT(/' ISAJET equivalent input:')
      WRITE(LOUT,3001) MSS(1),MU,MSS(31),XSUGIN(4)
3001  FORMAT(' MSSMA: ',4F8.2)
      WRITE(LOUT,3002) SQRT(GSS(19)),SQRT(GSS(17)),SQRT(GSS(18)),
     $SQRT(GSS(16)),SQRT(GSS(15))
3002  FORMAT(' MSSMB: ',5F8.2)
      WRITE(LOUT,3003) SIGN(1.,GSS(24))*SQRT(ABS(GSS(24))),
     $SQRT(GSS(22)),SIGN(1.,GSS(23))*SQRT(ABS(GSS(23))),
     $SQRT(GSS(21)),SQRT(GSS(20)),GSS(12),GSS(11),GSS(10)
3003  FORMAT(' MSSMC: ',8F8.2)
      WRITE(LOUT,3004)
3004  FORMAT(' MSSMD: SAME AS MSSMB (DEFAULT)')
      WRITE(LOUT,3005) GSS(7),GSS(8)
3005  FORMAT(' MSSME: ',2F8.2)
      RETURN
      END
+EOD
+DECK,SUGRUN
      PROGRAM SUGRUN
C
C     Main program to calculate MSSM input parameters for ISAJET
C     from renormalization group equations and supergravity.
C     All external names are of the form SUxxxx.
C     Must link with block data ALDATA.
C
C     Includes optional link to ISATOOLS, which requires libisared.a.
C     Make this from isared.tar; see the Makefile for instructions.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SUGMG
+CDE,SUGXIN
+CDE,SUGPAS
+CDE,SUGNU
+CDE,ISAPW
      CHARACTER*80 FNAME,FNLHA,FNWIG
      LOGICAL GOLHA,GOWIG
      INTEGER ILHA,IWIG
      REAL M0,MHF,A0,TANB,SGNMU,MT,XLAMGM,XMESGM,XN5GM,AMPL,XCMGV
      INTEGER NSTEP,IMODEL,INUSUG,IMODIN
      INTEGER K,NOUT,IALLOW,IITEST,J,II
      CHARACTER*40 VERSN,VISAJE
      PARAMETER (NOUT=33)
      INTEGER IDOUT(NOUT)
      CHARACTER*30 ISAPW2
      SAVE ISAPW2
C
C          Isatools common blocks and variables
C
      COMMON/SUGRED/OMGH2,SIGMA,XFREEZ,NSTEPS
      REAL OMGH2,SIGMA,XFREEZ
      INTEGER NSTEPS
      REAL ALEMIGM2,BFBSG,ALEMI
      COMMON/SUGRES/SIGMA0PROT,SIGMA0NEUT,SIGMASPROT,SIGMASNEUT
      REAL*8 SIGMA0PROT,SIGMA0NEUT,SIGMASPROT,SIGMASNEUT
      SAVE/SUGRES/
C-FP  INTEGER INUHM
      REAL*8 DAMU
      REAL BRBS,BRBD
C
      DATA IDOUT/
     $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR,
     $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL,
     $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,
     $ISHL,ISHH,ISHA,ISHC/
      DATA AMPL/2.4E18/
C          ISAPW2 is used to check whether ALDATA is loaded
      DATA ISAPW2/'ALDATA REQUIRED BY FORTRAN G,H'/
      DATA ILHA/11/,IWIG/12/
C
C          Initialize
C
      IF(ISAPW1.NE.ISAPW2) THEN
        PRINT*, ' ERROR: BLOCK DATA ALDATA HAS NOT BEEN LOADED.'
        PRINT*, ' ISAJET CANNOT RUN WITHOUT IT.'
        PRINT*, ' PLEASE READ THE FINE MANUAL FOR ISAJET.'
        STOP99
      ENDIF
C
      LOUT=1
      NSTEP=1000
      XNRIN(2)=1.E20
      XSUGIN(7)=0.
      INUHM=0
C
C          Open files
C
      PRINT*,'ENTER output filename in single quotes:'
      READ*,FNAME
      OPEN(1,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
      FNLHA=''
      GOLHA=.FALSE.
      PRINT*,'ENTER SUSY Les Houches Accord filename [/ for none]:'
      READ*,FNLHA
      IF(FNLHA.NE.'') THEN
        GOLHA=.TRUE.
        OPEN(ILHA,FILE=FNLHA,STATUS='NEW',FORM='FORMATTED')
      ENDIF
      FNWIG=''
      GOWIG=.FALSE.
      PRINT*,'ENTER Isawig (Herwig interface) filename [/ for none]:'
      READ*,FNWIG
      IF(FNWIG.NE.'') THEN
        GOWIG=.TRUE.
        OPEN(IWIG,FILE=FNWIG,STATUS='NEW',FORM='FORMATTED')
      ENDIF
C
      PRINT*,'ENTER 1 for mSUGRA:'
      PRINT*,'ENTER 2 for mGMSB:'
      PRINT*,'ENTER 3 for non-universal SUGRA:'
      PRINT*,'ENTER 4 for SUGRA with truly unified gauge couplings:'
      PRINT*,'ENTER 5 for non-minimal GMSB:'
      PRINT*,'ENTER 6 for SUGRA+right-handed neutrino:'
      PRINT*,'ENTER 7 for minimal anomaly-mediated SUSY breaking:'
      PRINT*,'ENTER 8 for non-minimal AMSB:'
      READ*,IMODIN
      IMODEL=IMODIN
      IF (IMODEL.EQ.4) THEN
        IAL3UN=1
        IMODEL=1
      END IF
      IF (IMODEL.EQ.1.OR.IMODEL.EQ.3.OR.IMODEL.EQ.6) THEN
        PRINT*,'ENTER M_0, M_(1/2), A_0, tan(beta), sgn(mu), M_t:'
        READ*,M0,MHF,A0,TANB,SGNMU,MT
        IF (IMODEL.EQ.6) THEN
          IMODEL=1
          PRINT*,' ENTER M(nu_3)[=0], M_Majorana, A_N, M(NRSS)'
          READ*,XNRIN(1),XNRIN(2),XNRIN(3),XNRIN(4)
          GO TO 15
        END IF
        IF (IMODEL.EQ.3) THEN
          IMODEL=1
10        PRINT*,' ENTER 1,...,5 for NUSUGx keyword; 0 to continue:'
          PRINT*,' NUSUG1 = GUT scale gaugino masses'
          PRINT*,' NUSUG2 = GUT scale A terms'
          PRINT*,' NUSUG3 = GUT scale Higgs masses'
          PRINT*,' NUSUG4 = GUT scale 1st/2nd generation masses'
          PRINT*,' NUSUG5 = GUT scale 3rd generation masses'
          PRINT*,' ENTER 6 to activate right-hand neutrino'
          PRINT*,' ENTER 7 to enter alternate high scale Q_max.ne.M_GUT'
          PRINT*,' ENTER 8 for mu, mA input at weak scale (NUHM model)'
          READ*,INUSUG
          IF (INUSUG.EQ.0) THEN
            GO TO 15
          ELSE IF (INUSUG.EQ.1) THEN
            PRINT*,'Enter GUT scale M_1, M_2, M_3:'
            READ*,XNUSUG(1),XNUSUG(2),XNUSUG(3)
C            IF (XNUSUG(3).LE.0.) THEN
C            PRINT*, ' NEGATIVE M_3 IS NOT ALLOWED'
C            STOP 99
C            END IF
          ELSE IF (INUSUG.EQ.2) THEN
            PRINT*,'Enter GUT scale A_t, A_b, A_tau:'
            READ*,XNUSUG(6),XNUSUG(5),XNUSUG(4)
          ELSE IF (INUSUG.EQ.3) THEN
            PRINT*,'Enter GUT scale m_Hd, m_Hu:'
            READ*,XNUSUG(7),XNUSUG(8)
          ELSE IF (INUSUG.EQ.4) THEN
            PRINT*,'Enter GUT scale M(ul), M(dr), M(ur), M(el), M(er):'
            READ*,XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10),XNUSUG(9)
          ELSE IF (INUSUG.EQ.5) THEN
            PRINT*,'Enter GUT scale M(tl), M(br), M(tr), M(Ll), M(Lr):'
            READ*,XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15),XNUSUG(14)
          ELSE IF (INUSUG.EQ.6) THEN
            PRINT*,' ENTER M(nu_3), M_Majorana, A_N, M(NRSS)'
            READ*,XNRIN(1),XNRIN(2),XNRIN(3),XNRIN(4)
          ELSE IF (INUSUG.EQ.7) THEN
            PRINT*,' ENTER Q_max high scale for SUSY BCs'
            READ*,XSUGIN(7)
          ELSE IF (INUSUG.EQ.8) THEN
            PRINT*,' ENTER mu(Q), mA(Q)'
            READ*,XNUSUG(19),XNUSUG(20)
            MU=XNUSUG(19)
            AMHA=XNUSUG(20)
            TWOM1=-MU
            INUHM=1
          END IF
          GO TO 10
        END IF
      ELSE IF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
          PRINT*,'ENTER Lambda, M_mes, N_5, tan(beta), sgn(mu), ',
     $    'M_t, C_gv:'
          READ*,M0,MHF,A0,TANB,SGNMU,MT,XCMGV
          XGMIN(7)=XCMGV
          XGMIN(8)=1.
          AMGVSS=M0*MHF*XCMGV/SQRT(3.)/AMPL
          IF (IMODEL.EQ.5) THEN
            IMODEL=2
            PRINT*,'Rsl = factor multiplying gaugino masses at M_mes'
            PRINT*,'dmH_d^2, dmH_u^2 = Higgs mass**2 shifts at M_mes'
            PRINT*,'d_Y = mass**2 shifts proportional to Y at M_mes'
            PRINT*,'n5_1,n5_2,n5_3 = n5 values for U(1),SU(2),SU(3)'
            PRINT*,'ENTER Rsl, dmH_d^2, dmH_u^2, d_Y, n5_1, n5_2, n5_3'
            READ*,XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
     $      XGMIN(13),XGMIN(14)
            END IF
      ELSE IF (IMODEL.EQ.7) THEN
        PRINT*,'ENTER M_0, M_(3/2), tan(beta), sgn(mu), M_t:'
        READ*,M0,MHF,TANB,SGNMU,MT
        A0=0.
        DO 101 II=1,7
101     XAMIN(II)=1.
      ELSE IF (IMODEL.EQ.8) THEN
        PRINT*,'ENTER M_0, M_(3/2), tan(beta), sgn(mu), M_t:'
        READ*,M0,MHF,TANB,SGNMU,MT
        A0=0.
        PRINT*,'ENTER cQ, cD, cU, cL, cE, cHd, cHu:'
        READ*,
     $XAMIN(1),XAMIN(2),XAMIN(3),XAMIN(4),XAMIN(5),XAMIN(6),XAMIN(7)
        IMODEL=7
      ELSE
        PRINT*,'Invalid model choice.'
        STOP99
      END IF
C
C          Solve RG equations
C
15    CALL SUGRA(M0,MHF,A0,TANB,SGNMU,MT,IMODEL)
C
C          Print results
C
      
      VERSN=VISAJE()
      WRITE(LOUT,20) VERSN
20    FORMAT(' ',44('*')/' *',42X,'*'/
     $  ' * ',A40,' *'/
     $  ' *',42X,'*'/' ',44('*')/)
      IF (NOGOOD.EQ.1) THEN
        PRINT*, 'BAD POINT: TACHYONIC PARTICLES!'
        WRITE(LOUT,*) 'BAD POINT: TACHYONIC PARTICLES!'
      ELSE IF (NOGOOD.EQ.2) THEN
        PRINT*, 'BAD POINT: NO EW SYMMETRY BREAKING!'
        WRITE(LOUT,*) 'BAD POINT: NO EW SYMMETRY BREAKING!'
      ELSE IF (NOGOOD.EQ.3) THEN
        PRINT*, 'BAD POINT: M(H_P)^2<0!'
        WRITE(LOUT,*) 'BAD POINT: M(H_P)^2<0!'
      ELSE IF (NOGOOD.EQ.4) THEN
        PRINT*, 'BAD POINT: YUKAWA>10!'
        WRITE(LOUT,*) 'BAD POINT: YUKAWA>10!'
      ELSE IF (NOGOOD.EQ.5.AND.IMODEL.EQ.1) THEN
        PRINT*, 'SUGRA BAD POINT: Z1SS NOT LSP!'
        WRITE(LOUT,*) 'SUGRA BAD POINT: Z1SS NOT LSP!'
      ELSE IF (NOGOOD.EQ.7) THEN
        PRINT*, 'BAD POINT: XT EWSB BAD!'
        WRITE(LOUT,*) 'BAD POINT: XT EWSB BAD!'
      ELSE IF (NOGOOD.EQ.8) THEN
        PRINT*, 'BAD POINT: MHL^2<0!'
        WRITE(LOUT,*) 'BAD POINT: MHL^2<0!'
      ELSE IF (NOGOOD.EQ.-1) THEN
        PRINT*, 'BAD POINT: NO RGE SOLUTION FOUND'
        WRITE(LOUT,*) 'BAD POINT: NO RGE SOLUTION FOUND'
      END IF
      IF (MHPNEG.EQ.1) THEN
        PRINT*, 'BAD POINT: M(H_P)^2<0!!'
        WRITE(LOUT,*) 'BAD POINT: M(H_P)^2<0!!'
        NOGOOD=3
      END IF
      IF(NOGOOD.NE.0) STOP99
      IF(ITACHY.NE.0) THEN
        WRITE(LOUT,*) 'WARNING: TACHYONIC SLEPTONS AT GUT SCALE'
        WRITE(LOUT,*) '         POINT MAY BE INVALID'
      ENDIF
CCC      IF (IGUTST.EQ.1) THEN
CCC        PRINT*, 'WARNING: GUT INSTABILITY IN NUHM MODEL'
CCC      END IF
C
C          Print selected model and results
C
      IF(IMODIN.EQ.1) WRITE(LOUT,1001)
1001  FORMAT(//' Minimal supergravity (mSUGRA) model:'/)
      IF(IMODIN.EQ.2) WRITE(LOUT,1002)
1002  FORMAT(//' Minimal gauge mediated (GMSB) model:'/)
      IF(IMODIN.EQ.3) WRITE(LOUT,1003)
1003  FORMAT(//' Non-universal supergravity model:'/)
      IF(IMODIN.EQ.4) WRITE(LOUT,1004)
1004  FORMAT(//' Supergravity model with truly unified couplings:'/)
      IF(IMODIN.EQ.5) WRITE(LOUT,1005)
1005  FORMAT(//' Non-minimal gauge mediated (GMSB) model:'/)
      IF(IMODIN.EQ.6) WRITE(LOUT,1006)
1006  FORMAT(//' Supergravity model with right-handed neutrinos:'/)
      IF(IMODIN.EQ.7) WRITE(LOUT,1007)
1007  FORMAT(//' Anomaly-mediated SUSY breaking model:'/)
      IF(IMODIN.EQ.8) WRITE(LOUT,1008)
1008  FORMAT(//' Non-minimal anomaly-mediated SUSY breaking model:'/)
C
C          Calculate all masses and decay modes
C
        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),
     $ MT,IALLOW,IMODEL)
C
C          Execute Isatools
C
+SELF,IF=ISATOOLS
      ALEMI=128.
C          g_mu - 2
      CALL ISAAMU(RV2V1,ALEMI,GAMMAL,GAMMAR,TWOM1,AAL,SQRT(GSS(16)),
     $SQRT(GSS(15)),AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,AMW1SS,AMW2SS,AMN2SS,
     $              ZMIXSS,0,DAMU)
C          B -> s gamma
      CALL ISABSG(IMODEL,AMHC,M0,MHF,A0,MTQ,MBQ,BFBSG,0)
C          Dark matter cross sections
C     CALL ISADET(SIGSC)
      CALL ISARES(0)
C          Relic density calculation -- requires isared.tar
      CALL ISARED(0)
C          B_s -> mu mu (BRBS) and B -> tau tau (BRBD)
      CALL ISABMM(MT,TANB,MSS(29),MSS(30),MSS(31),MSS(1),
     $MSS(10),MSS(11),GSS(11),THETAB,
     $MSS(12),MSS(13),GSS(12),THETAT,
     $MU,GSS(8),ALFAH,MSS(6),MSS(8),BRBS,BRBD)
+SELF
C
      CALL SUGPRT(IMODEL,IMODIN)
C
C          Test parameters
C
      IF(IALLOW.NE.0) THEN
        WRITE(LOUT,2001)
2001    FORMAT(//' MSSM WARNING: Z1SS IS NOT LSP')
      ENDIF
C
      CALL SSTEST(IALLOW)
      IITEST=IALLOW/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2002)
2002    FORMAT(' MSSM WARNING: Z -> Z1SS Z1SS EXCEEDS BOUND')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2004)
2004    FORMAT(' MSSM WARNING: Z -> CHARGINOS ALLOWED')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2008)
2008    FORMAT(' MSSM WARNING: Z -> Z1SS Z2SS TOO BIG')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2016)
2016    FORMAT(' MSSM WARNING: Z -> SQUARKS, SLEPTONS ALLOWED')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2032)
2032    FORMAT(' MSSM WARNING: Z -> Z* HL0 EXCEEDS BOUND')
      ENDIF
      IITEST=IITEST/2
      IF(MOD(IITEST,2).NE.0) THEN
        WRITE(LOUT,2064)
2064    FORMAT(' MSSM WARNING: Z -> HL0 HA0 ALLOWED')
      ENDIF
C
C          Isatools output
C
+SELF,IF=ISATOOLS
      BFBSG=1.0E-4*BFBSG
      WRITE(LOUT,3500) DAMU,BFBSG,OMGH2,BRBS,BRBD,
     $SIGMA0PROT,SIGMA0NEUT,SIGMASPROT,SIGMASNEUT
3500  FORMAT(//' Output from ISATOOLS:'/
     $' Delta a_mu       = ',E12.5,'    BF(b->s gamma)   = ',E12.5/
     $' Omega h^2        = ',E12.5/
     $' BF(Bs -> mu mu)  = ',E12.5,'    BF(B -> tau tau) = ',E12.5/
     $' LSP-nucleon spin independent (SI) and dependent (SD) sigmas:'/
     $' sigma(p,SI)[pb]  = ',E12.5,'    sigma(n,SI)[pb]  = ',E12.5/
     $' sigma(p,SD)[pb]  = ',E12.5,'    sigma(n,SD)[pb]  = ',E12.5)
+SELF
      WRITE(LOUT,3600)
3600  FORMAT(//' ISASUSY decay modes:'/
     $' Parent --> daughters',18X,'Width',10X,'Branching ratio'/)
C          Write all modes
      DO 200 J=1,NOUT
        CALL SSPRT(IDOUT(J))
200   CONTINUE
C
C          Make optional output files
C
      IF(GOLHA) THEN
        CALL ISALHA(ILHA,IMODEL,IMODIN,MT)
        DO 210 J=1,NOUT
          CALL ISALHD(ILHA,IDOUT(J),J,NOUT)
210     CONTINUE
      ENDIF
      IF(GOWIG) THEN
        CALL ISAWIG(IWIG,0,MT,GSS(8),SQRT(GSS(16)),SQRT(GSS(15)),
     &              SQRT(GSS(19)),SQRT(GSS(18)),SQRT(GSS(17)),
     &              SQRT(GSS(16)),SQRT(GSS(15)),SQRT(GSS(19)),
     &              SQRT(GSS(18)),SQRT(GSS(17)),SQRT(GSS(21)),
     &              SQRT(GSS(20)),SQRT(GSS(24)),SQRT(GSS(23)),
     &              SQRT(GSS(22)))
      ENDIF
C
      STOP
      END
+EOD
+PATCH,ISASUSY.
+EOD
+DECK,DDILOG,IF=NOCERN
      DOUBLE PRECISION FUNCTION DDILOG(X)
C
C          FROM CERN PROGRAM LIBRARY
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      DOUBLE PRECISION X,Y,T,S,A,PI3,PI6,ZERO,ONE,HALF,MALF,MONE,MTWO
      DOUBLE PRECISION C(0:18),H,ALFA,B0,B1,B2
      INTEGER I
C
      DATA ZERO /0.0D0/, ONE /1.0D0/
      DATA HALF /0.5D0/, MALF /-0.5D0/, MONE /-1.0D0/, MTWO /-2.0D0/
      DATA PI3 /3.28986 81336 96453D0/, PI6 /1.64493 40668 48226D0/
C
      DATA C( 0) / 0.42996 69356 08137 0D0/
      DATA C( 1) / 0.40975 98753 30771 1D0/
      DATA C( 2) /-0.01858 84366 50146 0D0/
      DATA C( 3) / 0.00145 75108 40622 7D0/
      DATA C( 4) /-0.00014 30418 44423 4D0/
      DATA C( 5) / 0.00001 58841 55418 8D0/
      DATA C( 6) /-0.00000 19078 49593 9D0/
      DATA C( 7) / 0.00000 02419 51808 5D0/
      DATA C( 8) /-0.00000 00319 33412 7D0/
      DATA C( 9) / 0.00000 00043 45450 6D0/
      DATA C(10) /-0.00000 00006 05784 8D0/
      DATA C(11) / 0.00000 00000 86121 0D0/
      DATA C(12) /-0.00000 00000 12443 3D0/
      DATA C(13) / 0.00000 00000 01822 6D0/
      DATA C(14) /-0.00000 00000 00270 1D0/
      DATA C(15) / 0.00000 00000 00040 4D0/
      DATA C(16) /-0.00000 00000 00006 1D0/
      DATA C(17) / 0.00000 00000 00000 9D0/
      DATA C(18) /-0.00000 00000 00000 1D0/
C 
      IF(X .EQ. ONE) THEN
       DDILOG=PI6
       RETURN
      ELSE IF(X .EQ. MONE) THEN
       DDILOG=MALF*PI6
       RETURN
      END IF
      T=-X
      IF(T .LE. MTWO) THEN
       Y=MONE/(ONE+T)
       S=ONE
       A=-PI3+HALF*(LOG(-T)**2-LOG(ONE+ONE/T)**2)
      ELSE IF(T .LT. MONE) THEN
       Y=MONE-T
       S=MONE
       A=LOG(-T)
       A=-PI6+A*(A+LOG(ONE+ONE/T))
      ELSE IF(T .LE. MALF) THEN
       Y=(MONE-T)/T
       S=ONE
       A=LOG(-T)
       A=-PI6+A*(MALF*A+LOG(ONE+T))
      ELSE IF(T .LT. ZERO) THEN
       Y=-T/(ONE+T)
       S=MONE
       A=HALF*LOG(ONE+T)**2
      ELSE IF(T .LE. ONE) THEN
       Y=T
       S=ONE
       A=ZERO
      ELSE
       Y=ONE/T
       S=MONE
       A=PI6+HALF*LOG(T)**2
      END IF
C
      H=Y+Y-ONE
      ALFA=H+H
      B1=ZERO
      B2=ZERO
      DO 1 I = 18,0,-1
      B0=C(I)+ALFA*B1-B2
      B2=B1
    1 B1=B0
      DDILOG=-(S*(B0-H*B2)+A)
      RETURN
      END
+EOD
+DECK,DRKSTP,IF=NOCERN
C-----------------------------------------------------------------------
      SUBROUTINE DRKSTP(N,H,X,Y,SUB,W)
C-----------------------------------------------------------------------
C
C     From CERN Program Library, routine D209, with error message for
C     N.LT.1 replaced by STOP 99 to eliminate Kernlib error routine.
C
      DOUBLE PRECISION H,X,Y,W,HLOCAL,H2,H6,XH,XH2
      DIMENSION Y(N),W(N,3)
      LOGICAL MFLAG,RFLAG
      EXTERNAL SUB
C
C     ******************************************************************
C
C     (DOUBLE PRECISION VERSION OF RKSTP.)
C
C     THIS SUBROUTINE REPLACES X BY X+H AND ADVANCES THE SOLUTION OF THE
C     SYSTEM OF DIFFERENTIAL EQUATIONS DY/DX=F(X,Y) FROM Y(X) TO Y(X+H)
C     USING A FIFTH-ORDER RUNGE-KUTTA METHOD.
C
C     SUB IS THE NAME OF A SUBROUTINE SUB(X,Y,F) WHICH SETS THE VECTOR F
C     TO THE DERIVATIVE AT X OF THE VECTOR Y.
C
C     W IS A WORKING-SPACE ARRAY, TREATED AS CONSISTING OF THREE CONSEC-
C     UTIVE WORKING VECTORS OF LENGTH N.
C
C     ******************************************************************
C
C  START.
      IF (N.LT.1) STOP 99
      NLOCAL=N
      HLOCAL=H
      H2=0.5D0*HLOCAL
      H6=HLOCAL/6D0
      XH=X+HLOCAL
      XH2=X+H2
      CALL SUB(X,Y,W(1,1))
      DO 1 J=1,NLOCAL
         W(J,2)=Y(J)+H2*W(J,1)
    1 CONTINUE
      CALL SUB(XH2,W(1,2),W(1,3))
      DO 2 J=1,NLOCAL
         W(J,1)=W(J,1)+2D0*W(J,3)
         W(J,2)=Y(J)+H2*W(J,3)
    2 CONTINUE
      CALL SUB(XH2,W(1,2),W(1,3))
      DO 3 J=1,NLOCAL
         W(J,1)=W(J,1)+2D0*W(J,3)
         W(J,2)=Y(J)+HLOCAL*W(J,3)
    3 CONTINUE
      CALL SUB(XH,W(1,2),W(1,3))
      DO 4 J=1,NLOCAL
         Y(J)=Y(J)+H6*(W(J,1)+W(J,3))
    4 CONTINUE
      X=XH
      RETURN
      END
+EOD
+DECK,EISRS1,IF=NOCERN
      SUBROUTINE EISRS1(NM,N,AR,WR,ZR,IERR,WORK)
C     ALL EIGENVALUES AND CORRESPONDING EIGENVECTORS OF A REAL
C     SYMMETRIC MATRIX
C     FROM CERN PROGRAM LIBRARY
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER NM,N,IERR
      REAL AR(NM,NM),WR(N),ZR(NM,NM),WORK(1)
      CALL TRED2(NM,N,AR,WR,WORK,ZR)
      CALL TQL2(NM,N,WR,WORK,ZR,IERR)
      RETURN
      END
+EOD
+DECK,GBEAM
      REAL FUNCTION GBEAM(X,E)
C***********************************************************************
C* Computes the effective single photon spectrum from beamstrahlung at *
C* e+e- colliders, using Peskin's approximate expression, 
C* Eq. 17 of SLAC-TN-04-032.
C* For a given
C* beamstrahlungs parameter Y; is supposed to work for Y <= 10 or so.  *
C***********************************************************************
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,EEPAR
C
      REAL X,E,GAMMA
      DOUBLE PRECISION NGAM,NUCL,NUGAM,Y,GAM,GAM13,
     ,RE,XKAPPA,Z,E2,DE,DX,DGBEAM,XL
      IF (X.LT.1.E-5) X=1.E-5
      DE=E
      DX=X
      Y=UPSLON
      GAM = DE/5.11D-4
      RE = 1.D0/(137.D0*5.11D-4)
      XL=SIGZ*1.D12/.197327D0
      XKAPPA = 2.D0/(3.D0*Y)
      NUCL = 2.5D0*Y/(SQRT(3.D0)*137.D0**2*GAM*RE)
      NUGAM = NUCL/SQRT(1.D0+Y**.6666666D0)
      NGAM = DSQRT(3.D0)*XL*NUGAM
      Z = 1.D0-DX
      E2 = DX*XKAPPA/Z
      GAM13=DBLE(GAMMA(.333333))
      DGBEAM = (NGAM/2.D0)*XKAPPA**.333333D0/DX**.666666D0/
     ,Z**1.333333D0*DEXP(-E2)/GAM13
      GBEAM=DGBEAM
      IF (GBEAM.LT.0.) GBEAM=0.
      RETURN
      END
+EOD
+DECK,GSTRUC.
      REAL FUNCTION GSTRUC(X,QS)
C
C     THIS IS PHOTON PARTON DISTRIBUTION FUNCTION;
C     Improved WEIZACKER-WILLIAMS; NOTE! GSTRUC=0 FOR X<0.0000001
C     See Frixione et al. hep-ph/9310350
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL AL,PI,AME,QS,X,DEL
C
      AL=1./128.
      PI=4*ATAN(1.)
      AME=.511E-3
      DEL=AME**2/QS
      IF (X.LT.0.0000001.OR.X.EQ.1.) THEN
        GSTRUC=0.
      ELSE
        GSTRUC = (AL/2./PI)*(LOG((1.-X)/X/X/DEL)*(1.+(1.-X)**2)/X-
     ,           2*(1.-X-DEL*X*X)/X)
      END IF
      RETURN
      END
+EOD
+DECK,ISALHA
C--------------------------------------------------------------------
      SUBROUTINE ISALHA(LOUT,IMODEL,IMODIN,MT)
C--------------------------------------------------------------------
C     
C     Print SUGRA parameters in 'Les Houches accord 3' (LHA3) format
C     C. Balazs, Jan. 5 2005, v1.0
C     (History: C. Balazs, July 24 2003, v0.1)
C
C     IMODEL = model type for SUGRA
C     IMODIN = input model type to control formatting
C     MT     = top mass
C
CsB   ISAJET common blocks from SUGPRT ...
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SUGPAS
+CDE,SSPAR
+CDE,SUGNU
CsB   Additional ISAJET common blocks ...
+CDE,SSSM
+CDE,CONST
CsB   End of ISAJET common blocks
C
      REAL GPX,SIN2W,ALEMI,AS,MT,ASMB,MBMB,SUALFS
      INTEGER IMODEL,J,K,IMODIN,LOUT
      INTEGER I,I1,I2,J1,J2
      REAL RMSUSY,SG,THX,THY
C
CsB   Local ISAJET related variables
      CHARACTER*40 VERSN,VISAJE
C
CsB   Local LHA3 related variables
      Integer iPDG(33),ISA2LHA3(33),I2L3GSS(50)
      DIMENSION CHAF(33),ModelDescr(7),SoftParaLHA(50)
      CHARACTER CHAF*16, ModelDescr*50,SoftParaLHA*16
CsB   These are the particle names the masses of which LHA3 wants 
C     (in this order)
      DATA CHAF /
     $' top',' h^0',' H^0',' A^0',' H^+',
     $' dnl',' upl',' stl',' chl',' b1',' t1',
     $' el-',' nuel',' mul-',' numl',' tau1',' nutl',
     $' glss',' z1ss',' z2ss',' w1ss',' z3ss',' z4ss',' w2ss',
     $' dnr',' upr',' str',' chr',' b2',' t2',
     $' er-',' mur-',' tau2' /
CsB   These are the PDG codes of the above
      DATA iPDG /
     &      6,     25,     35,     36,     37,
     &1000001,1000002,1000003,1000004,1000005,1000006,
     &1000011,1000012,1000013,1000014,1000015,1000016,
     &1000021,1000022,1000023,1000024,1000025,1000035,1000037,
     &2000001,2000002,2000003,2000004,2000005,2000006,
     &2000011,2000013,2000015 /
CsB   These are the MSS indices of the above
      Data ISA2LHA3 / 
     $ 0,29,30,31,32,
     $ 4, 2, 6, 8,10,12,
     $17,14,19,15,21,16,
     $ 1,23,24,27,25,26,28,
     $ 5, 3, 7, 9,11,13,
     $18,20,22/
CsB   These are the soft parameters of which LHA3 wants (in this order)
      DATA SoftParaLHA /
     ,'M_1(Q)','M_2(Q)','M_3(Q)','     ','     ',
     ,'      ','      ','      ','     ','     ',
     ,'      ','      ','      ','     ','     ',
     ,'      ','      ','      ','     ','     ',
     ,'      ','      ','      ','     ','     ',
     ,'      ','      ','      ','     ','     ',
     ,'MeL(Q)','MmuL(Q)','MtauL(Q)','MeR(Q)','MmuR(Q)',
     ,'MtauR(Q)','      ','      ','     ','     ',
     ,'MqL1(Q)','MqL2(Q)','MqL3(Q)','MuR(Q)','McR(Q)',
     ,'MtR(Q)','MdR(Q)','MsR(Q)','MbR(Q)','    '/
CsB   These are GSS indices of the above
      Data I2L3GSS / 
     $  7, 8, 9, 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,
     $ 16,16,21,15,15,20, 0, 0, 0, 0,
     $ 19,19,24,18,18,23,17,17,22, 0/
C
      Data ModelDescr /
     $'Minimal supergravity (mSUGRA,CMSSM) model',
     $'Minimal gauge mediated (GMSB) model',
     $'Non-universal supergravity model',
     $'Supergravity model with truly unified couplings',
     $'Non-minimal gauge mediated (GMSB) model',
     $'Supergravity model with right-handed neutrinos',
     $'Anomaly-mediated SUSY breaking model' /
C
      LOGICAL TESTING
      TESTING = .FALSE.
C
      IF (IMODIN.NE.1) THEN
        PRINT*, 'This ISALHA version only writes an mSUGRA spectrum'
      	RETURN
      ENDIF
C
C          Entry
C
      PI=4.*ATAN(1.)
      GPX=SQRT(.6)*GSS(1)
      SIN2W=GPX**2/(GSS(2)**2+GPX**2)
      ALEMI=4*PI/GSS(2)**2/SIN2W
      AS=.1172
C
CsB   Open LHA3 output file
C-FP      LOUT = 91
C-FP      Open(LOUT,FILE='ISALHA.out',FORM='FORMATTED')
C
CsB   Write LHA3 header
      WRITE(LOUT,7000) 
     . ' ISAJET SUSY parameters in Les Houches accord format'
      WRITE(LOUT,7000) 
     . ' Created by ISALHA3. Last revision by C. Balazs on 2005 Jan. 10'
      VERSN=VISAJE()
      VERSN=VERSN(14:)
C
      WRITE(LOUT,7001)    'SPINFO', 
     ,                    'Program information'
      WRITE(LOUT,7012) 1, 'ISASUGRA from ISAJET       ',
     ,                    'Spectrum Calculator'
      WRITE(LOUT,7012) 2,  VERSN, 
     ,                    'Version number'
C
      WRITE(LOUT,7001) 'MODSEL', 'Model selection'
      WRITE(LOUT,7010) 1, IMODIN, ModelDescr(IMODIN)
C
      Call SETCON
      ASMB=SUALFS(AMBT**2,.36,AMTP,3)
      MBMB=4.2
      WRITE(LOUT,7001) 'SMINPUTS', 'Standard Model inputs'
      WRITE(LOUT,7011) 1, ALEMI, 'alpha_em^(-1)' ! (MZ) SM MSbar'
      WRITE(LOUT,7011) 2,    GF, 'G_Fermi'
      WRITE(LOUT,7011) 3,    AS, 'alpha_s(M_Z)'
      WRITE(LOUT,7011) 4,   AMZ, 'm_{Z}(pole)'
C     WRITE(LOUT,7011) 5,  AMBT, 'm_{b}(pole)'
      WRITE(LOUT,7011) 5,  MBMB, 'm_{b}(m_{b})'
      WRITE(LOUT,7011) 6,  AMTP, 'm_{top}(pole)'
      WRITE(LOUT,7011) 7, AMTAU, 'm_{tau}(pole)'
C
      WRITE(LOUT,7001) 'MINPAR', 'SUSY breaking input parameters'
C
C          Print inputs and GUT couplings for SUGRA/AMSB models
C
      IF(IMODEL.EQ.1.OR.IMODEL.EQ.7) THEN
        IF(IMODEL.EQ.1) THEN
          WRITE(LOUT,7011) 1, XSUGIN(1), 'm_0'
          WRITE(LOUT,7011) 2, XSUGIN(2), 'm_{1/2}'
          WRITE(LOUT,7011) 3, XSUGIN(4), 'tan(beta)'
          WRITE(LOUT,7011) 4, XSUGIN(5), 'sign(mu)'
          WRITE(LOUT,7011) 5, XSUGIN(3), 'A_0'
C          WRITE(LOUT,1000) XSUGIN(1),XSUGIN(2),XSUGIN(3),XSUGIN(4),
C     $    XSUGIN(5),XSUGIN(6)
C1000      FORMAT(
C     $    ' M_0,  M_(1/2),  A_0,  tan(beta),  sgn(mu),  M_t ='
C     $    /4F10.3,2X,F6.1,F10.3)
        ELSE IF (IMODEL.EQ.7) THEN
          WRITE(LOUT,1018) XSUGIN(1),XSUGIN(2),XSUGIN(4),XSUGIN(5),
     $    XSUGIN(6)
1018      FORMAT(
     $    ' M_0,  M_(3/2),  tan(beta),  sgn(mu),  M_t ='
     $    /3F10.3,2X,F6.1,2F10.3)
        END IF
CsB
        Goto 1234
C
C          Write out non-universal GUT scale parameters
        IF(XNUSUG(1).LT.1.E19.OR.XNUSUG(2).LT.1.E19.OR.XNUSUG(3)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1010) XNUSUG(1),XNUSUG(2),XNUSUG(3)
1010      FORMAT(/' M_1(GUT)= ',F8.2,'    M_2(GUT)= ',F8.2,
     $    '    M_3(GUT)= ',F8.2) 
        END IF
        IF(XNUSUG(4).LT.1.E19.OR.XNUSUG(5).LT.1.E19.OR.XNUSUG(6)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1011) XNUSUG(4),XNUSUG(5),XNUSUG(6)
1011      FORMAT(/' A_tau(GUT)= ',F8.2,'    A_b(GUT)= ',F8.2,
     $    '    A_t(GUT)= ',F8.2)
        END IF
        IF(XNUSUG(7).LT.1.E19.OR.XNUSUG(8).LT.1.E19) THEN
          WRITE(LOUT,1012) XNUSUG(7),XNUSUG(8)
1012      FORMAT(/' M_Hd(GUT)= ',F8.2,'    M_Hu(GUT)= ',F8.2)
        END IF
        IF (XNUSUG(9).LT.1.E19.OR.XNUSUG(10).LT.1.E19) THEN
          WRITE(LOUT,1013) XNUSUG(9),XNUSUG(10)
1013      FORMAT(/' M_eR(GUT)= ',F8.2,'    M_eL(GUT)= ',F8.2)
        END IF
        IF(XNUSUG(11).LT.1.E19.OR.XNUSUG(12).LT.1.E19.OR.XNUSUG(13)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1014) XNUSUG(11),XNUSUG(12),XNUSUG(13)
1014      FORMAT(' M_dR(GUT)= ',F8.2,'    M_uR(GUT)= ',F8.2,
     $    '    M_uL(GUT)=',F8.2)
        END IF
        IF(XNUSUG(14).LT.1.E19.OR.XNUSUG(15).LT.1.E19) THEN
          WRITE(LOUT,1015) XNUSUG(14),XNUSUG(15)
1015      FORMAT(/' M_tauR(GUT)= ',F8.2,'    M_tauL(GUT)= ',F8.2)
        END IF
        IF(XNUSUG(16).LT.1.E19.OR.XNUSUG(17).LT.1.E19.OR.XNUSUG(18)
     $  .LT.1.E19) THEN
          WRITE(LOUT,1016) XNUSUG(16),XNUSUG(17),XNUSUG(18)
1016      FORMAT(' M_bR(GUT)= ',F8.2,'    M_tR(GUT)= ',F8.2,
     $    '    M_tL(GUT)=',F8.2)
        END IF
        IF(XSUGIN(7).NE.0) THEN
          WRITE(LOUT,1026) XSUGIN(7)
1026      FORMAT(' Q_max= ',E12.4)
        ENDIF
C
C          Right-handed neutrino parameters
        IF (XNRIN(2).LT.1.E19) THEN
          WRITE(LOUT,1017) XNRIN(1),XNRIN(2),XNRIN(3),XNRIN(4),
     $    FNMZ,FNGUT
1017      FORMAT(' Right-handed neutrino parameters:'/
     $    ' M(nu_tau)=',E10.3,'   M(N_R) =',E10.3,
     $    '   A_N=',F8.2,'   M(NRSS)=',F8.2/
     $    ' FN(M_Z)  =',F8.4, '   FN(M_GUT) =',F8.4)
        END IF
C
C          Unification results
        WRITE(LOUT,1001) MGUTSS,GGUTSS,AGUTSS
1001    FORMAT(/' ISASUGRA unification:'/' M_GUT      =',E10.3,
     $  '   g_GUT          =',F5.3,3X,'   alpha_GUT =',F5.3)
        WRITE(LOUT,999) FTGUT,FBGUT,FTAGUT
999     FORMAT(' FT_GUT     =',F6.3,
     $  '       FB_GUT         =',F6.3,3X,'  FL_GUT =',F6.3)
C
C          Print inputs for GMSB models
C
      ELSE IF (IMODEL.EQ.2) THEN
        WRITE(LOUT,1002) (XGMIN(J),J=1,7)
1002    FORMAT(
     $  ' Lambda,  M_mes,  N_5,  tan(beta),  sgn(mu),  M_t,  C_grav='
     $  /2E10.3,2F10.3,2X,F6.1,F10.3,1X,E10.3)
        WRITE(LOUT,1020) (XGMIN(J),J=8,14)
1020    FORMAT(/' GMSB2 model input:'/
     $  ' Rsl,    dmH_d^2,   dmH_u^2,     d_Y,     N5_1,  N5_2,  N5_3='
     $  /F7.3,1X,E10.3,1X,E10.3,1X,E10.3,2X,3F7.3)
        WRITE(LOUT,1003) AMGVSS
1003    FORMAT(/' M(gravitino)=',E10.3)
      END IF
C
C          Weak scale couplings
C
      WRITE(LOUT,1004) ALEMI,SIN2W,AS
1004  FORMAT(/' 1/alpha_em =',F8.2,2X,
     $'   sin**2(thetaw) =',F6.4,2X,'   alpha_s   =',F5.3)
      WRITE(LOUT,1005) GSS(7),GSS(8),GSS(9)
1005  FORMAT(' M_1        =',F8.2,2X,
     $'   M_2            =',F8.2,'   M_3       =',F8.2)
      WRITE(LOUT,1006) MU,B,HIGFRZ
1006  FORMAT(' mu(Q)      =',F8.2,2X,
     $'   B(Q)           =',F8.2,'   Q         =',F8.2)
      WRITE(LOUT,1007) GSS(13),GSS(14)
1007  FORMAT(' M_H1^2     =',E10.3,'   M_H2^2         =',E10.3)
C
1234  Continue
C
C          Print mass spectrum from ISASUGRA 
C
      WRITE(LOUT,7000) ' '
      WRITE(LOUT,6999) ' M_{GUT} =', MGUTSS
      WRITE(LOUT,7001) 'MASS', 'Scalar and gaugino mass spectrum'
      WRITE(LOUT,7000) ' PDG code   mass                 particle'
C
      If (Testing) then
        WRITE(LOUT,2000) MSS(1),MSS(2),MSS(3),MSS(4),MSS(5),MSS(10),
     $  MSS(11),MSS(12),MSS(13),MSS(14),MSS(17),MSS(18),MSS(16),
     $  MSS(21),MSS(22),MSS(23),MSS(24),MSS(25),MSS(26),MSS(27),
     $  MSS(28),MSS(29),MSS(30),MSS(31),MSS(32)
2000    FORMAT(/' ISAJET masses (with signs):'/
     $  ' M(GL)  =',F9.2/
     $  ' M(UL)  =',F9.2,'   M(UR)  =',F9.2,'   M(DL)  =',F9.2,
     $  '   M(DR) =',F9.2/
     $  ' M(B1)  =',F9.2,'   M(B2)  =',F9.2,'   M(T1)  =',F9.2,
     $  '   M(T2) =',F9.2/
     $  ' M(SN)  =',F9.2,'   M(EL)  =',F9.2,'   M(ER)  =',F9.2/
     $  ' M(NTAU)=',F9.2,'   M(TAU1)=',F9.2,'   M(TAU2)=',F9.2/
     $  ' M(Z1)  =',F9.2,'   M(Z2)  =',F9.2,'   M(Z3)  =',F9.2,
     $  '   M(Z4) =',F9.2/
     $  ' M(W1)  =',F9.2,'   M(W2)  =',F9.2/
     $  ' M(HL)  =',F9.2,'   M(HH)  =',F9.2,'   M(HA)  =',F9.2,
     $  '   M(H+) =',F9.2)
      EndIf
C
C     WRITE(LOUT,7013) iPDG(1),  MT, CHAF(1)
      WRITE(LOUT,7013)      24, AMW, ' W^+'
      DO 370 I=2,33
        sg = 1.
CsB     The signs of the (EW) gaugino masses are flipped according to ISAWIG
        If (iPDG(I).Eq.1000022 .or. iPDG(I).Eq.1000023 .or.
     .      iPDG(I).Eq.1000024 .or. iPDG(I).Eq.1000025 .or.
     .      iPDG(I).Eq.1000035 .or. iPDG(I).Eq.1000037) sg = -1.
        WRITE(LOUT,7013) iPDG(I), sg*MSS(ISA2LHA3(I)), CHAF(I)
 370  CONTINUE
C
C     SUSY scale
      RMSUSY = HIGFRZ !!! check this
      WRITE(LOUT,7000) ' Higgs mixing'
      WRITE(LOUT,7001) 'ALPHA','Effective Higgs mixing parameter'
      WRITE(LOUT,7016) -ALFAH, 'alpha' ! Sign flips for LHA3
C
      If (Testing) then
        WRITE(LOUT,2001) THETAT,THETAB,THETAL,ALFAH
2001    FORMAT(/,' theta_t=',F9.4,'   theta_b=',F9.4,
     $  '   theta_l=',F9.4,'   alpha_h=',F9.4)
      EndIf
C
C     Write out chargino /neutralino masses/eigenvectors
C
      If (Testing) then 
        WRITE(LOUT,3100) AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS
3100    FORMAT(/' NEUTRALINO MASSES (SIGNED) =',4F10.3)
        DO 100 J=1,4
          WRITE(LOUT,3200) J,(ZMIXSS(K,J),K=1,4)
3200      FORMAT(' EIGENVECTOR ',I1,'       =',4F10.5)
100     CONTINUE
        WRITE(LOUT,3300) AMW1SS,AMW2SS
3300    FORMAT(/' CHARGINO MASSES (SIGNED)  =',2F10.3)
        WRITE(LOUT,3400) GAMMAL,GAMMAR
3400    FORMAT(' GAMMAL, GAMMAR             =',2F10.5/)
      EndIf
C
CsB   Comparing Eq.(7.67a) in the book of Baer-Tata with Eq.(16) in 
C     hep-ph/0311123 (the les Houches accord), knowing that the accord 
C     (implicitly) uses the Haber-Kane translation between angles and 
C     mixing matrices it's obvious that one has to flip the sign of the 
C     sfernion mixing angles in ISAJET.
C     HB: I think instead we should dump out isajet mixing matrix since
C     SLHA doesn't ascribe to any particluar mixing scheme 10/28/05
      WRITE(LOUT,7001) 'STOPMIX','stop mixing matrix'
      WRITE(LOUT,7021) 1, 1,  COS(THETAT), 'O_{11}'
      WRITE(LOUT,7021) 1, 2, -SIN(THETAT), 'O_{12}'
      WRITE(LOUT,7021) 2, 1,  SIN(THETAT), 'O_{21}'
      WRITE(LOUT,7021) 2, 2,  COS(THETAT), 'O_{22}'
      WRITE(LOUT,7001) 'SBOTMIX','sbottom mixing matrix'
      WRITE(LOUT,7021) 1, 1,  COS(THETAB), 'O_{11}'
      WRITE(LOUT,7021) 1, 2, -SIN(THETAB), 'O_{12}'
      WRITE(LOUT,7021) 2, 1,  SIN(THETAB), 'O_{21}'
      WRITE(LOUT,7021) 2, 2,  COS(THETAB), 'O_{22}'
      WRITE(LOUT,7001) 'STAUMIX','stau mixing matrix'
      WRITE(LOUT,7021) 1, 1,  COS(THETAL), 'O_{11}'
      WRITE(LOUT,7021) 1, 2, -SIN(THETAL), 'O_{12}'
      WRITE(LOUT,7021) 2, 1,  SIN(THETAL), 'O_{21}'
      WRITE(LOUT,7021) 2, 2,  COS(THETAL), 'O_{22}'
      WRITE(LOUT,7001) 'NMIX','neutralino mixing matrix'
CsB   For the gaugino mixing matrices I follow ISAWIG1200 to the letter
CsB   Ascending mass order (rows) and in the order 
C     (bino, w3ino, higgs1, higgs2) (columns)
      DO I1=1,4
        DO I2=1,4
           sg = 1.
           If (I2.GT.2) sg = -1.
           J1 = 5 - I2
           J2 = I1
          WRITE(LOUT,7021) I1, I2, sg*ZMIXSS(J1,J2)
        EndDo
      EndDo
C
      THX=SIGN(1.,1./TAN(GAMMAL))
      THY=SIGN(1.,1./TAN(GAMMAR))
      WRITE(LOUT,7001) 'UMIX','chargino U mixing matrix'
      WRITE(LOUT,7021) 1, 1, -1.0*SIN(GAMMAL), 'U_{11}'
      WRITE(LOUT,7021) 1, 2, -1.0*COS(GAMMAL), 'U_{12}'
      WRITE(LOUT,7021) 2, 1, -THX*COS(GAMMAL), 'U_{21}'
      WRITE(LOUT,7021) 2, 2,  THX*SIN(GAMMAL), 'U_{22}'
      WRITE(LOUT,7001) 'VMIX','chargino V mixing matrix'
      WRITE(LOUT,7021) 1, 1, -1.0*SIN(GAMMAR), 'V_{11}'
      WRITE(LOUT,7021) 1, 2, -1.0*COS(GAMMAR), 'V_{12}'
      WRITE(LOUT,7021) 2, 1, -THY*COS(GAMMAR), 'V_{21}'
      WRITE(LOUT,7021) 2, 2,  THY*SIN(GAMMAR), 'V_{22}'
C
      WRITE(LOUT,7002) 'GAUGE',RMSUSY !!! check: are these at Q=RMSUSY?
      WRITE(LOUT,7011) 1, SQRT(.6)*GSS(1), 'g`'
      WRITE(LOUT,7011) 2, GSS(2), 'g_2'
      WRITE(LOUT,7011) 3, GSS(3), 'g_3'
C
      WRITE(LOUT,7002) 'YU',RMSUSY
      WRITE(LOUT,7021) 3, 3, GSS( 6), 'y_t' !!! check: are these at Q=RMSUSY?
C
      WRITE(LOUT,7002) 'YD',RMSUSY
      WRITE(LOUT,7021) 3, 3, GSS( 5), 'y_b'
C
      WRITE(LOUT,7002) 'YE',RMSUSY
      WRITE(LOUT,7021) 3, 3, GSS( 4), 'y_tau'
C
      WRITE(LOUT,7002) 'HMIX',RMSUSY,'Higgs mixing parameters' !!! check: are these at Q=RMSUSY?
      WRITE(LOUT,7011) 1,           MU, 'mu(Q)'
      WRITE(LOUT,7011) 2,        XtanB, 'tan(beta)(M_{GUT})'
      WRITE(LOUT,7011) 3, Sqrt(2.)*VEV, 'Higgs vev at Q'
      WRITE(LOUT,7011) 4,   MSS(31)**2, 'm_A^2(Q)'
C
      WRITE(LOUT,7002) 'MSOFT',RMSUSY,
     ,                 'DRbar SUSY breaking parameters' !!! check: are these at Q=RMSUSY?
      Do I=1,3
        If (I2L3GSS(I).NE.0)
     ,  WRITE(LOUT,7011) I,          GSS(I2L3GSS(I)),   SoftParaLHA(I)
      End Do
      Do I=4,50
        If (I2L3GSS(I).NE.0) !!! Fix sign - if necessary 
     ,  WRITE(LOUT,7011) I, Sqrt(Abs(GSS(I2L3GSS(I)))), SoftParaLHA(I)
      End Do
C
      WRITE(LOUT,7002) 'AU',RMSUSY
      WRITE(LOUT,7021) 1, 1, GSS(12), 'A_u' 
      WRITE(LOUT,7021) 2, 2, GSS(12), 'A_c' 
      WRITE(LOUT,7021) 3, 3, GSS(12), 'A_t' 
C
      WRITE(LOUT,7002) 'AD',RMSUSY
      WRITE(LOUT,7021) 1, 1, GSS(11), 'A_d' 
      WRITE(LOUT,7021) 2, 2, GSS(11), 'A_s' 
      WRITE(LOUT,7021) 3, 3, GSS(11), 'A_b' 
C
      WRITE(LOUT,7002) 'AE',RMSUSY
      WRITE(LOUT,7021) 1, 1, GSS(10), 'A_e' 
      WRITE(LOUT,7021) 2, 2, GSS(10), 'A_mu' 
      WRITE(LOUT,7021) 3, 3, GSS(10), 'A_tau' 
C
C          Print ISAJET MSSMi equivalent input
C
      If (Testing) then
        WRITE(LOUT,3000)
3000    FORMAT(/' ISAJET equivalent input:')
        WRITE(LOUT,3001) MSS(1),MU,MSS(31),XSUGIN(4)
3001    FORMAT(' MSSMA: ',4F8.2)
        WRITE(LOUT,3002) SQRT(GSS(19)),SQRT(GSS(17)),SQRT(GSS(18)),
     $  SQRT(GSS(16)),SQRT(GSS(15))
3002    FORMAT(' MSSMB: ',5F8.2)
        WRITE(LOUT,3003) SIGN(1.,GSS(24))*SQRT(ABS(GSS(24))),
     $  SQRT(GSS(22)),SIGN(1.,GSS(23))*SQRT(ABS(GSS(23))),
     $  SQRT(GSS(21)),SQRT(GSS(20)),GSS(12),GSS(11),GSS(10)
3003    FORMAT(' MSSMC: ',8F8.2)
        WRITE(LOUT,3004)
3004    FORMAT(' MSSMD: SAME AS MSSMB (DEFAULT)')
        WRITE(LOUT,3005) GSS(7),GSS(8)
3005    FORMAT(' MSSME: ',2F8.2)
      EndIf
C
      Close(91)
C
CsB LHA3 format statements
C
C     Formats for user information printout.
 5000 FORMAT(1x,17('*'),1x,'ISALHA v1.0: SUSY SPECTRUM '
     &     ,'INTERFACE',1x,17('*')/1x,'*',3x
     &     ,'ISALHA: Last Change',1x,A,1x,'-',1x,'C. Balazs')
 5001 FORMAT(1x,'*',3x,'Writing spectrum file on unit: ',I3)
 5002 FORMAT(1x,'*',3x,'Reading spectrum file on unit: ',I3)
 5003 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
 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,4x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
     &     4x,'~c',2x,1x,1x,'~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,4x,'~e',2x,1x,2x,'~nu_e',2x,1x,3x,'~mu',2x
     &     ,1x,1x,'~nu_mu',1x,1x,'~tau(12)',1x,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,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
     &     ,1x,4x,'H+'/1x,'*',3x,1x,5(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 ISALHA',1x,31('*'))
C
C     Format to use for comments
 6999 FORMAT('# ',A,1x,E16.8)
 7000 FORMAT('# ',A)
C     Format to use for block statements
 7001 FORMAT('Block',1x,A,3x,'#',1x,A)
 7002 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
C     Indexed Int
 7010 FORMAT(1x,I5,1x,I5,3x,'#',1x,A)
C     Indexed Double
 7011 FORMAT(1x,I5,3x,1P,E16.8,0P,3x,'#',1x,A)
C     Indexed Char(12)
 7012 FORMAT(1x,I5,3x,A27,3x,'#',1x,A)
C     Long Indexed Double
 7013 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
C     Indexed Double without leading integer
 7016 FORMAT(8x,1P,E16.8,0P,3x,'#',1x,A)
C     Double Matrix
 7022 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
C     Single matrix
 7021 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
C     Write Decay Table
 7500 FORMAT('Decay',1x,I9,1x,'WIDTH=',1P,E16.8,0P,3x,'#',1x,A)
 7501 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
C
      RETURN
      END
+EOD
+DECK,ISALHD
C--------------------------------------------------------------------
      SUBROUTINE ISALHD(LOUT,ID,J,JMAX)
C--------------------------------------------------------------------
C     
C     Output decay modes for ID in 'Les Houches accord 3' (LHA3) format
C     C. Balazs, May 21 2005, v0.1
C
C     Note these need not be contiguous, so the loop is over all modes 
C     in /SSMODE/.

CsB   ISAJET common blocks from SSPRT ...
CsB   ... explicitly included from v7.71
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSMODE
CsB   End of ISAJET common blocks
CsB   Local ISAJET related variables
      INTEGER ID,J,JMAX, I,K,NOUT,LOUT
      CHARACTER*5 SSID,LBLIN,LBLOUT(4)
      CHARACTER*40 VERSN,VISAJE
C
CsB   Local LHA3 related variables
      Integer PDGID,PDGIN,PDGOUT(4),iCnt
      Real Width
C
      If (J.EQ.1) then
C      	LOUT = 92
CsB     Open output file
      	Open(LOUT,FILE='ISALHD.out',FORM='FORMATTED')
CsB     Write header
        WRITE(LOUT,7000) 
     .  ' ISAJET decay tables in SUSY Les Houches accord format'
        WRITE(LOUT,7000)
     .  ' Created by ISALHD. Last revision: C. Balazs, 2005 May 25'
        VERSN=VISAJE()
        VERSN=VERSN(14:)
        WRITE(LOUT,7001)    'DCINFO', 
     ,                      'Program information'
        WRITE(LOUT,7012) 1, 'ISASUGRA from ISAJET       ',
     ,                      'Spectrum Calculator'
        WRITE(LOUT,7012) 2,  VERSN, 
     ,                      'Version number'

      End If
C
      Width=0.d0
      DO 90 I=1,NSSMOD
        IF(ISSMOD(I).NE.ID) GO TO 90
        LBLIN=SSID(ISSMOD(I))
        Width = Width + GSSMOD(I)
 90   CONTINUE
C
      iCnt=0
      NOUT=0
      DO 100 I=1,NSSMOD
        IF(ISSMOD(I).NE.ID) GO TO 100
        NOUT=NOUT+1
        LBLIN=SSID(ISSMOD(I))
        PDGIN=PDGID(LOUT,ISSMOD(I))
        If (iCnt.Eq.0) then
          Write(LOUT,'(A)') '#         PDG         Width'
          Write(LOUT,7500) PDGIN,Width,LBLIN//' decays'
          Write(LOUT,'(A)') '#          BR          NDA       ID1       
     .ID2       ID3       ID4'
          iCnt=1
        End If
        DO 110 K=1,4
        PDGOUT(K)=PDGID(LOUT,JSSMOD(K,I))
110     LBLOUT(K)=SSID(JSSMOD(K,I))
        If (PDGOUT(4).Eq.0) then
          If (PDGOUT(3).Eq.0) then
            WRITE(LOUT,7502) BSSMOD(I),2,
     ,                       PDGOUT(1),PDGOUT(2),
     ,                       LBLIN,(LBLOUT(K),K=1,4)
          Else
            WRITE(LOUT,7503) BSSMOD(I),3,
     ,                       PDGOUT(1),PDGOUT(2),PDGOUT(3),
     ,                       LBLIN,(LBLOUT(K),K=1,4)
          End If
        Else
            WRITE(LOUT,7504) BSSMOD(I),4,
     ,                       PDGOUT(1),PDGOUT(2),PDGOUT(3),PDGOUT(4),
     ,                       LBLIN,(LBLOUT(K),K=1,4)
        End If
100   CONTINUE
C
      If (J.EQ.JMAX) Close(LOUT)
C
CsB LHA3 format statements
C
 7000 FORMAT('# ',A)
C     Format to use for block statements
 7001 FORMAT('Block',1x,A,27x,'#',1x,A)
C     Indexed Char(12)
 7012 FORMAT(1x,I5,3x,A27,3x,'#',1x,A)
C     Write Decay Table
 7500 FORMAT('DECAY',1x,I9,1P,E16.8,0P,3x,'#',1x,A)
 7502 FORMAT(4x,1P,E16.8, 0P,3x,I2, 
     ,  0P,4x,I9, 0P,1x,I9,  23x,'#',1x,
     ,  A5,'  -->  ',4(A5,2X))
 7503 FORMAT(4x,1P,E16.8, 0P,3x,I2, 
     ,  0P,4x,I9, 0P,1x,I9, 0P,1x,I9,  13x,'#',1x,
     ,  A5,'  -->  ',4(A5,2X))
 7504 FORMAT(4x,1P,E16.8, 0P,3x,I2, 
     ,  0P,4x,I9, 0P,1x,I9, 0P,1x,I9, 0P,1x,I9,  3x,'#',1x,
     ,  A5,'  -->  ',4(A5,2X))
      RETURN
      END
+EOD
+DECK,ISAWIG.
C-----------------------------------------------------------------------
C
C                          HERWIG-ISAJET interface
C
C-----------------------------------------------------------------------
C
C                    VERSION 1.200 of 24th September 2002.
C
C-----------------------------------------------------------------------
C  Subroutines to produce an output file from ISAJET with SUSY masses 
C  and decay modes in a form HERWIG can read in.
C-----------------------------------------------------------------------
C  We also include the code to calculate the R-parity violating decay
C  modes which ISAJET does not include
C-----------------------------------------------------------------------
C  We now include an interface to HDECAY to allow the use of 
C  next-to-leading order Higgs decay rates
C-----------------------------------------------------------------------
C
C  We have made changes to allow the use of the code with either ISAJET
C  7.63/64 or 7.58 this is to enable the Snowmass accord points to be 
C  still be generated with the defined version of ISAJET.
C
C  The default is ISAJET7.64 in order to obtain code compatible with
C  7.63/7.58 the compiler option
C
C  -DISAJET758   for ISAJET7.58
C  -DISAJET763   for ISAJET7.63
C
C  should be used.
C
C-----------------------------------------------------------------------
C
C  We have also made changes to make using HDECAY easier and to allow 
C  the use of the new version of HDECAY.
C
C  The default is to compile a dummy subroutine. If you wish to use
C  HDECAY you should use the following compiler options
C
C -DHDECAY2   for version 2.0 of HDECAY
C -DHDECAY3   for version 3.0 of HDECAY
C
C-----------------------------------------------------------------------
C
C       F. Paige, March 2005:
C  Patchy format; Isajet common blocks included with +CDE statements.
C  OPEN statement removed.
C  Unit number for output passed as first argument, IH, and DATA
C  statement removed.
C  HDECAY version number (0,2,3) passed as second argument, IHDCY.
C  Ignored unless corresponding version selected with Patchy flag.
C
C-----------------------------------------------------------------------
C
C  This block contains the following code
C
C  ISAWIG to output the HERWIG decay table
C
C  Subroutines for R parity
C
C  RPDECY calculates all the decay rates
C  RPINF1 is a function for the amplitude squared terms in 3-body ME's
C  RPINF2 is a function for the interference terms in 3-body ME's
C  RPINT1 is the integrand for RPINF1
C  RPINT2 is the integrand for LR interference terms
C  RPINT3 is the integrand for the remaining terms
C  RPMAIN routine for the user to enter the couplings
C  RPNORM adds R-parity modes to tables, and removes modes < MINBR
C  RPMODA adds an R-parity violating mode to the table
C  RPRATE is a function for the 2-body rates
C  RPRTCH routine to test for negative square roots
C
C  HDECAY interface routines
C
C  HDCYAD is a routine used by the HDECAY interface to add decay modes
C         to the ISAJET decay tables
C  HDCYSY is the interface routine to HDECAY
C
C--13/04/99 Modified to work with ISAJET 7.42  by Peter Richardson 
C--02/07/01 Modified to work with AMSB models in ISAJET 7.48 and 7.51
C                       by Bryan Webber
C--09/04/02 Fixes to various RPV bugs and top decays to charged Higgs
C                       by Peter Richardson
C--19/09/02 Changes to allow use with either ISAJET7.58 or ISAJET7.63
C                       by Peter Richardson
C--19/09/02 Incorperated the HDECAY interface and made changes to allow
C           the use of HDECAY2 or 3 by Peter Richardson
C--24/09/02 Checked the code worked with ISAJET7.64 Peter Richardson
C
C-----------------------------------------------------------------------
C All the RPV rates from JHEP 0004:008,2000 
C                        by H. Dreiner, P. Richardson and M.H. Seymour
C-----------------------------------------------------------------------
C-----------------------------------------------------------------------
CDECK  ID>, ISAWIG
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author : Bryan Webber, Kosuke Odagiri & Peter Richardson
C-----------------------------------------------------------------------       
      SUBROUTINE ISAWIG(IH,IHDCY,MT,M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,
     &                      MER2,MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR)
C-----------------------------------------------------------------------
C
C  Writes a table of SUSY particle (and top quark) properties
C  and decays in a format suitable for reading by HERWIG.
C  Call at end of SSRUN or SUGRUN.
C  MT = top mass used in ISASUSY or ISASUGRA.
C  Other parameters passed via common /SUGMG/ & /SSMODE/
C
C--18/08/98 modified by BRW to include gravitino (for GMSB option)
C--11/01/99 modified by KO to output mixing matrices in correct format
C--18/01/99 modified by KO to output correct sign of ALFAH
C--02/04/99 modified by PR to include R-parity violation
C--13/04/99 modified by PR to work with ISAJET 7.42
C--23/04/99 modified by PR to inculde KO A and mu terms
C--25/05/99 modified by PR to change R-parity ME code to 300
C--18/06/99 modified by PR to move data statements and rewrite a format
C                             statement caused problems with LINUX 
C--14/08/99 modified by PR to change file format and remove modes < MINBR
C--16/11/99 modified by PR to interface with HDECAY
C--31/03/00 modified by PR to fix a bug in the chargino mixing,
C                             the sfermion mixing angles
C--25/05/00 modified by BRW to include 1st and 2nd generation pseudoscalar
C                              mesons as possible decay products (for AMSB)
C-----------------------------------------------------------------------
+SELF=IF=IMPNONE
      IMPLICIT NONE
+SELF
C
C          ISAJET common blocks and EQUIVALENCE
C
+CDE,SSMODE
+CDE,SSPAR
      REAL MSS(72)
      EQUIVALENCE (AMGLSS,MSS(1))
C
C  Common Block for the R-parity violating couplings
      COMMON/RSLASH/LAMDA1(3,3,3),LAMDA2(3,3,3),LAMDA3(3,3,3),RPARTY
      LOGICAL RPARTY
      REAL LAMDA1,LAMDA2,LAMDA3
      SAVE /RSLASH/
C--Inputs from ISAJET
      REAL MT,M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,MER2,
     &                        MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR
C
      REAL GEV2S,WIDTH,LTIM,MASS,THX,THY
      INTEGER IDEC(5),I,J,K,L,M,ID,JD,IH,NSS,NPP
      INTEGER IHDCY
C  SUSY HERWIG names, charge & PDG codes, ISAJET ID & mass codes
      PARAMETER (NSS=65,NPP=NSS+43)
      INTEGER IMISA(NSS),NDEC(NSS),IDHW(NPP),IDISA(NPP)
      DATA (IDISA(I),IMISA(I),I=1,NSS-2)/
     & 22, 4, 21, 2, 23, 6, 24, 8, 25,12, 26,16,-22, 4,-21, 2,
     &-23, 6,-24, 8,-25,12,-26,16, 42, 5, 41, 3, 43, 7, 44, 9,
     & 45,13, 46,17,-42, 5,-41, 3,-43, 7,-44, 9,-45,13,-46,17,
     & 32,18, 31,26, 34,20, 33,27, 36,24, 35,28,-32,18,-31,26,
     &-34,20,-33,27,-36,24,-35,28, 52,19, 51, 0, 54,21, 53, 0,
     & 56,25, 55, 0,-52,19,-51, 0,-54,21,-53, 0,-56,25,-55, 0,
     & 29, 1, 30,31, 40,32, 50,33, 60,34, 39,51, 49,52,-39,51,
     &-49,52, 82,55, 83,56, 84,57, 86,58,-86,58, 91,66/
C  non-SUSY HERWIG names & codes, PDG & ISAJET codes
      DATA (IDHW(I),IDISA(I),I=NSS-1,NPP)/
     &  6,  6, 12, -6,  1,  2,  2,  1,  3,  3,  4,  4,  5,  5,  7, -2,
     &  8, -1,  9, -3, 10, -4, 11, -5,121, 12,122, 11,123, 14,124, 13,
     &125, 16,126, 15,127,-12,128,-11,129,-14,130,-13,131,-16,132,-15,
     & 13,  9, 59, 10,198, 80,199,-80,200, 90,
     & 21, 110, 38, 120, 30,-120, 22, 220, 46, 130, 34,-130,
     & 50, 230, 42,-230, 25, 330,175, 140,140,-140,171, 240,
     &136,-240,179, 340,144,-340,163, 440/
C--constants etc.
      DATA GEV2S/6.582122E-25/
      DATA NDEC/NSS*0/
C Input variable
      CHARACTER *1 HYORN
C  Decide whether or not to use HDECAY
C  Valid version (2 or 3) must be defined with Patchy flag.
+SELF,IF=HDECAY2
      IF(IHDCY.EQ.2) THEN
        CALL HDCYSY(M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,MER2,
     &                 MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR) 
      ENDIF
+SELF,IF=HDECAY3
      IF(IHDCY.EQ.3) THEN
        CALL HDCYSY(M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,MER2,
     &                 MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR) 
      ENDIF
+SELF
C  Calculate the R-parity violating modes
      CALL RPMAIN
C  Add R-parity violating modes if needed and remove all modes less MINBR
      CALL RPNORM
C  Tell HERWIG where to store SUSY particles
      DO I=1,57
        IDHW(I)=400+I
      ENDDO
      DO I=58,62
        IDHW(I)=145+I
      ENDDO
      IDHW(63)=458
C
C  Output SUSY particle + top quark table
C
      WRITE (IH,'(I4)') NSS
      DO I=1,NSS
        IF (I.LT.63) THEN
          MASS=0.
          IF (IMISA(I).NE.0) MASS=MSS(IMISA(I))
          IF (I.GT.49.AND.I.LT.58) MASS=-MASS
        ELSEIF (I.EQ.63) THEN
          MASS=0.
        ELSE
C t and tbar
          MASS=MT
        ENDIF
C  Compute lifetime in ps
        ID=ABS(IDISA(I))
        WIDTH=0.
        DO J=1,NSSMOD
          IF (ISSMOD(J).EQ.ID) THEN
            NDEC(I)=NDEC(I)+1
            WIDTH=WIDTH+GSSMOD(J)
          ENDIF
        ENDDO
        IF (WIDTH.NE.0.) THEN
          LTIM=GEV2S/WIDTH
        ELSE
          LTIM=1E30
        ENDIF
        WRITE (IH,1) IDHW(I),MASS,LTIM
      ENDDO
    1 FORMAT(I5,F12.4,E15.5)
C 
C  Output decay modes
C
      DO I=1,NSS
        WRITE (IH,'(I4)') NDEC(I)
        IF (NDEC(I).NE.0) THEN
          ID=ABS(IDISA(I))
          DO J=1,NSSMOD
            IF (ISSMOD(J).EQ.ID) THEN
C  Translate decay products
              DO K=1,5
                L=JSSMOD(K,J)
                IF (L.EQ.0) THEN
                  IDEC(K)=0
                ELSE
                  IF (IDISA(I).LT.0) L=-L
                  DO M=1,NPP
                    IF (IDISA(M).EQ.L) THEN
                      IDEC(K)=IDHW(M)
                      GO TO 10
                    ENDIF
                  ENDDO
C   Antiparticle=particle
                  L=-L
                  DO M=1,NPP
                    IF (IDISA(M).EQ.L) THEN
                      IDEC(K)=IDHW(M)
                      GO TO 10
                    ENDIF
                  ENDDO
                  PRINT *,' Unknown ISAJET ID =',L
                  IDEC(K)=20
   10             CONTINUE
                ENDIF
              ENDDO
              JD=IDHW(I)
              IF (JD.EQ.6.OR.JD.EQ.12) THEN
C--bug fix 9/04/02 by P.R. for t --> H b
C   Special for t and tbar
                IF (IDEC(1).GT.120.AND.IDEC(1).LT.133.AND.
     &              IDEC(3).NE.0) THEN
C   Leptonic decay: ISAJET order is wrong for M.E. calcn
                  WRITE (IH,11) JD,BSSMOD(J),100,IDEC(2),IDEC(1),
     &                  IDEC(3),0,0
                ELSEIF(IDEC(3).NE.0) THEN
C   Nonleptonic decay
                  WRITE (IH,11) JD,BSSMOD(J),100,(IDEC(K),K=1,5)
C--Higgs decay
                ELSE
                  WRITE (IH,11) JD,BSSMOD(J),0,(IDEC(K),K=1,5)
                ENDIF
C--end of fix
C   RPARITY 3-body matrix elements, all code 200, HERWIG decides what to do
              ELSEIF(JD.GE.449.AND.JD.LE.457.AND.IDEC(1).LE.140.
     &          AND.IDEC(2).LE.140.AND.IDEC(3).LE.140) THEN
                WRITE (IH,11) JD,BSSMOD(J),300,(IDEC(K),K=1,5)
              ELSE
                WRITE (IH,11) JD,BSSMOD(J),0,(IDEC(K),K=1,5)
              ENDIF
   11         FORMAT(I6,E16.8,6I6)
   12         FORMAT(1X,A8,'  -->   ',3(A8,2X),1P,E12.4)
            ENDIF
          ENDDO
        ENDIF
      ENDDO  
C  tan(beta) and alpha, neutralinos, charginos, and sfermion mixings
      WRITE (IH,'(2F16.8)') 1./MSS(30),-MSS(59)
C  neutralino mixing matrix - in ascending mass order (rows)
C             and in the order (bino, w3ino, higgs1, higgs2) (columns)
      WRITE (IH,13) MSS(38),MSS(37),-MSS(36),-MSS(35)
      WRITE (IH,13) MSS(42),MSS(41),-MSS(40),-MSS(39)
      WRITE (IH,13) MSS(46),MSS(45),-MSS(44),-MSS(43)
      WRITE (IH,13) MSS(50),MSS(49),-MSS(48),-MSS(47)
C--Bug fix 22/03/00 by Peter Richardson
      THX=SIGN(1.0D0,1.0D0/TAN(MSS(53)))
      THY=SIGN(1.0D0,1.0D0/TAN(MSS(54)))
c                   WMXVSS(1,1) WMXVSS(1,2)  WMXVSS(2,1) WMXVSS(2,2)
      WRITE (IH,13)     -SIN(MSS(54)),    -COS(MSS(54)),
     &              -THY*COS(MSS(54)),THY*SIN(MSS(54))
c                   WMXUSS(1,1) WMXUSS(1,2)  WMXUSS(2,1) WMXUSS(2,2)
      WRITE (IH,13)      -SIN(MSS(53)),  -COS(MSS(53)),
     &               -THX*COS(MSS(53)),THX*SIN(MSS(53))
C  sfermion mixing A terms and mu for 
      WRITE (IH,'(3F16.8)') -MSS(61),-MSS(63),-MSS(65)
      WRITE (IH,'(3F16.8)')  MSS(60),MSS(62),MSS(64)
      WRITE (IH,'( F16.8)') -MSS(29)
C  R-parity violating couplings
      WRITE(IH,'(L5)') RPARTY
      IF(.NOT.RPARTY) THEN
        WRITE(IH,20) (((LAMDA1(I,J,K),K=1,3),J=1,3),I=1,3)
        WRITE(IH,20) (((LAMDA2(I,J,K),K=1,3),J=1,3),I=1,3)
        WRITE(IH,20) (((LAMDA3(I,J,K),K=1,3),J=1,3),I=1,3)
      ENDIF
      RETURN
 13   FORMAT(4F16.8)
 19   FORMAT(I6)
 20   FORMAT(27E16.8)
      END
CDECK  ID>, RPDECY
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
      SUBROUTINE RPDECY
C----------------------------------------------------------------------- 
C     SUBROUTINE TO CALCULATE ALL THE R-PARITY VIOLATING RATES
C     2-BODY SQUARK AND SLEPTON
C     3-BODY NEUTRALINO, GLUINO AND CHARGINO
C----------------------------------------------------------------------- 
C
+SELF=IF=IMPNONE
      IMPLICIT NONE
+SELF
C
C          ISAJET common blocks and EQUIVALENCE
C
+CDE,SSMODE
+CDE,SSPAR
      REAL MSS(72)
      EQUIVALENCE (AMGLSS,MSS(1))
C
C--Common block containing the Rparity violating couplings
C
      COMMON/RSLASH/LAMDA1(3,3,3),LAMDA2(3,3,3),LAMDA3(3,3,3),RPARTY
      LOGICAL RPARTY
      REAL LAMDA1,LAMDA2,LAMDA3
      SAVE /RSLASH/
C   
C--Common block containing the Standard Model parameters          
C 
+CDE,SSSM
C
C--Common Block to contain R-parity violating decay rates
C
      INTEGER NRPMD
      PARAMETER (NRPMD=5000)
      COMMON/RPARRT/NSSMD2,ISSMD2(NRPMD),JSSMD2(5,NRPMD),
     &              GSSMD2(NRPMD),BSSMD2(NRPMD)
      REAL GSSMD2,BSSMD2
      INTEGER ISSMD2,JSSMD2,NSSMD2
      SAVE /RPARRT/
+CDE,SSLUN
      REAL M(4),RESM(6),WIDTH(6),A(6),B(6)
      LOGICAL CRSTRM(6)
C--External isajet gaussian quadrature routine
      REAL RPINF1,RPINF2
      EXTERNAL RPRATE,RPINF1,RPINF2
C--Local Variables
      REAL MQU(6),MLP(3),MSLLT(6),MSLRT(3),MSQLT(6),MSQRT(6),MIXING(6),
     &     RATE,RPRATE,SLLTWD(6),SLRTWD(3),SQLTWD(6),CHARWD,CHARM(2), 
     &     SQRTWD(6),PI,G,ECHAR,CBETA,SBETA,CWEAK,LAMCOL,NEUTWD,  
     &     SWEAK,NPRIME(4,4),TBETA,GLUWD,WMXVSS(2,2),WMXUSS(2,2),
     &     BMIXSS(2,2),TMIXSS(2,2),LMIXSS(2,2),LCHAR(4),RCHAR(4),
     &     MCHAR(2),THX,THY
      INTEGER I,J,K,L,PIN,POUT1,POUT2,POUT3,CHANEL,N,NMSIGN(4),MIX,
     &        CMSIGN(2)
      REAL ZERO,ONE,EPS
      PARAMETER (ZERO=0.0,ONE=1.0,EPS=1E-40)
C--Couplings, etc
      PI = 3.1415926E0
      ECHAR = SQRT(4*PI*ALFAEM) 
      G     = SQRT(4*PI*ALFA2)
      TBETA = 1./RV2V1
      CBETA = COS(ATAN(TBETA))
      SBETA = SIN(ATAN(TBETA))
      CWEAK = COS(ASIN(SQRT(SN2THW)))
      SWEAK = SQRT(SN2THW)
C--Neutralino mixing
      DO I=1,4
        NMSIGN(I) = -INT(AMZISS(I)/ABS(AMZISS(I)))
      ENDDO
      DO I=1,4
        NPRIME(I,1) = ZMIXSS(4,I)*CWEAK+ZMIXSS(3,I)*SWEAK
        NPRIME(I,2) = -ZMIXSS(4,I)*SWEAK+ZMIXSS(3,I)*CWEAK
        NPRIME(I,3) = -ZMIXSS(2,I)
        NPRIME(I,4) = -ZMIXSS(1,I)
      ENDDO
C--Chargino mixing, fixed 01/04/00 PR
      THX=SIGN(1.0D0,1.0D0/TAN(GAMMAL))
      THY=SIGN(1.0D0,1.0D0/TAN(GAMMAR))
      CMSIGN(1) = -INT(AMW1SS/ABS(AMW1SS))
      CMSIGN(2) = -INT(AMW2SS/ABS(AMW2SS))
      WMXVSS(1,1) =    -SIN(GAMMAR)
      WMXVSS(1,2) =    -COS(GAMMAR)
      WMXVSS(2,1) =-THY*COS(GAMMAR)
      WMXVSS(2,2) = THY*SIN(GAMMAR) 
      WMXUSS(1,1) =    -SIN(GAMMAL)
      WMXUSS(1,2) =    -COS(GAMMAL)
      WMXUSS(2,1) =-THX*COS(GAMMAL)
      WMXUSS(2,2) = THX*SIN(GAMMAL)
      CHARM(1) = AMW1SS
      CHARM(2) = AMW2SS
C--Number of R-parity violating modes
      NSSMD2    = 0
C--Set up local mass variables 
      MQU(1)   = AMDN 
      MQU(2)   = AMUP
      MQU(3)   = AMST
      MQU(4)   = AMCH
      MQU(5)   = AMBT
      MQU(6)   = AMTP
      MLP(1)   = AME 
      MLP(2)   = AMMU
      MLP(3)   = AMTAU
      MSLLT(1) = AMELSS
      MSLLT(2) = AMN1SS
      MSLLT(3) = AMMLSS
      MSLLT(4) = AMN2SS
      MSLLT(5) = AML1SS
      MSLLT(6) = AMN3SS
      MSLRT(1) = AMERSS
      MSLRT(2) = AMMRSS
      MSLRT(3) = AML2SS
      MSQLT(1) = AMDLSS
      MSQLT(2) = AMULSS
      MSQLT(3) = AMSLSS
      MSQLT(4) = AMCLSS
      MSQLT(5) = AMB1SS
      MSQLT(6) = AMT1SS
      MSQRT(1) = AMDRSS
      MSQRT(2) = AMURSS
      MSQRT(3) = AMSRSS
      MSQRT(4) = AMCRSS
      MSQRT(5) = AMB2SS
      MSQRT(6) = AMT2SS
C--Scalar top/bottom/tau mixing, bug fix 01/04/00 PR
      TMIXSS(1,1) =  COS(THETAT) 
      TMIXSS(1,2) = -SIN(THETAT)
      TMIXSS(2,1) =  SIN(THETAT)
      TMIXSS(2,2) =  COS(THETAT)
      BMIXSS(1,1) =  COS(THETAB)
      BMIXSS(1,2) = -SIN(THETAB)
      BMIXSS(2,1) =  SIN(THETAB)
      BMIXSS(2,2) =  COS(THETAB)
      LMIXSS(1,1) =  COS(THETAL)
      LMIXSS(1,2) = -SIN(THETAL)
      LMIXSS(2,1) =  SIN(THETAL)
      LMIXSS(2,2) =  COS(THETAL)
C--Now begin the rate calculation
C  Scalar decay rates via Rparity violation
C--CHECKED AGAINST CALCULATIONS PR 1/4/99
C--First the rates of left charged leptons
      DO I=1,3
        DO J=1,3
          DO K=1,3
C--Via LLE
            RATE = ZERO
            IF(I.NE.3) THEN 
              IF(ABS(LAMDA1(J,I,K)).GT.EPS) 
     &          RATE = RPRATE(LAMDA1(J,I,K)**2,
     &                      MSLLT(2*I-1),MLP(K),ZERO)
                CALL RPMODA(RATE,30+2*I,10+2*K,-(9+2*J),0)
            ELSE
C--New for left/right stau mixing
              IF(ABS(LAMDA1(J,I,K)).GT.EPS) THEN
                RATE = RPRATE(LAMDA1(J,I,K)**2*LMIXSS(1,1)**2,
     &                      MSLLT(2*I-1),MLP(K),ZERO) 
                CALL RPMODA(RATE,36,10+2*K,-(9+2*J),0)
                RATE = RPRATE(LAMDA1(J,I,K)**2*LMIXSS(1,2)**2,
     &                      MSLRT(I),MLP(K),ZERO)
                CALL RPMODA(RATE,56,10+2*K,-(9+2*J),0)
              ENDIF
            ENDIF
C--Via LUD
            RATE = ZERO
            IF(J.EQ.1) POUT1 = -1
            IF(J.GT.1) POUT1 = -2*J
            IF(K.EQ.1) POUT2 = 2
            IF(K.GT.1) POUT2 = 2*K-1
            IF(I.NE.3) THEN
              IF(ABS(LAMDA2(I,J,K)).GT.EPS) 
     &          RATE = RPRATE(3*LAMDA2(I,J,K)**2,MSLLT(2*I-1),
     &                        MQU(2*J),MQU(2*K-1))
                CALL RPMODA(RATE,30+2*I,POUT1,POUT2,0)
            ELSE
C--New for left/right stau mixing
              IF(ABS(LAMDA2(I,J,K)).GT.EPS) THEN
                RATE=RPRATE(3*LAMDA2(I,J,K)**2*LMIXSS(1,1)**2,
     &                      MSLLT(2*I-1), MQU(2*J),MQU(2*K-1))
                CALL RPMODA(RATE,30+2*I,POUT1,POUT2,0)
                RATE=RPRATE(3*LAMDA2(I,J,K)**2*LMIXSS(1,2)**2,
     &                      MSLRT(I), MQU(2*J),MQU(2*K-1))
                CALL RPMODA(RATE,56,POUT1,POUT2,0)
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDDO
C--Now right charged leptons via LLE
      DO K=1,3
        DO I=1,3
          DO J=1,3
            RATE = ZERO
            IF(K.NE.3) THEN
              IF(ABS(LAMDA1(I,J,K)).GT.EPS) 
     &          RATE = RPRATE(LAMDA1(I,J,K)**2,MSLRT(K),
     &                     MLP(J),ZERO) 
                CALL RPMODA(RATE,50+2*K,10+2*J,9+2*I,0)
            ELSE
C--New for left/right stau mixing
              IF(ABS(LAMDA1(I,J,K)).GT.EPS) THEN
                RATE = RPRATE(LAMDA1(I,J,K)**2*LMIXSS(2,1)**2,
     &                     MSLLT(2*K-1),MLP(J),ZERO) 
                CALL RPMODA(RATE,36,10+2*J,9+2*I,0)
                RATE = RPRATE(LAMDA1(I,J,K)**2*LMIXSS(2,2)**2,
     &                     MSLRT(K),MLP(J),ZERO) 
                CALL RPMODA(RATE,56,10+2*J,9+2*I,0)
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDDO
C--Now sneutrinos 
      DO I=1,3
        DO J=1,3
          DO K=1,3
C--Via LLE
            RATE = ZERO
            IF(ABS(LAMDA1(J,I,K)).GT.EPS) 
     &        RATE = RPRATE(LAMDA1(J,I,K)**2,MSLLT(2*I),
     &                      MLP(J),MLP(K))
              CALL RPMODA(RATE,29+2*I,-(10+2*J),10+2*K,0)
C--Via LUD
            RATE = ZERO
            IF(ABS(LAMDA2(I,J,K)).GT.EPS)
     &         RATE = RPRATE(3*LAMDA2(I,J,K)**2,MSLLT(2*I)
     &                      ,MQU(2*J-1),MQU(2*K-1))
              IF(J.EQ.1) POUT1 = -2
              IF(J.GT.1) POUT1 = 1-2*J
              IF(K.EQ.1) POUT2 = 2
              IF(K.GT.1) POUT2 = 2*K-1
              CALL RPMODA(RATE,29+2*I,POUT1,POUT2,0)
          ENDDO
        ENDDO
      ENDDO  
C--Now left up squarks via LUD
      DO J=1,3
        DO I=1,3
          DO K=1,3
            RATE = ZERO
            IF(J.EQ.1) PIN   = 21
            IF(J.GT.1) PIN   = 20+2*J
            IF(K.EQ.1) POUT1 = 2
            IF(K.GT.1) POUT1 = 2*K-1
            IF(J.NE.3) THEN
              IF(ABS(LAMDA2(I,J,K)).GT.EPS) 
     &           RATE = RPRATE(LAMDA2(I,J,K)**2,MSQLT(2*J),
     &                        MQU(2*K-1),MLP(I))
              CALL RPMODA(RATE,PIN,-(2*I+10),POUT1,0)
            ELSE
C-- New for left/right stop mixing
              IF(ABS(LAMDA2(I,J,K)).GT.EPS) THEN
                RATE = RPRATE(LAMDA2(I,J,K)**2*TMIXSS(1,1)**2,
     &                        MSQLT(2*J),MQU(2*K-1),MLP(I)) 
                CALL RPMODA(RATE,26,-(2*I+10),POUT1,0)
                RATE = RPRATE(LAMDA2(I,J,K)**2*TMIXSS(1,2)**2,
     &                        MSQRT(2*J),MQU(2*K-1),MLP(I)) 
                CALL RPMODA(RATE,46,-(2*I+10),POUT1,0)
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDDO 
C--Now left down squarks via LUD
      DO J=1,3
        DO I=1,3
          DO K=1,3
            RATE = ZERO 
            IF(J.EQ.1) PIN   = 22
            IF(J.GT.1) PIN   = 19+2*J
            IF(K.EQ.1) POUT1 = 2
            IF(K.GT.1) POUT1 = 2*K-1
            IF(J.NE.3) THEN
              IF(ABS(LAMDA2(I,J,K)).GT.EPS) 
     &          RATE = RPRATE(LAMDA2(I,J,K)**2,MSQLT(2*J-1),
     &                        MQU(2*K-1),ZERO)
              CALL RPMODA(RATE,PIN,-9-2*I,POUT1,0)
            ELSE
C--New for left/right sbottom mixing
              IF(ABS(LAMDA2(I,J,K)).GT.EPS) THEN
                RATE = RPRATE(LAMDA2(I,J,K)**2*BMIXSS(1,1)**2,
     &                        MSQLT(2*J-1),MQU(2*K-1),ZERO)
                CALL RPMODA(RATE,25,-9-2*I,POUT1,0)
C--bug fix 9/04/02 by P.R.
                RATE = RPRATE(LAMDA2(I,J,K)**2*BMIXSS(2,1)**2,
     &                        MSQRT(2*J-1),MQU(2*K-1),ZERO)
                CALL RPMODA(RATE,45,-9-2*I,POUT1,0)
              ENDIF
            ENDIF
          ENDDO
        ENDDO
      ENDDO 
C--Now right up squarks via UDD
      DO I=1,3
        DO J=1,3
          DO K=1,3
            RATE = ZERO 
            IF(I.EQ.1) PIN   = 41
            IF(I.GT.1) PIN   = 40+2*I
            IF(J.EQ.1) POUT1 = -2
            IF(J.GT.1) POUT1 = 1-2*J
            IF(K.EQ.1) POUT2 = -2
            IF(K.GT.1) POUT2 = 1-2*K
            IF(I.NE.3) THEN
              IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) 
     &           RATE = RPRATE(2*LAMDA3(I,J,K)**2,MSQRT(2*I),
     &                       MQU(2*K-1),MQU(2*J-1))
              CALL RPMODA(RATE,PIN,POUT2,POUT1,0)
            ELSE
C--New for left right stop mixing
              IF(ABS(LAMDA3(I,J,K)).GT.EPS.AND.J.LT.K) THEN 
                RATE = RPRATE(2*LAMDA3(I,J,K)**2*TMIXSS(2,1)**2,
     &                     MSQLT(2*I),MQU(2*K-1),MQU(2*J-1))
                CALL RPMODA(RATE,26,POUT2,POUT1,0)
                RATE = RPRATE(2*LAMDA3(I,J,K)**2*TMIXSS(2,2)**2,
     &                     MSQRT(2*I),MQU(2*K-1),MQU(2*J-1))
                CALL RPMODA(RATE,46,POUT2,POUT1,0)
              ENDIF       
            ENDIF
          ENDDO
        ENDDO
      ENDDO
C--Now right down squarks 
      DO I=1,3
        DO J=1,3
          DO K=1,3
C--via LUD 1st rate
            RATE = ZERO 
            IF(I.EQ.1) PIN   = 42
            IF(I.GT.1) PIN   = 39+2*I
            IF(K.EQ.1) POUT1 = 2
            IF(K.GT.1) POUT1 = 2*K-1
            IF(I.NE.3) THEN
              IF(ABS(LAMDA2(J,K,I)).GT.EPS) 
     &          RATE = RPRATE(LAMDA2(J,K,I)**2,MSQRT(2*I-1),
     &                        ZERO,MQU(2*K-1))
              CALL RPMODA(RATE,PIN,9+2*J,POUT1,0)
            ELSE
C--New for left/right sbottom mixing
              IF(ABS(LAMDA2(J,K,I)).GT.EPS) THEN
C--bug fix 09/04/02 by P.R.
                RATE =  RPRATE(LAMDA2(J,K,I)**2*BMIXSS(2,1)**2,
     &                         MSQLT(2*I-1),ZERO,MQU(2*K-1))
                CALL RPMODA(RATE,25,9+2*J,POUT1,0)
                RATE =  RPRATE(LAMDA2(J,K,I)**2*BMIXSS(2,2)**2,
     &                         MSQRT(2*I-1),ZERO,MQU(2*K-1))
                CALL RPMODA(RATE,45,9+2*J,POUT1,0)
              ENDIF
            ENDIF
C--via LUD 2nd rate
              RATE = ZERO
              IF(K.EQ.1) PIN = 42
              IF(K.GT.1) PIN = 39+2*K
              IF(J.EQ.1) POUT1 = 1
              IF(J.GT.1) POUT1 = 2*J 
              IF(K.NE.3) THEN
                IF(ABS(LAMDA2(I,J,K)).GT.EPS)
     &            RATE = RPRATE(LAMDA2(I,J,K)**2,MSQRT(2*K-1),
     &                          MLP(I),MQU(2*J))
                CALL RPMODA(RATE,PIN,10+2*I,POUT1,0) 
              ELSE
C-- New for left/right sbottom mixing
                IF(ABS(LAMDA2(I,J,K)).GT.EPS) THEN
                  RATE = RPRATE(LAMDA2(I,J,K)**2*BMIXSS(2,1)**2,
     &                           MSQLT(2*K-1),MLP(I),MQU(2*J))
                  CALL RPMODA(RATE,25,10+2*I,POUT1,0) 
C--bug fix 09/04/02 by P.R.
                  RATE = RPRATE(LAMDA2(I,J,K)**2*BMIXSS(2,2)**2,
     &                           MSQRT(2*K-1),MLP(I),MQU(2*J))
                  CALL RPMODA(RATE,45,10+2*I,POUT1,0) 
                ENDIF
              ENDIF
C--via UDD
              RATE = ZERO
              IF(I.EQ.1) PIN   = 42
              IF(I.GT.1) PIN   = 39+2*I
              IF(J.EQ.1) POUT1 = -1
              IF(J.GT.1) POUT1 = -2*J
              IF(K.EQ.1) POUT2 = -2
              IF(K.GT.1) POUT2 = 1-2*K
              IF(I.NE.3) THEN
                IF(ABS(LAMDA3(J,K,I)).GT.EPS) 
     &            RATE = RPRATE(2*LAMDA3(J,K,I)**2,MSQRT(2*I-1),
     &                            MQU(2*K-1),MQU(2*J))
                CALL RPMODA(RATE,PIN,POUT1,POUT2,0)
              ELSE
C--New for left right sbottom mixing
                IF(ABS(LAMDA3(J,K,I)).GT.EPS) THEN
                  RATE = RPRATE(2*LAMDA3(J,K,I)**2*BMIXSS(2,1)**2,
     &                            MSQLT(2*I-1),MQU(2*K-1),MQU(2*J))
                  CALL RPMODA(RATE,25,POUT1,POUT2,0)
                  RATE = RPRATE(2*LAMDA3(J,K,I)**2*BMIXSS(2,2)**2,
     &                            MSQRT(2*I-1),MQU(2*K-1),MQU(2*J))
                  CALL RPMODA(RATE,45,POUT1,POUT2,0)
                ENDIF
              ENDIF
          ENDDO
        ENDDO
      ENDDO
C------------END OF SCALAR DECAY RATES
C--Masses and Widths for the 3-body decays
C--First obtain all the widths we need and put in the arrays
      DO I=1,6
        IF(I.LE.3) SLRTWD(I) =  ZERO
        SLLTWD(I) =  ZERO
        SQLTWD(I) =  ZERO
        SQRTWD(I) =  ZERO
      ENDDO
      DO J=1,NSSMOD
        DO I=1,6
          IF(ISSMOD(J).EQ.(20+I)) SQLTWD(I) = SQLTWD(I)+GSSMOD(J)
          IF(ISSMOD(J).EQ.(30+I)) SLLTWD(I) = SLLTWD(I)+GSSMOD(J)
          IF(ISSMOD(J).EQ.(40+I)) SQRTWD(I) = SQRTWD(I)+GSSMOD(J)
          IF(ISSMOD(J).EQ.(50+2*I).AND.I.LE.3) SLRTWD(I) = 
     &                                        SLRTWD(I)+GSSMOD(J)
        ENDDO
      ENDDO
      DO J=1,NSSMD2
        DO I=1,6
          IF(ISSMD2(J).EQ.(20+I)) SQLTWD(I) = SQLTWD(I)+GSSMD2(J)
          IF(ISSMD2(J).EQ.(30+I)) SLLTWD(I) = SLLTWD(I)+GSSMD2(J)
          IF(ISSMD2(J).EQ.(40+I)) SQRTWD(I) = SQRTWD(I)+GSSMD2(J)
          IF(ISSMD2(J).EQ.(50+2*I).AND.I.LE.3) SLRTWD(I) =
     &                                        SLRTWD(I)+GSSMD2(J)
        ENDDO
      ENDDO
C--Change order of down and up to make loops easier
      RATE = SQLTWD(2)
      SQLTWD(2) = SQLTWD(1)
      SQLTWD(1) = RATE
      RATE = SQRTWD(2)
      SQRTWD(2) = SQRTWD(1)
      SQRTWD(1) = RATE
C--Now calculate the rates
C--Neutralino Decay Rates via R-parity violation
      DO CHANEL=1,4
        DO L=1,4
C--First calculate the charges we will need everywhere
          LCHAR(1) = -(ECHAR*NPRIME(L,1)/3.
     &                 +G*(.5-SN2THW/3)*NPRIME(L,2)/CWEAK)
          LCHAR(2) = ECHAR*NPRIME(L,1)*2/3.
     &                 +G*(.5-2*SN2THW/3)*NPRIME(L,2)/CWEAK
          LCHAR(3) = -(ECHAR*NPRIME(L,1)
     &                 +G*(.5-SN2THW)*NPRIME(L,2)/CWEAK)
          LCHAR(4) = G*NPRIME(L,2)/(2*CWEAK)
          RCHAR(1) = (ECHAR*NPRIME(L,1)
     &                -G*SN2THW*NPRIME(L,2)/CWEAK)/3.
          RCHAR(2) = -(ECHAR*NPRIME(L,1)-
     &                  G*SN2THW*NPRIME(L,2)/CWEAK)*2/3.
          RCHAR(3) =  ECHAR*NPRIME(L,1)
     &                -G*SN2THW*NPRIME(L,2)/CWEAK
          RCHAR(4) = ZERO
          MCHAR(1) = G*NPRIME(L,3)/(2*AMW*CBETA)
          MCHAR(2) = G*NPRIME(L,4)/(2*AMW*SBETA)
          DO I=1,3
            DO J=1,3
              DO K=1,3
                DO MIX=1,3
                  MIXING(2*MIX-1) = ONE
                  MIXING(2*MIX)   = ZERO
                  RESM(2*MIX-1)   = ZERO
                  RESM(2*MIX)     = ZERO
                  WIDTH(2*MIX-1)  = ZERO
                  WIDTH(2*MIX)    = ZERO
                ENDDO   
                NEUTWD = ZERO
                M(4) = ABS(AMZISS(L))
C--Charged lepton LQD mode
                IF(CHANEL.EQ.1) THEN
                  WIDTH(1)=SLLTWD(2*I)
                  WIDTH(3)=SQLTWD(2*J)
                  WIDTH(5)=SQRTWD(2*K-1)      
                  M(1) = MLP(I)
                  M(2) = MQU(2*J)
                  M(3) = MQU(2*K-1)
                  RESM(1) = MSLLT(2*I-1)
                  RESM(3) = MSQLT(2*J)
                  RESM(5) = MSQRT(2*K-1)
                  IF(I.NE.3) THEN
                    A(1) = MCHAR(1)*M(1)
                    B(1) = LCHAR(3)
                  ELSE
C--left/right stau mixing
                    DO MIX=1,2  
                      MIXING(MIX) = LMIXSS(1,MIX)
                      A(MIX) = MCHAR(1)*M(1)*LMIXSS(1,MIX)+
     &                         RCHAR(3)*LMIXSS(2,MIX)
                      B(MIX) = MCHAR(1)*M(1)*LMIXSS(2,MIX)+
     &                         LCHAR(3)*LMIXSS(1,MIX)
                    ENDDO         
                    RESM(2) = MSLRT(3)
                    WIDTH(2)= SLRTWD(3)
                  ENDIF
                  IF(J.NE.3) THEN
                    A(3) = MCHAR(2)*M(2)
                    B(3) = LCHAR(2)
                  ELSE
C--left/right stop mixing
                    DO MIX=1,2
                      MIXING(2+MIX) = TMIXSS(1,MIX) 
                      A(2+MIX) = MCHAR(2)*M(2)*TMIXSS(1,MIX)+
     &                           RCHAR(2)*TMIXSS(2,MIX)
                      B(2+MIX) = MCHAR(2)*M(2)*TMIXSS(2,MIX)+
     &                           LCHAR(2)*TMIXSS(1,MIX)     
                    ENDDO      
                    RESM(4) = MSQRT(2*J)
                    WIDTH(4) = SQRTWD(2*J)
                  ENDIF
                  IF(K.NE.3) THEN
                    A(5) = MCHAR(1)*M(3)
                    B(5) = RCHAR(1)
                  ELSE
C--left/right sbottom mixing
                    DO MIX=1,2  
                      MIXING(4+MIX) = BMIXSS(2,MIX)
                      A(4+MIX) = MCHAR(1)*M(3)*BMIXSS(2,MIX)+
     &                           LCHAR(1)*BMIXSS(1,MIX)
                      B(4+MIX) = MCHAR(1)*M(3)*BMIXSS(1,MIX)+
     &                           RCHAR(1)*BMIXSS(2,MIX)     
                    ENDDO  
                    RESM(5) = MSQLT(2*K-1)
                    RESM(6) = MSQRT(2*K-1)    
                    WIDTH(5)=SQLTWD(2*K-1)
                    WIDTH(6)=SQRTWD(2*K-1)      
                  ENDIF
                  LAMCOL = 6*LAMDA2(I,J,K)**2 
                  POUT1 = -10-2*I
                  IF(J.EQ.1) POUT2 = -1
                  IF(J.GT.1) POUT2 = -2*J
                  IF(K.EQ.1) POUT3 = 2
                  IF(K.GT.1) POUT3 = 2*K-1
C--neutrino LQD mode
                ELSEIF(CHANEL.EQ.2) THEN
                  WIDTH(1) = SLLTWD(2*I-1)
                  WIDTH(3) = SQLTWD(2*J-1)
                  WIDTH(5) = SQRTWD(2*K-1) 
                  M(1) = ZERO
                  M(2) = MQU(2*J-1)
                  M(3) = MQU(2*K-1)
                  RESM(1) = MSLLT(2*I)
                  RESM(3) = MSQLT(2*J-1)
C--bug fix 09/04/02 by P.R.
                  RESM(5) = MSQRT(2*K-1)
                  A(1) = ZERO
                  B(1) = LCHAR(4)
                  IF(J.NE.3) THEN
                    A(3) = MCHAR(1)*M(2)
                    B(3) = LCHAR(1)
                  ELSE
C--left/right sbottom mixing
                    DO MIX=1,2 
                      MIXING(2+MIX) = BMIXSS(1,MIX)
                      A(2+MIX) = MCHAR(1)*M(2)*BMIXSS(1,MIX)+
     &                           RCHAR(1)*BMIXSS(2,MIX)
                      B(2+MIX) = MCHAR(1)*M(2)*BMIXSS(2,MIX)+
     &                           LCHAR(1)*BMIXSS(1,MIX)
                    ENDDO      
                    RESM(4) = MSQRT(2*J-1)
                    WIDTH(4) = SQRTWD(2*J-1)
                  ENDIF
                  IF(K.NE.3) THEN
                    A(5) = MCHAR(1)*M(3)
                    B(5) = RCHAR(1)
                  ELSE
C--left/right sbottom mixing
                    DO MIX=1,2  
                      MIXING(4+MIX) = BMIXSS(2,MIX) 
                      A(4+MIX) = MCHAR(1)*M(3)*BMIXSS(2,MIX)+
     &                           LCHAR(1)*BMIXSS(1,MIX)
                      B(4+MIX) = MCHAR(1)*M(3)*BMIXSS(1,MIX)+
     &                           RCHAR(1)*BMIXSS(2,MIX)     
                    ENDDO  
                    RESM(5)= MSQLT(2*K-1)
                    RESM(6)= MSQRT(2*K-1)    
                    WIDTH(5)=SQLTWD(2*K-1)
                    WIDTH(6)=SQRTWD(2*K-1)      
                  ENDIF
                  LAMCOL = 6*LAMDA2(I,J,K)**2
                  POUT1 = -9-2*I 
                  IF(J.EQ.1) POUT2 = -2
                  IF(J.GT.1) POUT2 = 1-2*J
                  IF(K.EQ.1) POUT3 = 2
                  IF(K.GT.1) POUT3 = 2*K-1
C--LLE mode
                ELSEIF(CHANEL.EQ.3) THEN
                  WIDTH(1) = SLLTWD(2*I)
                  WIDTH(3) = SLLTWD(2*J-1)
                  WIDTH(5) = SLRTWD(K)
                  M(1) = MLP(I) 
                  M(2) = ZERO 
                  M(3) = MLP(K)
                  RESM(1) = MSLLT(2*I-1)
                  RESM(3) = MSLLT(2*J)
                  RESM(5) = MSLRT(K)
                  A(3) = ZERO
                  B(3) = LCHAR(4)
                  IF(I.NE.3) THEN
                    A(1) = MCHAR(1)*M(1)
                    B(1) = LCHAR(3)
                  ELSE
C--left/right stau mixing
                    DO MIX=1,2  
                      MIXING(MIX) = LMIXSS(1,MIX)
                      A(MIX) =MCHAR(1)*M(1)*LMIXSS(1,MIX)+
     &                        RCHAR(3)*LMIXSS(2,MIX)
                      B(MIX) =MCHAR(1)*M(1)*LMIXSS(2,MIX)+
     &                        LCHAR(3)*LMIXSS(1,MIX)
                    ENDDO         
                    RESM(2) = MSLRT(3)
                    WIDTH(2)= SLRTWD(3)
                  ENDIF
                  IF(K.NE.3) THEN
                    A(5) = MCHAR(1)*M(3)
                    B(5) = RCHAR(3)
                  ELSE
C--left/right stau mixing
                    DO MIX=1,2
                      MIXING(4+MIX) = LMIXSS(2,MIX)  
                      A(4+MIX) = MCHAR(1)*M(3)*LMIXSS(2,MIX)+
     &                           LCHAR(3)*LMIXSS(1,MIX)
                      B(4+MIX) = MCHAR(1)*M(3)*LMIXSS(1,MIX)+
     &                           RCHAR(3)*LMIXSS(2,MIX)
                    ENDDO  
                    RESM(5)= MSLLT(2*K-1)
                    RESM(6)= MSLRT(K)    
                    WIDTH(5)=SLLTWD(2*K)
                    WIDTH(6)=SLRTWD(K)      
                  ENDIF
                  LAMCOL = 2*LAMDA1(I,J,K)**2
                  POUT1 = -10-2*I
                  POUT2 =  -9-2*J
                  POUT3 = 10+2*K
C--UDD mode
                ELSEIF(CHANEL.EQ.4) THEN
                  WIDTH(1) = SQRTWD(2*I)
                  WIDTH(3) = SQRTWD(2*J-1)
                  WIDTH(5) = SQRTWD(2*K-1) 
                  M(1) = MQU(2*I)
                  M(2) = MQU(2*J-1)
                  M(3) = MQU(2*K-1)
                  RESM(1) = MSQRT(2*I)
                  RESM(3) = MSQRT(2*J-1)
                  RESM(5) = MSQRT(2*K-1)
                  IF(I.NE.3) THEN
                    A(1) = MCHAR(2)*M(1)
                    B(1) = RCHAR(2)
                  ELSE
C--left/right stop mixing
                    DO MIX=1,2  
                      MIXING(MIX) = TMIXSS(2,MIX)
                      A(MIX) = MCHAR(2)*M(1)*TMIXSS(2,MIX)+
     &                         LCHAR(2)*TMIXSS(1,MIX)
                      B(MIX) = MCHAR(2)*M(1)*TMIXSS(1,MIX)+
     &                         RCHAR(2)*TMIXSS(2,MIX)
                    ENDDO  
                    RESM(1) = MSQLT(2*I)
                    RESM(2) = MSQRT(2*I)
                    WIDTH(1) = SQLTWD(2*I)
                    WIDTH(2) = SQRTWD(2*I)
                  ENDIF
                  IF(J.NE.3) THEN
                    A(3) = MCHAR(1)*M(2)
                    B(3) = RCHAR(1)
                  ELSE
C--left/right sbottom mixing
                    DO MIX=1,2  
                      MIXING(2+MIX) = BMIXSS(2,MIX)
                      A(2+MIX) = MCHAR(1)*M(2)*BMIXSS(2,MIX)+
     &                           LCHAR(1)*BMIXSS(1,MIX)
                      B(2+MIX) = MCHAR(1)*M(2)*BMIXSS(1,MIX)+
     &                           RCHAR(1)*BMIXSS(2,MIX)  
                    ENDDO     
                    RESM(3)= MSQLT(2*J-1)
                    RESM(4)= MSQRT(2*J-1)    
                    WIDTH(3)=SQLTWD(2*J-1)
                    WIDTH(4)=SQRTWD(2*J-1)  
                  ENDIF
                  IF(K.NE.3) THEN
                    A(5) = MCHAR(1)*M(3)
                    B(5) = RCHAR(1)
                  ELSE
C--left/right sbottom mixing
                    DO MIX=1,2  
                      MIXING(4+MIX) = BMIXSS(2,MIX)
                      A(4+MIX) = MCHAR(1)*M(3)*BMIXSS(2,MIX)+
     &                           LCHAR(1)*BMIXSS(1,MIX)
                      B(4+MIX) = MCHAR(1)*M(3)*BMIXSS(1,MIX)+
     &                           RCHAR(1)*BMIXSS(2,MIX)     
                    ENDDO  
                    RESM(5)= MSQLT(2*K-1)
                    RESM(6)= MSQRT(2*K-1)    
                    WIDTH(5)=SQLTWD(2*K-1)
                    WIDTH(6)=SQRTWD(2*K-1)      
                  ENDIF
                  IF(I.EQ.1) POUT1 = 1
                  IF(I.GT.1) POUT1 = 2*I
                  IF(J.EQ.1) POUT2 = 2
                  IF(J.GT.1) POUT2 = 2*J-1
                  IF(K.EQ.1) POUT3 = 2
                  IF(K.GT.1) POUT3 = 2*K-1
                  IF(J.LT.K) THEN
                    LAMCOL = 12*LAMDA3(I,J,K)**2
                  ELSE
                    LAMCOL = ZERO
                  ENDIF
                ENDIF
                IF(NMSIGN(L).LT.0) THEN
                  IF(CHANEL.EQ.4) THEN
                    DO N=1,6
                      B(N) = -B(N)
                    ENDDO
                  ELSE
                    DO N=1,2
                      A(N)   = -A(N)
                      A(N+2) = -A(N+2)
                      B(N+4) = -B(N+4)
                    ENDDO
                  ENDIF
                ENDIF
C--Decide whether to remove diagrams
                DO N=1,6
                  CRSTRM(N) = .FALSE.
                ENDDO
                IF(M(4).LT.(M(1)+M(2)+M(3))) GOTO 10
                CRSTRM(1) = (M(4).GT.(M(1)+ABS(RESM(1))).
     &                       AND.ABS(RESM(1)).GT.(M(2)+M(3))) 
                CRSTRM(2) = (M(4).GT.(M(1)+ABS(RESM(2))).
     &                       AND.ABS(RESM(2)).GT.(M(2)+M(3))) 
     &                       .OR.(ABS(RESM(2)).LT.EPS)
                CRSTRM(3) = (M(4).GT.(M(2)+ABS(RESM(3))).
     &                       AND.ABS(RESM(3)).GT.(M(1)+M(3)))
                CRSTRM(4) = (M(4).GT.(M(2)+ABS(RESM(4))).
     &                       AND.ABS(RESM(4)).GT.(M(1)+M(3)))
     &                       .OR.(ABS(RESM(4)).LT.EPS)
                CRSTRM(5) = (M(4).GT.(M(3)+ABS(RESM(5))).
     &                       AND.ABS(RESM(5)).GT.(M(1)+M(2)))
                CRSTRM(6) = (M(4).GT.(M(3)+ABS(RESM(6))).
     &                       AND.ABS(RESM(6)).GT.(M(1)+M(2)))
     &                       .OR.(ABS(RESM(6)).LT.EPS)
C--Calculation of the rate
                NEUTWD = ZERO
                IF((CRSTRM(1).AND.CRSTRM(2).AND.CRSTRM(3).AND.
     &          CRSTRM(4).AND.CRSTRM(5).AND.CRSTRM(6)).
     &          OR.LAMCOL.LT.EPS) GOTO 10
C--first the diagram squared pieces
                IF(.NOT.CRSTRM(1)) NEUTWD = NEUTWD+ MIXING(1)**2*
     &          RPINF1(M(2),M(3),M(1),M(4),WIDTH(1),RESM(1),A(1),B(1))
                IF(.NOT.CRSTRM(2)) NEUTWD = NEUTWD+MIXING(2)**2*
     &          RPINF1(M(2),M(3),M(1),M(4),WIDTH(2),RESM(2),A(2),B(2))
                IF(.NOT.CRSTRM(3)) NEUTWD = NEUTWD+MIXING(3)**2*
     &          RPINF1(M(1),M(3),M(2),M(4),WIDTH(3),RESM(3),A(3),B(3))
                IF(.NOT.CRSTRM(4)) NEUTWD = NEUTWD+ MIXING(4)**2*
     &          RPINF1(M(1),M(3),M(2),M(4),WIDTH(4),RESM(4),A(4),B(4))
                IF(.NOT.CRSTRM(5)) NEUTWD = NEUTWD+MIXING(5)**2*
     &          RPINF1(M(1),M(2),M(3),M(4),WIDTH(5),RESM(5),A(5),B(5))
                IF(.NOT.CRSTRM(6)) NEUTWD = NEUTWD+MIXING(6)**2*
     &          RPINF1(M(1),M(2),M(3),M(4),WIDTH(6),RESM(6),A(6),B(6))
C--now for the light/heavy interference due left/right mixing
                IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) NEUTWD=NEUTWD+
     &          MIXING(1)*MIXING(2)*RPINF2(M(2),M(3),M(1),M(4),WIDTH(1),
     &           WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
                IF(.NOT.CRSTRM(3).AND..NOT.CRSTRM(4)) NEUTWD=NEUTWD+
     &          MIXING(3)*MIXING(4)*RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),
     &          WIDTH(4),RESM(3),RESM(4),A(3),A(4),B(3),B(4),1)
                IF(.NOT.CRSTRM(5).AND..NOT.CRSTRM(6)) NEUTWD=NEUTWD+
     &          MIXING(5)*MIXING(6)*RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),
     &          WIDTH(6),RESM(5),RESM(6),A(5),A(6),B(5),B(6),1)
C--now for the true interference terms
                IF(.NOT.CRSTRM(1)) THEN
                  IF(.NOT.CRSTRM(3)) NEUTWD=NEUTWD-MIXING(1)*MIXING(3)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(1),RESM(3),
     &            RESM(1),A(1),A(3),B(1),B(3),2)
                  IF(.NOT.CRSTRM(4)) NEUTWD=NEUTWD-MIXING(1)*MIXING(4)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(1),RESM(4),
     &            RESM(1),A(1),A(4),B(1),B(4),2)
                  IF(.NOT.CRSTRM(5)) NEUTWD=NEUTWD-MIXING(1)*MIXING(5)*
     &            RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),WIDTH(1),RESM(5),
     &            RESM(1),A(1),A(5),B(1),B(5),2)
                  IF(.NOT.CRSTRM(6)) NEUTWD=NEUTWD-MIXING(1)*MIXING(6)*
     &            RPINF2(M(1),M(2),M(3),M(4),WIDTH(6),WIDTH(1),RESM(6),
     &            RESM(1),A(1),A(6),B(1),B(6),2)
                ENDIF
                IF(.NOT.CRSTRM(2)) THEN
                  IF(.NOT.CRSTRM(3)) NEUTWD=NEUTWD-MIXING(2)*MIXING(3)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(2),RESM(3),
     &            RESM(2),A(2),A(3),B(2),B(3),2)
                  IF(.NOT.CRSTRM(4)) NEUTWD=NEUTWD-MIXING(2)*MIXING(4)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(2),RESM(4),
     &            RESM(2),A(2),A(4),B(2),B(4),2)
                  IF(.NOT.CRSTRM(5)) NEUTWD=NEUTWD-MIXING(2)*MIXING(5)*
     &            RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),WIDTH(2),RESM(5),
     &            RESM(2),A(2),A(5),B(2),B(5),2)
                  IF(.NOT.CRSTRM(6)) NEUTWD=NEUTWD-MIXING(2)*MIXING(6)*
     &            RPINF2(M(1),M(2),M(3),M(4),WIDTH(6),WIDTH(2),RESM(6),
     &            RESM(2),A(2),A(6),B(2),B(6),2)
                ENDIF
                IF(.NOT.CRSTRM(3)) THEN
                  IF(.NOT.CRSTRM(5)) NEUTWD=NEUTWD-MIXING(3)*MIXING(5)*
     &            RPINF2(M(2),M(1),M(3),M(4),WIDTH(5),WIDTH(3),RESM(5),
     &            RESM(3),A(3),A(5),B(3),B(5),2)
                  IF(.NOT.CRSTRM(6)) NEUTWD=NEUTWD-MIXING(3)*MIXING(6)*
     &            RPINF2(M(2),M(1),M(3),M(4),WIDTH(6),WIDTH(3),RESM(6),
     &            RESM(3),A(3),A(6),B(3),B(6),2)
                ENDIF
                IF(.NOT.CRSTRM(4)) THEN
                  IF(.NOT.CRSTRM(5)) NEUTWD=NEUTWD-MIXING(4)*MIXING(5)*
     &            RPINF2(M(2),M(1),M(3),M(4),WIDTH(5),WIDTH(4),RESM(5),
     &            RESM(4),A(4),A(5),B(4),B(5),2)
                  IF(.NOT.CRSTRM(6)) NEUTWD=NEUTWD-MIXING(4)*MIXING(6)*
     &            RPINF2(M(2),M(1),M(3),M(4),WIDTH(6),WIDTH(4),RESM(6),
     &            RESM(4),A(4),A(6),B(4),B(6),2)
                ENDIF
                NEUTWD = LAMCOL*NEUTWD/((2*PI)**3*32*M(4)**3)
C--Output the rate and particles to decay tables
 10             IF(NEUTWD.GT.EPS) THEN
                  CALL RPMODA(NEUTWD,20+10*L,POUT1,POUT2,POUT3)
                  CALL RPMODA(NEUTWD,20+10*L,-POUT1,-POUT2,-POUT3)
                ENDIF
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDDO
C--Gluino decay rates all the info we need is already in the arrays
C--Easier as only three gluino channels. Just calculate the total rate
C--and handle the colour structure inside HERWIG
C--Now calculate the rates
C--First the LQD rates
      DO CHANEL=1,2
        DO I=1,3
          DO J=1,3
            DO K=1,3
              DO MIX=1,2
                MIXING(2*MIX-1) = ONE
                MIXING(2*MIX)   = ZERO
                RESM(2*MIX-1)   = ZERO
                RESM(2*MIX)     = ZERO
                WIDTH(2*MIX-1)  = ZERO
                WIDTH(2*MIX)    = ZERO 
              ENDDO
C--charged lepton, ubar, down
              IF(CHANEL.EQ.1) THEN
                WIDTH(1)=SQLTWD(2*J)
                WIDTH(3)=SQRTWD(2*K-1)      
                M(1) = MLP(I)
                M(2) = MQU(2*J)
                M(3) = MQU(2*K-1)
                M(4) = AMGLSS
                RESM(1) = MSQLT(2*J)
                RESM(3) = MSQRT(2*K-1)
                IF(J.NE.3) THEN
                  A(1) =ZERO 
                  B(1) = -ONE 
                ELSE
C--left/right stop mixing
                  DO MIX=1,2
                    MIXING(MIX) = TMIXSS(1,MIX)  
                    A(MIX) = TMIXSS(2,MIX)
                    B(MIX) =-TMIXSS(1,MIX)
                  ENDDO    
C--bug fix 09/04/02 by P.R.  
                  RESM(2) = MSQRT(2*J)
                  WIDTH(2) = SQRTWD(2*J)
                ENDIF
                IF(K.NE.3) THEN
                  A(3) = ZERO
                  B(3) = ONE
                ELSE
C--left/right sbottom mixing
                  MIXING(3) = BMIXSS(2,1) 
                  MIXING(4) = BMIXSS(2,2)
                  DO MIX=1,2 
                    MIXING(2+MIX) = BMIXSS(2,MIX) 
                    A(2+MIX) = -BMIXSS(1,MIX) 
                    B(2+MIX) =  BMIXSS(2,MIX)
                  ENDDO 
                  RESM(3)= MSQLT(2*K-1)
                  RESM(4)= MSQRT(2*K-1)    
                  WIDTH(3)=SQLTWD(2*K-1)
                  WIDTH(4)=SQRTWD(2*K-1)      
                ENDIF
                LAMCOL = ALFA3*4*PI*LAMDA2(I,J,K)**2 
                POUT1 = -10-2*I
                IF(J.EQ.1) POUT2 = -1
                IF(J.GT.1) POUT2 = -2*J
                IF(K.EQ.1) POUT3 = 2
                IF(K.GT.1) POUT3 = 2*K-1
C--neutrino, dbar, down.
              ELSEIF(CHANEL.EQ.2) THEN
                WIDTH(1) = SQLTWD(2*J-1)
                WIDTH(3) = SQRTWD(2*K-1) 
                M(1) = ZERO
                M(2) = MQU(2*J-1)
                M(3) = MQU(2*K-1)
                M(4) = AMGLSS
                RESM(1) = MSQLT(2*J-1)
C--bug fix 09/04/02 by P.R. 
                RESM(3) = MSQRT(2*K-1)
                IF(J.NE.3) THEN
                  A(1) =  ZERO
                  B(1) =-ONE
                ELSE
C--left/right sbottom mixing
                  DO MIX=1,2
                    MIXING(MIX) = BMIXSS(1,MIX) 
                    A(MIX) = BMIXSS(2,MIX)
                    B(MIX) = -BMIXSS(1,MIX) 
                  ENDDO      
                  RESM(2) = MSQRT(2*J-1)
                  WIDTH(2) = SQRTWD(2*J-1)
                ENDIF
                IF(K.NE.3) THEN
                  A(3) = ZERO
                  B(3) = ONE
                ELSE
C--left/right sbottom mixing
                  DO MIX=1,2 
                    MIXING(2+MIX) = BMIXSS(2,MIX)  
                    A(2+MIX) = -BMIXSS(1,MIX) 
                    B(2+MIX) =  BMIXSS(2,MIX)
                  ENDDO  
                  RESM(3)= MSQLT(2*K-1)
                  RESM(4)= MSQRT(2*K-1)    
                  WIDTH(3)=SQLTWD(2*K-1)
                  WIDTH(4)=SQRTWD(2*K-1)      
                ENDIF
                LAMCOL = ALFA3*4*PI*LAMDA2(I,J,K)**2
                POUT1 = -9-2*I 
                IF(J.EQ.1) POUT2 = -2
                IF(J.GT.1) POUT2 = 1-2*J
                IF(K.EQ.1) POUT3 = 2
                IF(K.GT.1) POUT3 = 2*K-1
              ENDIF
C--Decide whether to remove diagrams
              DO N=1,4
                CRSTRM(N) = .FALSE.
              ENDDO
C--bug fix 09/04/02 by P.R.
              CRSTRM(1) = (M(4).GT.(M(2)+ABS(RESM(1))).
     &                     AND.ABS(RESM(1)).GT.(M(1)+M(3)))
              CRSTRM(2) = (M(4).GT.(M(2)+ABS(RESM(2))).
     &                       AND.ABS(RESM(2)).GT.(M(1)+M(3)))
     &                       .OR.(ABS(RESM(2)).LT.EPS)
              CRSTRM(3) = (M(4).GT.(M(3)+ABS(RESM(3))).
     &                       AND.ABS(RESM(3)).GT.(M(1)+M(2)))
              CRSTRM(4) = (M(4).GT.(M(3)+ABS(RESM(4))).
     &                       AND.ABS(RESM(4)).GT.(M(1)+M(2)))
     &                       .OR.(ABS(RESM(4)).LT.EPS)
C--Calculation of the rate
              GLUWD = 0
              IF((CRSTRM(1).AND.CRSTRM(2).AND.
     &            CRSTRM(3).AND.CRSTRM(4)).OR.
     &           LAMCOL.LT.EPS.OR.(M(1)+M(2)+M(3)).GT.M(4)) GOTO 20
C--First the amplitude square pieces
              IF(.NOT.CRSTRM(1)) GLUWD = GLUWD+MIXING(1)**2*
     &        RPINF1(M(1),M(3),M(2),M(4),WIDTH(1),RESM(1),A(1),B(1))
              IF(.NOT.CRSTRM(2)) GLUWD = GLUWD+ MIXING(2)**2*
     &        RPINF1(M(1),M(3),M(2),M(4),WIDTH(2),RESM(2),A(2),B(2))
              IF(.NOT.CRSTRM(3)) GLUWD = GLUWD+MIXING(3)**2*
     &        RPINF1(M(1),M(2),M(3),M(4),WIDTH(3),RESM(3),A(3),B(3))
              IF(.NOT.CRSTRM(4)) GLUWD = GLUWD+MIXING(4)**2*
     &        RPINF1(M(1),M(2),M(3),M(4),WIDTH(4),RESM(4),A(4),B(4))
C--now for the light/heavy interference due left/right mixing
              IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) GLUWD=GLUWD+
     &        MIXING(1)*MIXING(2)*RPINF2(M(1),M(3),M(2),M(4),WIDTH(1),
     &        WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
              IF(.NOT.CRSTRM(3).AND..NOT.CRSTRM(4)) GLUWD=GLUWD+
     &        MIXING(3)*MIXING(4)*RPINF2(M(1),M(2),M(3),M(4),WIDTH(3),
     &        WIDTH(4),RESM(3),RESM(4),A(3),A(4),B(3),B(4),1)
C--now for the true interference terms
              IF(.NOT.CRSTRM(3)) THEN
                IF(.NOT.CRSTRM(3)) GLUWD=GLUWD-MIXING(1)*MIXING(3)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(3),WIDTH(1),RESM(3),
     &          RESM(1),A(1),A(3),B(1),B(3),2)
                IF(.NOT.CRSTRM(4)) GLUWD=GLUWD-MIXING(1)*MIXING(4)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(4),WIDTH(1),RESM(4),
     &          RESM(1),A(1),A(4),B(1),B(4),2)
              ENDIF
              IF(.NOT.CRSTRM(2)) THEN
                IF(.NOT.CRSTRM(3)) GLUWD=GLUWD-MIXING(2)*MIXING(3)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(3),WIDTH(2),RESM(3),
     &          RESM(2),A(2),A(3),B(2),B(3),2)
                IF(.NOT.CRSTRM(4)) GLUWD=GLUWD-MIXING(2)*MIXING(4)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(4),WIDTH(2),RESM(4),
     &          RESM(2),A(2),A(4),B(2),B(4),2)
              ENDIF
              GLUWD = LAMCOL*GLUWD
              GLUWD = GLUWD/((2*PI)**3*32*M(4)**3)
C--Output the rate and particles to decay tables
 20           IF(GLUWD.GT.EPS) THEN
                CALL RPMODA(GLUWD,29,POUT1,POUT2,POUT3)
                CALL RPMODA(GLUWD,29,-POUT1,-POUT2,-POUT3)
              ENDIF
            ENDDO
          ENDDO
        ENDDO
      ENDDO
C--Now the gluino decay via UDD, there are three diagrams before LR mixing
C--i.e. gluino -> u d d
      DO I=1,3
        DO J=1,3
          DO K=1,3
            DO MIX=1,3
              MIXING(2*MIX-1) = ONE
              MIXING(2*MIX)   = ZERO
              RESM(2*MIX-1)   = ZERO
              RESM(2*MIX)     = ZERO
              WIDTH(2*MIX-1)  = ZERO
              WIDTH(2*MIX)    = ZERO 
            ENDDO
            WIDTH(1) = SQRTWD(2*I)
            WIDTH(3) = SQRTWD(2*J-1)
            WIDTH(5) = SQRTWD(2*K-1) 
            M(1) = MQU(2*I)
            M(2) = MQU(2*J-1)
            M(3) = MQU(2*K-1)
            M(4) = AMGLSS
            RESM(1) = MSQRT(2*I)
            RESM(3) = MSQRT(2*J-1)
            RESM(5) = MSQRT(2*K-1)
            IF(I.NE.3) THEN
              A(1) = ZERO
              B(1) = ONE
            ELSE
C--left/right stop mixing
              DO MIX=1,2
                MIXING(MIX) = TMIXSS(2,MIX)  
                A(MIX) = -TMIXSS(1,MIX)
                B(MIX) = TMIXSS(2,MIX)
              ENDDO  
              RESM(1) = MSQLT(2*I)
              RESM(2) = MSQRT(2*I)
              WIDTH(1) = SQLTWD(2*I)
              WIDTH(2) = SQRTWD(2*I)
            ENDIF
            IF(J.NE.3) THEN
              A(3) = ZERO
              B(3) = ONE
            ELSE
C--left/right sbottom mixing
              DO MIX=1,2  
                MIXING(2+MIX) = BMIXSS(2,MIX)
                A(2+MIX) =-BMIXSS(1,MIX)
                B(2+MIX) = BMIXSS(2,MIX)
              ENDDO     
              RESM(3)= MSQLT(2*J-1)
              RESM(4)= MSQRT(2*J-1)    
              WIDTH(3)=SQLTWD(2*J-1)
              WIDTH(4)=SQRTWD(2*J-1)  
            ENDIF
            IF(K.NE.3) THEN
              A(5) = ZERO
              B(5) = ONE 
            ELSE
C--left/right sbottom mixing
            DO MIX=1,2  
              MIXING(4+MIX)=BMIXSS(2,MIX)
              A(4+MIX) =-BMIXSS(1,MIX)
              B(4+MIX) = BMIXSS(2,MIX)
            ENDDO  
              RESM(5)= MSQLT(2*K-1)
              RESM(6)= MSQRT(2*K-1)    
              WIDTH(5)=SQLTWD(2*K-1)
              WIDTH(6)=SQRTWD(2*K-1)      
            ENDIF
            IF(I.EQ.1) POUT1 = 1
            IF(I.GT.1) POUT1 = 2*I
            IF(J.EQ.1) POUT2 = 2
            IF(J.GT.1) POUT2 = 2*J-1
            IF(K.EQ.1) POUT3 = 2
            IF(K.GT.1) POUT3 = 2*K-1
            IF(J.LT.K) THEN
              LAMCOL = 2*ALFA3*4*PI*LAMDA3(I,J,K)**2
            ELSE
              LAMCOL = 0
            ENDIF
C--Decide whether to remove diagrams
            DO N=1,6
              CRSTRM(N) = .FALSE.
            ENDDO
            GLUWD = ZERO
            IF(M(4).LT.(M(1)+M(2)+M(3))) GOTO 30
            CRSTRM(1) = (M(4).GT.(M(1)+ABS(RESM(1))).
     &                  AND.ABS(RESM(1)).GT.(M(2)+M(3))) 
            CRSTRM(2) = (M(4).GT.(M(1)+ABS(RESM(2))).
     &                  AND.ABS(RESM(2)).GT.(M(2)+M(3))) 
     &                  .OR.(ABS(RESM(2)).LT.EPS)
            CRSTRM(3) = (M(4).GT.(M(2)+ABS(RESM(3))).
     &                  AND.ABS(RESM(3)).GT.(M(1)+M(3)))
            CRSTRM(4) = (M(4).GT.(M(2)+ABS(RESM(4))).
     &                  AND.ABS(RESM(4)).GT.(M(1)+M(3)))
     &                  .OR.(ABS(RESM(4)).LT.EPS)
            CRSTRM(5) = (M(4).GT.(M(3)+ABS(RESM(5))).
     &                  AND.ABS(RESM(5)).GT.(M(1)+M(2)))
            CRSTRM(6) = (M(4).GT.(M(3)+ABS(RESM(6))).
     &                  AND.ABS(RESM(6)).GT.(M(1)+M(2)))
     &                  .OR.(ABS(RESM(6)).LT.EPS)
C--Calculation of the rate
            IF((CRSTRM(1).AND.CRSTRM(2).AND.CRSTRM(3).AND.
     &      CRSTRM(4).AND.CRSTRM(5).AND.CRSTRM(6)).
     &      OR.LAMCOL.LT.EPS) GOTO 30
C--first the diagram squared pieces
            IF(.NOT.CRSTRM(1)) GLUWD = GLUWD+ MIXING(1)**2*
     &      RPINF1(M(2),M(3),M(1),M(4),WIDTH(1),RESM(1),A(1),B(1))
            IF(.NOT.CRSTRM(2)) GLUWD = GLUWD+MIXING(2)**2*
     &      RPINF1(M(2),M(3),M(1),M(4),WIDTH(2),RESM(2),A(2),B(2))
            IF(.NOT.CRSTRM(3)) GLUWD = GLUWD+MIXING(3)**2*
     &      RPINF1(M(1),M(3),M(2),M(4),WIDTH(3),RESM(3),A(3),B(3))
            IF(.NOT.CRSTRM(4)) GLUWD = GLUWD+ MIXING(4)**2*
     &      RPINF1(M(1),M(3),M(2),M(4),WIDTH(4),RESM(4),A(4),B(4))
            IF(.NOT.CRSTRM(5)) GLUWD = GLUWD+MIXING(5)**2*
     &      RPINF1(M(1),M(2),M(3),M(4),WIDTH(5),RESM(5),A(5),B(5))
            IF(.NOT.CRSTRM(6)) GLUWD = GLUWD+MIXING(6)**2*
     &      RPINF1(M(1),M(2),M(3),M(4),WIDTH(6),RESM(6),A(6),B(6))
C--now for the light/heavy interference due left/right mixing
            IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) GLUWD=GLUWD+
     &      MIXING(1)*MIXING(2)*RPINF2(M(2),M(3),M(1),M(4),WIDTH(1),
     &      WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
            IF(.NOT.CRSTRM(3).AND..NOT.CRSTRM(4)) GLUWD=GLUWD+
     &      MIXING(3)*MIXING(4)*RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),
     &      WIDTH(4),RESM(3),RESM(4),A(3),A(4),B(3),B(4),1)
            IF(.NOT.CRSTRM(5).AND..NOT.CRSTRM(6)) GLUWD=GLUWD+
     &      MIXING(5)*MIXING(6)*RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),
     &      WIDTH(6),RESM(5),RESM(6),A(5),A(6),B(5),B(6),1)
C--now for the true interference terms
            IF(.NOT.CRSTRM(1)) THEN
              IF(.NOT.CRSTRM(3)) GLUWD=GLUWD+0.5*MIXING(1)*MIXING(3)*
     &        RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(1),RESM(3),
     &        RESM(1),A(1),A(3),B(1),B(3),2)
              IF(.NOT.CRSTRM(4)) GLUWD=GLUWD+0.5*MIXING(1)*MIXING(4)*
     &        RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(1),RESM(4),
     &        RESM(1),A(1),A(4),B(1),B(4),2)
              IF(.NOT.CRSTRM(5)) GLUWD=GLUWD+0.5*MIXING(1)*MIXING(5)*
     &        RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),WIDTH(1),RESM(5),
     &        RESM(1),A(1),A(5),B(1),B(5),2)
              IF(.NOT.CRSTRM(6)) GLUWD=GLUWD+0.5*MIXING(1)*MIXING(6)*
     &        RPINF2(M(1),M(2),M(3),M(4),WIDTH(6),WIDTH(1),RESM(6),
     &        RESM(1),A(1),A(6),B(1),B(6),2)
            ENDIF
            IF(.NOT.CRSTRM(2)) THEN
              IF(.NOT.CRSTRM(3)) GLUWD=GLUWD+0.5*MIXING(2)*MIXING(3)*
     &        RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(2),RESM(3),
     &        RESM(2),A(2),A(3),B(2),B(3),2)
              IF(.NOT.CRSTRM(4)) GLUWD=GLUWD+0.5*MIXING(2)*MIXING(4)*
     &        RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(2),RESM(4),
     &        RESM(2),A(2),A(4),B(2),B(4),2)
              IF(.NOT.CRSTRM(5)) GLUWD=GLUWD+0.5*MIXING(2)*MIXING(5)*
     &        RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),WIDTH(2),RESM(5),
     &        RESM(2),A(2),A(5),B(2),B(5),2)
              IF(.NOT.CRSTRM(6)) GLUWD=GLUWD+0.5*MIXING(2)*MIXING(6)*
     &        RPINF2(M(1),M(2),M(3),M(4),WIDTH(6),WIDTH(2),RESM(6),
     &        RESM(2),A(2),A(6),B(2),B(6),2)
            ENDIF
            IF(.NOT.CRSTRM(3)) THEN
              IF(.NOT.CRSTRM(5)) GLUWD=GLUWD+0.5*MIXING(3)*MIXING(5)*
     &        RPINF2(M(2),M(1),M(3),M(4),WIDTH(5),WIDTH(3),RESM(5),
     &        RESM(3),A(3),A(5),B(3),B(5),2)
              IF(.NOT.CRSTRM(6)) GLUWD=GLUWD+0.5*MIXING(3)*MIXING(6)*
     &        RPINF2(M(2),M(1),M(3),M(4),WIDTH(6),WIDTH(3),RESM(6),
     &        RESM(3),A(3),A(6),B(3),B(6),2)
            ENDIF
            IF(.NOT.CRSTRM(4)) THEN
              IF(.NOT.CRSTRM(5)) GLUWD=GLUWD+0.5*MIXING(4)*MIXING(5)*
     &        RPINF2(M(2),M(1),M(3),M(4),WIDTH(5),WIDTH(4),RESM(5),
     &        RESM(4),A(4),A(5),B(4),B(5),2)
              IF(.NOT.CRSTRM(6)) GLUWD=GLUWD+0.5*MIXING(4)*MIXING(6)*
     &        RPINF2(M(2),M(1),M(3),M(4),WIDTH(6),WIDTH(4),RESM(6),
     &        RESM(4),A(4),A(6),B(4),B(6),2)
            ENDIF
            GLUWD = LAMCOL*GLUWD
            GLUWD = GLUWD/((2*PI)**3*32*M(4)**3)
C--Output the rate and particles to decay tables
 30         IF(GLUWD.GT.EPS) THEN
              CALL RPMODA(GLUWD,29,POUT1,POUT2,POUT3)
              CALL RPMODA(GLUWD,29,-POUT1,-POUT2,-POUT3)
            ENDIF
          ENDDO
        ENDDO
      ENDDO
C--Decay modes of the chargino 
C--we will do the one diagram via LLE and LQD modes first
      MCHAR(1) = 1./(SQRT(2.)*AMW*CBETA)
      MCHAR(2) = 1./(SQRT(2.)*AMW*SBETA)
      DO L=1,2
        DO CHANEL=1,3
          DO I=1,3
            DO J=1,3
              DO K=1,3
                MIXING(1) = ONE
                MIXING(2) = ZERO
                DO MIX=1,2
                  RESM(MIX) = ZERO
                  WIDTH(MIX) = ZERO
                ENDDO
                IF(CHANEL.EQ.1) THEN
C--LLE decay to charged lepton, neutrino, antineutrino
                  M(1) = ZERO
                  M(2) = MLP(J)
                  M(3) = ZERO
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSLRT(K)
                  WIDTH(1) = SLRTWD(K)
                  IF(K.NE.3) THEN
                    A(1) = -WMXUSS(L,2)*MLP(K)*MCHAR(1)
                    B(1) = ZERO
                  ELSE
C--left/right stau mixing
                    DO MIX=1,2  
                      MIXING(MIX) = LMIXSS(2,MIX)
                      A(MIX) = WMXUSS(L,1)*LMIXSS(1,MIX)-
     &             WMXUSS(L,2)*MLP(K)*MCHAR(1)*LMIXSS(2,MIX)
                      B(MIX) = ZERO
                    ENDDO     
                    RESM(1)= MSLLT(2*K-1)
                    RESM(2)= MSLRT(K)    
                    WIDTH(1)=SLLTWD(2*K)
                    WIDTH(2)=SLRTWD(K) 
                  ENDIF
                  LAMCOL = G**2*LAMDA1(I,J,K)**2
                  POUT1 = -9-2*I 
                  POUT2 = -10-2*J  
                  POUT3 = 9+2*K
                ELSEIF(CHANEL.EQ.2) THEN
C--LQD decay to antineutrino, dbar, up
                  M(1) = ZERO
                  M(2) = MQU(2*J-1)
                  M(3) = MQU(2*K)
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSQRT(2*K-1)
                  WIDTH(1)= SQRTWD(2*K-1)
                  IF(K.NE.3) THEN
                    A(1) = -WMXUSS(L,2)*MQU(2*K-1)*MCHAR(1)
                    B(1) = 0
                  ELSE
                    DO MIX=1,2
                      MIXING(MIX) = BMIXSS(2,MIX)
                      A(MIX) = WMXUSS(L,1)*BMIXSS(1,MIX)-
     &            WMXUSS(L,2)*BMIXSS(2,MIX)*MQU(2*K-1)*MCHAR(1)
                      B(MIX) = -MQU(2*K)*WMXVSS(L,2)*BMIXSS(1,MIX)*
     &                         MCHAR(2) 
                      IF(CMSIGN(L).LT.0) B(MIX)=-B(MIX)
                    ENDDO
                    RESM(1)= MSQLT(2*K-1)
                    RESM(2)= MSQRT(2*K-1)    
                    WIDTH(1)=SQLTWD(2*K-1)
                    WIDTH(2)=SQRTWD(2*K-1)
                  ENDIF
                  LAMCOL = 3.*G**2*LAMDA2(I,J,K)**2
                  POUT1 = -9-2*I 
                  POUT2 = 1-2*J
                  POUT3 = 2*K
                  IF(J.EQ.1) POUT2 = -2
                  IF(K.EQ.1) POUT3 = 1
                ELSEIF(CHANEL.EQ.3) THEN
C--LQD decay to charged lepton, ubar, up
                  M(1) = MLP(I)
                  M(2) = MQU(2*J)
                  M(3) = MQU(2*K)
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSQRT(2*K-1)
                  WIDTH(1)= SQRTWD(2*K-1)
                  IF(K.NE.3) THEN
                    A(1) = -WMXUSS(L,2)*MQU(2*K-1)*MCHAR(1)
                    B(1) = ZERO
                  ELSE
                    DO MIX=1,2
                      MIXING(MIX) = BMIXSS(2,MIX)
                      A(MIX) = WMXUSS(L,1)*BMIXSS(1,MIX)-
     &            WMXUSS(L,2)*BMIXSS(2,MIX)*MQU(2*K-1)*MCHAR(1)
                      B(MIX) = -MQU(2*K)*WMXVSS(L,2)*BMIXSS(1,MIX)*
     &                         MCHAR(2)
                      IF(CMSIGN(L).LT.0) B(MIX)=-B(MIX)
                    ENDDO
                    RESM(1)= MSQLT(2*K-1)
                    RESM(2)= MSQRT(2*K-1)    
                    WIDTH(1)=SQLTWD(2*K-1)
                    WIDTH(2)=SQRTWD(2*K-1) 
                  ENDIF
                  LAMCOL = 3.*G**2*LAMDA2(I,J,K)**2
                  POUT1 = -10-2*I 
                  POUT2 = -2*J
                  POUT3 = 2*K
                  IF(J.EQ.1) POUT2 = -1
                  IF(K.EQ.1) POUT3 = 1
                ENDIF  
                CHARWD = ZERO
                IF(M(4).LT.(M(1)+M(2)+M(3))) GOTO 40
C--Decide whether to remove diagrams
                DO N=1,2
                  CRSTRM(N) = .FALSE.
                ENDDO
                CRSTRM(1) = (M(4).GT.(M(3)+ABS(RESM(1))).
     &                      AND.ABS(RESM(1)).GT.(M(1)+M(2))) 
                CRSTRM(2) = (M(4).GT.(M(3)+ABS(RESM(2))).
     &                      AND.ABS(RESM(2)).GT.(M(1)+M(2))) 
     &                     .OR.(ABS(RESM(2)).LT.EPS)
C--Calculation of the rate
               IF((CRSTRM(1).AND.CRSTRM(2)).OR.LAMCOL.LT.EPS) GOTO 40
C--first the diagram squared pieces
                IF(.NOT.CRSTRM(1)) CHARWD = CHARWD+ MIXING(1)**2*
     &          RPINF1(M(1),M(2),M(3),M(4),WIDTH(1),RESM(1),A(1),B(1))
                IF(.NOT.CRSTRM(2)) CHARWD = CHARWD+MIXING(2)**2*
     &          RPINF1(M(1),M(2),M(3),M(4),WIDTH(2),RESM(2),A(2),B(2))
C--now for the light/heavy interference due left/right mixing
                IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) CHARWD=CHARWD+
     &          MIXING(1)*MIXING(2)*RPINF2(M(1),M(2),M(3),M(4),WIDTH(1),
     &          WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
                CHARWD = LAMCOL*CHARWD/((2*PI)**3*32*M(4)**3)
 40             IF(CHARWD.GT.EPS) CALL RPMODA(CHARWD,29+10*L,
     &                                          POUT1,POUT2,POUT3)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDDO
C--Now for the two diagram LLE and LQD modes, these tend to have
C--higher branching ratios
      DO L=1,2
        DO CHANEL=1,4
          DO I=1,3
            DO J=1,3
              DO K=1,3
                DO N=1,6
                  A(N) = ZERO
                  B(N) = ZERO
                  RESM(N) = ZERO
                  WIDTH(N) = ZERO
                ENDDO
                DO MIX=1,2
                  MIXING(2*MIX-1) = 1.
                  MIXING(2*MIX) = ZERO
                ENDDO
C--LLE to neutrino, neutrino, charged lepton
                IF(CHANEL.EQ.1) THEN
                  M(1) = ZERO
                  M(2) = ZERO
                  M(3) = MLP(K)
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSLLT(2*I-1)
                  RESM(3) = MSLLT(2*J-1)
                  WIDTH(1)= SLLTWD(2*I)
                  WIDTH(3)= SLLTWD(2*J)
                  IF(I.NE.3) THEN
                    B(1) = WMXUSS(L,1)
                  ELSE
                    DO MIX=1,2
                      MIXING(MIX) = LMIXSS(1,MIX)
                      B(MIX) = WMXUSS(L,1)*LMIXSS(1,MIX)-
     &                WMXUSS(L,2)*LMIXSS(2,MIX)*MLP(I)*MCHAR(1)
                    ENDDO
                    RESM(2)= MSLRT(I)    
                    WIDTH(2)=SLRTWD(I) 
                  ENDIF
                  IF(J.NE.3) THEN
                    B(3) = WMXUSS(L,1)
                  ELSE
                    DO MIX=1,2
                      MIXING(2+MIX) = LMIXSS(1,MIX)
                      B(2+MIX) = WMXUSS(L,1)*LMIXSS(1,MIX)-
     &                WMXUSS(L,2)*LMIXSS(2,MIX)*MLP(J)*MCHAR(1)
                    ENDDO
                    RESM(4)= MSLRT(J)    
                    WIDTH(4)=SLRTWD(J) 
                  ENDIF
                  IF(I.GT.J) THEN
                    LAMCOL = G**2*LAMDA1(I,J,K)**2
                  ELSE
                    LAMCOL = ZERO
                  ENDIF
                  POUT1 = 9+2*I 
                  POUT2 = 9+2*J
                  POUT3 = -10-2*K
C--LLE +ve lepton, +ve lepton, -ve lepton 
                ELSEIF(CHANEL.EQ.2) THEN
                  M(1) = MLP(I)
                  M(2) = MLP(J)
                  M(3) = MLP(K)
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSLLT(2*I)
                  RESM(3) = MSLLT(2*J)
                  WIDTH(1)= SLLTWD(2*I-1)
                  WIDTH(3)= SLLTWD(2*J-1)
                  A(1) = -MLP(I)*WMXUSS(L,2)*MCHAR(1)
                  B(1) = WMXVSS(L,1)
                  A(3) = -MLP(J)*WMXUSS(L,2)*MCHAR(1)
                  B(3) = WMXVSS(L,1)
                  IF(CMSIGN(L).LT.0) THEN
                    B(1) = -B(1)
                    B(3) = -B(3)
                  ENDIF
                  IF(I.GT.J) THEN
                    LAMCOL = G**2*LAMDA1(I,J,K)**2
                  ELSE
                    LAMCOL = ZERO
                  ENDIF
                  POUT1 = -10-2*I 
                  POUT2 = -10-2*J
                  POUT3 =  10+2*K
C--LQD to charged lepton, dbar, down
                ELSEIF(CHANEL.EQ.3) THEN
                  M(1) = MLP(I)
                  M(2) = MQU(2*J-1)
                  M(3) = MQU(2*K-1)
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSLLT(2*I)
                  RESM(3) = MSQLT(2*J)
                  WIDTH(1)= SLLTWD(2*I-1)
                  WIDTH(3)= SQLTWD(2*J)
                  A(1) = -MLP(I)*WMXUSS(L,2)*MCHAR(1)
                  B(1) =  WMXVSS(L,1)
                  IF(J.NE.3) THEN
                    A(3) = -MQU(2*J-1)*WMXUSS(L,2)*MCHAR(1)
                    B(3) = WMXVSS(L,1)
                  ELSE
                    DO MIX=1,2
                      MIXING(2+MIX) = TMIXSS(1,MIX)
                      A(2+MIX) = -MQU(2*J-1)*WMXUSS(L,2)*MCHAR(1)
     &                           *TMIXSS(1,MIX)
                      B(2+MIX) = WMXVSS(L,1)*TMIXSS(1,MIX)-
     &                WMXVSS(L,2)*TMIXSS(2,MIX)*MQU(2*J)*MCHAR(2)
                    ENDDO
                    RESM(4)= MSQRT(2*J)    
                    WIDTH(4)=SQRTWD(2*J) 
                  ENDIF
                  IF(CMSIGN(L).LT.0) THEN
                    B(1) = -B(1)
                    B(3) = -B(3)
                    B(4) = -B(4)
                  ENDIF
                  LAMCOL = 3*G**2*LAMDA2(I,J,K)**2
                  POUT1 = -10-2*I 
                  POUT2 = 1-2*J
                  POUT3 = 2*K-1
                  IF(J.EQ.1) POUT2 = -2 
                  IF(K.EQ.1) POUT3 = 2
C--LQD to neutrino, up, dbar
                ELSEIF(CHANEL.EQ.4) THEN
                  M(1) = ZERO
                  M(2) = MQU(2*J)
                  M(3) = MQU(2*K-1)
                  M(4) = ABS(CHARM(L))
                  RESM(1) = MSLLT(2*I-1)
                  RESM(3) = MSQLT(2*J-1)
                  WIDTH(1)= SLLTWD(2*I)
                  WIDTH(3)= SQLTWD(2*J-1)
                  IF(I.NE.3) THEN
                    B(1) = WMXUSS(L,1)
                  ELSE
                    DO MIX=1,2
                      MIXING(MIX) = LMIXSS(1,MIX)
                      B(MIX) = WMXUSS(L,1)*LMIXSS(1,MIX)-
     &                WMXUSS(L,2)*LMIXSS(2,MIX)*MLP(I)*MCHAR(1)
                    ENDDO
                    RESM(2)= MSLRT(I)    
                    WIDTH(2)=SLRTWD(I) 
                  ENDIF
                  IF(J.NE.3) THEN
                    A(3) = -MQU(2*J)*WMXVSS(L,2)*MCHAR(2)
                    B(3) = WMXUSS(L,1)
                  ELSE
                    DO MIX=1,2
                      MIXING(2+MIX) = BMIXSS(1,MIX)
                      A(2+MIX) = -MQU(2*J)*WMXVSS(L,2)*BMIXSS(1,MIX)*
     &                         MCHAR(2)
                      B(2+MIX) = WMXUSS(L,1)*BMIXSS(1,MIX)-
     &            WMXUSS(L,2)*BMIXSS(2,MIX)*MQU(2*J-1)*MCHAR(1)
                    ENDDO
                    RESM(4)= MSQRT(2*J-1)    
                    WIDTH(4)=SQRTWD(2*J-1) 
                  ENDIF
                  IF(CMSIGN(L).LT.0) THEN
                    DO N=1,4
                      A(N) = -A(N)
                    ENDDO
                  ENDIF
                  LAMCOL = 3*G**2*LAMDA2(I,J,K)**2
                  POUT1 = 9+2*I 
                  POUT2 = 2*J
                  POUT3 = 1-2*K
                  IF(J.EQ.1) POUT2 = 1 
                  IF(K.EQ.1) POUT3 = -2
                ENDIF
C--Decide whether to remove diagrams
                CHARWD =ZERO
                IF(M(4).LT.(M(1)+M(2)+M(3))) GOTO 50
                DO N=1,4
                  CRSTRM(N) = .FALSE.
                ENDDO
                CRSTRM(1) = (M(4).GT.(M(1)+ABS(RESM(1))).
     &                       AND.ABS(RESM(1)).GT.(M(2)+M(3))) 
                CRSTRM(2) = (M(4).GT.(M(1)+ABS(RESM(2))).
     &                       AND.ABS(RESM(2)).GT.(M(2)+M(3))) 
     &                       .OR.(ABS(RESM(2)).LT.EPS)
                CRSTRM(3) = (M(4).GT.(M(2)+ABS(RESM(3))).
     &                       AND.ABS(RESM(3)).GT.(M(1)+M(3)))
                CRSTRM(4) = (M(4).GT.(M(2)+ABS(RESM(4))).
     &                       AND.ABS(RESM(4)).GT.(M(1)+M(3)))
     &                       .OR.(ABS(RESM(4)).LT.EPS)
C--Calculation of the rate
                CHARWD = ZERO
                IF((CRSTRM(1).AND.CRSTRM(2).AND.CRSTRM(3).AND.
     &          CRSTRM(4)).OR.LAMCOL.LT.EPS) GOTO 50
C--first the diagram squared pieces
                IF(.NOT.CRSTRM(1)) CHARWD = CHARWD+ MIXING(1)**2*
     &          RPINF1(M(2),M(3),M(1),M(4),WIDTH(1),RESM(1),A(1),B(1))
                IF(.NOT.CRSTRM(2)) CHARWD = CHARWD+MIXING(2)**2*
     &          RPINF1(M(2),M(3),M(1),M(4),WIDTH(2),RESM(2),A(2),B(2))
                IF(.NOT.CRSTRM(3)) CHARWD = CHARWD+MIXING(3)**2*
     &          RPINF1(M(1),M(3),M(2),M(4),WIDTH(3),RESM(3),A(3),B(3))
                IF(.NOT.CRSTRM(4)) CHARWD = CHARWD+ MIXING(4)**2*
     &          RPINF1(M(1),M(3),M(2),M(4),WIDTH(4),RESM(4),A(4),B(4))
C--now for the light/heavy interference due left/right mixing
                IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) CHARWD=CHARWD+
     &          MIXING(1)*MIXING(2)*RPINF2(M(2),M(3),M(1),M(4),WIDTH(1),
     &           WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
                IF(.NOT.CRSTRM(3).AND..NOT.CRSTRM(4)) CHARWD=CHARWD+
     &          MIXING(3)*MIXING(4)*RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),
     &          WIDTH(4),RESM(3),RESM(4),A(3),A(4),B(3),B(4),1)
C--now for the true interference terms
                IF(.NOT.CRSTRM(1)) THEN
                  IF(.NOT.CRSTRM(3)) CHARWD=CHARWD+MIXING(1)*MIXING(3)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(1),RESM(3),
     &            RESM(1),A(1),A(3),B(1),B(3),2)
                  IF(.NOT.CRSTRM(4)) CHARWD=CHARWD+MIXING(1)*MIXING(4)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(1),RESM(4),
     &            RESM(1),A(1),A(4),B(1),B(4),2)
                ENDIF
                IF(.NOT.CRSTRM(2)) THEN
                  IF(.NOT.CRSTRM(3)) CHARWD=CHARWD+MIXING(2)*MIXING(3)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(2),RESM(3),
     &            RESM(2),A(2),A(3),B(2),B(3),2)
                  IF(.NOT.CRSTRM(4)) CHARWD=CHARWD+MIXING(2)*MIXING(4)*
     &            RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(2),RESM(4),
     &            RESM(2),A(2),A(4),B(2),B(4),2)
                ENDIF
C--final factors
                CHARWD = LAMCOL*CHARWD/((2*PI)**3*32*M(4)**3)
 50             IF(CHARWD.GT.EPS) CALL RPMODA(CHARWD,29+10*L,
     &                                          POUT1,POUT2,POUT3)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      ENDDO
C--Finally the BV chargino
C--first the decay to two up type and one down type quark
      DO L=1,2
        DO I=1,3
          DO J=1,3
            DO K=1,3
              DO MIX=1,2
                MIXING(MIX) = LAMDA3(J,I,K)
                MIXING(2+MIX)= LAMDA3(I,J,K)
              ENDDO
              M(1) = MQU(2*I)
              M(2) = MQU(2*J)
              M(3) = MQU(2*K-1)
              M(4) = ABS(CHARM(L))
              RESM(1) = MSQRT(2*I-1)
              RESM(3) = MSQRT(2*J-1)
              WIDTH(1)= SQRTWD(2*I-1)
              WIDTH(3)= SQRTWD(2*J-1)
              RESM(2) =ZERO
              WIDTH(2)=ZERO
              RESM(4) =ZERO
              WIDTH(4)=ZERO
              IF(I.NE.3) THEN
                A(1)=-WMXUSS(L,2)*MCHAR(1)*MQU(2*I-1)
                B(1)= ZERO
                MIXING(2) = ZERO
              ELSE
                DO MIX=1,2
                  MIXING(MIX) = BMIXSS(2,MIX)*MIXING(MIX)
                  A(MIX) = WMXUSS(L,1)*BMIXSS(1,MIX)-
     &         WMXUSS(L,2)*MCHAR(1)*MQU(2*I-1)*BMIXSS(2,MIX)
                  B(MIX) = -MQU(2*I)*WMXVSS(L,2)*BMIXSS(1,MIX)*
     &                     MCHAR(2)
                ENDDO
                RESM(1) = MSQLT(2*I-1)
                RESM(2) = MSQRT(2*I-1)
                WIDTH(1)= SQLTWD(2*I-1)
                WIDTH(2)= SQRTWD(2*I-1)
              ENDIF
              IF(J.NE.3) THEN
                A(3) = -MQU(2*J-1)*WMXUSS(L,2)*MCHAR(1)
                B(3) = ZERO
                MIXING(4) = ZERO
              ELSE
                DO MIX=1,2
                  MIXING(2+MIX) = BMIXSS(2,MIX)*MIXING(MIX+2)
                  A(2+MIX) = WMXUSS(L,1)*BMIXSS(1,MIX)-
     &         WMXUSS(L,2)*MCHAR(1)*MQU(2*J-1)*BMIXSS(2,MIX)
                  B(2+MIX) = -MQU(2*J)*WMXVSS(L,2)*BMIXSS(1,MIX)*
     &                     MCHAR(2)
                ENDDO 
                RESM(3) = MSQLT(2*J-1)
                RESM(4) = MSQRT(2*J-1)
                WIDTH(3)= SQLTWD(2*J-1)
                WIDTH(4)= SQRTWD(2*J-1)
              ENDIF
              IF(CMSIGN(L).LT.0) THEN
                DO N=1,4
                  B(N) = -B(N)
                ENDDO
              ENDIF
              IF(I.LE.J) THEN
                LAMCOL = 6*G**2
              ELSE
                LAMCOL = ZERO
              ENDIF
              POUT1 = 2*I
              POUT2 = 2*J
              POUT3 = 2*K-1
              IF(I.EQ.1) POUT1 = 1
              IF(J.EQ.1) POUT2 = 1 
              IF(K.EQ.1) POUT3 = 2
C--Decide whether to remove diagrams
              DO N=1,4
                CRSTRM(N) = .FALSE.
              ENDDO
              CHARWD = ZERO
              IF(M(4).LT.(M(1)+M(2)+M(3)).OR.LAMCOL.LT.EPS) GOTO 60
              CRSTRM(1) = (M(4).GT.(M(1)+ABS(RESM(1))).
     &                     AND.ABS(RESM(1)).GT.(M(2)+M(3))) 
              CRSTRM(2) = (M(4).GT.(M(1)+ABS(RESM(2))).
     &                     AND.ABS(RESM(2)).GT.(M(2)+M(3))) 
     &                     .OR.(ABS(RESM(2)).LT.EPS)
              CRSTRM(3) = (M(4).GT.(M(2)+ABS(RESM(3))).
     &                     AND.ABS(RESM(3)).GT.(M(1)+M(3)))
              CRSTRM(4) = (M(4).GT.(M(2)+ABS(RESM(4))).
     &                     AND.ABS(RESM(4)).GT.(M(1)+M(3)))
     &                     .OR.(ABS(RESM(4)).LT.EPS)
C--Calculation of the rate
              CHARWD = ZERO
              IF((CRSTRM(1).AND.CRSTRM(2).AND.CRSTRM(3).AND.
     &        CRSTRM(4))) GOTO 60
C--first the diagram squared pieces
              IF(.NOT.CRSTRM(1)) CHARWD = CHARWD+ MIXING(1)**2*
     &        RPINF1(M(2),M(3),M(1),M(4),WIDTH(1),RESM(1),A(1),B(1))
              IF(.NOT.CRSTRM(2)) CHARWD = CHARWD+MIXING(2)**2*
     &        RPINF1(M(2),M(3),M(1),M(4),WIDTH(2),RESM(2),A(2),B(2))
              IF(.NOT.CRSTRM(3)) CHARWD = CHARWD+MIXING(3)**2*
     &        RPINF1(M(1),M(3),M(2),M(4),WIDTH(3),RESM(3),A(3),B(3))
              IF(.NOT.CRSTRM(4)) CHARWD = CHARWD+ MIXING(4)**2*
     &        RPINF1(M(1),M(3),M(2),M(4),WIDTH(4),RESM(4),A(4),B(4))
C--now for the light/heavy interference due left/right mixing
              IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) CHARWD=CHARWD+
     &        MIXING(1)*MIXING(2)*RPINF2(M(2),M(3),M(1),M(4),WIDTH(1),
     &        WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
              IF(.NOT.CRSTRM(3).AND..NOT.CRSTRM(4)) CHARWD=CHARWD+
     &        MIXING(3)*MIXING(4)*RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),
     &        WIDTH(4),RESM(3),RESM(4),A(3),A(4),B(3),B(4),1)
C--now for the true interference terms
              IF(.NOT.CRSTRM(1)) THEN
                IF(.NOT.CRSTRM(3)) CHARWD=CHARWD+MIXING(1)*MIXING(3)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(1),RESM(3),
     &          RESM(1),A(1),A(3),B(1),B(3),2)
                IF(.NOT.CRSTRM(4)) CHARWD=CHARWD+MIXING(1)*MIXING(4)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(1),RESM(4),
     &          RESM(1),A(1),A(4),B(1),B(4),2)
              ENDIF
              IF(.NOT.CRSTRM(2)) THEN
                IF(.NOT.CRSTRM(3)) CHARWD=CHARWD+MIXING(2)*MIXING(3)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(2),RESM(3),
     &          RESM(2),A(2),A(3),B(2),B(3),2)
                IF(.NOT.CRSTRM(4)) CHARWD=CHARWD+MIXING(2)*MIXING(4)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(2),RESM(4),
     &          RESM(2),A(2),A(4),B(2),B(4),2)
              ENDIF
              CHARWD = LAMCOL*CHARWD/((2*PI)**3*32*M(4)**3)
C--Identical particle symmetry factor
              IF(I.EQ.J) CHARWD = CHARWD/2.0
C--Output the rate and particles to decay tables
 60           IF(CHARWD.GT.EPS) CALL RPMODA(CHARWD,29+10*L,POUT1,
     &                                                    POUT2,POUT3)
            ENDDO
          ENDDO
        ENDDO
      ENDDO
C--Now the decay to three down quarks
      DO L=1,2
        DO I=1,3
          DO J=1,3
            DO K=1,3
              DO MIX=1,2
                MIXING(MIX)   = LAMDA3(I,J,K)
                MIXING(MIX+2) = LAMDA3(J,K,I)
                MIXING(MIX+4) = LAMDA3(K,I,J)
              ENDDO   
              DO MIX=1,3
                RESM(2*MIX-1)   = ZERO
                RESM(2*MIX)     = ZERO
                WIDTH(2*MIX-1)  = ZERO
                WIDTH(2*MIX)    = ZERO 
              ENDDO
              CHARWD = ZERO
              M(1) = MQU(2*I-1)
              M(2) = MQU(2*J-1)
              M(3) = MQU(2*K-1)
              M(4) = ABS(CHARM(L))
              RESM(1) = MSQRT(2*I)
              RESM(3) = MSQRT(2*J)
              RESM(5) = MSQRT(2*K)
              WIDTH(1)= SQRTWD(2*I)
              WIDTH(3)= SQRTWD(2*J)
              WIDTH(5)= SQRTWD(2*K)
              IF(I.NE.3) THEN
                A(1) = -WMXVSS(L,2)*MQU(2*I)*MCHAR(2)
                B(1) = ZERO
                MIXING(2) = ZERO
              ELSE
                DO MIX=1,2
                  MIXING(MIX) = TMIXSS(2,MIX)*MIXING(MIX)
                  A(MIX) =WMXVSS(L,1)*TMIXSS(1,MIX)-
     &     WMXVSS(L,2)*MQU(2*I)*MCHAR(2)*TMIXSS(2,MIX)
                  B(MIX) =-MQU(2*I-1)*TMIXSS(1,MIX)*WMXUSS(L,2)*
     &                     MCHAR(1)
                ENDDO
C--bug fix 09/04/02 by P.R.
                RESM(1) = MSQLT(2*I)
                RESM(2) = MSQRT(2*I)
                WIDTH(1)= SQLTWD(2*I)
                WIDTH(2)= SQRTWD(2*I)
              ENDIF
              IF(J.NE.3) THEN
                A(3) = -WMXVSS(L,2)*MQU(2*J)*MCHAR(2)
                B(3) = ZERO 
                MIXING(4) = ZERO
              ELSE
                DO MIX=1,2
                  MIXING(MIX+2) = TMIXSS(2,MIX)*MIXING(MIX+2)
                  A(MIX+2) =WMXVSS(L,1)*TMIXSS(1,MIX)-
     &     WMXVSS(L,2)*MQU(2*J)*MCHAR(2)*TMIXSS(2,MIX)
                  B(MIX+2) =-MQU(2*I-1)*TMIXSS(1,MIX)*WMXUSS(L,2)*
     &                     MCHAR(1)
                ENDDO
C--bug fix 09/04/02 by P.R.
                RESM(3) = MSQLT(2*J)
                RESM(4) = MSQRT(2*J)
                WIDTH(3)= SQLTWD(2*J)
                WIDTH(4)= SQRTWD(2*J)
              ENDIF
              IF(K.NE.3) THEN
                A(5) = -WMXVSS(L,2)*MQU(2*K)*MCHAR(2)
                B(5) = ZERO
C--bug fix 09/04/02 by P.R.
                MIXING(6) = ZERO
              ELSE
                DO MIX=1,2
                  MIXING(MIX+4) = TMIXSS(2,MIX)*MIXING(MIX+4)
                  A(MIX+4) =WMXVSS(L,1)*TMIXSS(1,MIX)-
     &     WMXVSS(L,2)*MQU(2*K)*MCHAR(2)*TMIXSS(2,MIX)
                  B(MIX+4) =-MQU(2*K-1)*TMIXSS(1,MIX)*WMXUSS(L,2)*
     &                     MCHAR(1)
                ENDDO
C--bug fix 09/04/02 by P.R.
                RESM(5) = MSQLT(2*K)
                RESM(6) = MSQRT(2*K)
                WIDTH(5)= SQLTWD(2*K)
                WIDTH(6)= SQRTWD(2*K)
              ENDIF
              IF(CMSIGN(L).LT.0) THEN
                DO N=1,6
                  A(N) = -A(N)
                ENDDO
              ENDIF
              IF(K.LE.J.AND.J.LE.I) THEN
                LAMCOL = 6*G**2
              ELSE
                LAMCOL = ZERO
              ENDIF
              POUT1 = 1-2*I
              POUT2 = 1-2*J
              POUT3 = 1-2*K
              IF(I.EQ.1) POUT1 = -2
              IF(J.EQ.1) POUT2 = -2
              IF(K.EQ.1) POUT3 = -2
C--Decide whether to remove diagrams
              DO N=1,6
                CRSTRM(N) = .FALSE.
              ENDDO
              IF(M(4).LT.(M(1)+M(2)+M(3))) GOTO 70
              CRSTRM(1) = (M(4).GT.(M(1)+ABS(RESM(1))).
     &                     AND.ABS(RESM(1)).GT.(M(2)+M(3))) 
              CRSTRM(2) = (M(4).GT.(M(1)+ABS(RESM(2))).
     &                     AND.ABS(RESM(2)).GT.(M(2)+M(3))) 
     &                     .OR.(ABS(RESM(2)).LT.EPS)
              CRSTRM(3) = (M(4).GT.(M(2)+ABS(RESM(3))).
     &                     AND.ABS(RESM(3)).GT.(M(1)+M(3)))
              CRSTRM(4) = (M(4).GT.(M(2)+ABS(RESM(4))).
     &                     AND.ABS(RESM(4)).GT.(M(1)+M(3)))
     &                     .OR.(ABS(RESM(4)).LT.EPS)
              CRSTRM(5) = (M(4).GT.(M(3)+ABS(RESM(5))).
     &                     AND.ABS(RESM(5)).GT.(M(1)+M(2)))
              CRSTRM(6) = (M(4).GT.(M(3)+ABS(RESM(6))).
     &                     AND.ABS(RESM(6)).GT.(M(1)+M(2)))
     &                     .OR.(ABS(RESM(6)).LT.EPS)
C--Calculation of the rate
              CHARWD = ZERO
              IF((CRSTRM(1).AND.CRSTRM(2).AND.CRSTRM(3).AND.
     &        CRSTRM(4).AND.CRSTRM(5).AND.CRSTRM(6)).
     &        OR.LAMCOL.LT.EPS) GOTO 70
C--first the diagram squared pieces
              IF(.NOT.CRSTRM(1)) CHARWD = CHARWD+ MIXING(1)**2*
     &        RPINF1(M(2),M(3),M(1),M(4),WIDTH(1),RESM(1),A(1),B(1))
              IF(.NOT.CRSTRM(2)) CHARWD = CHARWD+MIXING(2)**2*
     &        RPINF1(M(2),M(3),M(1),M(4),WIDTH(2),RESM(2),A(2),B(2))
              IF(.NOT.CRSTRM(3)) CHARWD = CHARWD+MIXING(3)**2*
     &        RPINF1(M(1),M(3),M(2),M(4),WIDTH(3),RESM(3),A(3),B(3))
              IF(.NOT.CRSTRM(4)) CHARWD = CHARWD+ MIXING(4)**2*
     &        RPINF1(M(1),M(3),M(2),M(4),WIDTH(4),RESM(4),A(4),B(4))
              IF(.NOT.CRSTRM(5)) CHARWD = CHARWD+MIXING(5)**2*
     &        RPINF1(M(1),M(2),M(3),M(4),WIDTH(5),RESM(5),A(5),B(5))
              IF(.NOT.CRSTRM(6)) CHARWD = CHARWD+MIXING(6)**2*
     &        RPINF1(M(1),M(2),M(3),M(4),WIDTH(6),RESM(6),A(6),B(6))
C--now for the light/heavy interference due left/right mixing
              IF(.NOT.CRSTRM(1).AND..NOT.CRSTRM(2)) CHARWD=CHARWD+
     &        MIXING(1)*MIXING(2)*RPINF2(M(2),M(3),M(1),M(4),WIDTH(1),
     &        WIDTH(2),RESM(1),RESM(2),A(1),A(2),B(1),B(2),1)
              IF(.NOT.CRSTRM(3).AND..NOT.CRSTRM(4)) CHARWD=CHARWD+
     &        MIXING(3)*MIXING(4)*RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),
     &        WIDTH(4),RESM(3),RESM(4),A(3),A(4),B(3),B(4),1)
              IF(.NOT.CRSTRM(5).AND..NOT.CRSTRM(6)) CHARWD=CHARWD+
     &        MIXING(5)*MIXING(6)*RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),
     &        WIDTH(6),RESM(5),RESM(6),A(5),A(6),B(5),B(6),1)
C--now for the true interference terms
              IF(.NOT.CRSTRM(1)) THEN
                IF(.NOT.CRSTRM(3)) CHARWD=CHARWD-MIXING(1)*MIXING(3)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(1),RESM(3),
     &          RESM(1),A(1),A(3),B(1),B(3),2)
                IF(.NOT.CRSTRM(4)) CHARWD=CHARWD-MIXING(1)*MIXING(4)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(1),RESM(4),
     &          RESM(1),A(1),A(4),B(1),B(4),2)
                IF(.NOT.CRSTRM(5)) CHARWD=CHARWD-MIXING(1)*MIXING(5)*
     &          RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),WIDTH(1),RESM(5),
     &          RESM(1),A(1),A(5),B(1),B(5),2)
                IF(.NOT.CRSTRM(6)) CHARWD=CHARWD-MIXING(1)*MIXING(6)*
     &          RPINF2(M(1),M(2),M(3),M(4),WIDTH(6),WIDTH(1),RESM(6),
     &          RESM(1),A(1),A(6),B(1),B(6),2)
              ENDIF
              IF(.NOT.CRSTRM(2)) THEN
                IF(.NOT.CRSTRM(3)) CHARWD=CHARWD-MIXING(2)*MIXING(3)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(3),WIDTH(2),RESM(3),
     &          RESM(2),A(2),A(3),B(2),B(3),2)
                IF(.NOT.CRSTRM(4)) CHARWD=CHARWD-MIXING(2)*MIXING(4)*
     &          RPINF2(M(1),M(3),M(2),M(4),WIDTH(4),WIDTH(2),RESM(4),
     &          RESM(2),A(2),A(4),B(2),B(4),2)
                IF(.NOT.CRSTRM(5)) CHARWD=CHARWD-MIXING(2)*MIXING(5)*
     &          RPINF2(M(1),M(2),M(3),M(4),WIDTH(5),WIDTH(2),RESM(5),
     &          RESM(2),A(2),A(5),B(2),B(5),2)
                IF(.NOT.CRSTRM(6)) CHARWD=CHARWD-MIXING(2)*MIXING(6)*
     &          RPINF2(M(1),M(2),M(3),M(4),WIDTH(6),WIDTH(2),RESM(6),
     &          RESM(2),A(2),A(6),B(2),B(6),2)
              ENDIF
              IF(.NOT.CRSTRM(3)) THEN
                IF(.NOT.CRSTRM(5)) CHARWD=CHARWD-MIXING(3)*MIXING(5)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(5),WIDTH(3),RESM(5),
     &          RESM(3),A(3),A(5),B(3),B(5),2)
                IF(.NOT.CRSTRM(6)) CHARWD=CHARWD-MIXING(3)*MIXING(6)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(6),WIDTH(3),RESM(6),
     &          RESM(3),A(3),A(6),B(3),B(6),2)
              ENDIF
              IF(.NOT.CRSTRM(4)) THEN
                IF(.NOT.CRSTRM(5)) CHARWD=CHARWD-MIXING(4)*MIXING(5)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(5),WIDTH(4),RESM(5),
     &          RESM(4),A(4),A(5),B(4),B(5),2)
                IF(.NOT.CRSTRM(6)) CHARWD=CHARWD-MIXING(4)*MIXING(6)*
     &          RPINF2(M(2),M(1),M(3),M(4),WIDTH(6),WIDTH(4),RESM(6),
     &          RESM(4),A(4),A(6),B(4),B(6),2)
              ENDIF
              CHARWD = LAMCOL*CHARWD/((2*PI)**3*32*M(4)**3)
C--Identical particle symmetry factor
              IF(I.EQ.J.OR.I.EQ.K.OR.J.EQ.K) CHARWD = CHARWD/2.0
C--Output the rate and particles to decay tables
 70           IF(CHARWD.GT.EPS) CALL RPMODA(CHARWD,29+10*L,POUT1,
     &                                              POUT2,POUT3)
            ENDDO
          ENDDO
        ENDDO
      ENDDO
      END
CDECK  ID>, RPINF1
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
       FUNCTION RPINF1(MI1,MI2,MI3,MI4,WIDTH,RESM,AIN,BIN)
C-----------------------------------------------------------------------
C      FUNCTION TO RETURN THE INTEGRATED AMPLITUDE SQUARE PIECE OF A
C      THREE BODY DECAY MATRIX ELEMENT
C-----------------------------------------------------------------------
       DOUBLE PRECISION LOW,UPP
       REAL MI1,MI2,MI3,MI4,WIDTH,RESM,AIN,BIN,RPINF1
       DOUBLE PRECISION SSDINT,RPINT1
       EXTERNAL SSDINT,RPINT1
C--common block to pass the masses,etc
       COMMON /SQUTRM/ M(4),GAM,MR,A,B
       DOUBLE PRECISION M,GAM,MR,A,B
C--Set the masses and couplings in the integration routine
       M(1) = DBLE(MI1)
       M(2) = DBLE(MI2)
       M(3) = DBLE(MI3)
       M(4) = DBLE(MI4)
       A    = DBLE(AIN)
       B    = DBLE(BIN)
       GAM  = DBLE(WIDTH)
       MR   = DBLE(ABS(RESM))
C--Perform the smoothing
       LOW = ATAN(((M(1)+M(2))**2-MR**2)/(GAM*MR))/(GAM*MR)
       UPP = ATAN(((M(4)-M(3))**2-MR**2)/(GAM*MR))/(GAM*MR)
C--Do the outer integral
       RPINF1 = 0.5E0*REAL(SSDINT(LOW,RPINT1,UPP))
       END
CDECK  ID>, RPINF2
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
       FUNCTION RPINF2(MI1,MI2,MI3,MI4,WIDTH1,WIDTH2,RESM1,RESM2,
     &                 AIN1,AIN2,BIN1,BIN2,TYPE)
C-----------------------------------------------------------------------
C      FUNCTION TO CALCULATE THE INTERFERENCE TERMS FOR 3-BODY
C      RPARITY VIOLATING DECAY RATES
C-----------------------------------------------------------------------
       IMPLICIT NONE
       DOUBLE PRECISION LOW,UPP
       REAL MI1,MI2,MI3,MI4,WIDTH1,WIDTH2,RESM1,RESM2,AIN1,AIN2
     &      ,BIN1,BIN2,RPINF2
       INTEGER I,TYPE
       DOUBLE PRECISION SSDINT,RPINT2,RPINT3
       EXTERNAL SSDINT,RPINT2,RPINT3
C--common block to pass the masses,etc
       COMMON /INFTRM/ M(4),MSQ(4),GAM(2),MR(2),MRSQ(2),A(2),B(2)
       DOUBLE PRECISION M,GAM,MR,MRSQ,A,B,MSQ
C--Set the masses and couplings in the integration routine
       M(1)   = DBLE(MI1)
       M(2)   = DBLE(MI2)
       M(3)   = DBLE(MI3)
       M(4)   = DBLE(MI4)
       A(1)   = DBLE(AIN1)
       A(2)   = DBLE(AIN2)
       B(1)   = DBLE(BIN1)
       B(2)   = DBLE(BIN2)
       GAM(1) = DBLE(WIDTH1)
       GAM(2) = DBLE(WIDTH2)
       MR(1)  = DBLE(RESM1)
       MR(2)  = DBLE(RESM2)
       DO I=1,4
         MSQ(I)=M(I)**2
       ENDDO
       DO I=1,2
         MRSQ(I)=MR(I)**2
       ENDDO
C--Perform the smoothing
       LOW = ATAN(((M(1)+M(2))**2-MR(1)**2)/(GAM(1)*ABS(MR(1))))
     &       /(GAM(1)*ABS(MR(1)))
       UPP = ATAN(((M(4)-M(3))**2-MR(1)**2)/(GAM(1)*ABS(MR(1))))
     &       /(GAM(1)*ABS(MR(1)))
C--Do the outer integral
       IF(TYPE.EQ.1) RPINF2 = REAL(SSDINT(LOW,RPINT2,UPP))
       IF(TYPE.EQ.2) RPINF2 = REAL(SSDINT(LOW,RPINT3,UPP))
       END
CDECK  ID>, RPINT1
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
       FUNCTION RPINT1(RHO)
C-----------------------------------------------------------------------
C      INTEGRAND FOR THE AMPLITUDE SQUARE PIECE OF THE THREE BODY DECAY
C-----------------------------------------------------------------------
       DOUBLE PRECISION RHO,X,RPINT1,M23MIN,M23MAX,E2STAR,E3STAR,
     &                  Y,LIMIT(2),E2MIMA,E3MIMA
       INTEGER          I
C--common block to pass the masses,etc
       COMMON /SQUTRM/ M(4),GAM,MR,A,B
       DOUBLE PRECISION M,GAM,MR,A,B,RPRTCH
       EXTERNAL RPRTCH
C--Calculate the change of variables
       X = MR**2+GAM*MR*TAN(GAM*MR*RHO)
C--Evaulate limits on the inner integral
       E2STAR = (X-M(1)**2+M(2)**2)/(2*SQRT(X))
       E3STAR = (M(4)**2-X-M(3)**2)/(2*SQRT(X))
       E2MIMA = RPRTCH(M(2),E2STAR)
       E3MIMA = RPRTCH(M(3),E3STAR)
       M23MAX = (E2STAR+E3STAR)**2-(E2MIMA-E3MIMA)**2
       M23MIN = (E2STAR+E3STAR)**2-(E2MIMA+E3MIMA)**2
C--Do the inner integral
       Y = M23MIN
       DO I=1,2
          LIMIT(I) =         Y*(X - M(1)**2 - M(2)**2)*
     -  (4*A*B*M(3)*M(4) + (A**2 + B**2)*(-X + M(3)**2 + M(4)**2))
          Y=M23MAX
       ENDDO
       RPINT1 = LIMIT(2)-LIMIT(1)
       END
CDECK  ID>, RPINT2
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
       FUNCTION RPINT2(RHO)
C-----------------------------------------------------------------------
C      FUNCTION FOR THE INTEGRAND FOR THE LIGHT/HEAVY INTERFERENCE
C      TERM IN A 3-BODY R-PARITY VIOLATING DECAY
C-----------------------------------------------------------------------
       DOUBLE PRECISION RHO,X,RPINT2,M23MIN,M23MAX,E2STAR,E3STAR,
     &                  Y,LIMIT(2),E2MIMA,E3MIMA
       INTEGER          I
C--common block to pass the masses,etc
       COMMON /INFTRM/ M(4),MSQ(4),GAM(2),MR(2),MRSQ(2),A(2),B(2)
       DOUBLE PRECISION M,MSQ,GAM,MR,MRSQ,A,B,RPRTCH
       EXTERNAL RPRTCH
C--Calculate the change of variables
       X = MR(1)**2+GAM(1)*ABS(MR(1))*TAN(GAM(1)*ABS(MR(1))*RHO)
C--Evaulate limits on the inner integral
       E2STAR = (X-M(1)**2+M(2)**2)/(2*SQRT(X))
       E3STAR = (M(4)**2-X-M(3)**2)/(2*SQRT(X))
       E2MIMA = RPRTCH(M(2),E2STAR)
       E3MIMA = RPRTCH(M(3),E3STAR)
       M23MAX = (E2STAR+E3STAR)**2-(E2MIMA-E3MIMA)**2
       M23MIN = (E2STAR+E3STAR)**2-(E2MIMA+E3MIMA)**2
C--Do the inner intergral
       Y = M23MIN
       DO I=1,2
          LIMIT(I) =         (Y*(X - MSQ(1) - MSQ(2))*
     -    (2*(A(2)*B(1) + A(1)*B(2))*M(3)*M(4) + 
     -      (A(1)*A(2) + B(1)*B(2))*(-X + MSQ(3) + MSQ(4)))*
     -    (GAM(1)*GAM(2)*MR(1)*MR(2) + (X - MR(1)**2)*(X - MR(2)**2)))
     -   /(GAM(2)**2*MR(2)**2 + (X - MR(2)**2)**2)
          Y=M23MAX
       ENDDO
       RPINT2 = LIMIT(2)-LIMIT(1)
       END
CDECK  ID>, RPINT3
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
       FUNCTION RPINT3(RHO)
C-----------------------------------------------------------------------
C      FUNCTION FOR INTEGRAND OF THE NORMAL INTERFERENCE TERM IN A 
C      3-BODY R-PARITY VIOLATING DECAY 
C-----------------------------------------------------------------------
       IMPLICIT NONE
       DOUBLE PRECISION RHO,X,RPINT3,M23MIN,M23MAX,E2STAR,E3STAR,
     &                  Y,LIMIT(2),E2MIMA,E3MIMA
       INTEGER          I
C--common block to pass the masses,etc
       COMMON /INFTRM/ M(4),MSQ(4),GAM(2),MR(2),MRSQ(2),A(2),B(2)
       DOUBLE PRECISION M,MSQ,GAM,MR,MRSQ,A,B,RPRTCH
       EXTERNAL RPRTCH
C--Calculate the change of variables
       X = MR(1)**2+GAM(1)*ABS(MR(1))*TAN(GAM(1)*ABS(MR(1))*RHO)
C--Evaulate limits on the inner integral
       E2STAR = (X-M(1)**2+M(2)**2)/(2*SQRT(X))
       E3STAR = (M(4)**2-X-M(3)**2)/(2*SQRT(X))
       E2MIMA = RPRTCH(M(2),E2STAR)
       E3MIMA = RPRTCH(M(3),E3STAR)
       M23MAX = (E2STAR+E3STAR)**2-(E2MIMA-E3MIMA)**2
       M23MIN = (E2STAR+E3STAR)**2-(E2MIMA+E3MIMA)**2
C--Do the inner integral
       Y = M23MIN
       DO I=1,2
          LIMIT(I) =Y*(X*B(1)*B(2)+A(1)*A(2)*M(1)*M(3)
     -      +A(1)*B(2)*M(1)*M(4))*
     -   (X-MRSQ(1))+(ATAN((Y-MRSQ(2))/(GAM(2)*SQRT(MRSQ(2))))*
     -     (X*A(1)*A(2)*GAM(1)*M(1)*M(3)*MR(1)*MR(2) + 
     -       X*A(2)*B(1)*GAM(1)*M(3)*M(4)*MR(1)*MR(2) - 
     -       X**2*B(1)*B(2)*GAM(2)*MRSQ(2) - 
     -       X*A(1)*A(2)*GAM(2)*M(1)*M(3)*MRSQ(2) - 
     -       X*A(1)*B(2)*GAM(2)*M(1)*M(4)*MRSQ(2) + 
     -       X*B(1)*B(2)*GAM(1)*MR(1)*MR(2)*MRSQ(2) + 
     -       A(1)*A(2)*GAM(1)*M(1)*M(3)*MR(1)*MR(2)*MRSQ(2) + 
     -       A(1)*B(2)*GAM(1)*M(1)*M(4)*MR(1)*MR(2)*MRSQ(2) + 
     -       X*B(1)*B(2)*GAM(2)*MRSQ(1)*MRSQ(2) + 
     -       A(1)*A(2)*GAM(2)*M(1)*M(3)*MRSQ(1)*MRSQ(2) + 
     -       A(1)*B(2)*GAM(2)*M(1)*M(4)*MRSQ(1)*MRSQ(2) - 
     -       A(1)*A(2)*GAM(1)*M(1)*M(3)*MR(1)*MR(2)*MSQ(1) - 
     -       A(2)*B(1)*GAM(1)*M(3)*M(4)*MR(1)*MR(2)*MSQ(1) - 
     -       A(1)*B(2)*GAM(1)*M(1)*M(4)*MR(1)*MR(2)*MSQ(2) - 
     -       A(2)*B(1)*GAM(1)*M(3)*M(4)*MR(1)*MR(2)*MSQ(2) - 
     -       A(1)*A(2)*GAM(1)*M(1)*M(3)*MR(1)*MR(2)*MSQ(3) - 
     -       A(1)*B(2)*GAM(1)*M(1)*M(4)*MR(1)*MR(2)*MSQ(3) - 
     -       B(1)*B(2)*GAM(1)*MR(1)*MR(2)*MSQ(1)*MSQ(3) - 
     - B(1)*B(2)*GAM(1)*MR(1)*MR(2)*MSQ(2)*MSQ(4)))/SQRT(MRSQ(2))+ 
     -  (LOG(Y**2 - 2*Y*MRSQ(2) + GAM(2)**2*MRSQ(2) + MRSQ(2)**2)*
     -     (X**2*A(1)*A(2)*M(1)*M(3) + X**2*A(2)*B(1)*M(3)*M(4) + 
     -       X*B(1)*B(2)*GAM(1)*GAM(2)*MR(1)*MR(2) + 
     -       A(1)*A(2)*GAM(1)*GAM(2)*M(1)*M(3)*MR(1)*MR(2) + 
     -       A(1)*B(2)*GAM(1)*GAM(2)*M(1)*M(4)*MR(1)*MR(2) - 
     - X*A(1)*A(2)*M(1)*M(3)*MRSQ(1)-X*A(2)*B(1)*M(3)*M(4)*MRSQ(1)+ 
     -       X**2*B(1)*B(2)*MRSQ(2) + X*A(1)*A(2)*M(1)*M(3)*MRSQ(2)+ 
     -    X*A(1)*B(2)*M(1)*M(4)*MRSQ(2)-X*B(1)*B(2)*MRSQ(1)*MRSQ(2)- 
     -       A(1)*A(2)*M(1)*M(3)*MRSQ(1)*MRSQ(2) - 
     -       A(1)*B(2)*M(1)*M(4)*MRSQ(1)*MRSQ(2) - 
     - X*A(1)*A(2)*M(1)*M(3)*MSQ(1) - X*A(2)*B(1)*M(3)*M(4)*MSQ(1) + 
     -       A(1)*A(2)*M(1)*M(3)*MRSQ(1)*MSQ(1) + 
     -       A(2)*B(1)*M(3)*M(4)*MRSQ(1)*MSQ(1) - 
     - X*A(1)*B(2)*M(1)*M(4)*MSQ(2) - X*A(2)*B(1)*M(3)*M(4)*MSQ(2) + 
     -       A(1)*B(2)*M(1)*M(4)*MRSQ(1)*MSQ(2) + 
     -       A(2)*B(1)*M(3)*M(4)*MRSQ(1)*MSQ(2) - 
     - X*A(1)*A(2)*M(1)*M(3)*MSQ(3) - X*A(1)*B(2)*M(1)*M(4)*MSQ(3) + 
     -     A(1)*A(2)*M(1)*M(3)*MRSQ(1)*MSQ(3) + 
     - A(1)*B(2)*M(1)*M(4)*MRSQ(1)*MSQ(3)-X*B(1)*B(2)*MSQ(1)*MSQ(3) + 
     -  B(1)*B(2)*MRSQ(1)*MSQ(1)*MSQ(3) - X*B(1)*B(2)*MSQ(2)*MSQ(4) + 
     - B(1)*B(2)*MRSQ(1)*MSQ(2)*MSQ(4)))/2.0D0
          Y=M23MAX
       ENDDO
       RPINT3 = LIMIT(2)-LIMIT(1)
       END
CDECK  ID>, RPMAIN
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C-----------------------------------------------------------------------
      SUBROUTINE RPMAIN 
C-----------------------------------------------------------------------
C     MAIN R-PARITY SUBROUTINE
C-----------------------------------------------------------------------
C     RPARTY   = logical, .TRUE. is consereved/.FALSE. is violated
C     LAMDA1   = LLE couplings
C     LAMDA2   = LUD couplings
C     LAMDA3   = UDD couplings
      COMMON/RSLASH/LAMDA1(3,3,3),LAMDA2(3,3,3),LAMDA3(3,3,3),RPARTY
      LOGICAL RPARTY
      REAL LAMDA1,LAMDA2,LAMDA3
      SAVE /RSLASH/
      CHARACTER*2 RYORN
C--Decide if want Rparity violating couplings
C-FP  Assume no Rparity violation, just return
      RPARTY=.TRUE.
      RETURN
      PRINT 100
 100  FORMAT(' R PARITY VIOLATION (Y/N)')
      READ(*,'(A1)')RYORN
      RPARTY = RYORN.NE.'Y'.AND.RYORN.NE.'y'
      IF(RPARTY) RETURN
C--If decide want rparity violation input the couplings
      PRINT 150
 150  FORMAT('Do you want lambda couplings(y/n)?')
      READ (*,'(A1)') RYORN
      IF(RYORN.EQ.'Y'.OR.RYORN.EQ.'y') THEN
        PRINT 200
 200    FORMAT(
     &      'ENTER LAMDBA IN ORDER 121,122,123,131,132,133,231,232,233')
        READ*,LAMDA1(1,2,1),LAMDA1(1,2,2),LAMDA1(1,2,3),LAMDA1(1,3,1),
     &        LAMDA1(1,3,2),LAMDA1(1,3,3),LAMDA1(2,3,1),LAMDA1(2,3,2),
     &        LAMDA1(2,3,3)
C--use the antisymmetry to find the rest
        DO K=1,3
          DO I=1,3
            DO J=1,3
              IF(I.EQ.J) LAMDA1(I,J,K) = 0.0E0
              IF(I.GT.J) LAMDA1(I,J,K) = -LAMDA1(J,I,K)
            ENDDO
          ENDDO
        ENDDO
      ELSE
        DO I=1,3
          DO J=1,3
            DO K=1,3
              LAMDA1(I,J,K) = 0.
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      PRINT 250
 250  FORMAT('Do you want lambda` couplings(y/n)?')
      READ(*,'(A1)') RYORN
      IF(RYORN.EQ.'Y'.OR.RYORN.EQ.'y') THEN
        PRINT 300
        PRINT 310
        PRINT 320
        PRINT 330
 300    FORMAT('ENTER LAMBDA` IN THE ORDER')
 310    FORMAT('111,112,113,121,122,123,131,132,133,')
 320    FORMAT('211,212,213,221,222,223,231,232,233,')
 330    FORMAT('311,312,313,321,322,323,331,332,333,')
        READ*,(((LAMDA2(I,J,K) ,K=1,3),J=1,3),I=1,3)
      ELSE
        DO I=1,3
          DO J=1,3
            DO K=1,3
              LAMDA2(I,J,K) = 0.
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      PRINT 350
 350  FORMAT('Do you want lambda`` couplings(y/n)?')
      READ (*,'(A1)') RYORN
      IF(RYORN.EQ.'Y'.OR.RYORN.EQ.'y') THEN
        PRINT 400
 400    FORMAT(
     &      'ENTER LAMDBA`` ORDER 112,113,123,212,213,223,312,313,323')
        READ*,LAMDA3(1,1,2),LAMDA3(1,1,3),LAMDA3(1,2,3),LAMDA3(2,1,2),
     &        LAMDA3(2,1,3),LAMDA3(2,2,3),LAMDA3(3,1,2),LAMDA3(3,1,3),
     &        LAMDA3(3,2,3)
C--use the antisymmetry to find the rest
        DO I=1,3
          DO J=1,3
            DO K=1,3
              IF(J.EQ.K) LAMDA3(I,J,K) = 0.0E0
              IF(J.GT.K) LAMDA3(I,J,K) = -LAMDA3(I,K,J)
            ENDDO
          ENDDO
        ENDDO
      ELSE
        DO I=1,3
          DO J=1,3
            DO K=1,3
              LAMDA3(I,J,K) = 0.
            ENDDO
          ENDDO
        ENDDO
      ENDIF
      CALL RPDECY
      END
CDECK  ID>, RPMODA
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
      SUBROUTINE RPMODA(RATE,PIN,POUT1,POUT2,POUT3)
C-----------------------------------------------------------------------
C     SUBROUTINE TO ADDED MODE TO DECAY TABLE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER NRPMD
      PARAMETER (NRPMD=5000)
      COMMON/RPARRT/NSSMD2,ISSMD2(NRPMD),JSSMD2(5,NRPMD),
     &              GSSMD2(NRPMD),BSSMD2(NRPMD)
      INTEGER NSSMD2,ISSMD2,JSSMD2,PIN,POUT1,POUT2,POUT3
      REAL    GSSMD2,BSSMD2,RATE
      SAVE /RPARRT/
      IF(RATE.GT.1E-40.AND.NSSMD2+1.LE.NRPMD) THEN
        NSSMD2=NSSMD2+1
        ISSMD2(NSSMD2)   = PIN
        JSSMD2(1,NSSMD2) = POUT1
        JSSMD2(2,NSSMD2) = POUT2
        JSSMD2(3,NSSMD2) = POUT3 
        JSSMD2(4,NSSMD2) = 0 
        JSSMD2(5,NSSMD2) = 0
        GSSMD2(NSSMD2) = RATE
        BSSMD2(NSSMD2) = 0
      ELSEIF(NSSMD2+1.GT.NRPMD) THEN
        print *,'TOO MANY R-PARITY VIOLATING MODES'
        print *,'INCREASE NRPMD AND RERUN'
        STOP
      ENDIF
      END
CDECK  ID>, RPNORM
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson 
C----------------------------------------------------------------------- 
      SUBROUTINE RPNORM  
C----------------------------------------------------------------------- 
C     SUBROUTINE TO REMOVE ALL MODES WITH BRANCHING RATIO LESS THAN 1E-5
C     AND TO ADD THE RPARITY VIOLATING MODES IF NEEDED
C-----------------------------------------------------------------------
      IMPLICIT NONE
C
C--Common block containing the SUSY parameters
C
+CDE,SSMODE
C
C--Common Block to contain R-parity violating decay rates
C
      INTEGER NRPMD
      PARAMETER (NRPMD=5000)
      COMMON/RPARRT/NSSMD2,ISSMD2(NRPMD),JSSMD2(5,NRPMD),
     &              GSSMD2(NRPMD),BSSMD2(NRPMD)
      REAL GSSMD2,BSSMD2
      INTEGER ISSMD2,JSSMD2,NSSMD2
      SAVE /RPARRT/
+CDE,SSLUN
C  Common Block for the R-parity violating couplings
      COMMON/RSLASH/LAMDA1(3,3,3),LAMDA2(3,3,3),LAMDA3(3,3,3),RPARTY
      LOGICAL RPARTY
      REAL LAMDA1,LAMDA2,LAMDA3
      SAVE /RSLASH/
C--Local varaibles
      INTEGER SUSYLP,SUSYMN(9),SUSYMX(9),SUSYSP(9),I,J,NRMMDS,NRMMDR,
     &        ANUMRM,L,K
      REAL RATE,ZERO,RRATE,RPBR,EPS,RMBRRT,MINBR
      PARAMETER(ZERO=0.,MINBR=1E-5,EPS=1E-50)  
      DATA SUSYMN /31,51,21,41,29,82,86,30,39/
      DATA SUSYMX /36,56,26,46,29,84,86,60,49/
      DATA SUSYSP / 1, 1, 1, 1, 1, 1, 1,10,10/
C--Now we need to recalculate rates,etc.
      DO SUSYLP = 1,9
        DO 50 I=SUSYMN(SUSYLP),SUSYMX(SUSYLP),SUSYSP(SUSYLP) 
C--If Rparity conserved just remove modes less then MINBR
          IF(RPARTY) THEN 
            RMBRRT = ZERO
            NRMMDS = 0
            DO J=1,NSSMOD
              IF(ISSMOD(J).EQ.I.AND.BSSMOD(J).LT.MINBR) THEN
                RMBRRT = RMBRRT + BSSMOD(J)
                ISSMOD(J) = 100000
                NRMMDS = NRMMDS+1 
              ENDIF
            ENDDO
C--Now remove the modes we have removed, and renormalise BR's to 1
            IF(NRMMDS.GT.0.OR.NRMMDR.GT.0) THEN
              ANUMRM = 0
              RMBRRT = 1/(1-RMBRRT)
              DO J=1,NSSMOD
 10             IF(ISSMOD(J+ANUMRM).EQ.100000) ANUMRM=ANUMRM+1
                ISSMOD(J) = ISSMOD(J+ANUMRM)
                DO L=1,5
                  JSSMOD(L,J)=JSSMOD(L,J+ANUMRM)
                ENDDO
                GSSMOD(J)=GSSMOD(J+ANUMRM)
                BSSMOD(J)=BSSMOD(J+ANUMRM)
                IF(ISSMOD(J).EQ.100000) GOTO 10
                IF(ISSMOD(J).EQ.I) THEN
                  BSSMOD(J) = BSSMOD(J)*RMBRRT
                  GSSMOD(J) = GSSMOD(J)*RMBRRT
                ENDIF
              ENDDO
              ANUMRM = 0
              NSSMOD = NSSMOD-NRMMDS
            ENDIF
          ELSE
C--If R-paroty violated need to calculate rate and renormalise
C--Obtain the MSSM rate
            RATE  = ZERO
            RRATE = ZERO
            RPBR  = ZERO
            DO J=1,NSSMOD
              IF(ISSMOD(J).EQ.I) THEN
                RATE = RATE + GSSMOD(J)
              ENDIF
            ENDDO
C--Calculate the Rparity violating rate      
            DO J=1,NSSMD2
              IF(ISSMD2(J).EQ.I) THEN
                RRATE = RRATE + GSSMD2(J)
              ENDIF
            ENDDO        
            IF(RRATE.LT.EPS) GOTO 50
            RPBR = RATE/(RATE+RRATE)
            RATE = RATE+RRATE
C--Reset MSSM rates and branching ratios
            DO J=1,NSSMOD
              IF(ISSMOD(J).EQ.I) BSSMOD(J) = BSSMOD(J)*RPBR
            ENDDO
C--Calculate Rparity violating branching ratios
            DO J=1,NSSMD2
              IF(ISSMD2(J).EQ.I) BSSMD2(J) = GSSMD2(J)/RATE         
            ENDDO
C--Now remove any modes of the particle with branching ratio
C--less than MINBR
            RMBRRT = ZERO
            NRMMDS = 0
            NRMMDR = 0
            DO J=1,NSSMOD
              IF(ISSMOD(J).EQ.I.AND.BSSMOD(J).LT.MINBR) THEN
                RMBRRT = RMBRRT + BSSMOD(J)
                ISSMOD(J) = 100000
                NRMMDS = NRMMDS+1 
              ENDIF
            ENDDO
            IF(RRATE.LT.EPS) GOTO 50
            DO J=1,NSSMD2
              IF(ISSMD2(J).EQ.I.AND.BSSMD2(J).LT.MINBR) THEN
                RMBRRT = RMBRRT + BSSMD2(J)
                ISSMD2(J) = 100000
                NRMMDR = NRMMDR +1
              ENDIF
            ENDDO  
C--Now remove the modes we have removed, and renormalise BR's to 1
            IF(NRMMDS.GT.0.OR.NRMMDR.GT.0) THEN
              ANUMRM = 0
              RMBRRT = 1/(1-RMBRRT)
              DO J=1,NSSMOD
 20             IF(ISSMOD(J+ANUMRM).EQ.100000) ANUMRM=ANUMRM+1
                ISSMOD(J) = ISSMOD(J+ANUMRM)
                DO L=1,5
                  JSSMOD(L,J)=JSSMOD(L,J+ANUMRM)
                ENDDO
                GSSMOD(J)=GSSMOD(J+ANUMRM)
                BSSMOD(J)=BSSMOD(J+ANUMRM)
                IF(ISSMOD(J).EQ.100000) GOTO 20
                IF(ISSMOD(J).EQ.I) THEN
                  BSSMOD(J) = BSSMOD(J)*RMBRRT
                  GSSMOD(J) = GSSMOD(J)*RMBRRT
                ENDIF
              ENDDO
              ANUMRM = 0
              DO J=1,NSSMD2
 30             IF(ISSMD2(J+ANUMRM).EQ.100000) ANUMRM=ANUMRM+1
                  ISSMD2(J) = ISSMD2(J+ANUMRM)
                  DO L=1,5
                    JSSMD2(L,J)=JSSMD2(L,J+ANUMRM)
                  ENDDO
                  GSSMD2(J)=GSSMD2(J+ANUMRM)
                  BSSMD2(J)=BSSMD2(J+ANUMRM)
                  IF(ISSMD2(J).EQ.100000) GOTO 30
                  IF(ISSMD2(J).EQ.I) THEN
                  BSSMD2(J) = BSSMD2(J)*RMBRRT
                  GSSMD2(J) = GSSMD2(J)*RMBRRT
               ENDIF
              ENDDO
              NSSMOD = NSSMOD-NRMMDS
              NSSMD2 = NSSMD2-NRMMDR
            ENDIF
          ENDIF
 50     CONTINUE
      ENDDO
      IF(RPARTY) RETURN
C--NOW WE NEED TO COMBINE THE RPARITY AND MSSM MODES
      IF((NSSMOD+NSSMD2).GT.MXSS) THEN      
        WRITE(LOUT,*) 'WARNING REMOVING',NSSMOD+NSSMD2-MXSS,'MODES'
        print *,'WARNING EXCEEDS ISAJET NO OF MODES'
        print *,'REMOVING THE',NSSMOD+NSSMD2-MXSS,
     &          'MODES WITH LOWEST BRANCHING RATIO'
        print *,'RECOMMEND YOU RERUN WITH HIGHER MXSS'
      ENDIF
 110   IF((NSSMOD+NSSMD2).GT.MXSS) THEN
        RMBRRT = 1
        NRMMDS = 0
        DO J=1,NSSMOD
          IF(BSSMOD(J).LT.RMBRRT) THEN
            RMBRRT = BSSMOD(J)
            NRMMDS = J
          ENDIF
        ENDDO
        DO J=1,NSSMD2
          IF(BSSMD2(J).LT.RMBRRT) THEN
            RMBRRT = BSSMD2(J)
            NRMMDS = J+MXSS
          ENDIF
        ENDDO
C--remove mode with lowest branching ratio and rescale BR's
        RMBRRT = 1/(1-RMBRRT)
        IF(NRMMDS.LE.MXSS) NRMMDR = ISSMOD(NRMMDS)
        IF(NRMMDS.GT.MXSS) NRMMDR = ISSMD2(NRMMDS-MXSS)
        DO J=1,NSSMOD
          IF(ISSMOD(J).EQ.NRMMDR) THEN
            GSSMOD(J) = RMBRRT*GSSMOD(J)
            BSSMOD(J) = RMBRRT*BSSMOD(J)
          ENDIF
        ENDDO
        DO J=1,NSSMD2
          IF(ISSMD2(J).EQ.NRMMDR) THEN
            GSSMD2(J) = RMBRRT*GSSMD2(J)
            BSSMD2(J) = RMBRRT*BSSMD2(J)
          ENDIF
        ENDDO
        IF(NRMMDS.LE.MXSS) THEN
          DO J=NRMMDS,NSSMOD-1
            ISSMOD(J) = ISSMOD(J+1)
            DO L=1,5
              JSSMOD(L,J) = JSSMOD(L,J+1)
            ENDDO
            GSSMOD(J)=GSSMOD(J+1)
            BSSMOD(J)=BSSMOD(J+1)
          ENDDO
          NSSMOD = NSSMOD-1
        ELSE
          DO J=(NRMMDS-MXSS),NSSMD2-1
            ISSMD2(J) = ISSMD2(J+1)
            DO L=1,5
              JSSMD2(L,J) = JSSMD2(L,J+1)
            ENDDO
            GSSMD2(J) = GSSMD2(J+1)
            BSSMD2(J) = BSSMD2(J+1)
          ENDDO
          NSSMD2 = NSSMD2-1
        ENDIF   
      ENDIF   
      IF((NSSMD2+NSSMOD).GT.MXSS) GOTO 110
C--Now less than maximum so add the R parity violating modes
      DO J=1,NSSMD2
        NSSMOD=NSSMOD+1
        ISSMOD(NSSMOD) = ISSMD2(J)
        DO K=1,5
          JSSMOD(K,NSSMOD) = JSSMD2(K,J)
        ENDDO
        GSSMOD(NSSMOD) = GSSMD2(J)
        BSSMOD(NSSMOD) = BSSMD2(J)
        MSSMOD(NSSMOD) = 0
      ENDDO
      END
CDECK  ID>, RPRATE
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
      FUNCTION RPRATE(LAMCOL,M1,M2,M3)
C-----------------------------------------------------------------------
C     FUNCTION TO CALCULATE A 2 BODY R-PARITY VIOLATING DECAY RATE
C-----------------------------------------------------------------------
      IMPLICIT NONE
      REAL LAMCOL,M1,M2,M3,RPRATE,PCM,PI
      PI = 3.1415926E0
      RPRATE = 0
      IF(M1.LT.(M2+M3)) RETURN
      RPRATE = LAMCOL*(M1**2-M2**2-M3**2)
      PCM = SQRT((M1**2-(M2+M3)**2)*(M1**2-(M2-M3)**2))/(2*M1)
      RPRATE = RPRATE*PCM/(8*PI*M1**2)
      END
CDECK  ID>, RPRTCH
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :     Peter Richardson  
C----------------------------------------------------------------------- 
       FUNCTION RPRTCH(MASS,ENERGY)
C-----------------------------------------------------------------------
C      AVOID ERRORS DUE TO TAKING SQRT OF SMALL NEGATIVE NUMBERS
C      OCCURS DUE ROUNDING ERRORS
C-----------------------------------------------------------------------
       DOUBLE PRECISION RPRTCH,ENERGY,MASS
+CDE,SSLUN
       RPRTCH =ENERGY**2-MASS**2
       IF(RPRTCH.LT.0) THEN
         IF(RPRTCH/(ENERGY**2+MASS**2).LT.1D-20) THEN
           RPRTCH = 0.0D0
         ELSE
           WRITE(LOUT,*) 'WARNING SQRT OF NEGATIVE NUMBER',RPRTCH
           RPRTCH = 0.0D0
         ENDIF
       ENDIF
       RPRTCH = SQRT(RPRTCH)
       END
C-----------------------------------------------------------------------
C
C                         ISAWIG-HDECAY interface
C
C-----------------------------------------------------------------------
C  This block contains the code to interface HDECAY with ISAWIG so that
C  HDECAY can be used to give NLO Higgs widths and branching ratios
C-----------------------------------------------------------------------
C  This code is designed to work with HDECAY2.0/3.0
C  if you are using a later version of HDECAY there may be problems
CDECK  ID>, HDCYAD
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :  Peter Richardson
C-----------------------------------------------------------------------
      SUBROUTINE HDCYAD(HIGGS,WIDTH,BRFRAC,DECAY)
C-----------------------------------------------------------------------
C--Subroutine to add Higgs modes to the ISAJET decay tables
C-----------------------------------------------------------------------
      IMPLICIT NONE
C--Common block containing ISAJET decay modes
+CDE,SSMODE
C
      DOUBLE PRECISION WIDTH,BRFRAC
      INTEGER HIGGS,DECAY(3),J
      NSSMOD = NSSMOD+1
      IF(NSSMOD.GT.MXSS) THEN
        WRITE(*,*) 'TOO MANY MODES'
        WRITE(*,*) 'RERUN WITH INCREASED MXSS'
        WRITE(*,*) 'STOPPING'
        STOP
      ENDIF
      ISSMOD(NSSMOD) = HIGGS
      DO J=1,3
        JSSMOD(J,NSSMOD) = DECAY(J)
      ENDDO
      DO J=4,5
        JSSMOD(J,NSSMOD) = 0
      ENDDO
      GSSMOD(NSSMOD) = WIDTH*BRFRAC
      BSSMOD(NSSMOD) = BRFRAC
      MSSMOD(NSSMOD) = 0
      END 
C
C   N.B. THERE ARE THREE VERSIONS OF THIS ROUTINE
C   ONE FOR HDECAY 2.0, ONE FOR HDECAY3.0 AND ONE DUMMY
C
+SELF,IF=HDECAY3
CDECK  ID>, HDCYSY
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :  Peter Richardson based on HDECAY main program by M. Spira
C-----------------------------------------------------------------------
      SUBROUTINE HDCYSY(M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,
     &                     MER2,MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR) 
C-----------------------------------------------------------------------
C  Subroutine to interface with ISAWIG for MSSM Higgs Decays
C  for use with version 3 of HDECAY
C-----------------------------------------------------------------------
      IMPLICIT NONE
C--varaibles passed from ISAWIG
      REAL M1,M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,MER2,MQL2,MUR2,MDR2,
     &     MEL,MER,MSQ,MUR,MDR
C--declarations for HDECAY variables
      DOUBLE PRECISION GMN(4),XMN(4),GMC(2),GMST(2),GMSB(2),GMSL(2),
     &                 GMSU(2),GMSD(2),GMSE(2),GMSN(2),
     &     AXMPL,AXMGD,HLBRGD,HABRGD,HHBRGD,HCBRGD,BHLSUSY,
     &     BHLST,BHLSB,BHLSTAU,BHHSUSY,BHHST,BHHSB,BHHSTAU,
     &     BHASUSY,BHCSUSY,BHCSTB,HLBRSC(2,2),HLBRSN(4,4),HHBRSC(2,2),
     .          HHBRSN(4,4),HABRSC(2,2),HABRSN(4,4),HCBRSU(2,4),
     .          HHBRST(2,2),HHBRSB(2,2),HCBRSTB(2,2),
     &     HLBRCHT,HHBRCHT,HABRCHT,HLBRNET,HHBRNET,
     .     HABRNET,HCBRCNT,HLBRSL,HHBRSL,HCBRSL,HABRSL,HABRST,
     .     HABRSB,HHBRSQ,HHBRSQT,HCBRSQ,
     .     HCBRSQT,HLBRSQ,HLBRSQT,HLBRS,HLBRH,HLWDTH,
     &     HHBRS,HHBRH,HHWDTH,
     &     HCBRS,HCWDTH,SMBRB,SMBRL,SMBRM,SMBRS,SMBRC,SMBRT,SMBRG,
     .     SMBRGA,SMBRZGA,SMBRW,SMBRZ,SMWDTH,HABRS,HAWDTH,AMGLU,
     &     AMQL1,AMUR1,AMDR1,AMEL1,AMER1,AMGLUINO,XMSB1,XMSB2,STHB,CTHB,
     .     XLBB,XHBB,XABB,GAMC0,GAMT0,GAMT1,GAMW,GAMZ,GAT,
     &     GAB,GLT,GLB,GHT,GHB,GZAH,GZAL,
     .     GHHH,GLLL,GHLL,GLHH,GHAA,GLAA,GLVV,GHVV,
     .     GLPM,GHPM,B,A,XLAMBDA,AMC0,AMB0,AMT0,
     .     XMST1,XMST2,AMS,AMC,AMB,AMT,AMSB,GF,ALPH,AMTAU,AMMUON,AMZ,
     &     AMW,VUS,VCB,VUB,AMA,AML,AMH,AMCH,AMAR,AMSM,
     &     AMEL,AMER,AMSQ,AMUR,AMDR,AL,AU,AD,AMU,AM2,
     &     PI,ALSMZ,RVUB,TGBET,AMABEG,AMAEND,ACC,XITLA_HDEC
      INTEGER IGOLD,NFGG,N0,IHIGGS,NNLO,IPOLE,IMODEL,IONSH,IONWZ,
     &     IOFSUSY,NLOOP,NBER
      EXTERNAL XITLA_HDEC
C--HDECAY Common block
      COMMON/MASSES_HDEC/AMS,AMC,AMB,AMT
      COMMON/STRANGE_HDEC/AMSB
      COMMON/PARAM_HDEC/GF,ALPH,AMTAU,AMMUON,AMZ,AMW
      COMMON/CKMPAR_HDEC/VUS,VCB,VUB
      COMMON/HMASS_HDEC/AMSM,AMA,AML,AMH,AMCH,AMAR
      COMMON/BREAK_HDEC/AMEL,AMER,AMSQ,AMUR,AMDR,AL,AU,AD,AMU,AM2 
      COMMON/BREAKGLU_HDEC/AMGLU
      COMMON/SFER1ST_HDEC/AMQL1,AMUR1,AMDR1,AMEL1,AMER1

      COMMON/GLUINO_HDEC/AMGLUINO,XMSB1,XMSB2,STHB,CTHB,
     .              XLBB(2,2),XHBB(2,2),XABB(2,2),
     .              XMST1,XMST2
      COMMON/WZWDTH_HDEC/GAMC0,GAMT0,GAMT1,GAMW,GAMZ


      COMMON/COUP_HDEC/GAT,GAB,GLT,GLB,GHT,GHB,GZAH,GZAL,
     .            GHHH,GLLL,GHLL,GLHH,GHAA,GLAA,GLVV,GHVV,
     .            GLPM,GHPM,B,A
      COMMON/ALS_HDEC/XLAMBDA,AMC0,AMB0,AMT0,N0
      COMMON/FLAG_HDEC/IHIGGS,NNLO,IPOLE
      COMMON/MODEL_HDEC/IMODEL
      COMMON/ONSHELL_HDEC/IONSH,IONWZ,IOFSUSY
      COMMON/OLDFASH_HDEC/NFGG
      COMMON/WIDTHSM_HDEC/SMBRB,SMBRL,SMBRM,SMBRS,SMBRC,SMBRT,SMBRG,
     .               SMBRGA,SMBRZGA,SMBRW,SMBRZ,SMWDTH
      COMMON/WIDTHA_HDEC/HABRS(10),HAWDTH
      COMMON/WIDTHHL_HDEC/HLBRS(11),HLBRH(3),HLWDTH
      COMMON/WIDTHHH_HDEC/HHBRS(11),HHBRH(4),HHWDTH
      COMMON/WIDTHHC_HDEC/HCBRS(9),HCWDTH
      COMMON/WISUSY_HDEC/HLBRSC,HLBRSN,HHBRSC,HHBRSN,HABRSC,HABRSN,
     .              HCBRSU,HLBRCHT,HHBRCHT,HABRCHT,HLBRNET,HHBRNET,
     .              HABRNET,HCBRCNT,HLBRSL,HHBRSL,HCBRSL,HABRSL,HABRST,
     .              HABRSB,HHBRSQ,HHBRST,HHBRSB,HHBRSQT,HCBRSQ,HCBRSTB,
     .              HCBRSQT,HLBRSQ,HLBRSQT
      COMMON/GOLDST_HDEC/AXMPL,AXMGD,IGOLD
      COMMON/WIGOLD_HDEC/HLBRGD,HABRGD,HHBRGD,HCBRGD
      COMMON/WISFER_HDEC/BHLSUSY(7),BHLST(2,2),BHLSB(2,2),BHLSTAU(2,2),
     .                   BHHSUSY(7),BHHST(2,2),BHHSB(2,2),BHHSTAU(2,2),
     .                   BHASUSY(3),BHCSUSY(4),BHCSTB(2,2)
      COMMON/SMASS_HDEC/GMN,XMN,GMC,GMST,GMSB,GMSL,GMSU,GMSD,GMSE,GMSN 
C--Common blocks from ISAJET which contains the masses and rates
C--and ISAJET SM parameters
C--Common block containing ISAJET masses and mixings
+CDE,SSPAR
C--Common block containing ISAJET SM paramaters
+CDE,SSSM
C--Common block containing ISAJET decay modes
+CDE,SSMODE
C--ISAJET SUGRA common block
+CDE,SUGMG
C--local variables 
      INTEGER NOHGMD,I,SMDECS(3,11),SMDECA(3,10),TPDEC(3,2),HGDECH(3,5),
     &        CHRDEC(3,2,2),NETDEC(3,4,4),SMDECC(3,9),CNDEC(3,2,4),J,
     &        JMAX,SFRDC(3,15),SFRDCA(3,3),TAUDEC(3,2,2),BOTDEC(3,2,2),
     &        TOPDEC(3,2,2),SFRDCC(3,6),BTDEC(3,2,2),MODE,TOTMOD
      DOUBLE PRECISION EPS,TEMPWD
      REAL SSPOLE
      PARAMETER(EPS=1.0D-20)
      REAL EPS2
      PARAMETER (EPS2=1E-3)
      EXTERNAL SSPOLE
C--particle content of the various decay modes
      DATA SMDECS /  5, -5,  0, 16,-16,  0, 14,-14,  0,  3, -3,  0,
     &               4, -4,  0,  6, -6,  0,  9,  9,  0, 10, 10,  0,
     &              10, 90,  0, 80,-80,  0, 90, 90,  0/  
      DATA SMDECA /  5, -5,  0, 16,-16,  0, 14,-14,  0,  3, -3,  0,
     &               4, -4,  0,  6, -6,  0,  9,  9,  0, 10, 10,  0,
     &              10, 90,  0, 90, 82,  0/
      DATA TPDEC  /-80,  6, -5, 80, -6,  5/
      DATA HGDECH / 82, 82,  0, 84, 84,  0, 90, 84,  0, 80,-86,  0,
     &             -80, 86,  0/           
      DATA CHRDEC / 39,-39,  0, 39,-49,  0, 49,-39,  0, 49,-49,  0/
      DATA NETDEC / 30, 30,  0, 30, 40,  0, 30, 50,  0, 30, 60,  0,
     &              40, 30,  0, 40, 40,  0, 40, 50,  0, 40, 60,  0,
     &              50, 30,  0, 50, 40,  0, 50, 50,  0, 50, 60,  0,
     &              60, 30,  0, 60, 40,  0, 60, 50,  0, 60, 60,  0/
      DATA SMDECC / -5,  4,  0,-16, 15,  0,-14, 13,  0, -5,  1,  0,
     &              -3,  1,  0, -3,  4,  0, -5,  6,  0, 82, 80,  0,
     &              84, 80,  0/           
      DATA CNDEC /  39, 30,  0, 49, 30,  0, 39, 40,  0, 49, 40,  0,
     &              39, 50,  0, 49, 50,  0, 39, 60,  0, 49, 60,  0/
      DATA SFRDC /  31,-31,  0, 33,-33,  0, 35,-35,  0, 32,-32,  0,
     &              34,-34,  0, 52,-52,  0, 54,-54,  0, 21,-21,  0,
     &              24,-24,  0, 41,-41,  0, 44,-44,  0, 22,-22,  0,
     &              23,-23,  0, 42,-42,  0, 43,-43,  0/   
      DATA SFRDCA/  36,-56,  0, 25,-45,  0, 26,-46,  0/
      DATA TAUDEC/  36,-36,  0, 36,-56,  0, 56,-36,  0, 56,-56,  0/
      DATA BOTDEC/  25,-25,  0, 25,-45,  0, 45,-25,  0, 45,-45,  0/
      DATA TOPDEC/  26,-26,  0, 26,-46,  0, 46,-26,  0, 46,-46,  0/
      DATA SFRDCC/  31,-32,  0, 33,-34,  0, 35,-36,  0, 35,-56,  0,
     &              21,-22,  0, 24,-23,  0/
      DATA BTDEC /  26,-25,  0, 26,-45,  0, 46,-25,  0, 46,-45,  0/ 
C--define PI
      PI = 4*DATAN(1D0)
C--Output the authorship of HDECAY and warnings about the spectrum
      WRITE(*,*) 'Deleting ISAJET masses and Higgs decays'
      WRITE(*,*) 'Using HDECAY masses and Higgs decay modes'
      WRITE(*,*) 'HDECAY by A. Djouadi, J. Kalinowski, M. Spira'
      WRITE(*,*) 'Please refer to  Comput.Phys.Commun.108:56-74,1998'
C--Set the options we need
C--calculate all the SUSY Higgs decay modes
      IHIGGS = 5
C   IMODEL: USE SPECIFIC SUBROUTINE FOR MSSM HIGSS MASSES AND COUPLINGS
C           =1: CARENA ET AL., NUCL. PHYS. B461 (1996) 407 (SUBHPOLE)
C           =2: CARENA ET AL., PHYS. LETT. B355 (1995) 209 (SUBH)
C           =3: HABER ET AL.
C           =4: HEINEMEYER ET AL., HEP-PH/0002213 (FEYNHIGGSFAST1.2.2)
C
 500  WRITE(*,*) 
     &     'USE SPECIFIC SUBROUTINE FOR MSSM HIGSS MASSES AND COUPLINGS'
      WRITE(*,*) 
     &     '1: CARENA ET AL., NUCL. PHYS. B461 (1996) 407 (SUBHPOLE)'
      WRITE(*,*) 
     &     '2: CARENA ET AL., PHYS. LETT. B355 (1995) 209 (SUBH)'
      WRITE(*,*) 
     &     '3: HABER ET AL'
      WRITE(*,*) 
     &     '4: HEINEMEYER ET AL., HEP-PH/0002213 (FEYNHIGGSFAST1.2.2)'
      READ(*,*) IMODEL
      IF(IMODEL.LT.1.OR.IMODEL.GT.4) GOTO 500
      IF(IMODEL.EQ.3)THEN
       WRITE(6,*)'MU (UP TO THE SIGN) WILL BE IDENTIFIED WITH M_SQ...'
      ENDIF
C--if using SSRUN
      IF(M2.GE.1.E19) M2 =ALFA2I*SSPOLE(AMGLSS,AMZI**2,-ALFA3I)/ALFA3I
C--check the soft terms are the same for the 1st and 2nd generations
      IF(MEL2.LE.1.E19) THEN
        IF(ABS(MEL1-MEL2).GT.EPS2) WRITE(*,1000) 'left slepton'
        IF(ABS(MER1-MER2).GT.EPS2) WRITE(*,1000) 'right slepton'
        IF(ABS(MQL1-MQL2).GT.EPS2) WRITE(*,1000) 'left squark'
        IF(ABS(MUR1-MUR2).GT.EPS2) WRITE(*,1000) 'right up squark'
        IF(ABS(MDR1-MDR2).GT.EPS2) WRITE(*,1000) 'left up squark'
      ENDIF

C--Now set the parameters for HDECAY equal to the relevant ones from ISAJET
C--first the Standard Model Masses and Widths
      AMS    = DBLE(AMSTI)
      AMC    = DBLE(AMCHI)
      AMB    = DBLE(AMBTI)
      AMT    = DBLE(AMTPI)
      AMTAU  = DBLE(AMTAUI)
      AMMUON = DBLE(AMMUI)
      AMZ    = DBLE(AMZI)
      AMW    = DBLE(AMWI)
      GAMW   = DBLE(GAMWI)
      GAMZ   = DBLE(GAMZI)
C--Standard Model couplings
      ALSMZ  = DBLE(ALFA3I)
      ALPH   = 137.0359895D0
      GF     = SQRT(2.0D0)*PI/(2.0D0*ALPH*AMW**2*DBLE(SN2THWI))
C--Hard wire in the various CKM Matrix Elements(perhaps we should read these in)
      VUS    = 0.2205D0
      VCB    = 0.04D0
      RVUB   = 0.08D0
C--Now the SUSY parameters
      TGBET  = 1.0D0/DBLE(RV2V1)
      AMABEG = DBLE(AMHA)
      AMAEND = AMABEG
      AMU    = -DBLE(TWOM1)
      AM2    = DBLE(M2) 
      AMGLUINO = DBLE(AMGLSS)
      AMGLU = AMGLUINO
      AMEL1  = DBLE(MEL1)
      AMER1  = DBLE(MER1)
      AMQL1  = DBLE(MQL1)
      AMUR1  = DBLE(MUR1)
      AMDR1  = DBLE(MDR1)
      AMEL   = DBLE(MEL)
      AMER   = DBLE(MER)
      AMSQ   = DBLE(MSQ)
      AMUR   = DBLE(MUR)
      AMDR   = DBLE(MDR)
      AL     = DBLE(AAL)
      AU     = DBLE(AAT)
      AD     = DBLE(AAB)   
C--Options for HDECAY
 501  WRITE(*,*) 'OPTION FOR NNLO POLE MASS'
      WRITE(*,*) 
     &     '1: USE O(ALPHA_S) FORMULA FOR POLE MASS --> MSBAR MASS'
      WRITE(*,*) 
     &     '2: USE O(ALPHA_S**2) FORMULA FOR POLE MASS --> MSBAR MASS'
      READ(*,*) NNLO
      IF(NNLO.LT.1.OR.NNLO.GT.2) GOTO 501
 502  WRITE(*,*) 'OPTION FOR OFF_SHELL DECAY'
      WRITE(*,*) '0: INCLUDE OFF_SHELL DECAYS H,A --> T*T*, A --> Z*H,'
      WRITE(*,*) '   H --> W*H+,Z*A, H+ --> W*A, W*H, T*B'
      WRITE(*,*) '1: EXCLUDE THE OFF-SHELL DECAYS ABOVE'
      READ(*,*) IONSH
      IF(IONSH.GT.1.OR.IONSH.LT.0) GOTO 502
 503  WRITE(*,*) 'OPTION FOR GAUGE BOSON DECAYS'
      WRITE(*,*)
     &     '0: INCLUDE DOUBLE OFF-SHELL PAIR DECAYS PHI --> W*W*,Z*Z*'
      WRITE(*,*) 
     &     '1: INCLUDE ONLY SINGLE OFF-SHELL DECAYS PHI --> W*W,Z*Z'
      READ(*,*) IONWZ
      IF(IONWZ.GT.1.OR.IONWZ.LT.0) GOTO 503
 504  WRITE(*,*) 'OPTION FOR HIGGS MASSES'
      WRITE(*,*) '0: COMPUTES RUNNING HIGGS MASSES (FASTER)'
      WRITE(*,*) '1: COMPUTES POLE HIGGS MASSES'
      READ(*,*) IPOLE
      IF(IPOLE.GT.1.OR.IPOLE.LT.0) GOTO 504
 505  WRITE(*,*) 'OPTION FOR HIGGS DECAYS TO SUSY PARTICLES'
      WRITE(*,*) '0: INCLUDE DECAYS (AND LOOPS) INTO SUSY PARTICLES'
      WRITE(*,*) '1: EXCLUDE DECAYS (AND LOOPS) INTO SUSY PARTICLES'
      READ(*,*) IOFSUSY
      IF(IOFSUSY.GT.1.OR.IOFSUSY.LT.0) GOTO 505
 506  WRITE(*,*) 
     &     'NUMBER OF LIGHT FLAVORS INCLUDED IN THE GLUONIC DECAYS'
      WRITE(*,*) 'PHI --> GG* --> GQQ (3,4 OR 5)'
      READ(*,*)  NFGG
      IF(NFGG.LT.3.OR.NFGG.GT.5) GOTO 506
      VUB=RVUB*VCB
      ALPH=1.D0/ALPH
      AMSB = AMS
      IGOLD = 0
      AXMPL = 2.4E18
      AXMGD = AMGVSS
C--Now code for the HDECAY package
C--initialisation and checks
C--CHECK NFGG
      IF(NFGG.GT.5.OR.NFGG.LT.3)THEN
       WRITE(6,*)'NF-GG NOT VALID. TAKING THE DEFAULT NF-GG = 3....'
       NFGG = 3
      ENDIF
      AMC0=AMC
      AMB0=AMB
      AMT0=AMT
      ACC=1.D-8
      NLOOP=2
      XLAMBDA=XITLA_HDEC(NLOOP,ALSMZ,ACC)
      N0=5
      CALL ALSINI_HDEC(ACC)
C--INITIALIZE COEFFICIENTS FOR POLYLOGARITHMS
      NBER = 18
      CALL BERNINI_HDEC(NBER)
C
C--WRITE THE INPUT PARAMTERS 

      WRITE(6,8)'HIGGS    = ',IHIGGS
      WRITE(6,8)'MODEL    = ',IMODEL
      WRITE(6,9)'TGBET    = ',TGBET
      WRITE(6,9)'MABEG    = ',AMABEG
      WRITE(6,9)'MAEND    = ',AMAEND
      WRITE(6,9)'ALS(MZ)  = ',ALSMZ
      WRITE(6,9)'MSBAR(1) = ',AMS
      WRITE(6,9)'MC       = ',AMC
      WRITE(6,9)'MB       = ',AMB
      WRITE(6,9)'MT       = ',AMT
      WRITE(6,9)'MTAU     = ',AMTAU
      WRITE(6,9)'MMUON    = ',AMMUON
      WRITE(6,9)'ALPH     = ',1.D0/ALPH
      WRITE(6,9)'GF       = ',GF
      WRITE(6,9)'GAMW     = ',GAMW
      WRITE(6,9)'GAMZ     = ',GAMZ
      WRITE(6,9)'MZ       = ',AMZ
      WRITE(6,9)'MW       = ',AMW
      WRITE(6,9)'VUS      = ',VUS
      WRITE(6,9)'VCB      = ',VCB
      WRITE(6,9)'VUB/VCB  = ',RVUB
      WRITE(6,9)'MU       = ',AMU
      WRITE(6,9)'M2       = ',AM2
      WRITE(6,9)'MEL1      = ',AMEL1
      WRITE(6,9)'MER1      = ',AMER1
      WRITE(6,9)'MQL1      = ',AMQL1
      WRITE(6,9)'MUR1      = ',AMUR1
      WRITE(6,9)'MDR1      = ',AMDR1
      WRITE(6,9)'MEL      = ',AMEL
      WRITE(6,9)'MER      = ',AMER
      WRITE(6,9)'MSQ      = ',AMSQ
      WRITE(6,9)'MUR      = ',AMUR
      WRITE(6,9)'MDR      = ',AMDR
      WRITE(6,9)'AL       = ',AL
      WRITE(6,9)'AU       = ',AU
      WRITE(6,9)'AD       = ',AD
      WRITE(6,8)'NNLO (M) = ',NNLO
      WRITE(6,8)'ON-SHELL = ',IONSH
      WRITE(6,8)'ON-SH-WZ = ',IONWZ
      WRITE(6,8)'OFF-SUSY = ',IOFSUSY
      WRITE(6,8)'IPOLE    = ',IPOLE 
      WRITE(6,8)'NF-GG    = ',NFGG
      WRITE(6,9)'LAMBDA_5 = ',XLAMBDA
7     FORMAT(A11,I7)
8     FORMAT(A11,I4)
9     FORMAT(A11,G15.6)
C--set the pseudoscalar mass
      AMAR = AMABEG
      AMSM = AMAR
      AMA  = AMAR
C--calclaute the decay modes
      CALL HDEC(TGBET)
C--Now we need to enter the HDECAY modes in the ISAJET event record and
C--overwrite the masses of the HIGGS
C--Remove the Higgs decay modes from the ISAJET decay tables
      NOHGMD = 0
      DO I=1,NSSMOD
        IF(NOHGMD.NE.0) THEN
          ISSMOD(I-NOHGMD) = ISSMOD(I)
          DO J=1,5
            JSSMOD(J,I-NOHGMD) = JSSMOD(J,I)
          ENDDO
          GSSMOD(I-NOHGMD) = GSSMOD(I)
          BSSMOD(I-NOHGMD) = BSSMOD(I)
          MSSMOD(I-NOHGMD) = MSSMOD(I)
        ENDIF
        IF(ABS(ISSMOD(I)).EQ.86.OR.
     & (ISSMOD(I).GE.82.AND.ISSMOD(I).LE.84)) NOHGMD = NOHGMD+1
      ENDDO
      NSSMOD = NSSMOD-NOHGMD
C--Now write out the HDECAY modes into the ISAJET tables
C--this has to be done line by line
C--Decay to Standard Model particles of the lightest Higgs
      DO 10 I=1,11
        IF(HLBRS(I).LT.EPS) GOTO 10
        IF(I.NE.6.OR.AML.GT.2.0D0*AMT) THEN
          CALL HDCYAD(82,HLWDTH,HLBRS(I),SMDECS(1,I))
        ELSE
C--Decay to off mass shell top quark
          DO J=1,2
            CALL HDCYAD(82,HLWDTH,HLBRS(I)/2.0D0,TPDEC(1,J))
          ENDDO
        ENDIF
 10   CONTINUE
C--Decay to charginos of the lightest Higgs
      DO I=1,2
        DO 11 J=1,2
          IF(HLBRSC(I,J).LT.EPS) GOTO 11
          CALL HDCYAD(82,HLWDTH,HLBRSC(I,J),CHRDEC(1,I,J))
 11     CONTINUE
      ENDDO
C--Decay to neutralinos of the lightest scalar Higgs
      DO I=1,4
        DO 12 J=1,I
          TEMPWD = HLBRSN(I,J)
          IF(I.NE.J) TEMPWD = TEMPWD+ HLBRSN(J,I)
          IF(TEMPWD.LT.EPS) GOTO 12
          CALL HDCYAD(82,HLWDTH,TEMPWD,NETDEC(1,I,J))
 12     CONTINUE
      ENDDO
C--Decay to sfermions of the lightest scalar Higgs
C--first the decays to the first 2 generations(degenerate)
      TOTMOD = 0
      MODE = 0
      DO 13 I=1,7
        TOTMOD = TOTMOD+MODE
        MODE = 2
        IF(I.EQ.1) MODE = 3
        IF(BHLSUSY(I).LT.EPS) GOTO 13
        TEMPWD = BHLSUSY(I)/MODE   
        DO J=1,MODE
          CALL HDCYAD(82,HLWDTH,TEMPWD,SFRDC(1,TOTMOD+J))
        ENDDO     
 13   CONTINUE
C--now to the 3rd generation
      DO I=1,2
        DO 14 J=1,2
          IF(BHLSTAU(I,J).GE.EPS) 
     &      CALL HDCYAD(82,HLWDTH,BHLSTAU(I,J),TAUDEC(1,I,J))
          IF(BHLSB(I,J).GE.EPS) 
     &      CALL HDCYAD(82,HLWDTH,BHLSB(I,J),BOTDEC(1,I,J))
          IF(BHLST(I,J).GE.EPS) 
     &      CALL HDCYAD(82,HLWDTH,BHLST(I,J),TOPDEC(1,I,J))
 14     CONTINUE
      ENDDO
C--Decay to Standard Model particles of the heavy scalar Higgs
      DO 20 I=1,11
        IF(HHBRS(I).LT.EPS) GOTO 20
        IF(I.NE.6.OR.AMH.GT.2.0D0*AMT) THEN
          CALL HDCYAD(83,HHWDTH,HHBRS(I),SMDECS(1,I))
        ELSE
C--Decay to off mass shell top quark
          DO J=1,2
            CALL HDCYAD(83,HHWDTH,HHBRS(I)/2.0D0,TPDEC(1,J))
          ENDDO
        ENDIF
 20   CONTINUE 
C--Decay to charginos of the heaviest scalar Higgs
      DO I=1,2
        DO 21 J=1,2
          IF(HHBRSC(I,J).LT.EPS) GOTO 21
          CALL HDCYAD(83,HHWDTH,HHBRSC(I,J),CHRDEC(1,I,J))
 21     CONTINUE
      ENDDO  
C--Decay to neutralinos of the heaviest scalar Higgs
      DO I=1,4
        DO 22 J=1,I
          TEMPWD = HHBRSN(I,J)
          IF(I.NE.J) TEMPWD = TEMPWD+ HHBRSN(J,I)
          IF(TEMPWD.LT.EPS) GOTO 22
          CALL HDCYAD(83,HHWDTH,TEMPWD,NETDEC(1,I,J))
 22     CONTINUE
      ENDDO   
C--Decay to sfermions of the heaviest scalar Higgs
C--1st two generations
      TOTMOD = 0
      MODE   = 0
      DO 23 I=1,7
        TOTMOD = TOTMOD+MODE
        MODE = 2
        IF(I.EQ.1) MODE = 3
        IF(BHHSUSY(I).LT.EPS) GOTO 23
        TEMPWD = BHHSUSY(I)/MODE     
        DO J=1,MODE
          CALL HDCYAD(83,HHWDTH,TEMPWD,SFRDC(1,TOTMOD+J))
        ENDDO   
 23   CONTINUE
C--now to the 3rd generation
      DO I=1,2
        DO 24 J=1,2
          IF(BHHSTAU(I,J).GE.EPS) 
     &      CALL HDCYAD(83,HHWDTH,BHHSTAU(I,J),TAUDEC(1,I,J))
          IF(BHHSB(I,J).GE.EPS) 
     &      CALL HDCYAD(83,HHWDTH,BHHSB(I,J),BOTDEC(1,I,J))
          IF(BHHST(I,J).GE.EPS) 
     &      CALL HDCYAD(83,HHWDTH,BHHST(I,J),TOPDEC(1,I,J))
 24     CONTINUE
      ENDDO
C--Decay to Higgs of heavy scalar Higgs
      DO 25 I=1,4
        IF(HHBRH(I).LT.EPS) GOTO 25
        IF(I.NE.4) THEN
          JMAX = 1
          TEMPWD = HHBRH(I)
        ELSE
          JMAX = 2
          TEMPWD = HHBRH(I)/2.0D0
        ENDIF
        DO J=1,JMAX
          CALL HDCYAD(83,HHWDTH,TEMPWD,HGDECH(1,I+J-1))
        ENDDO
 25   CONTINUE
C--Decay to Standard Model particles of the pseudoscalar Higgs
      DO 30 I=1,10
        IF(HABRS(I).LT.EPS) GOTO 30
        IF(I.NE.6.OR.AMA.GT.2.0D0*AMT) THEN
          CALL HDCYAD(84,HAWDTH,HABRS(I),SMDECA(1,I))
        ELSE
C--Decay to off mass shell top quark
          DO J=1,2
            CALL HDCYAD(84,HAWDTH,HABRS(I)/2.0D0,TPDEC(1,J))
          ENDDO
        ENDIF
 30   CONTINUE  
C--Decay to charginos of the pseudoscalar Higgs
      DO I=1,2
        DO 31 J=1,2
          IF(HABRSC(I,J).LT.EPS) GOTO 31
          CALL HDCYAD(84,HAWDTH,HABRSC(I,J),CHRDEC(1,I,J))
 31     CONTINUE
      ENDDO    
C--Decay to neutralinos of the pseudoscalar Higgs
      DO I=1,4
        DO 32 J=1,I
          TEMPWD = HABRSN(I,J)
          IF(I.NE.J) TEMPWD = TEMPWD+ HABRSN(J,I)
          IF(TEMPWD.LT.EPS) GOTO 32
          CALL HDCYAD(84,HAWDTH,TEMPWD,NETDEC(1,I,J))
 32     CONTINUE
      ENDDO   
C--Decays to sfermions of the pseudoscalar Higgs
      DO 33 I=1,3
        IF(BHASUSY(I).GE.EPS) 
     &    CALL HDCYAD(84,HAWDTH,BHASUSY(I),SFRDCA(1,I))
 33   CONTINUE
C--Decay to Standard Model particles of the charged Higgs
      DO 40 I=1,9
        IF(HCBRS(I).LT.EPS) GOTO 40
        CALL HDCYAD(86,HCWDTH,HCBRS(I),SMDECC(1,I))
 40   CONTINUE
C--Decay to charginos and neutralino of the charged Higgs
      DO I=1,2
        DO 41 J=1,4
        IF(HCBRSU(I,J).LT.EPS) GOTO 41 
        CALL HDCYAD(86,HCWDTH,HCBRSU(I,J),CNDEC(1,I,J))
 41     CONTINUE
      ENDDO
C--Decay to first 2 genration sfermions and stau
      TOTMOD = 0
      MODE = 0
      DO 42 I=1,4
        TOTMOD = TOTMOD+MODE
        MODE = 1
        IF(I.EQ.2.OR.I.EQ.4) MODE = 2
        IF(BHCSUSY(I).LT.EPS) GOTO 42
        TEMPWD = BHCSUSY(I)/MODE
        DO J=1,MODE
          CALL HDCYAD(86,HCWDTH,TEMPWD,SFRDCC(1,TOTMOD+J))
        ENDDO
 42   CONTINUE
C--Now the decay to sbottom and stop
      DO I = 1,2
        DO 43 J=1,2
          IF(BHCSTB(I,J).LT.EPS) GOTO 43
          CALL HDCYAD(86,HCWDTH,BHCSTB(I,J),BTDEC(1,I,J))
 43     CONTINUE
      ENDDO
C--Now reset the ISAJET HIGGS MASSES with the HDECAY ones
      AMHL = REAL(AML)
      AMHH = REAL(AMH)
      AMHA = REAL(AMA)
      AMHC = REAL(AMCH)
      RETURN
 1000 FORMAT('WARNING ',A15,
     &        ' SOFT TERM IS NOT THE SAME FOR 1st AND 2nd GENERATION')
      END
+SELF
+SELF,IF=HDECAY2
CDECK  ID>, HDCYSY
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :  Peter Richardson based on HDECAY main program by M. Spira
C-----------------------------------------------------------------------
      SUBROUTINE HDCYSY(M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,
     &                     MER2,MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR) 
C-----------------------------------------------------------------------
C  Subroutine to interface with ISAWIG for MSSM Higgs Decays
C  for use with version 2.0 of HDECAY
C-----------------------------------------------------------------------
      IMPLICIT NONE
C--varaibles passed from ISAWIG
      REAL M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,MER2,MQL2,MUR2,MDR2,
     &     MEL,MER,MSQ,MUR,MDR
C--declarations for HDECAY variables
      DOUBLE PRECISION GMN(4),XMN(4),GMC(2),GMST(2),GMSB(2),GMSL(2),
     .                 GMSU(2),GMSD(2),GMSE(2),GMSN(2)
      DOUBLE PRECISION HLBRSC(2,2),HLBRSN(4,4),HHBRSC(2,2),HHBRSN(4,4),
     .                 HABRSC(2,2),HABRSN(4,4),HCBRSU(2,4),
     .                 HHBRST(2,2),HHBRSB(2,2),HCBRSTB(2,2)
      DOUBLE PRECISION AMT,AMSB,AMMUON,AMZ,
     &                 AMW,VUS,VCB,VUB,AMSM,AMA,AML,AMH,AMCH,AMAR,AMEL,
     &                 AMER,AMSQ,AMUR,AMDR,AL,AU,AD,AMU,AM2,AMQL1,AMUR1,
     &                 AMDR1,AMEL1,AMER1,GAMC0,GAMT0,GAMT1,GAMW,GAMZ,
     &                 GAT,GAB,GLT,GLB,GHT,GHB,GZAH,GZAL,GHHH,GLLL,GHLL,
     &                 GLHH,GHAA,GLAA,GLVV,GHVV,GLPM,GHPM,B,A,XLAMBDA,
     &                 AMC0,AMB0,AMT0,SMBRB,SMBRL,SMBRM,SMBRS,SMBRC,
     &                 SMBRT,SMBRG,SMBRGA,SMBRZGA,SMBRW,SMBRZ,SMWDTH,
     &                 HABRS,HAWDTH,HHBRS,HHBRH,HHWDTH,HCBRS,HCWDTH,
     &                 HLBRS,HLBRH,HLWDTH,HLBRCHT,HHBRCHT,HABRCHT,AMB,
     &                 HLBRNET,HHBRNET,HABRNET,HCBRCNT,HLBRSL,HHBRSL,
     &                 HCBRSL,HABRSL,HABRST,HABRSB,HHBRSQ,XITLA,GF,ALPH,
     &                 HHBRSQT,HCBRSQ,HCBRSQT,HLBRSQ,HLBRSQT,AMS,AMC,
     &                 BHLSUSY,BHLST,BHLSB,BHLSTAU,BHHSUSY,BHHST,
     &                 BHHSB,BHHSTAU,BHASUSY,BHCSUSY,AMTAU,BHCSTB,
     &                 PI,ALSMZ,RVUB,TGBET,AMABEG,AMAEND,ACC                 
      INTEGER N0,IHIGGS,NNLO,IPOLE,IONSH,IONWZ,IOFSUSY,NFGG,NLOOP,NBER
      COMMON/MASSES/AMS,AMC,AMB,AMT
      COMMON/STRANGE/AMSB
      COMMON/PARAM/GF,ALPH,AMTAU,AMMUON,AMZ,AMW
      COMMON/CKMPAR/VUS,VCB,VUB
      COMMON/HMASS/AMSM,AMA,AML,AMH,AMCH,AMAR
      COMMON/BREAK/AMEL,AMER,AMSQ,AMUR,AMDR,AL,AU,AD,AMU,AM2
      COMMON/SFER1ST/AMQL1,AMUR1,AMDR1,AMEL1,AMER1
      COMMON/WZWDTH/GAMC0,GAMT0,GAMT1,GAMW,GAMZ
      COMMON/COUP/GAT,GAB,GLT,GLB,GHT,GHB,GZAH,GZAL,
     .            GHHH,GLLL,GHLL,GLHH,GHAA,GLAA,GLVV,GHVV,
     .            GLPM,GHPM,B,A
      COMMON/ALS/XLAMBDA,AMC0,AMB0,AMT0,N0
      COMMON/FLAG/IHIGGS,NNLO,IPOLE
      COMMON/ONSHELL/IONSH,IONWZ,IOFSUSY
      COMMON/OLDFASH/NFGG
      COMMON/WIDTHSM/SMBRB,SMBRL,SMBRM,SMBRS,SMBRC,SMBRT,SMBRG,SMBRGA,
     .               SMBRZGA,SMBRW,SMBRZ,SMWDTH
      COMMON/WIDTHA/HABRS(10),HAWDTH
      COMMON/WIDTHHL/HLBRS(11),HLBRH(3),HLWDTH
      COMMON/WIDTHHH/HHBRS(11),HHBRH(4),HHWDTH
      COMMON/WIDTHHC/HCBRS(9),HCWDTH
      COMMON/WISUSY/HLBRSC,HLBRSN,HHBRSC,HHBRSN,HABRSC,HABRSN,HCBRSU,
     .              HLBRCHT,HHBRCHT,HABRCHT,HLBRNET,HHBRNET,HABRNET,
     .              HCBRCNT,HLBRSL,HHBRSL,HCBRSL,HABRSL,HABRST,HABRSB,
     .              HHBRSQ,HHBRST,HHBRSB,HHBRSQT,HCBRSQ,HCBRSTB,
     .              HCBRSQT,HLBRSQ,HLBRSQT
      COMMON/WISFER/BHLSUSY(7),BHLST(2,2),BHLSB(2,2),BHLSTAU(2,2),
     .              BHHSUSY(7),BHHST(2,2),BHHSB(2,2),BHHSTAU(2,2),
     .              BHASUSY(3),BHCSUSY(4),BHCSTB(2,2)
      COMMON/SMASS/GMN,XMN,GMC,GMST,GMSB,GMSL,GMSU,GMSD,GMSE,GMSN 
C--Common blocks from ISAJET which contains the masses and rates
C--and ISAJET SM parameters
C--Common block containing ISAJET masses and mixings
+CDE,SSPAR
C--Common block containing ISAJET SM paramaters
+CDE,SSSM
C--Common block containing ISAJET decay modes
+CDE,SSMODE
C--ISAJET SUGRA common block
+CDE,SUGMG
C--local variables 
      INTEGER NOHGMD,I,SMDECS(3,11),SMDECA(3,10),TPDEC(3,2),HGDECH(3,5),
     &        CHRDEC(3,2,2),NETDEC(3,4,4),SMDECC(3,9),CNDEC(3,2,4),J,
     &        JMAX,SFRDC(3,15),SFRDCA(3,3),TAUDEC(3,2,2),BOTDEC(3,2,2),
     &        TOPDEC(3,2,2),SFRDCC(3,6),BTDEC(3,2,2),MODE,TOTMOD
      DOUBLE PRECISION EPS,TEMPWD
      REAL SSPOLE
      PARAMETER(EPS=1.0D-20)
      REAL EPS2
      PARAMETER (EPS2=1E-3)
      EXTERNAL SSPOLE
C--particle content of the various decay modes
      DATA SMDECS /  5, -5,  0, 16,-16,  0, 14,-14,  0,  3, -3,  0,
     &               4, -4,  0,  6, -6,  0,  9,  9,  0, 10, 10,  0,
     &              10, 90,  0, 80,-80,  0, 90, 90,  0/  
      DATA SMDECA /  5, -5,  0, 16,-16,  0, 14,-14,  0,  3, -3,  0,
     &               4, -4,  0,  6, -6,  0,  9,  9,  0, 10, 10,  0,
     &              10, 90,  0, 90, 82,  0/
      DATA TPDEC  /-80,  6, -5, 80, -6,  5/
      DATA HGDECH / 82, 82,  0, 84, 84,  0, 90, 84,  0, 80,-86,  0,
     &             -80, 86,  0/           
      DATA CHRDEC / 39,-39,  0, 39,-49,  0, 49,-39,  0, 49,-49,  0/
      DATA NETDEC / 30, 30,  0, 30, 40,  0, 30, 50,  0, 30, 60,  0,
     &              40, 30,  0, 40, 40,  0, 40, 50,  0, 40, 60,  0,
     &              50, 30,  0, 50, 40,  0, 50, 50,  0, 50, 60,  0,
     &              60, 30,  0, 60, 40,  0, 60, 50,  0, 60, 60,  0/
      DATA SMDECC / -5,  4,  0,-16, 15,  0,-14, 13,  0, -5,  1,  0,
     &              -3,  1,  0, -3,  4,  0, -5,  6,  0, 82, 80,  0,
     &              84, 80,  0/           
      DATA CNDEC /  39, 30,  0, 49, 30,  0, 39, 40,  0, 49, 40,  0,
     &              39, 50,  0, 49, 50,  0, 39, 60,  0, 49, 60,  0/
      DATA SFRDC /  31,-31,  0, 33,-33,  0, 35,-35,  0, 32,-32,  0,
     &              34,-34,  0, 52,-52,  0, 54,-54,  0, 21,-21,  0,
     &              24,-24,  0, 41,-41,  0, 44,-44,  0, 22,-22,  0,
     &              23,-23,  0, 42,-42,  0, 43,-43,  0/   
      DATA SFRDCA/  36,-56,  0, 25,-45,  0, 26,-46,  0/
      DATA TAUDEC/  36,-36,  0, 36,-56,  0, 56,-36,  0, 56,-56,  0/
      DATA BOTDEC/  25,-25,  0, 25,-45,  0, 45,-25,  0, 45,-45,  0/
      DATA TOPDEC/  26,-26,  0, 26,-46,  0, 46,-26,  0, 46,-46,  0/
      DATA SFRDCC/  31,-32,  0, 33,-34,  0, 35,-36,  0, 35,-56,  0,
     &              21,-22,  0, 24,-23,  0/
      DATA BTDEC /  26,-25,  0, 26,-45,  0, 46,-25,  0, 46,-45,  0/ 
C--define PI
      PI = 4*DATAN(1D0)
C--Output the authorship of HDECAY and warnings about the spectrum
      WRITE(*,*) 'Deleting ISAJET masses and Higgs decays'
      WRITE(*,*) 'Using HDECAY masses and Higgs decay modes'
      WRITE(*,*) 'HDECAY by A. Djouadi, J. Kalinowski, M. Spira'
      WRITE(*,*) 'Please refer to  Comput.Phys.Commun.108:56-74,1998'
C--Set the options we need
C--calculate all the SUSY Higgs decay modes
      IHIGGS = 5
C--if using SSRUN
      IF(M2.GE.1.E19) M2 =ALFA2I*SSPOLE(AMGLSS,AMZI**2,-ALFA3I)/ALFA3I
C--check the soft terms are the same for the 1st and 2nd generations
      IF(MEL2.LE.1.E19) THEN
        IF(ABS(MEL1-MEL2).GT.EPS2) WRITE(*,1000) 'left slepton'
        IF(ABS(MER1-MER2).GT.EPS2) WRITE(*,1000) 'right slepton'
        IF(ABS(MQL1-MQL2).GT.EPS2) WRITE(*,1000) 'left squark'
        IF(ABS(MUR1-MUR2).GT.EPS2) WRITE(*,1000) 'right up squark'
        IF(ABS(MDR1-MDR2).GT.EPS2) WRITE(*,1000) 'left up squark'
      ENDIF
C--Now set the parameters for HDECAY equal to the relevant ones from ISAJET
C--first the Standard Model Masses and Widths
      AMS    = DBLE(AMSTI)
      AMC    = DBLE(AMCHI)
      AMB    = DBLE(AMBTI)
      AMT    = DBLE(AMTPI)
      AMTAU  = DBLE(AMTAUI)
      AMMUON = DBLE(AMMUI)
      AMZ    = DBLE(AMZI)
      AMW    = DBLE(AMWI)
      GAMW   = DBLE(GAMWI)
      GAMZ   = DBLE(GAMZI)
C--Standard Model couplings
      ALSMZ  = DBLE(ALFA3I)
      ALPH   = 137.0359895D0
      GF     = SQRT(2.0D0)*PI/(2.0D0*ALPH*AMW**2*DBLE(SN2THWI))
C--Hard wire in the various CKM Matrix Elements(perhaps we should read these in)
      VUS    = 0.2205D0
      VCB    = 0.04D0
      RVUB   = 0.08D0
C--Now the SUSY parameters
      TGBET  = 1.0D0/DBLE(RV2V1)
      AMABEG = DBLE(AMHA)
      AMAEND = AMABEG
      AMU    = -DBLE(TWOM1)
      AM2    = DBLE(M2) 
      AMEL1  = DBLE(MEL1)
      AMER1  = DBLE(MER1)
      AMQL1  = DBLE(MQL1)
      AMUR1  = DBLE(MUR1)
      AMDR1  = DBLE(MDR1)
      AMEL   = DBLE(MEL)
      AMER   = DBLE(MER)
      AMSQ   = DBLE(MSQ)
      AMUR   = DBLE(MUR)
      AMDR   = DBLE(MDR)
      AL     = DBLE(AAL)
      AU     = DBLE(AAT)
      AD     = DBLE(AAB)   
C--Options for HDECAY
      NNLO   = 1
      IONSH  = 0
      IONWZ  = 0
      IPOLE  = 1
      IOFSUSY= 0
      NFGG   = 5
      VUB=RVUB*VCB
      ALPH=1.D0/ALPH
      AMSB = AMS
9     FORMAT(A11,G15.6)
C--Now code for the HDECAY package
C--initialisation and checks
C--CHECK NFGG
      IF(NFGG.GT.5.OR.NFGG.LT.3)THEN
       WRITE(6,*)'NF-GG NOT VALID. TAKING THE DEFAULT NF-GG = 3....'
       NFGG = 3
      ENDIF
      AMC0=AMC
      AMB0=AMB
      AMT0=AMT
      ACC=1.D-8
      NLOOP=2
      XLAMBDA=XITLA(NLOOP,ALSMZ,ACC)
      N0=5
      CALL ALSINI(ACC)
C--INITIALIZE COEFFICIENTS FOR POLYLOGARITHMS
      NBER = 18
      CALL BERNINI(NBER)
C--set the pseudoscalar mass
      AMAR = AMABEG
      AMSM = AMAR
      AMA  = AMAR
C--SUSY MASS and coupling calculations
      CALL SUSYCP(TGBET)
C--calclaute the decay modes
      CALL HDEC(TGBET)
C--Now we need to enter the HDECAY modes in the ISAJET event record and
C--overwrite the masses of the HIGGS
C--Remove the Higgs decay modes from the ISAJET decay tables
      NOHGMD = 0
      DO I=1,NSSMOD
        IF(NOHGMD.NE.0) THEN
          ISSMOD(I-NOHGMD) = ISSMOD(I)
          DO J=1,5
            JSSMOD(J,I-NOHGMD) = JSSMOD(J,I)
          ENDDO
          GSSMOD(I-NOHGMD) = GSSMOD(I)
          BSSMOD(I-NOHGMD) = BSSMOD(I)
          MSSMOD(I-NOHGMD) = MSSMOD(I)
        ENDIF
        IF(ABS(ISSMOD(I)).EQ.86.OR.
     & (ISSMOD(I).GE.82.AND.ISSMOD(I).LE.84)) NOHGMD = NOHGMD+1
      ENDDO
      NSSMOD = NSSMOD-NOHGMD
C--Now write out the HDECAY modes into the ISAJET tables
C--this has to be done line by line
C--Decay to Standard Model particles of the lightest Higgs
      DO 10 I=1,11
        IF(HLBRS(I).LT.EPS) GOTO 10
        IF(I.NE.6.OR.AML.GT.2.0D0*AMT) THEN
          CALL HDCYAD(82,HLWDTH,HLBRS(I),SMDECS(1,I))
        ELSE
C--Decay to off mass shell top quark
          DO J=1,2
            CALL HDCYAD(82,HLWDTH,HLBRS(I)/2.0D0,TPDEC(1,J))
          ENDDO
        ENDIF
 10   CONTINUE
C--Decay to charginos of the lightest Higgs
      DO I=1,2
        DO 11 J=1,2
          IF(HLBRSC(I,J).LT.EPS) GOTO 11
          CALL HDCYAD(82,HLWDTH,HLBRSC(I,J),CHRDEC(1,I,J))
 11     CONTINUE
      ENDDO
C--Decay to neutralinos of the lightest scalar Higgs
      DO I=1,4
        DO 12 J=1,I
          TEMPWD = HLBRSN(I,J)
          IF(I.NE.J) TEMPWD = TEMPWD+ HLBRSN(J,I)
          IF(TEMPWD.LT.EPS) GOTO 12
          CALL HDCYAD(82,HLWDTH,TEMPWD,NETDEC(1,I,J))
 12     CONTINUE
      ENDDO
C--Decay to sfermions of the lightest scalar Higgs
C--first the decays to the first 2 generations(degenerate)
      TOTMOD = 0
      MODE = 0
      DO 13 I=1,7
        TOTMOD = TOTMOD+MODE
        MODE = 2
        IF(I.EQ.1) MODE = 3
        IF(BHLSUSY(I).LT.EPS) GOTO 13
        TEMPWD = BHLSUSY(I)/MODE   
        DO J=1,MODE
          CALL HDCYAD(82,HLWDTH,TEMPWD,SFRDC(1,TOTMOD+J))
        ENDDO     
 13   CONTINUE
C--now to the 3rd generation
      DO I=1,2
        DO 14 J=1,2
          IF(BHLSTAU(I,J).GE.EPS) 
     &      CALL HDCYAD(82,HLWDTH,BHLSTAU(I,J),TAUDEC(1,I,J))
          IF(BHLSB(I,J).GE.EPS) 
     &      CALL HDCYAD(82,HLWDTH,BHLSB(I,J),BOTDEC(1,I,J))
          IF(BHLST(I,J).GE.EPS) 
     &      CALL HDCYAD(82,HLWDTH,BHLST(I,J),TOPDEC(1,I,J))
 14     CONTINUE
      ENDDO
C--Decay to Standard Model particles of the heavy scalar Higgs
      DO 20 I=1,11
        IF(HHBRS(I).LT.EPS) GOTO 20
        IF(I.NE.6.OR.AMH.GT.2.0D0*AMT) THEN
          CALL HDCYAD(83,HHWDTH,HHBRS(I),SMDECS(1,I))
        ELSE
C--Decay to off mass shell top quark
          DO J=1,2
            CALL HDCYAD(83,HHWDTH,HHBRS(I)/2.0D0,TPDEC(1,J))
          ENDDO
        ENDIF
 20   CONTINUE 
C--Decay to charginos of the heaviest scalar Higgs
      DO I=1,2
        DO 21 J=1,2
          IF(HHBRSC(I,J).LT.EPS) GOTO 21
          CALL HDCYAD(83,HHWDTH,HHBRSC(I,J),CHRDEC(1,I,J))
 21     CONTINUE
      ENDDO  
C--Decay to neutralinos of the heaviest scalar Higgs
      DO I=1,4
        DO 22 J=1,I
          TEMPWD = HHBRSN(I,J)
          IF(I.NE.J) TEMPWD = TEMPWD+ HHBRSN(J,I)
          IF(TEMPWD.LT.EPS) GOTO 22
          CALL HDCYAD(83,HHWDTH,TEMPWD,NETDEC(1,I,J))
 22     CONTINUE
      ENDDO   
C--Decay to sfermions of the heaviest scalar Higgs
C--1st two generations
      TOTMOD = 0
      MODE   = 0
      DO 23 I=1,7
        TOTMOD = TOTMOD+MODE
        MODE = 2
        IF(I.EQ.1) MODE = 3
        IF(BHHSUSY(I).LT.EPS) GOTO 23
        TEMPWD = BHHSUSY(I)/MODE     
        DO J=1,MODE
          CALL HDCYAD(83,HHWDTH,TEMPWD,SFRDC(1,TOTMOD+J))
        ENDDO   
 23   CONTINUE
C--now to the 3rd generation
      DO I=1,2
        DO 24 J=1,2
          IF(BHHSTAU(I,J).GE.EPS) 
     &      CALL HDCYAD(83,HHWDTH,BHHSTAU(I,J),TAUDEC(1,I,J))
          IF(BHHSB(I,J).GE.EPS) 
     &      CALL HDCYAD(83,HHWDTH,BHHSB(I,J),BOTDEC(1,I,J))
          IF(BHHST(I,J).GE.EPS) 
     &      CALL HDCYAD(83,HHWDTH,BHHST(I,J),TOPDEC(1,I,J))
 24     CONTINUE
      ENDDO
C--Decay to Higgs of heavy scalar Higgs
      DO 25 I=1,4
        IF(HHBRH(I).LT.EPS) GOTO 25
        IF(I.NE.4) THEN
          JMAX = 1
          TEMPWD = HHBRH(I)
        ELSE
          JMAX = 2
          TEMPWD = HHBRH(I)/2.0D0
        ENDIF
        DO J=1,JMAX
          CALL HDCYAD(83,HHWDTH,TEMPWD,HGDECH(1,I+J-1))
        ENDDO
 25   CONTINUE
C--Decay to Standard Model particles of the pseudoscalar Higgs
      DO 30 I=1,10
        IF(HABRS(I).LT.EPS) GOTO 30
        IF(I.NE.6.OR.AMA.GT.2.0D0*AMT) THEN
          CALL HDCYAD(84,HAWDTH,HABRS(I),SMDECA(1,I))
        ELSE
C--Decay to off mass shell top quark
          DO J=1,2
            CALL HDCYAD(84,HAWDTH,HABRS(I)/2.0D0,TPDEC(1,J))
          ENDDO
        ENDIF
 30   CONTINUE  
C--Decay to charginos of the pseudoscalar Higgs
      DO I=1,2
        DO 31 J=1,2
          IF(HABRSC(I,J).LT.EPS) GOTO 31
          CALL HDCYAD(84,HAWDTH,HABRSC(I,J),CHRDEC(1,I,J))
 31     CONTINUE
      ENDDO    
C--Decay to neutralinos of the pseudoscalar Higgs
      DO I=1,4
        DO 32 J=1,I
          TEMPWD = HABRSN(I,J)
          IF(I.NE.J) TEMPWD = TEMPWD+ HABRSN(J,I)
          IF(TEMPWD.LT.EPS) GOTO 32
          CALL HDCYAD(84,HAWDTH,TEMPWD,NETDEC(1,I,J))
 32     CONTINUE
      ENDDO   
C--Decays to sfermions of the pseudoscalar Higgs
      DO 33 I=1,3
        IF(BHASUSY(I).GE.EPS) 
     &    CALL HDCYAD(84,HAWDTH,BHASUSY(I),SFRDCA(1,I))
 33   CONTINUE
C--Decay to Standard Model particles of the charged Higgs
      DO 40 I=1,9
        IF(HCBRS(I).LT.EPS) GOTO 40
        CALL HDCYAD(86,HCWDTH,HCBRS(I),SMDECC(1,I))
 40   CONTINUE
C--Decay to charginos and neutralino of the charged Higgs
      DO I=1,2
        DO 41 J=1,4
        IF(HCBRSU(I,J).LT.EPS) GOTO 41 
        CALL HDCYAD(86,HCWDTH,HCBRSU(I,J),CNDEC(1,I,J))
 41     CONTINUE
      ENDDO
C--Decay to first 2 genration sfermions and stau
      TOTMOD = 0
      MODE = 0
      DO 42 I=1,4
        TOTMOD = TOTMOD+MODE
        MODE = 1
        IF(I.EQ.2.OR.I.EQ.4) MODE = 2
        IF(BHCSUSY(I).LT.EPS) GOTO 42
        TEMPWD = BHCSUSY(I)/MODE
        DO J=1,MODE
          CALL HDCYAD(86,HCWDTH,TEMPWD,SFRDCC(1,TOTMOD+J))
        ENDDO
 42   CONTINUE
C--Now the decay to sbottom and stop
      DO I = 1,2
        DO 43 J=1,2
          IF(BHCSTB(I,J).LT.EPS) GOTO 43
          CALL HDCYAD(86,HCWDTH,BHCSTB(I,J),BTDEC(1,I,J))
 43     CONTINUE
      ENDDO
C--Now reset the ISAJET HIGGS MASSES with the HDECAY ones
      AMHL = REAL(AML)
      AMHH = REAL(AMH)
      AMHA = REAL(AMA)
      AMHC = REAL(AMCH)
      RETURN
 1000 FORMAT('WARNING ',A15,
     &        ' SOFT TERM IS NOT THE SAME FOR 1st AND 2nd GENERATION')
      END
+SELF
+SELF,IF=-HDECAY2,-HDECAY3
CDECK  ID>, HDCYSY
*CMZ :-        -24/09/02  14:59:17  by  Peter Richardson
*-- Author :  Peter Richardson 
C-----------------------------------------------------------------------
      SUBROUTINE HDCYSY(M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,
     &                     MER2,MQL2,MUR2,MDR2,MEL,MER,MSQ,MUR,MDR) 
C-----------------------------------------------------------------------
C  Dummy version of subroutine to interface HDECAY with ISAWIG for MSSM
C  Higgs Decays
C-----------------------------------------------------------------------
      IMPLICIT NONE
C--variables passed from ISAWIG
      REAL M2,MEL1,MER1,MQL1,MUR1,MDR1,MEL2,MER2,MQL2,MUR2,MDR2,
     &     MEL,MER,MSQ,MUR,MDR
      WRITE (6,10)
   10 FORMAT(/10X,'HDECAY CALLED BUT NOT LINKED')
      STOP
      END
+SELF
+EOD
+DECK,PDGID
C--------------------------------------------------------------------
      FUNCTION PDGID(LOUT,ID)
C-----------------------------------------------------------------------
C
C     Return PDG code for ID, assuming the default IDENT codes
C     are used in /SSTYPE/.
C
C     C. Balazs, May 21 2005, v0.1
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      Integer PDGID
      Integer LABEL(-120:120)
      SAVE LABEL
      INTEGER ID,J,LOUT
C
      DATA LABEL(0)/0/
C
      DATA (LABEL(J),J=1,10)
     $/       2,       1,       3,       4,       5,       6
     $, 9999999, 9999999,      21,      22/
      DATA (LABEL(J),J=-1,-10,-1)
     $/      -2,      -1,      -3,      -4,      -5,      -6
     $, 9999999, 9999999, 9999999, 9999999/
C
      DATA (LABEL(J),J=11,20)
     $/      12,      11,      14,      13,      16,      15
     $, 9999999, 9999999, 9999999, 9999999/
      DATA (LABEL(J),J=-11,-20,-1)
     $/     -12,     -11,     -14,     -13,     -16,     -15
     $, 9999999, 9999999, 9999999, 9999999/
C
      DATA (LABEL(J),J=21,30)
     $/ 1000002, 1000001, 1000003, 1000004, 1000005, 1000006
     $, 9999999, 9999999, 1000021, 1000022/
      DATA (LABEL(J),J=-21,-30,-1)
     $/-1000002,-1000001,-1000003,-1000004,-1000005,-1000006
     $, 9999999, 9999999, 9999999, 9999999/
C
      DATA (LABEL(J),J=31,40)
     $/ 1000012, 1000011, 1000014, 1000013, 1000016, 1000015
     $, 9999999, 9999999, 1000024, 1000023/
      DATA (LABEL(J),J=-31,-40,-1)
     $/-1000012,-1000011,-1000014,-1000013,-1000016,-1000015
     $, 9999999, 9999999,-1000024, 9999999/
C
      DATA (LABEL(J),J=41,50)
     $/ 2000002, 2000001, 2000003, 2000004, 2000005, 2000006
     $, 9999999, 9999999, 1000037, 1000025/
      DATA (LABEL(J),J=-41,-50,-1)
     $/-2000002,-2000001,-2000003,-2000004,-2000005,-2000006
     $, 9999999, 9999999,-1000037, 9999999/
C
      DATA (LABEL(J),J=51,60)
     $/ 2000012, 2000011, 2000014, 2000013, 2000016, 2000015
     $, 9999999, 9999999, 9999999, 1000035/
      DATA (LABEL(J),J=-51,-60,-1)
     $/-2000012,-2000011,-2000014,-2000013,-2000016,-2000015
     $, 9999999, 9999999, 9999999, 9999999/
C
      DATA (LABEL(J),J=82,86)
     $/      25,     35,     36, 9999999,    37/
      DATA LABEL(-86)/ -37/
C
      DATA LABEL(80)/ 24/,LABEL(-80)/-24/,LABEL(90)/ 23/
      DATA LABEL(91)/ 1000039/
!     DATA LABEL(110)/'PI0  '/
!     DATA LABEL(120)/'PI+  '/,LABEL(-120)/'PI-  '/
C
      IF(IABS(ID).GT.120) THEN
        WRITE(LOUT,*) 'SSID: ID = ',ID
        STOP99
      ENDIF
      PDGID=LABEL(ID)
      RETURN
      END
+EOD
+DECK,PIBLBL
        REAL FUNCTION PIBLBL(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PIBLBL: b_L squark self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBL(4),BC0BBL(4),FBBLL(4),GBBLL(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FT,FB,C(4),DD(4),G1,G2,G3
     $,MH0(4),MHP(2),LHBLBI(4,2),LHBLTI(2,2),FTBLL(4),VMAT(2,2)
     $,UMAT(2,2),GTBLL(4),AP0BBL(4),BP0BBL(4)
     $,APPTBL(2),BPPTBL(2),ACPTBL(2),BCPTBL(2)
     $,LSBLBL(2),LSBLBR(2),LHBLBL(2),LHBLBR(2),LSBLBI(2,2)
     $,LHBLTL(2),LHBLTR(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3UL,I3DL,I3EL,I3NL,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EDL,SWW2,GDL,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DD(1)=COSA2
      DD(2)=SINA2
      DD(3)=COSBE2
      DD(4)=SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EDL=-1./3.
      SWW2=1-(AMW/AMZ)**2
      GDL=I3DL-EDL*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBL(I)=0.
        BP0BBL(I)=0.
        AC0BBL(I)=0.
        BC0BBL(I)=0.
      ENDDO
      BP0BBL(1)=GGP/SR2*YDL
      BP0BBL(2)=SR2*GG*I3DL
      AP0BBL(3)=FB
      DO I=1,4
        DO II=1,4
          AC0BBL(I)=AC0BBL(I)+CONJG(N(I,II))*AP0BBL(II)
          BC0BBL(I)=BC0BBL(I)+N(I,II)*BC0BBL(II)
        ENDDO
      ENDDO
      DO I=1,4
        FBBLL(I)=CONJG(AC0BBL(I))*AC0BBL(I)
     $+CONJG(BC0BBL(I))*BC0BBL(I)
        GBBLL(I)=CONJG(BC0BBL(I))*AC0BBL(I)
     $+CONJG(AC0BBL(I))*BC0BBL(I)
      ENDDO
      DO I=1,2
        APPTBL(I)=0.
        BPPTBL(I)=0.
        ACPTBL(I)=0.
        BCPTBL(I)=0.
      ENDDO
      BPPTBL(1)=GG
      APPTBL(2)=-FT
      DO I=1,2
        DO II=1,2
          ACPTBL(I)=ACPTBL(I)+VMAT(I,II)*APPTBL(II)
          BCPTBL(I)=BCPTBL(I)+UMAT(I,II)*BPPTBL(II)
        ENDDO
      ENDDO
      DO I=1,2
        FTBLL(I)=ACPTBL(I)*ACPTBL(I)+BCPTBL(I)*BCPTBL(I)
        GTBLL(I)=BCPTBL(I)*ACPTBL(I)+ACPTBL(I)*BCPTBL(I)
      ENDDO
      LSBLBL(1)=GG*AMZ/CTHW*GDL*COSBE+SR2*FB*MBQ
      LSBLBR(1)=-FB/SR2*AAB
      LSBLBL(2)=-GG*AMZ/CTHW*GDL*SINBE
      LSBLBR(2)=-FB/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBLBI(1,1)=LSBLBL(1)*COSB-LSBLBR(1)*SINB
      LSBLBI(1,2)=LSBLBL(1)*SINB+LSBLBR(1)*COSB
      LSBLBI(2,1)=LSBLBL(2)*COSB-LSBLBR(2)*SINB
      LSBLBI(2,2)=LSBLBL(2)*SINB+LSBLBR(2)*COSB
      LHBLBI(1,1)=COSA*LSBLBI(1,1)-SINA*LSBLBI(2,1)
      LHBLBI(1,2)=COSA*LSBLBI(1,2)-SINA*LSBLBI(2,2)
      LHBLBI(2,1)=SINA*LSBLBI(1,1)+COSA*LSBLBI(2,1)
      LHBLBI(2,2)=SINA*LSBLBI(1,2)+COSA*LSBLBI(2,2)
      LHBLBL(1)=0.
      LHBLBR(1)=-FB/SR2*(-TWOM1*SINBE-AAB*COSBE)
      LHBLBL(2)=0.
      LHBLBR(2)=-FB/SR2*(-TWOM1*COSBE+AAB*SINBE)
      LHBLBI(3,1)=LHBLBL(1)*COSB-LHBLBR(1)*SINB
      LHBLBI(3,2)=LHBLBL(1)*SINB+LHBLBR(1)*COSB
      LHBLBI(4,1)=LHBLBL(2)*COSB-LHBLBR(2)*SINB
      LHBLBI(4,2)=LHBLBL(2)*SINB+LHBLBR(2)*COSB
      LHBLTL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)-FT*MTQ*SINBE
     $+FB*MBQ*COSBE
      LHBLTR(1)=-FT*(-TWOM1*COSBE-AAT*SINBE)
      LHBLTL(2)=GG*AMW/SR2*2.*COSBE*SINBE-FT*MTQ*COSBE
     $-FB*MBQ*SINBE
      LHBLTR(2)=FT*(-TWOM1*SINBE+AAT*COSBE)
      LHBLTI(1,1)=LHBLTL(1)*COST-LHBLTR(1)*SINT
      LHBLTI(1,2)=LHBLTL(1)*SINT+LHBLTR(1)*COST
      LHBLTI(2,1)=LHBLTL(2)*COST-LHBLTR(2)*SINT
      LHBLTI(2,2)=LHBLTL(2)*SINT+LHBLTR(2)*COST
      TEMP=4.*G3**2/3.*(2.*SSG(P,MSS(1),AMBT)
     $+COSB2*SSF(P,MSS(10),0.)+SINB2*SSF(P,MSS(11),0.)
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+FB**2*(SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11)))
     $+FT**2*(SINT2*SSA0(MSS(13))+COST2*SSA0(MSS(12)))
     $+4.*GG**2/CHWW2*GDL**2*SSA0(AMZ)+2.*GG**2*SSA0(AMW)
     $+(1./3.)**2*4.*PI/137.036*(COSB2*SSF(P,MSS(10),0.)
     $+SINB2*SSF(P,MSS(11),0.))+GG**2/CHWW2*GDL**2
     $*(COSB2*SSF(P,MSS(10),AMZ)+SINB2*SSF(P,MSS(11),AMZ))
     $+GG**2/2.*(COST2*SSF(P,MSS(13),AMW)+SINT2*SSF(P,MSS(12),AMW))
     $+GG**2/4.*(COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))
     $+2.*(COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12))))
     $+GG**2*I3DL*(3.*(I3UL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+I3DL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))))
     $+I3EL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+I3NL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
     $+GGP**2/4.*YDL**2*(COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+GGP**2/4.*YDL*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP+(FB**2*DD(I)-GG**2*GDL/2./CHWW2*C(I))
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+(FT**2*DD(I)+GG**2*(GDL/2./CHWW2-I3DL)*C(I))
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+(LHBLBI(I,1))**2*SSB0(P2,MH0(I),MSS(10))
     $+(LHBLBI(I,2))**2*SSB0(P2,MH0(I),MSS(11))
      ENDDO
      DO I=1,2
          TEMP=TEMP+(LHBLTI(I,1))**2*SSB0(P2,MSS(13),MHP(I))
     $+(LHBLTI(I,2))**2*SSB0(P2,MSS(12),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FBBLL(I)*SSG(P,ABS(MSS(22+I)),AMBT)
     $-2.*GBBLL(I)*ABS(MSS(22+I))*MBQ*SSB0(P2,ABS(MSS(22+I)),AMBT)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FTBLL(I)*SSG(P,ABS(MSS(26+I)),AMTP)
     $-2.*GTBLL(I)*ABS(MSS(26+I))*MTQ*SSB0(P2,ABS(MSS(26+I)),AMTP)
      ENDDO
      PIBLBL=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PIBLBR
        REAL FUNCTION PIBLBR(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PIBLBR: off-diagonal b squark self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBL(4),BC0BBL(4),FBBLR(4),GBBLR(4)
     $,AC0BBR(4),BC0BBR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FT,FB,FL,C(4),DD(4),G1,G2,G3
     $,MH0(4),MHP(2),LHBLBI(4,2),LHBLTI(2,2),FTBLR(4),VMAT(2,2)
     $,UMAT(2,2),GTBLR(4),AP0BBL(4),BP0BBL(4),AP0BBR(4),BP0BBR(4)
     $,APPTBL(2),BPPTBL(2),ACPTBL(2),BCPTBL(2)
     $,APPTBR(2),BPPTBR(2),ACPTBR(2),BCPTBR(2)
     $,LSBLBL(2),LSBLBR(2),LHBLBL(2),LHBLBR(2),LSBLBI(2,2)
     $,LSBRBR(2),LHBRBR(2),LSBRBI(2,2),LHBRTR(2)
     $,LHBLTL(2),LHBLTR(2),LHBRTL(2),LHBRBI(4,2),LHBRTI(2,2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3DL,YDR,YDL
     $,EDL,EDR,SWW2,GDL,GDR,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      FL=MLQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DD(1)=COSA2
      DD(2)=SINA2
      DD(3)=COSBE2
      DD(4)=SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3DL=-1./2.
      YDR=2./3.
      YDL=1./3.
      EDL=-1./3.
      EDR=1./3.
      SWW2=1-(AMW/AMZ)**2
      GDL=I3DL-EDL*SWW2
      GDR=-EDR*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBL(I)=0.
        BP0BBL(I)=0.
        AC0BBL(I)=0.
        BC0BBL(I)=0.
        AP0BBR(I)=0.
        BP0BBR(I)=0.
        AC0BBR(I)=0.
        BC0BBR(I)=0.
      ENDDO
      BP0BBL(1)=GGP/SR2*YDL
      BP0BBL(2)=SR2*GG*I3DL
      AP0BBL(3)=FB
      AP0BBR(1)=GGP/SR2*YDR
      BP0BBR(3)=FB
      DO I=1,4
        DO II=1,4
          AC0BBL(I)=AC0BBL(I)+CONJG(N(I,II))*AP0BBL(II)
          BC0BBL(I)=BC0BBL(I)+N(I,II)*BC0BBL(II)
          AC0BBR(I)=AC0BBR(I)+CONJG(N(I,II))*AP0BBR(II)
          BC0BBR(I)=BC0BBR(I)+N(I,II)*BC0BBR(II)
        ENDDO
      ENDDO
      DO I=1,4
        FBBLR(I)=CONJG(AC0BBL(I))*AC0BBR(I)
     $+CONJG(BC0BBL(I))*BC0BBR(I)
        GBBLR(I)=CONJG(BC0BBL(I))*AC0BBR(I)
     $+CONJG(AC0BBL(I))*BC0BBR(I)
      ENDDO
      DO I=1,2
        APPTBL(I)=0.
        BPPTBL(I)=0.
        ACPTBL(I)=0.
        BCPTBL(I)=0.
        APPTBR(I)=0.
        BPPTBR(I)=0.
        ACPTBR(I)=0.
        BCPTBR(I)=0.
      ENDDO
      BPPTBL(1)=GG
      APPTBL(2)=-FT
      BPPTBR(1)=-FB
      DO I=1,2
        DO II=1,2
          ACPTBL(I)=ACPTBL(I)+VMAT(I,II)*APPTBL(II)
          BCPTBL(I)=BCPTBL(I)+UMAT(I,II)*BPPTBL(II)
          ACPTBR(I)=ACPTBR(I)+VMAT(I,II)*APPTBR(II)
          BCPTBR(I)=BCPTBR(I)+UMAT(I,II)*BPPTBR(II)
        ENDDO
      ENDDO
      DO I=1,2
        FTBLR(I)=ACPTBL(I)*ACPTBR(I)+BCPTBL(I)*BCPTBR(I)
        GTBLR(I)=BCPTBL(I)*ACPTBR(I)+ACPTBL(I)*BCPTBR(I)
      ENDDO
      LSBLBL(1)=GG*AMZ/CTHW*GDL*COSBE+SR2*FB*MBQ
      LSBLBR(1)=-FB/SR2*AAB
      LSBLBL(2)=-GG*AMZ/CTHW*GDL*SINBE
      LSBLBR(2)=-FB/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBLBI(1,1)=LSBLBL(1)*COSB-LSBLBR(1)*SINB
      LSBLBI(1,2)=LSBLBL(1)*SINB+LSBLBR(1)*COSB
      LSBLBI(2,1)=LSBLBL(2)*COSB-LSBLBR(2)*SINB
      LSBLBI(2,2)=LSBLBL(2)*SINB+LSBLBR(2)*COSB
      LHBLBI(1,1)=COSA*LSBLBI(1,1)-SINA*LSBLBI(2,1)
      LHBLBI(1,2)=COSA*LSBLBI(1,2)-SINA*LSBLBI(2,2)
      LHBLBI(2,1)=SINA*LSBLBI(1,1)+COSA*LSBLBI(2,1)
      LHBLBI(2,2)=SINA*LSBLBI(1,2)+COSA*LSBLBI(2,2)
      LHBLBL(1)=0.
      LHBLBR(1)=-FB/SR2*(-TWOM1*SINBE-AAB*COSBE)
      LHBLBL(2)=0.
      LHBLBR(2)=-FB/SR2*(-TWOM1*COSBE+AAB*SINBE)
      LHBLBI(3,1)=LHBLBL(1)*COSB-LHBLBR(1)*SINB
      LHBLBI(3,2)=LHBLBL(1)*SINB+LHBLBR(1)*COSB
      LHBLBI(4,1)=LHBLBL(2)*COSB-LHBLBR(2)*SINB
      LHBLBI(4,2)=LHBLBL(2)*SINB+LHBLBR(2)*COSB
      LHBLTL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)-FT*MTQ*SINBE
     $+FB*MBQ*COSBE
      LHBLTR(1)=-FT*(-TWOM1*COSBE-AAT*SINBE)
      LHBLTL(2)=GG*AMW/SR2*2.*COSBE*SINBE-FT*MTQ*COSBE
     $-FB*MBQ*SINBE
      LHBLTR(2)=FT*(-TWOM1*SINBE+AAT*COSBE)
      LHBLTI(1,1)=LHBLTL(1)*COST-LHBLTR(1)*SINT
      LHBLTI(1,2)=LHBLTL(1)*SINT+LHBLTR(1)*COST
      LHBLTI(2,1)=LHBLTL(2)*COST-LHBLTR(2)*SINT
      LHBLTI(2,2)=LHBLTL(2)*SINT+LHBLTR(2)*COST
      LSBRBR(1)=GG*AMZ/CTHW*GDR*COSBE+SR2*FB*MBQ
      LSBRBR(2)=-GG*AMZ/CTHW*GDR*SINBE
C     First index is for Higgs sector, second is for sfermion
      LSBRBI(1,1)=LSBLBR(1)*COSB-LSBRBR(1)*SINB
      LSBRBI(1,2)=LSBLBR(1)*SINB+LSBRBR(1)*COSB
      LSBRBI(2,1)=LSBLBR(2)*COSB-LSBRBR(2)*SINB
      LSBRBI(2,2)=LSBLBR(2)*SINB+LSBRBR(2)*COSB
      LHBRBI(1,1)=COSA*LSBRBI(1,1)-SINA*LSBRBI(2,1)
      LHBRBI(1,2)=COSA*LSBRBI(1,2)-SINA*LSBRBI(2,2)
      LHBRBI(2,1)=SINA*LSBRBI(1,1)+COSA*LSBRBI(2,1)
      LHBRBI(2,2)=SINA*LSBRBI(1,2)+COSA*LSBRBI(2,2)
      LHBRBR(1)=0.
      LHBRBR(2)=0.
      LHBRBI(3,1)=-LHBLBR(1)*COSB-LHBRBR(1)*SINB
      LHBRBI(3,2)=-LHBLBR(1)*SINB+LHBRBR(1)*COSB
      LHBRBI(4,1)=-LHBLBR(2)*COSB-LHBRBR(2)*SINB
      LHBRBI(4,2)=-LHBLBR(2)*SINB+LHBRBR(2)*COSB
      LHBRTR(1)=0.
      LHBRTL(1)=FB*(-TWOM1*SINBE-AAB*COSBE)
      LHBRTR(2)=-FT*MBQ*COSBE-FB*MTQ*SINBE
      LHBRTL(2)=FB*(-TWOM1*COSBE+AAB*SINBE)
      LHBRTI(1,1)=LHBRTL(1)*COST-LHBRTR(1)*SINT
      LHBRTI(1,2)=LHBRTL(1)*SINT+LHBRTR(1)*COST
      LHBRTI(2,1)=LHBRTL(2)*COST-LHBRTR(2)*SINT
      LHBRTI(2,2)=LHBRTL(2)*SINT+LHBRTR(2)*COST
      TEMP=4.*G3**2/3.*(-4.*MSS(1)*SGNM3*MBQ*SSB0(P2,MSS(1),AMBT)
     $-SINB*COSB*(SSF(P,MSS(10),0.)-SSF(P,MSS(11),0.)
     $-SSA0(MSS(10))+SSA0(MSS(11))))
     $-FB/2.*(3.*FB*2.*SINB*COSB*(SSA0(MSS(10))-SSA0(MSS(11)))
     $+FL*SINL*COSL*(SSA0(MSS(21))-SSA0(MSS(22))))
     $-GGP**2/4.*YDL*YDR*SINB*COSB*(SSA0(MSS(10))-SSA0(MSS(11)))
     $-(1./3.)**2*4.*PI/137.036*SINB*COSB*(SSF(P,MSS(10),0.)
     $-SSF(P,MSS(11),0.))+GG**2/CHWW2*GDL*GDR*SINB*COSB
     $*(SSF(P,MSS(10),AMZ)-SSF(P,MSS(11),AMZ))
      DO I=1,4
          TEMP=TEMP+LHBLBI(I,1)*LHBRBI(I,1)
     $*SSB0(P2,MH0(I),MSS(10))+LHBLBI(I,2)*LHBRBI(I,2)
     $*SSB0(P2,MH0(I),MSS(11))
      ENDDO
      DO I=1,2
          TEMP=TEMP+LHBLTI(I,1)*LHBRTI(I,1)*SSB0(P2,MSS(13),MHP(I))
     $+LHBLTI(I,2)*LHBRTI(I,2)*SSB0(P2,MSS(12),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FBBLR(I)*SSG(P,ABS(MSS(22+I)),AMBT)
     $-2.*GBBLR(I)*ABS(MSS(22+I))*MBQ*SSB0(P2,ABS(MSS(22+I)),AMBT)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FTBLR(I)*SSG(P,ABS(MSS(26+I)),AMTP)
     $-2.*GTBLR(I)*ABS(MSS(26+I))*MTQ*SSB0(P2,ABS(MSS(26+I)),AMTP)
      ENDDO
      PIBLBR=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PIBRBR
        REAL FUNCTION PIBRBR(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PIBRBR: b_R squark self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBR(4),BC0BBR(4),FBBRR(4),GBBRR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FT,FB,C(4),DD(4),DU(4)
     $,MH0(4),MHP(2),LHBRBI(4,2),LHBRTI(2,2),FTBRR(4),VMAT(2,2)
     $,UMAT(2,2),GTBRR(4),AP0BBR(4),BP0BBR(4),G1,G2,G3
     $,APPTBR(2),BPPTBR(2),ACPTBR(2),BCPTBR(2)
     $,LSBRBR(2),LSBLBR(2),LHBRBR(2),LHBLBR(2),LSBRBI(2,2)
     $,LHBRTR(2),LHBRTL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EDR,SWW2,GDR,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DD(1)=COSA2
      DD(2)=SINA2
      DD(3)=COSBE2
      DD(4)=SINBE2
      DU(1)=SINA2
      DU(2)=COSA2
      DU(3)=SINBE2
      DU(4)=COSBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EDR=1./3.
      SWW2=1-(AMW/AMZ)**2
      GDR=-EDR*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBR(I)=0.
        BP0BBR(I)=0.
        AC0BBR(I)=0.
        BC0BBR(I)=0.
      ENDDO
      AP0BBR(1)=GGP/SR2*YDR
      BP0BBR(3)=FB
      DO I=1,4
        DO II=1,4
          AC0BBR(I)=AC0BBR(I)+CONJG(N(I,II))*AP0BBR(II)
          BC0BBR(I)=BC0BBR(I)+N(I,II)*BC0BBR(II)
        ENDDO
      ENDDO
      DO I=1,4
        FBBRR(I)=CONJG(AC0BBR(I))*AC0BBR(I)
     $+CONJG(BC0BBR(I))*BC0BBR(I)
        GBBRR(I)=CONJG(BC0BBR(I))*AC0BBR(I)
     $+CONJG(AC0BBR(I))*BC0BBR(I)
      ENDDO
      DO I=1,2
        APPTBR(I)=0.
        BPPTBR(I)=0.
        ACPTBR(I)=0.
        BCPTBR(I)=0.
      ENDDO
      BPPTBR(1)=-FB
      DO I=1,2
        DO II=1,2
          ACPTBR(I)=ACPTBR(I)+VMAT(I,II)*APPTBR(II)
          BCPTBR(I)=BCPTBR(I)+UMAT(I,II)*BPPTBR(II)
        ENDDO
      ENDDO
      DO I=1,2
        FTBRR(I)=ACPTBR(I)*ACPTBR(I)+BCPTBR(I)*BCPTBR(I)
        GTBRR(I)=BCPTBR(I)*ACPTBR(I)+ACPTBR(I)*BCPTBR(I)
      ENDDO
      LSBRBR(1)=GG*AMZ/CTHW*GDR*COSBE+SR2*FB*MBQ
      LSBLBR(1)=-FB/SR2*AAB
      LSBRBR(2)=-GG*AMZ/CTHW*GDR*SINBE
      LSBLBR(2)=-FB/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBRBI(1,1)=LSBLBR(1)*COSB-LSBRBR(1)*SINB
      LSBRBI(1,2)=LSBLBR(1)*SINB+LSBRBR(1)*COSB
      LSBRBI(2,1)=LSBLBR(2)*COSB-LSBRBR(2)*SINB
      LSBRBI(2,2)=LSBLBR(2)*SINB+LSBRBR(2)*COSB
      LHBRBI(1,1)=COSA*LSBRBI(1,1)-SINA*LSBRBI(2,1)
      LHBRBI(1,2)=COSA*LSBRBI(1,2)-SINA*LSBRBI(2,2)
      LHBRBI(2,1)=SINA*LSBRBI(1,1)+COSA*LSBRBI(2,1)
      LHBRBI(2,2)=SINA*LSBRBI(1,2)+COSA*LSBRBI(2,2)
      LHBRBR(1)=0.
      LHBLBR(1)=-FB/SR2*(-TWOM1*SINBE-AAB*COSBE)
      LHBRBR(2)=0.
      LHBLBR(2)=-FB/SR2*(-TWOM1*COSBE+AAB*SINBE)
      LHBRBI(3,1)=-LHBLBR(1)*COSB-LHBRBR(1)*SINB
      LHBRBI(3,2)=-LHBLBR(1)*SINB+LHBRBR(1)*COSB
      LHBRBI(4,1)=-LHBLBR(2)*COSB-LHBRBR(2)*SINB
      LHBRBI(4,2)=-LHBLBR(2)*SINB+LHBRBR(2)*COSB
      LHBRTR(1)=0.
      LHBRTL(1)=FB*(-TWOM1*SINBE-AAB*COSBE)
      LHBRTR(2)=-FT*MBQ*COSBE-FB*MTQ*SINBE
      LHBRTL(2)=FB*(-TWOM1*COSBE+AAB*SINBE)
      LHBRTI(1,1)=LHBRTL(1)*COST-LHBRTR(1)*SINT
      LHBRTI(1,2)=LHBRTL(1)*SINT+LHBRTR(1)*COST
      LHBRTI(2,1)=LHBRTL(2)*COST-LHBRTR(2)*SINT
      LHBRTI(2,2)=LHBRTL(2)*SINT+LHBRTR(2)*COST
      TEMP=4.*G3**2/3.*(2.*SSG(P,MSS(1),AMBT)
     $+SINB2*SSF(P,MSS(10),0.)+COSB2*SSF(P,MSS(11),0.)
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11)))
     $+FB**2*(COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+4.*GG**2/CHWW2*GDR**2*SSA0(AMZ)
     $+(1./3.)**2*4.*PI/137.036*(SINB2*SSF(P,MSS(10),0.)
     $+COSB2*SSF(P,MSS(11),0.))+GG**2/CHWW2*GDR**2
     $*(SINB2*SSF(P,MSS(10),AMZ)+COSB2*SSF(P,MSS(11),AMZ))
     $+GGP**2/4.*YDR**2*(SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11)))
     $+GGP**2/4.*YDR*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP+(FB**2*DD(I)-GG**2*GDR/2./CHWW2*C(I))
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+(FB**2*DU(I)+GG**2*GDR/2./CHWW2*C(I))
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+(LHBRBI(I,1))**2*SSB0(P2,MH0(I),MSS(10))
     $+(LHBRBI(I,2))**2*SSB0(P2,MH0(I),MSS(11))
      ENDDO
      DO I=1,2
          TEMP=TEMP+(LHBRTI(I,1))**2*SSB0(P2,MSS(13),MHP(I))
     $+(LHBRTI(I,2))**2*SSB0(P2,MSS(12),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FBBRR(I)*SSG(P,ABS(MSS(22+I)),AMBT)
     $-2.*GBBRR(I)*ABS(MSS(22+I))*MBQ*SSB0(P2,ABS(MSS(22+I)),AMBT)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FTBRR(I)*SSG(P,ABS(MSS(26+I)),AMTP)
     $-2.*GTBRR(I)*ABS(MSS(26+I))*MTQ*SSB0(P2,ABS(MSS(26+I)),AMTP)
      ENDDO
      PIBRBR=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PIELEL
        REAL FUNCTION PIELEL(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PIELEL: left selectron self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBL(4),BC0BBL(4),FLLLL(4),GLLLL(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,C(4),G1,G2,G3
     $,MH0(4),MHP(2),LHLLLI(4,2),LHLLN(2),FNLLL(4),VMAT(2,2)
     $,UMAT(2,2),AP0BBL(4),BP0BBL(4)
     $,APPTBL(2),BPPTBL(2),ACPTBL(2),BCPTBL(2)
     $,LSBLBL(2),LSBLBR(2),LSBLBI(2,2)
     $,LHBLTL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3UL,I3DL,I3EL,I3NL,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EEL,SWW2,GEL,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EEL=-1.
      SWW2=1-(AMW/AMZ)**2
      GEL=I3EL-EEL*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBL(I)=0.
        BP0BBL(I)=0.
        AC0BBL(I)=0.
        BC0BBL(I)=0.
      ENDDO
      BP0BBL(1)=GGP/SR2*YEL
      BP0BBL(2)=SR2*GG*I3EL
      DO I=1,4
        DO II=1,4
          AC0BBL(I)=AC0BBL(I)+CONJG(N(I,II))*AP0BBL(II)
          BC0BBL(I)=BC0BBL(I)+N(I,II)*BC0BBL(II)
        ENDDO
      ENDDO
      DO I=1,4
        FLLLL(I)=CONJG(AC0BBL(I))*AC0BBL(I)
     $+CONJG(BC0BBL(I))*BC0BBL(I)
        GLLLL(I)=CONJG(BC0BBL(I))*AC0BBL(I)
     $+CONJG(AC0BBL(I))*BC0BBL(I)
      ENDDO
      DO I=1,2
        APPTBL(I)=0.
        BPPTBL(I)=0.
        ACPTBL(I)=0.
        BCPTBL(I)=0.
      ENDDO
      BPPTBL(1)=GG
      DO I=1,2
        DO II=1,2
          ACPTBL(I)=ACPTBL(I)+VMAT(I,II)*APPTBL(II)
          BCPTBL(I)=BCPTBL(I)+UMAT(I,II)*BPPTBL(II)
        ENDDO
      ENDDO
      DO I=1,2
        FNLLL(I)=ACPTBL(I)*ACPTBL(I)+BCPTBL(I)*BCPTBL(I)
      ENDDO
      LSBLBL(1)=GG*AMZ/CTHW*GEL*COSBE
      LSBLBR(1)=0.
      LSBLBL(2)=-GG*AMZ/CTHW*GEL*SINBE
      LSBLBR(2)=0.
C     First index is for Higgs sector, second is for sfermion
      LSBLBI(1,1)=LSBLBL(1)
      LSBLBI(1,2)=LSBLBR(1)
      LSBLBI(2,1)=LSBLBL(2)
      LSBLBI(2,2)=LSBLBR(2)
      LHLLLI(1,1)=COSA*LSBLBI(1,1)-SINA*LSBLBI(2,1)
      LHLLLI(1,2)=COSA*LSBLBI(1,2)-SINA*LSBLBI(2,2)
      LHLLLI(2,1)=SINA*LSBLBI(1,1)+COSA*LSBLBI(2,1)
      LHLLLI(2,2)=SINA*LSBLBI(1,2)+COSA*LSBLBI(2,2)
      LHLLLI(3,1)=0.
      LHLLLI(3,2)=0.
      LHLLLI(4,1)=0.
      LHLLLI(4,2)=0.
      LHBLTL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)
      LHBLTL(2)=GG*AMW/SR2*2.*COSBE*SINBE
      LHLLN(1)=LHBLTL(1)
      LHLLN(2)=LHBLTL(2)
      TEMP=4.*GG**2/CHWW2*GEL**2*SSA0(AMZ)+2.*GG**2*SSA0(AMW)
     $+4.*PI/137.036*SSF(P,MSS(17),0.)+GG**2/CHWW2*GEL**2
     $*SSF(P,MSS(17),AMZ)+GG**2/2.*SSF(P,MSS(14),AMW)
     $+GG**2/4.*(SSA0(MSS(17))+2.*SSA0(MSS(14)))
     $+GG**2*I3EL*(3.*(I3UL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+I3DL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))))
     $+I3EL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+I3NL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
     $+GGP**2/4.*YEL**2*SSA0(MSS(17))
     $+GGP**2/4.*YEL*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP-GG**2*GEL/2./CHWW2*C(I)
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+GG**2*(GEL/2./CHWW2-I3EL)*C(I)
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+LHLLLI(I,1)**2*SSB0(P2,MH0(I),MSS(17))
     $+LHLLLI(I,2)**2*SSB0(P2,MH0(I),MSS(18))
      ENDDO
      DO I=1,2
          TEMP=TEMP+LHLLN(I)**2*SSB0(P2,MSS(14),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FLLLL(I)*SSG(P,ABS(MSS(22+I)),AME)
     $-2.*GLLLL(I)*ABS(MSS(22+I))*AME*SSB0(P2,ABS(MSS(22+I)),AME)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FNLLL(I)*SSG(P,ABS(MSS(26+I)),0.)
      ENDDO
      PIELEL=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PIERER
        REAL FUNCTION PIERER(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PIERER: right selectron self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBR(4),BC0BBR(4),FLLRR(4),GLLRR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,C(4),G1,G2,G3
     $,MH0(4),MHP(2),LHLRLI(4,2),VMAT(2,2)
     $,UMAT(2,2),AP0BBR(4),BP0BBR(4)
     $,LSBRBR(2),LSBLBR(2),LSBRBI(2,2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EER,SWW2,GER,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EER=1.
      SWW2=1-(AMW/AMZ)**2
      GER=-EER*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBR(I)=0.
        BP0BBR(I)=0.
        AC0BBR(I)=0.
        BC0BBR(I)=0.
      ENDDO
      AP0BBR(1)=GGP/SR2*YER
      DO I=1,4
        DO II=1,4
          AC0BBR(I)=AC0BBR(I)+CONJG(N(I,II))*AP0BBR(II)
          BC0BBR(I)=BC0BBR(I)+N(I,II)*BC0BBR(II)
        ENDDO
      ENDDO
      DO I=1,4
        FLLRR(I)=CONJG(AC0BBR(I))*AC0BBR(I)
     $+CONJG(BC0BBR(I))*BC0BBR(I)
        GLLRR(I)=CONJG(BC0BBR(I))*AC0BBR(I)
     $+CONJG(AC0BBR(I))*BC0BBR(I)
      ENDDO
      LSBRBR(1)=GG*AMZ/CTHW*GER*COSBE
      LSBLBR(1)=0.
      LSBRBR(2)=-GG*AMZ/CTHW*GER*SINBE
      LSBLBR(2)=0.
C     First index is for Higgs sector, second is for sfermion
      LSBRBI(1,1)=LSBLBR(1)
      LSBRBI(1,2)=LSBRBR(1)
      LSBRBI(2,1)=LSBLBR(2)
      LSBRBI(2,2)=LSBRBR(2)
      LHLRLI(1,1)=COSA*LSBRBI(1,1)-SINA*LSBRBI(2,1)
      LHLRLI(1,2)=COSA*LSBRBI(1,2)-SINA*LSBRBI(2,2)
      LHLRLI(2,1)=SINA*LSBRBI(1,1)+COSA*LSBRBI(2,1)
      LHLRLI(2,2)=SINA*LSBRBI(1,2)+COSA*LSBRBI(2,2)
      LHLRLI(3,1)=0.
      LHLRLI(3,2)=0.
      LHLRLI(4,1)=0.
      LHLRLI(4,2)=0.
      TEMP=4.*GG**2/CHWW2*GER**2*SSA0(AMZ)
     $+4.*PI/137.036*SSF(P,MSS(18),0.)
     $+GG**2/CHWW2*GER**2*SSF(P,MSS(18),AMZ)
     $+GGP**2/4.*YER**2*SSA0(MSS(18))
     $+GGP**2/4.*YER*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP-GG**2*GER/2./CHWW2*C(I)*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+GG**2*GER/2./CHWW2*C(I)*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+LHLRLI(I,1)**2*SSB0(P2,MH0(I),MSS(17))
     $+LHLRLI(I,2)**2*SSB0(P2,MH0(I),MSS(18))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FLLRR(I)*SSG(P,ABS(MSS(22+I)),AME)
     $-2.*GLLRR(I)*ABS(MSS(22+I))*AME*SSB0(P2,ABS(MSS(22+I)),AME)
      ENDDO
      PIERER=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PILLLL
        REAL FUNCTION PILLLL(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PILLLL: tau_L slepton self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBL(4),BC0BBL(4),FLLLL(4),GLLLL(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FL,C(4),DD(4),G1,G2,G3
     $,MH0(4),MHP(2),LHLLLI(4,2),LHLLN(2),FNLLL(4),VMAT(2,2)
     $,UMAT(2,2),AP0BBL(4),BP0BBL(4)
     $,APPTBL(2),BPPTBL(2),ACPTBL(2),BCPTBL(2)
     $,LSBLBL(2),LSBLBR(2),LHBLBL(2),LHBLBR(2),LSBLBI(2,2)
     $,LHBLTL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3UL,I3DL,I3EL,I3NL,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EEL,SWW2,GEL,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FL=MLQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DD(1)=COSA2
      DD(2)=SINA2
      DD(3)=COSBE2
      DD(4)=SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EEL=-1.
      SWW2=1-(AMW/AMZ)**2
      GEL=I3EL-EEL*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBL(I)=0.
        BP0BBL(I)=0.
        AC0BBL(I)=0.
        BC0BBL(I)=0.
      ENDDO
      BP0BBL(1)=GGP/SR2*YEL
      BP0BBL(2)=SR2*GG*I3EL
      AP0BBL(3)=FL
      DO I=1,4
        DO II=1,4
          AC0BBL(I)=AC0BBL(I)+CONJG(N(I,II))*AP0BBL(II)
          BC0BBL(I)=BC0BBL(I)+N(I,II)*BC0BBL(II)
        ENDDO
      ENDDO
      DO I=1,4
        FLLLL(I)=CONJG(AC0BBL(I))*AC0BBL(I)
     $+CONJG(BC0BBL(I))*BC0BBL(I)
        GLLLL(I)=CONJG(BC0BBL(I))*AC0BBL(I)
     $+CONJG(AC0BBL(I))*BC0BBL(I)
      ENDDO
      DO I=1,2
        APPTBL(I)=0.
        BPPTBL(I)=0.
        ACPTBL(I)=0.
        BCPTBL(I)=0.
      ENDDO
      BPPTBL(1)=GG
      DO I=1,2
        DO II=1,2
          ACPTBL(I)=ACPTBL(I)+VMAT(I,II)*APPTBL(II)
          BCPTBL(I)=BCPTBL(I)+UMAT(I,II)*BPPTBL(II)
        ENDDO
      ENDDO
      DO I=1,2
        FNLLL(I)=ACPTBL(I)*ACPTBL(I)+BCPTBL(I)*BCPTBL(I)
      ENDDO
      LSBLBL(1)=GG*AMZ/CTHW*GEL*COSBE+SR2*FL*MLQ
      LSBLBR(1)=-FL/SR2*AAL
      LSBLBL(2)=-GG*AMZ/CTHW*GEL*SINBE
      LSBLBR(2)=-FL/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBLBI(1,1)=LSBLBL(1)*COSL-LSBLBR(1)*SINL
      LSBLBI(1,2)=LSBLBL(1)*SINL+LSBLBR(1)*COSL
      LSBLBI(2,1)=LSBLBL(2)*COSL-LSBLBR(2)*SINL
      LSBLBI(2,2)=LSBLBL(2)*SINL+LSBLBR(2)*COSL
      LHLLLI(1,1)=COSA*LSBLBI(1,1)-SINA*LSBLBI(2,1)
      LHLLLI(1,2)=COSA*LSBLBI(1,2)-SINA*LSBLBI(2,2)
      LHLLLI(2,1)=SINA*LSBLBI(1,1)+COSA*LSBLBI(2,1)
      LHLLLI(2,2)=SINA*LSBLBI(1,2)+COSA*LSBLBI(2,2)
      LHBLBL(1)=0.
      LHBLBR(1)=-FL/SR2*(-TWOM1*SINBE-AAL*COSBE)
      LHBLBL(2)=0.
      LHBLBR(2)=-FL/SR2*(-TWOM1*COSBE+AAL*SINBE)
      LHLLLI(3,1)=LHBLBL(1)*COSL-LHBLBR(1)*SINL
      LHLLLI(3,2)=LHBLBL(1)*SINL+LHBLBR(1)*COSL
      LHLLLI(4,1)=LHBLBL(2)*COSL-LHBLBR(2)*SINL
      LHLLLI(4,2)=LHBLBL(2)*SINL+LHBLBR(2)*COSL
      LHBLTL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)+FL*MLQ*COSBE
      LHBLTL(2)=GG*AMW/SR2*2.*COSBE*SINBE-FL*MLQ*SINBE
      LHLLN(1)=LHBLTL(1)
      LHLLN(2)=LHBLTL(2)
      TEMP=FL**2*(SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+4.*GG**2/CHWW2*GEL**2*SSA0(AMZ)+2.*GG**2*SSA0(AMW)
     $+4.*PI/137.036*(COSL2*SSF(P,MSS(21),0.)
     $+SINL2*SSF(P,MSS(22),0.))+GG**2/CHWW2*GEL**2
     $*(COSL2*SSF(P,MSS(21),AMZ)+SINL2*SSF(P,MSS(22),AMZ))
     $+GG**2/2.*SSF(P,MSS(16),AMW)
     $+GG**2/4.*(COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22))
     $+2.*SSA0(MSS(16)))
     $+GG**2*I3EL*(3.*(I3UL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+I3DL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))))
     $+I3EL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+I3NL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
     $+GGP**2/4.*YEL**2*(COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+GGP**2/4.*YEL*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP+(FL**2*DD(I)-GG**2*GEL/2./CHWW2*C(I))
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+GG**2*(GEL/2./CHWW2-I3EL)*C(I)
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+(LHLLLI(I,1))**2*SSB0(P2,MH0(I),MSS(21))
     $+(LHLLLI(I,2))**2*SSB0(P2,MH0(I),MSS(22))
      ENDDO
      DO I=1,2
          TEMP=TEMP+(LHLLN(I))**2*SSB0(P2,MSS(16),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FLLLL(I)*SSG(P,ABS(MSS(22+I)),AMTAU)
     $-2.*GLLLL(I)*ABS(MSS(22+I))*MLQ*SSB0(P2,ABS(MSS(22+I)),AMTAU)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FNLLL(I)*SSG(P,ABS(MSS(26+I)),0.)
      ENDDO
      PILLLL=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PILLLR
        REAL FUNCTION PILLLR(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PILLLR: off-diagonal tau slpeton self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBL(4),BC0BBL(4),FLLLR(4),GLLLR(4)
     $,AC0BBR(4),BC0BBR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FL,FB,G1,G2,G3
     $,MH0(4),MHP(2),LHLLLI(4,2),LHLRLI(4,2),LHLLN(2),LHLRN(2)
     $,FNLLR(4),VMAT(2,2),UMAT(2,2),AP0BBL(4),BP0BBL(4),AP0BBR(4)
     $,BP0BBR(4),APPTBR(2),BPPTBR(2),ACPTBR(2),BCPTBR(2)
     $,APPTBL(2),BPPTBL(2),ACPTBL(2),BCPTBL(2),LHBRBR(2)
     $,LSBLBL(2),LSBLBR(2),LSBRBR(2),LHBLBL(2),LHBLBR(2),LSBLBI(2,2)
     $,LHBLTL(2),LSBRBI(2,2),LHBRTL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2
     $,I3EL,YER,YEL,EEL,EER,SWW2,GEL,GER,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FL=MLQ/VDQ
      FB=MBQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3EL=-1./2.
      YER=2.
      YEL=-1.
      EEL=-1.
      EER=1.
      SWW2=1-(AMW/AMZ)**2
      GEL=I3EL-EEL*SWW2
      GER=-EER*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBL(I)=0.
        BP0BBL(I)=0.
        AC0BBL(I)=0.
        BC0BBL(I)=0.
      ENDDO
      BP0BBL(1)=GGP/SR2*YEL
      BP0BBL(2)=SR2*GG*I3EL
      AP0BBL(3)=FL
      DO I=1,4
        DO II=1,4
          AC0BBL(I)=AC0BBL(I)+CONJG(N(I,II))*AP0BBL(II)
          BC0BBL(I)=BC0BBL(I)+N(I,II)*BC0BBL(II)
        ENDDO
      ENDDO
      DO I=1,4
        AP0BBR(I)=0.
        BP0BBR(I)=0.
        AC0BBR(I)=0.
        BC0BBR(I)=0.
      ENDDO
      AP0BBR(1)=GGP/SR2*YER
      BP0BBR(3)=FL
      DO I=1,4
        DO II=1,4
          AC0BBR(I)=AC0BBR(I)+CONJG(N(I,II))*AP0BBR(II)
          BC0BBR(I)=BC0BBR(I)+N(I,II)*BC0BBR(II)
        ENDDO
      ENDDO
      DO I=1,4
        FLLLR(I)=CONJG(AC0BBL(I))*AC0BBR(I)
     $+CONJG(BC0BBL(I))*BC0BBR(I)
        GLLLR(I)=CONJG(BC0BBL(I))*AC0BBR(I)
     $+CONJG(AC0BBL(I))*BC0BBR(I)
      ENDDO
      DO I=1,2
        APPTBL(I)=0.
        BPPTBL(I)=0.
        ACPTBL(I)=0.
        BCPTBL(I)=0.
      ENDDO
      BPPTBL(1)=GG
      DO I=1,2
        DO II=1,2
          ACPTBL(I)=ACPTBL(I)+VMAT(I,II)*APPTBL(II)
          BCPTBL(I)=BCPTBL(I)+UMAT(I,II)*BPPTBL(II)
        ENDDO
      ENDDO
      DO I=1,2
        APPTBR(I)=0.
        BPPTBR(I)=0.
        ACPTBR(I)=0.
        BCPTBR(I)=0.
      ENDDO
      BPPTBR(1)=-FL
      DO I=1,2
        DO II=1,2
          ACPTBR(I)=ACPTBR(I)+VMAT(I,II)*APPTBR(II)
          BCPTBR(I)=BCPTBR(I)+UMAT(I,II)*BPPTBR(II)
        ENDDO
      ENDDO
      DO I=1,2
        FNLLR(I)=ACPTBL(I)*ACPTBR(I)+BCPTBL(I)*BCPTBR(I)
      ENDDO
      LSBLBL(1)=GG*AMZ/CTHW*GEL*COSBE+SR2*FL*MLQ
      LSBLBR(1)=-FL/SR2*AAL
      LSBLBL(2)=-GG*AMZ/CTHW*GEL*SINBE
      LSBLBR(2)=-FL/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBLBI(1,1)=LSBLBL(1)*COSL-LSBLBR(1)*SINL
      LSBLBI(1,2)=LSBLBL(1)*SINL+LSBLBR(1)*COSL
      LSBLBI(2,1)=LSBLBL(2)*COSL-LSBLBR(2)*SINL
      LSBLBI(2,2)=LSBLBL(2)*SINL+LSBLBR(2)*COSL
      LHLLLI(1,1)=COSA*LSBLBI(1,1)-SINA*LSBLBI(2,1)
      LHLLLI(1,2)=COSA*LSBLBI(1,2)-SINA*LSBLBI(2,2)
      LHLLLI(2,1)=SINA*LSBLBI(1,1)+COSA*LSBLBI(2,1)
      LHLLLI(2,2)=SINA*LSBLBI(1,2)+COSA*LSBLBI(2,2)
      LHBLBL(1)=0.
      LHBLBR(1)=-FL/SR2*(-TWOM1*SINBE-AAL*COSBE)
      LHBLBL(2)=0.
      LHBLBR(2)=-FL/SR2*(-TWOM1*COSBE+AAL*SINBE)
      LHLLLI(3,1)=LHBLBL(1)*COSL-LHBLBR(1)*SINL
      LHLLLI(3,2)=LHBLBL(1)*SINL+LHBLBR(1)*COSL
      LHLLLI(4,1)=LHBLBL(2)*COSL-LHBLBR(2)*SINL
      LHLLLI(4,2)=LHBLBL(2)*SINL+LHBLBR(2)*COSL
      LHBLTL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)+FL*MLQ*COSBE
      LHBLTL(2)=GG*AMW/SR2*2.*COSBE*SINBE-FL*MLQ*SINBE
      LHLLN(1)=LHBLTL(1)
      LHLLN(2)=LHBLTL(2)
      LSBRBR(1)=GG*AMZ/CTHW*GER*COSBE+SR2*FL*MLQ
      LSBLBR(1)=-FL/SR2*AAL
      LSBRBR(2)=-GG*AMZ/CTHW*GER*SINBE
      LSBLBR(2)=-FL/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBRBI(1,1)=LSBLBR(1)*COSL-LSBRBR(1)*SINL
      LSBRBI(1,2)=LSBLBR(1)*SINL+LSBRBR(1)*COSL
      LSBRBI(2,1)=LSBLBR(2)*COSL-LSBRBR(2)*SINL
      LSBRBI(2,2)=LSBLBR(2)*SINL+LSBRBR(2)*COSL
      LHLRLI(1,1)=COSA*LSBRBI(1,1)-SINA*LSBRBI(2,1)
      LHLRLI(1,2)=COSA*LSBRBI(1,2)-SINA*LSBRBI(2,2)
      LHLRLI(2,1)=SINA*LSBRBI(1,1)+COSA*LSBRBI(2,1)
      LHLRLI(2,2)=SINA*LSBRBI(1,2)+COSA*LSBRBI(2,2)
      LHBRBR(1)=0.
      LHBLBR(1)=-FL/SR2*(-TWOM1*SINBE-AAL*COSBE)
      LHBRBR(2)=0.
      LHBLBR(2)=-FL/SR2*(-TWOM1*COSBE+AAL*SINBE)
      LHLRLI(3,1)=-LHBLBR(1)*COSL-LHBRBR(1)*SINL
      LHLRLI(3,2)=-LHBLBR(1)*SINL+LHBRBR(1)*COSL
      LHLRLI(4,1)=-LHBLBR(2)*COSL-LHBRBR(2)*SINL
      LHLRLI(4,2)=-LHBLBR(2)*SINL+LHBRBR(2)*COSL
      LHBRTL(1)=FL*(-TWOM1*SINBE-AAL*COSBE)
      LHBRTL(2)=FL*(-TWOM1*COSBE+AAL*SINBE)
      LHLRN(1)=LHBRTL(1)
      LHLRN(2)=LHBRTL(2)
      TEMP=-FL/2.*(3.*FB*2.*SINB*COSB*(SSA0(MSS(10))-SSA0(MSS(11)))
     $+FL*SINL*COSL*(SSA0(MSS(21))-SSA0(MSS(22))))
     $-GGP**2/4.*YEL*YER*SINL*COSL*(SSA0(MSS(21))-SSA0(MSS(22)))
     $-4.*PI/137.036*SINL*COSL*(SSF(P,MSS(21),0.)
     $-SSF(P,MSS(22),0.))+GG**2/CHWW2*GEL*GER*SINL*COSL
     $*(SSF(P,MSS(21),AMZ)-SSF(P,MSS(22),AMZ))
      DO I=1,4
          TEMP=TEMP+LHLLLI(I,1)*LHLRLI(I,1)
     $*SSB0(P2,MH0(I),MSS(21))+LHLLLI(I,2)*LHLRLI(I,2)
     $*SSB0(P2,MH0(I),MSS(22))
      ENDDO
      DO I=1,2
          TEMP=TEMP+LHLLN(I)*LHLRN(I)*SSB0(P2,MSS(16),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FLLLR(I)*SSG(P,ABS(MSS(22+I)),AMTAU)
     $-2.*GLLLR(I)*ABS(MSS(22+I))*MLQ*SSB0(P2,ABS(MSS(22+I)),AMTAU)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FNLLR(I)*SSG(P,ABS(MSS(26+I)),0.)
      ENDDO
      PILLLR=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PILRLR
        REAL FUNCTION PILRLR(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PILRLR: tau_R slepton self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0BBR(4),BC0BBR(4),FLLRR(4),GLLRR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FL,C(4),DD(4),DU(4),G1,G2,G3
     $,MH0(4),MHP(2),LHLRLI(4,2),LHLRN(2),FNLRR(4),VMAT(2,2)
     $,UMAT(2,2),AP0BBR(4),BP0BBR(4)
     $,APPTBR(2),BPPTBR(2),ACPTBR(2),BCPTBR(2)
     $,LSBRBR(2),LSBLBR(2),LHBRBR(2),LHBLBR(2),LSBRBI(2,2)
     $,LHBRTL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EER,SWW2,GER,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FL=MLQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DD(1)=COSA2
      DD(2)=SINA2
      DD(3)=COSBE2
      DD(4)=SINBE2
      DU(1)=SINA2
      DU(2)=COSA2
      DU(3)=SINBE2
      DU(4)=COSBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EER=1.
      SWW2=1-(AMW/AMZ)**2
      GER=-EER*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0BBR(I)=0.
        BP0BBR(I)=0.
        AC0BBR(I)=0.
        BC0BBR(I)=0.
      ENDDO
      AP0BBR(1)=GGP/SR2*YER
      BP0BBR(3)=FL
      DO I=1,4
        DO II=1,4
          AC0BBR(I)=AC0BBR(I)+CONJG(N(I,II))*AP0BBR(II)
          BC0BBR(I)=BC0BBR(I)+N(I,II)*BC0BBR(II)
        ENDDO
      ENDDO
      DO I=1,4
        FLLRR(I)=CONJG(AC0BBR(I))*AC0BBR(I)
     $+CONJG(BC0BBR(I))*BC0BBR(I)
        GLLRR(I)=CONJG(BC0BBR(I))*AC0BBR(I)
     $+CONJG(AC0BBR(I))*BC0BBR(I)
      ENDDO
      DO I=1,2
        APPTBR(I)=0.
        BPPTBR(I)=0.
        ACPTBR(I)=0.
        BCPTBR(I)=0.
      ENDDO
      BPPTBR(1)=-FL
      DO I=1,2
        DO II=1,2
          ACPTBR(I)=ACPTBR(I)+VMAT(I,II)*APPTBR(II)
          BCPTBR(I)=BCPTBR(I)+UMAT(I,II)*BPPTBR(II)
        ENDDO
      ENDDO
      DO I=1,2
        FNLRR(I)=ACPTBR(I)*ACPTBR(I)+BCPTBR(I)*BCPTBR(I)
      ENDDO
      LSBRBR(1)=GG*AMZ/CTHW*GER*COSBE+SR2*FL*MLQ
      LSBLBR(1)=-FL/SR2*AAL
      LSBRBR(2)=-GG*AMZ/CTHW*GER*SINBE
      LSBLBR(2)=-FL/SR2*TWOM1
C     First index is for Higgs sector, second is for sfermion
      LSBRBI(1,1)=LSBLBR(1)*COSL-LSBRBR(1)*SINL
      LSBRBI(1,2)=LSBLBR(1)*SINL+LSBRBR(1)*COSL
      LSBRBI(2,1)=LSBLBR(2)*COSL-LSBRBR(2)*SINL
      LSBRBI(2,2)=LSBLBR(2)*SINL+LSBRBR(2)*COSL
      LHLRLI(1,1)=COSA*LSBRBI(1,1)-SINA*LSBRBI(2,1)
      LHLRLI(1,2)=COSA*LSBRBI(1,2)-SINA*LSBRBI(2,2)
      LHLRLI(2,1)=SINA*LSBRBI(1,1)+COSA*LSBRBI(2,1)
      LHLRLI(2,2)=SINA*LSBRBI(1,2)+COSA*LSBRBI(2,2)
      LHBRBR(1)=0.
      LHBLBR(1)=-FL/SR2*(-TWOM1*SINBE-AAL*COSBE)
      LHBRBR(2)=0.
      LHBLBR(2)=-FL/SR2*(-TWOM1*COSBE+AAL*SINBE)
      LHLRLI(3,1)=-LHBLBR(1)*COSL-LHBRBR(1)*SINL
      LHLRLI(3,2)=-LHBLBR(1)*SINL+LHBRBR(1)*COSL
      LHLRLI(4,1)=-LHBLBR(2)*COSL-LHBRBR(2)*SINL
      LHLRLI(4,2)=-LHBLBR(2)*SINL+LHBRBR(2)*COSL
      LHBRTL(1)=FL*(-TWOM1*SINBE-AAL*COSBE)
      LHBRTL(2)=FL*(-TWOM1*COSBE+AAL*SINBE)
      LHLRN(1)=LHBRTL(1)
      LHLRN(2)=LHBRTL(2)
      TEMP=FL**2*(COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22))
     $+SSA0(MSS(16)))+4.*GG**2/CHWW2*GER**2*SSA0(AMZ)
     $+4.*PI/137.036*(SINL2*SSF(P,MSS(21),0.)
     $+COSL2*SSF(P,MSS(22),0.))+GG**2/CHWW2*GER**2
     $*(SINL2*SSF(P,MSS(21),AMZ)+COSL2*SSF(P,MSS(22),AMZ))
     $+GGP**2/4.*YER**2*(SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+GGP**2/4.*YER*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP+(FL**2*DD(I)-GG**2*GER/2./CHWW2*C(I))
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+(FL**2*DU(I)+GG**2*GER/2./CHWW2*C(I))
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+(LHLRLI(I,1))**2*SSB0(P2,MH0(I),MSS(21))
     $+(LHLRLI(I,2))**2*SSB0(P2,MH0(I),MSS(22))
      ENDDO
      DO I=1,2
          TEMP=TEMP+(LHLRN(I))**2*SSB0(P2,MSS(16),MHP(I))
      ENDDO
      DO I=1,4
        TEMP=TEMP+FLLRR(I)*SSG(P,ABS(MSS(22+I)),AMTAU)
     $-2.*GLLRR(I)*ABS(MSS(22+I))*MLQ*SSB0(P2,ABS(MSS(22+I)),AMTAU)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FNLRR(I)*SSG(P,ABS(MSS(26+I)),0.)
      ENDDO
      PILRLR=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PINENE
        REAL FUNCTION PINENE(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PINENE: electron sneutrino self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0TTL(4),BC0TTL(4),FTTLL(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,C(4),G1,G2,G3
     $,MH0(4),MHP(2),LHTLTI(4,2),LHTLBI(2,2),FBTLL(4),VMAT(2,2)
     $,UMAT(2,2),GBTLL(4),AP0TTL(4),BP0TTL(4)
     $,APPBTL(2),BPPBTL(2),ACPBTL(2),BCPBTL(2)
     $,LSTLTL(2),LSTLTR(2),LSTLTI(2,2)
     $,LHTLBL(2),LHTLBR(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3UL,I3DL,I3EL,I3NL,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,SWW2,GNL,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      SWW2=1-(AMW/AMZ)**2
      GNL=I3NL
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0TTL(I)=0.
        BP0TTL(I)=0.
        AC0TTL(I)=0.
        BC0TTL(I)=0.
      ENDDO
      BP0TTL(1)=GGP/SR2*YNL
      BP0TTL(2)=SR2*GG*I3NL
      DO I=1,4
        DO II=1,4
          AC0TTL(I)=AC0TTL(I)+CONJG(N(I,II))*AP0TTL(II)
          BC0TTL(I)=BC0TTL(I)+N(I,II)*BC0TTL(II)
        ENDDO
      ENDDO
      DO I=1,4
        FTTLL(I)=CONJG(AC0TTL(I))*AC0TTL(I)
     $+CONJG(BC0TTL(I))*BC0TTL(I)
      ENDDO
      DO I=1,2
        APPBTL(I)=0.
        BPPBTL(I)=0.
        ACPBTL(I)=0.
        BCPBTL(I)=0.
      ENDDO
      APPBTL(1)=GG
      DO I=1,2
        DO II=1,2
          ACPBTL(I)=ACPBTL(I)+VMAT(I,II)*APPBTL(II)
          BCPBTL(I)=BCPBTL(I)+UMAT(I,II)*BPPBTL(II)
        ENDDO
      ENDDO
      DO I=1,2
        FBTLL(I)=ACPBTL(I)*ACPBTL(I)+BCPBTL(I)*BCPBTL(I)
        GBTLL(I)=BCPBTL(I)*ACPBTL(I)+ACPBTL(I)*BCPBTL(I)
      ENDDO
      LSTLTL(1)=GG*AMZ/CTHW*GNL*COSBE
      LSTLTR(1)=0.
      LSTLTL(2)=-GG*AMZ/CTHW*GNL*SINBE
      LSTLTR(2)=0.
C     First index is for Higgs sector, second is for sfermion
      LSTLTI(1,1)=LSTLTL(1)
      LSTLTI(1,2)=LSTLTR(1)
      LSTLTI(2,1)=LSTLTL(2)
      LSTLTI(2,2)=LSTLTR(2)
      LHTLTI(1,1)=COSA*LSTLTI(1,1)-SINA*LSTLTI(2,1)
      LHTLTI(1,2)=COSA*LSTLTI(1,2)-SINA*LSTLTI(2,2)
      LHTLTI(2,1)=SINA*LSTLTI(1,1)+COSA*LSTLTI(2,1)
      LHTLTI(2,2)=SINA*LSTLTI(1,2)+COSA*LSTLTI(2,2)
      LHTLTI(3,1)=0.
      LHTLTI(3,2)=0.
      LHTLTI(4,1)=0.
      LHTLTI(4,2)=0.
      LHTLBL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)
      LHTLBR(1)=0.
      LHTLBL(2)=GG*AMW/SR2*2.*COSBE*SINBE
      LHTLBR(2)=0.
      LHTLBI(1,1)=LHTLBL(1)
      LHTLBI(1,2)=LHTLBR(1)
      LHTLBI(2,1)=LHTLBL(2)
      LHTLBI(2,2)=LHTLBR(2)
      TEMP=4.*GG**2/CHWW2*GNL**2*SSA0(AMZ)+2.*GG**2*SSA0(AMW)
     $+GG**2/CHWW2*GNL**2*SSF(P,MSS(14),AMZ)
     $+GG**2/2.*SSF(P,MSS(17),AMW)
     $+GG**2/4.*(SSA0(MSS(14))+2.*SSA0(MSS(17)))
     $+GG**2*I3NL*(3.*(I3UL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+I3DL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))))
     $+I3EL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+I3NL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
     $+GGP**2/4.*YNL**2*SSA0(MSS(14))
     $+GGP**2/4.*YNL*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP-GG**2*GNL/2./CHWW2*C(I)*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+GG**2*(GNL/2./CHWW2-I3NL)*C(I)*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+LHTLTI(I,1)**2*SSB0(P2,MH0(I),MSS(14))
      ENDDO
      DO I=1,2
        DO II=1,2
          TEMP=TEMP+(LHTLBI(I,II))**2*SSB0(P2,MSS(16+II),MHP(I))
        ENDDO
      ENDDO
      DO I=1,4
        TEMP=TEMP+FTTLL(I)*SSG(P,ABS(MSS(22+I)),0.)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FBTLL(I)*SSG(P,ABS(MSS(26+I)),AME)
     $-2.*GBTLL(I)*ABS(MSS(26+I))*AME*SSB0(P2,ABS(MSS(26+I)),AME)
      ENDDO
      PINENE=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PITLTL
        REAL FUNCTION PITLTL(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PITLTL: t_L squark self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0TTL(4),BC0TTL(4),FTTLL(4),GTTLL(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FT,FB,C(4),DU(4),G1,G2,G3
     $,MH0(4),MHP(2),LHTLTI(4,2),LHTLBI(2,2),FBTLL(4),VMAT(2,2)
     $,UMAT(2,2),GBTLL(4),AP0TTL(4),BP0TTL(4)
     $,APPBTL(2),BPPBTL(2),ACPBTL(2),BCPBTL(2)
     $,LSTLTL(2),LSTLTR(2),LHTLTL(2),LHTLTR(2),LSTLTI(2,2)
     $,LHTLBL(2),LHTLBR(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3UL,I3DL,I3EL,I3NL,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EUL,SWW2,GUL,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DU(1)=SINA2
      DU(2)=COSA2
      DU(3)=SINBE2
      DU(4)=COSBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EUL=2./3.
      SWW2=1-(AMW/AMZ)**2
      GUL=I3UL-EUL*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0TTL(I)=0.
        BP0TTL(I)=0.
        AC0TTL(I)=0.
        BC0TTL(I)=0.
      ENDDO
      BP0TTL(1)=GGP/SR2*YUL
      BP0TTL(2)=SR2*GG*I3UL
      AP0TTL(4)=FT
      DO I=1,4
        DO II=1,4
          AC0TTL(I)=AC0TTL(I)+CONJG(N(I,II))*AP0TTL(II)
          BC0TTL(I)=BC0TTL(I)+N(I,II)*BC0TTL(II)
        ENDDO
      ENDDO
      DO I=1,4
        FTTLL(I)=CONJG(AC0TTL(I))*AC0TTL(I)
     $+CONJG(BC0TTL(I))*BC0TTL(I)
        GTTLL(I)=CONJG(BC0TTL(I))*AC0TTL(I)
     $+CONJG(AC0TTL(I))*BC0TTL(I)
      ENDDO
      DO I=1,2
        APPBTL(I)=0.
        BPPBTL(I)=0.
        ACPBTL(I)=0.
        BCPBTL(I)=0.
      ENDDO
      APPBTL(1)=GG
      BPPBTL(2)=-FB
      DO I=1,2
        DO II=1,2
          ACPBTL(I)=ACPBTL(I)+VMAT(I,II)*APPBTL(II)
          BCPBTL(I)=BCPBTL(I)+UMAT(I,II)*BPPBTL(II)
        ENDDO
      ENDDO
      DO I=1,2
        FBTLL(I)=ACPBTL(I)*ACPBTL(I)+BCPBTL(I)*BCPBTL(I)
        GBTLL(I)=BCPBTL(I)*ACPBTL(I)+ACPBTL(I)*BCPBTL(I)
      ENDDO
      LSTLTL(1)=GG*AMZ/CTHW*GUL*COSBE
      LSTLTR(1)=-FT/SR2*TWOM1
      LSTLTL(2)=-GG*AMZ/CTHW*GUL*SINBE+SR2*FT*MTQ
      LSTLTR(2)=-FT/SR2*AAT
C     First index is for Higgs sector, second is for sfermion
      LSTLTI(1,1)=LSTLTL(1)*COST-LSTLTR(1)*SINT
      LSTLTI(1,2)=LSTLTL(1)*SINT+LSTLTR(1)*COST
      LSTLTI(2,1)=LSTLTL(2)*COST-LSTLTR(2)*SINT
      LSTLTI(2,2)=LSTLTL(2)*SINT+LSTLTR(2)*COST
      LHTLTI(1,1)=COSA*LSTLTI(1,1)-SINA*LSTLTI(2,1)
      LHTLTI(1,2)=COSA*LSTLTI(1,2)-SINA*LSTLTI(2,2)
      LHTLTI(2,1)=SINA*LSTLTI(1,1)+COSA*LSTLTI(2,1)
      LHTLTI(2,2)=SINA*LSTLTI(1,2)+COSA*LSTLTI(2,2)
      LHTLTL(1)=0.
      LHTLTR(1)=FT/SR2*(-TWOM1*COSBE-AAT*SINBE)
      LHTLTL(2)=0.
      LHTLTR(2)=-FT/SR2*(-TWOM1*SINBE+AAT*COSBE)
      LHTLTI(3,1)=LHTLTL(1)*COST-LHTLTR(1)*SINT
      LHTLTI(3,2)=LHTLTL(1)*SINT+LHTLTR(1)*COST
      LHTLTI(4,1)=LHTLTL(2)*COST-LHTLTR(2)*SINT
      LHTLTI(4,2)=LHTLTL(2)*SINT+LHTLTR(2)*COST
      LHTLBL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)-FT*MTQ*SINBE
     $+FB*MBQ*COSBE
      LHTLBR(1)=FB*(-TWOM1*SINBE-AAB*COSBE)
      LHTLBL(2)=GG*AMW/SR2*2.*COSBE*SINBE-FT*MTQ*COSBE
     $-FB*MBQ*SINBE
      LHTLBR(2)=FB*(-TWOM1*COSBE+AAB*SINBE)
      LHTLBI(1,1)=LHTLBL(1)*COSB-LHTLBR(1)*SINB
      LHTLBI(1,2)=LHTLBL(1)*SINB+LHTLBR(1)*COSB
      LHTLBI(2,1)=LHTLBL(2)*COSB-LHTLBR(2)*SINB
      LHTLBI(2,2)=LHTLBL(2)*SINB+LHTLBR(2)*COSB
      TEMP=4.*G3**2/3.*(2.*SSG(P,MSS(1),AMTP)
     $+COST2*SSF(P,MSS(13),0.)+SINT2*SSF(P,MSS(12),0.)
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+FT**2*(SINT2*SSA0(MSS(13))+COST2*SSA0(MSS(12)))
     $+FB**2*(SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11)))
     $+4.*GG**2/CHWW2*GUL**2*SSA0(AMZ)+2.*GG**2*SSA0(AMW)
     $+(2./3.)**2*4.*PI/137.036*(COST2*SSF(P,MSS(13),0.)
     $+SINT2*SSF(P,MSS(12),0.))+GG**2/CHWW2*GUL**2
     $*(COST2*SSF(P,MSS(13),AMZ)+SINT2*SSF(P,MSS(12),AMZ))
     $+GG**2/2.*(COSB2*SSF(P,MSS(10),AMW)+SINB2*SSF(P,MSS(11),AMW))
     $+GG**2/4.*(COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12))
     $+2.*(COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))))
     $+GG**2*I3UL*(3.*(I3UL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+I3DL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11))))
     $+I3EL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+I3NL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
     $+GGP**2/4.*YUL**2*(COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+GGP**2/4.*YUL*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP+(FT**2*DU(I)-GG**2*GUL/2./CHWW2*C(I))
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+(FB**2*DU(I)+GG**2*(GUL/2./CHWW2-I3UL)*C(I))
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+(LHTLTI(I,1))**2*SSB0(P2,MH0(I),MSS(13))
     $+(LHTLTI(I,2))**2*SSB0(P2,MH0(I),MSS(12))
      ENDDO
      DO I=1,2
        DO II=1,2
          TEMP=TEMP+(LHTLBI(I,II))**2*SSB0(P2,MSS(9+II),MHP(I))
        ENDDO
      ENDDO
      DO I=1,4
        TEMP=TEMP+FTTLL(I)*SSG(P,ABS(MSS(22+I)),AMTP)
     $-2.*GTTLL(I)*ABS(MSS(22+I))*MTQ*SSB0(P2,ABS(MSS(22+I)),AMTP)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FBTLL(I)*SSG(P,ABS(MSS(26+I)),AMBT)
     $-2.*GBTLL(I)*ABS(MSS(26+I))*MBQ*SSB0(P2,ABS(MSS(26+I)),AMBT)
      ENDDO
      PITLTL=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PITLTR
        REAL FUNCTION PITLTR(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PITLTR: off-diagonal t squark self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0TTR(4),AC0TTL(4),BC0TTR(4),BC0TTL(4)
     $,FTTLR(4),GTTLR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FT,FB,G1,G2,G3
     $,MH0(4),MHP(2),LHTLTI(4,2),LHTLBI(2,2),FBTLR(4),VMAT(2,2)
     $,UMAT(2,2),GBTLR(4),AP0TTR(4),AP0TTL(4),BP0TTR(4),BP0TTL(4)
     $,APPBTL(2),APPBTR(2),BPPBTL(2),BPPBTR(2)
     $,ACPBTL(2),ACPBTR(2),BCPBTL(2),BCPBTR(2)
     $,LSTLTL(2),LSTLTR(2),LHTLTL(2),LHTLTR(2),LSTLTI(2,2)
     $,LHTLBL(2),LHTLBR(2)
     $,LHTRTI(4,2),LHTRBI(2,2),LSTRTR(2),LHTRTR(2),LSTRTI(2,2)
     $,LHTRBR(2),LHTRBL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,I3UL,YUR,YUL
     $,EUL,EUR,SWW2,GUL,GUR,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      I3UL=1./2.
      YUR=-4./3.
      YUL=1./3.
      EUL=2./3.
      EUR=-2./3.
      SWW2=1-(AMW/AMZ)**2
      EUR=-2./3.
      GUR=-EUR*SWW2
      GUL=I3UL-EUL*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0TTR(I)=0.
        AP0TTL(I)=0.
        BP0TTR(I)=0.
        BP0TTL(I)=0.
        AC0TTR(I)=0.
        AC0TTL(I)=0.
        BC0TTR(I)=0.
        BC0TTL(I)=0.
      ENDDO
      AP0TTR(1)=GGP/SR2*YUR
      BP0TTL(1)=GGP/SR2*YUL
      BP0TTL(2)=SR2*GG*I3UL
      AP0TTL(4)=FT
      BP0TTR(4)=FT
      DO I=1,4
        DO II=1,4
          AC0TTR(I)=AC0TTR(I)+CONJG(N(I,II))*AP0TTR(II)
          AC0TTL(I)=AC0TTL(I)+CONJG(N(I,II))*AP0TTL(II)
          BC0TTR(I)=BC0TTR(I)+N(I,II)*BC0TTR(II)
          BC0TTL(I)=BC0TTL(I)+N(I,II)*BC0TTL(II)
        ENDDO
      ENDDO
      DO I=1,4
        FTTLR(I)=CONJG(AC0TTL(I))*AC0TTR(I)
     $+CONJG(BC0TTL(I))*BC0TTR(I)
        GTTLR(I)=CONJG(BC0TTL(I))*AC0TTR(I)
     $+CONJG(AC0TTL(I))*BC0TTR(I)
      ENDDO
      DO I=1,2
        APPBTL(I)=0.
        APPBTR(I)=0.
        BPPBTL(I)=0.
        BPPBTR(I)=0.
        ACPBTL(I)=0.
        ACPBTR(I)=0.
        BCPBTL(I)=0.
        BCPBTR(I)=0.
      ENDDO
      APPBTL(1)=GG
      BPPBTL(2)=-FB
      APPBTR(2)=-FT
      DO I=1,2
        DO II=1,2
          ACPBTL(I)=ACPBTL(I)+VMAT(I,II)*APPBTL(II)
          ACPBTR(I)=ACPBTR(I)+VMAT(I,II)*APPBTR(II)
          BCPBTL(I)=BCPBTL(I)+UMAT(I,II)*BPPBTL(II)
          BCPBTR(I)=BCPBTR(I)+UMAT(I,II)*BPPBTR(II)
        ENDDO
      ENDDO
      DO I=1,2
        FBTLR(I)=ACPBTL(I)*ACPBTR(I)+BCPBTL(I)*BCPBTR(I)
        GBTLR(I)=BCPBTL(I)*ACPBTR(I)+ACPBTL(I)*BCPBTR(I)
      ENDDO
      LSTLTL(1)=GG*AMZ/CTHW*GUL*COSBE
      LSTLTR(1)=-FT/SR2*TWOM1
      LSTLTL(2)=-GG*AMZ/CTHW*GUL*SINBE+SR2*FT*MTQ
      LSTLTR(2)=-FT/SR2*AAT
C     First index is for Higgs sector, second is for sfermion
      LSTLTI(1,1)=LSTLTL(1)*COST-LSTLTR(1)*SINT
      LSTLTI(1,2)=LSTLTL(1)*SINT+LSTLTR(1)*COST
      LSTLTI(2,1)=LSTLTL(2)*COST-LSTLTR(2)*SINT
      LSTLTI(2,2)=LSTLTL(2)*SINT+LSTLTR(2)*COST
      LHTLTI(1,1)=COSA*LSTLTI(1,1)-SINA*LSTLTI(2,1)
      LHTLTI(1,2)=COSA*LSTLTI(1,2)-SINA*LSTLTI(2,2)
      LHTLTI(2,1)=SINA*LSTLTI(1,1)+COSA*LSTLTI(2,1)
      LHTLTI(2,2)=SINA*LSTLTI(1,2)+COSA*LSTLTI(2,2)
      LHTLTL(1)=0.
      LHTLTR(1)=FT/SR2*(-TWOM1*COSBE-AAT*SINBE)
      LHTLTL(2)=0.
      LHTLTR(2)=-FT/SR2*(-TWOM1*SINBE+AAT*COSBE)
      LHTLTI(3,1)=LHTLTL(1)*COST-LHTLTR(1)*SINT
      LHTLTI(3,2)=LHTLTL(1)*SINT+LHTLTR(1)*COST
      LHTLTI(4,1)=LHTLTL(2)*COST-LHTLTR(2)*SINT
      LHTLTI(4,2)=LHTLTL(2)*SINT+LHTLTR(2)*COST
      LHTLBL(1)=-GG*AMW/SR2*(COSBE2-SINBE2)-FT*MTQ*SINBE
     $+FB*MBQ*COSBE
      LHTLBR(1)=FB*(-TWOM1*SINBE-AAB*COSBE)
      LHTLBL(2)=GG*AMW/SR2*2.*COSBE*SINBE-FT*MTQ*COSBE
     $-FB*MBQ*SINBE
      LHTLBR(2)=FB*(-TWOM1*COSBE+AAB*SINBE)
      LHTLBI(1,1)=LHTLBL(1)*COSB-LHTLBR(1)*SINB
      LHTLBI(1,2)=LHTLBL(1)*SINB+LHTLBR(1)*COSB
      LHTLBI(2,1)=LHTLBL(2)*COSB-LHTLBR(2)*SINB
      LHTLBI(2,2)=LHTLBL(2)*SINB+LHTLBR(2)*COSB
      LSTRTR(1)=GG*AMZ/CTHW*GUR*COSBE
      LSTRTR(2)=-GG*AMZ/CTHW*GUR*SINBE+SR2*FT*MTQ
      LSTRTI(1,1)=LSTLTR(1)*COST-LSTRTR(1)*SINT
      LSTRTI(1,2)=LSTLTR(1)*SINT+LSTRTR(1)*COST
      LSTRTI(2,1)=LSTLTR(2)*COST-LSTRTR(2)*SINT
      LSTRTI(2,2)=LSTLTR(2)*SINT+LSTRTR(2)*COST
      LHTRTI(1,1)=COSA*LSTRTI(1,1)-SINA*LSTRTI(2,1)
      LHTRTI(1,2)=COSA*LSTRTI(1,2)-SINA*LSTRTI(2,2)
      LHTRTI(2,1)=SINA*LSTRTI(1,1)+COSA*LSTRTI(2,1)
      LHTRTI(2,2)=SINA*LSTRTI(1,2)+COSA*LSTRTI(2,2)
      LHTRTR(1)=0.
      LHTRTR(2)=0.
      LHTRTI(3,1)=-LHTLTR(1)*COST-LHTRTR(1)*SINT
      LHTRTI(3,2)=-LHTLTR(1)*SINT+LHTRTR(1)*COST
      LHTRTI(4,1)=-LHTLTR(2)*COST-LHTRTR(2)*SINT
      LHTRTI(4,2)=-LHTLTR(2)*SINT+LHTRTR(2)*COST
      LHTRBR(1)=0.
      LHTRBL(1)=-FT*(-TWOM1*COSBE-AAT*SINBE)
      LHTRBR(2)=-FT*MBQ*COSBE-FB*MTQ*SINBE
      LHTRBL(2)=FB*(-TWOM1*SINBE+AAT*COSBE)
      LHTRBI(1,1)=LHTRBL(1)*COSB-LHTRBR(1)*SINB
      LHTRBI(1,2)=LHTRBL(1)*SINB+LHTRBR(1)*COSB
      LHTRBI(2,1)=LHTRBL(2)*COSB-LHTRBR(2)*SINB
      LHTRBI(2,2)=LHTRBL(2)*SINB+LHTRBR(2)*COSB
      TEMP=4.*G3**2/3.*(-4.*MSS(1)*SGNM3*MTQ*SSB0(P2,MSS(1),AMTP)
     $-SINT*COST*(SSF(P,MSS(13),0.)-SSF(P,MSS(12),0.)
     $-SSA0(MSS(13))+SSA0(MSS(12))))
     $-FT/2.*3.*FT*2.*SINT*COST*(SSA0(MSS(13))-SSA0(MSS(12)))
     $-GGP**2/4.*YUL*YUR*SINT*COST*(SSA0(MSS(13))-SSA0(MSS(12)))
     $-(2./3.)**2*4.*PI/137.036*SINT*COST*(SSF(P,MSS(13),0.)
     $-SSF(P,MSS(12),0.))+GG**2/CHWW2*GUL*GUR*SINT*COST
     $*(SSF(P,MSS(13),AMZ)-SSF(P,MSS(12),AMZ))
      DO I=1,4
          TEMP=TEMP+LHTLTI(I,1)*LHTRTI(I,1)
     $*SSB0(P2,MH0(I),MSS(13))+LHTLTI(I,2)*LHTRTI(I,2)
     $*SSB0(P2,MH0(I),MSS(12))
      ENDDO
      DO I=1,2
        DO II=1,2
          TEMP=TEMP+LHTLBI(I,II)*LHTRBI(I,II)*SSB0(P2,MSS(9+II),MHP(I))
        ENDDO
      ENDDO
      DO I=1,4
        TEMP=TEMP+FTTLR(I)*SSG(P,ABS(MSS(22+I)),AMTP)
     $-2.*GTTLR(I)*ABS(MSS(22+I))*MTQ*SSB0(P2,ABS(MSS(22+I)),AMTP)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FBTLR(I)*SSG(P,ABS(MSS(26+I)),AMBT)
     $-2.*GBTLR(I)*ABS(MSS(26+I))*MBQ*SSB0(P2,ABS(MSS(26+I)),AMBT)
      ENDDO
      PITLTR=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,PITRTR
        REAL FUNCTION PITRTR(P2,G1,G2,G3,CTHW)
C-----------------------------------------------------------------------
C          PITRTR: t_R squark self-energy
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C          P2 = 4-momentum squared
C          CTHW = Cos(theta_W) in DR bar scheme
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,SSG,SSF
      DOUBLE PRECISION SSA0
      COMPLEX TEMP,N(4,4),AC0TTR(4),BC0TTR(4),FTTRR(4),GTTRR(4)
      REAL P2,P,GG,GGP,CTHW,CHWW2,BE,FT,FB,C(4),DU(4),DD(4),G1,G2,G3
     $,MH0(4),MHP(2),LHTRTI(4,2),LHTRBI(2,2),FBTRR(4),VMAT(2,2)
     $,UMAT(2,2),GBTRR(4),AP0TTR(4),BP0TTR(4)
     $,APPBTR(2),BPPBTR(2),ACPBTR(2),BCPBTR(2)
     $,LSTRTR(2),LSTLTR(2),LHTRTR(2),LHTLTR(2),LSTRTI(2,2)
     $,LHTRBR(2),LHTRBL(2)
      REAL COST,SINT,COST2,SINT2,COSB,SINB,COSB2,SINB2
     $,COSL,SINL,COSL2,SINL2,THX,THY
      REAL SINA2,COSA2,SINBE2,COSBE2,YUR,YUL
     $,YDR,YDL,YER,YEL,YNL,EUR,SWW2,GUR,SINA,COSA,SINBE,COSBE
      INTEGER I,II,THIW1,THIW2
      COMPLEX IMAG
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      P=SQRT(P2)
      CHWW2=CTHW**2
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      COST2=COST**2
      SINT2=1-COST2
      COSB2=COSB**2
      SINB2=1-COSB2
      COSL2=COSL**2
      SINL2=1-COSL2
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      SINA2=SIN(ALFAH)**2
      COSA2=COS(ALFAH)**2
      SINBE2=SIN(BE)**2
      COSBE2=COS(BE)**2
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      C(1)=-(COSA2-SINA2)
      C(2)=COSA2-SINA2
      C(3)=-(COSBE2-SINBE2)
      C(4)=COSBE2-SINBE2
      DU(1)=SINA2
      DU(2)=COSA2
      DU(3)=SINBE2
      DU(4)=COSBE2
      DD(1)=COSA2
      DD(2)=SINA2
      DD(3)=COSBE2
      DD(4)=SINBE2
      MH0(1)=MSS(30)
      MH0(2)=MSS(29)
      MH0(3)=AMZ
      MH0(4)=MSS(31)
      MHP(2)=AMW
      MHP(1)=MSS(32)
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNL=-1.
      EUR=-2./3.
      SWW2=1-(AMW/AMZ)**2
      GUR=-EUR*SWW2
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          I=0
        ELSE
          I=1
        END IF
        N(II,1)=-IMAG**I*ZMIXSS(4,II)
        N(II,2)=-IMAG**I*ZMIXSS(3,II)
        N(II,3)=IMAG**I*ZMIXSS(2,II)
        N(II,4)=IMAG**I*ZMIXSS(1,II)
      ENDDO
      DO I=1,4
        AP0TTR(I)=0.
        BP0TTR(I)=0.
        AC0TTR(I)=0.
        BC0TTR(I)=0.
      ENDDO
      AP0TTR(1)=GGP/SR2*YUR
      BP0TTR(4)=FT
      DO I=1,4
        DO II=1,4
          AC0TTR(I)=AC0TTR(I)+CONJG(N(I,II))*AP0TTR(II)
          BC0TTR(I)=BC0TTR(I)+N(I,II)*BC0TTR(II)
        ENDDO
      ENDDO
      DO I=1,4
        FTTRR(I)=CONJG(AC0TTR(I))*AC0TTR(I)
     $+CONJG(BC0TTR(I))*BC0TTR(I)
        GTTRR(I)=CONJG(BC0TTR(I))*AC0TTR(I)
     $+CONJG(AC0TTR(I))*BC0TTR(I)
      ENDDO
      DO I=1,2
        APPBTR(I)=0.
        BPPBTR(I)=0.
        ACPBTR(I)=0.
        BCPBTR(I)=0.
      ENDDO
      APPBTR(2)=-FT
      DO I=1,2
        DO II=1,2
          ACPBTR(I)=ACPBTR(I)+VMAT(I,II)*APPBTR(II)
          BCPBTR(I)=BCPBTR(I)+UMAT(I,II)*BPPBTR(II)
        ENDDO
      ENDDO
      DO I=1,2
        FBTRR(I)=ACPBTR(I)*ACPBTR(I)+BCPBTR(I)*BCPBTR(I)
        GBTRR(I)=BCPBTR(I)*ACPBTR(I)+ACPBTR(I)*BCPBTR(I)
      ENDDO
      LSTRTR(1)=GG*AMZ/CTHW*GUR*COSBE
      LSTLTR(1)=-FT/SR2*TWOM1
      LSTRTR(2)=-GG*AMZ/CTHW*GUR*SINBE+SR2*FT*MTQ
      LSTLTR(2)=-FT/SR2*AAT
C     First index is for Higgs sector, second is for sfermion
      LSTRTI(1,1)=LSTLTR(1)*COST-LSTRTR(1)*SINT
      LSTRTI(1,2)=LSTLTR(1)*SINT+LSTRTR(1)*COST
      LSTRTI(2,1)=LSTLTR(2)*COST-LSTRTR(2)*SINT
      LSTRTI(2,2)=LSTLTR(2)*SINT+LSTRTR(2)*COST
      LHTRTI(1,1)=COSA*LSTRTI(1,1)-SINA*LSTRTI(2,1)
      LHTRTI(1,2)=COSA*LSTRTI(1,2)-SINA*LSTRTI(2,2)
      LHTRTI(2,1)=SINA*LSTRTI(1,1)+COSA*LSTRTI(2,1)
      LHTRTI(2,2)=SINA*LSTRTI(1,2)+COSA*LSTRTI(2,2)
      LHTRTR(1)=0.
      LHTLTR(1)=FT/SR2*(-TWOM1*COSBE-AAT*SINBE)
      LHTRTR(2)=0.
      LHTLTR(2)=-FT/SR2*(-TWOM1*SINBE+AAT*COSBE)
      LHTRTI(3,1)=-LHTLTR(1)*COST-LHTRTR(1)*SINT
      LHTRTI(3,2)=-LHTLTR(1)*SINT+LHTRTR(1)*COST
      LHTRTI(4,1)=-LHTLTR(2)*COST-LHTRTR(2)*SINT
      LHTRTI(4,2)=-LHTLTR(2)*SINT+LHTRTR(2)*COST
      LHTRBR(1)=0.
      LHTRBL(1)=-FT*(-TWOM1*COSBE-AAT*SINBE)
      LHTRBR(2)=-FT*MBQ*COSBE-FB*MTQ*SINBE
      LHTRBL(2)=FB*(-TWOM1*SINBE+AAT*COSBE)
      LHTRBI(1,1)=LHTRBL(1)*COSB-LHTRBR(1)*SINB
      LHTRBI(1,2)=LHTRBL(1)*SINB+LHTRBR(1)*COSB
      LHTRBI(2,1)=LHTRBL(2)*COSB-LHTRBR(2)*SINB
      LHTRBI(2,2)=LHTRBL(2)*SINB+LHTRBR(2)*COSB
      TEMP=4.*G3**2/3.*(2.*SSG(P,MSS(1),AMTP)
     $+SINT2*SSF(P,MSS(13),0.)+COST2*SSF(P,MSS(12),0.)
     $+SINT2*SSA0(MSS(13))+COST2*SSA0(MSS(12)))
     $+FT**2*(COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+4.*GG**2/CHWW2*GUR**2*SSA0(AMZ)
     $+(2./3.)**2*4.*PI/137.036*(SINT2*SSF(P,MSS(13),0.)
     $+COST2*SSF(P,MSS(12),0.))+GG**2/CHWW2*GUR**2
     $*(SINT2*SSF(P,MSS(13),AMZ)+COST2*SSF(P,MSS(12),AMZ))
     $+GGP**2/4.*YUR**2*(SINT2*SSA0(MSS(13))+COST2*SSA0(MSS(12)))
     $+GGP**2/4.*YUR*(3.*(YUL*(SSA0(MSS(2))+SSA0(MSS(8))
     $+COST2*SSA0(MSS(13))+SINT2*SSA0(MSS(12)))
     $+YUR*(SSA0(MSS(3))+SSA0(MSS(9))+SINT2*SSA0(MSS(13))
     $+COST2*SSA0(MSS(12)))+YDL*(SSA0(MSS(4))+SSA0(MSS(6))
     $+COSB2*SSA0(MSS(10))+SINB2*SSA0(MSS(11)))
     $+YDR*(SSA0(MSS(5))+SSA0(MSS(7))
     $+SINB2*SSA0(MSS(10))+COSB2*SSA0(MSS(11))))
     $+YEL*(SSA0(MSS(17))+SSA0(MSS(19))
     $+COSL2*SSA0(MSS(21))+SINL2*SSA0(MSS(22)))
     $+YER*(SSA0(MSS(18))+SSA0(MSS(20))
     $+SINL2*SSA0(MSS(21))+COSL2*SSA0(MSS(22)))
     $+YNL*(SSA0(MSS(14))+SSA0(MSS(15))+SSA0(MSS(16))))
      DO I=1,4
        TEMP=TEMP+(FT**2*DU(I)-GG**2*GUR/2./CHWW2*C(I))
     $*SSA0(MH0(I))/2.
      ENDDO
      DO I=3,4
        TEMP=TEMP+(FT**2*DD(I)+GG**2*GUR/2./CHWW2*C(I))
     $*SSA0(MHP(I-2))
      ENDDO
      DO I=1,4
          TEMP=TEMP+(LHTRTI(I,1))**2*SSB0(P2,MH0(I),MSS(13))
     $+(LHTRTI(I,2))**2*SSB0(P2,MH0(I),MSS(12))
      ENDDO
      DO I=1,2
        DO II=1,2
          TEMP=TEMP+(LHTRBI(I,II))**2*SSB0(P2,MSS(9+II),MHP(I))
        ENDDO
      ENDDO
      DO I=1,4
        TEMP=TEMP+FTTRR(I)*SSG(P,ABS(MSS(22+I)),AMTP)
     $-2.*GTTRR(I)*ABS(MSS(22+I))*MTQ*SSB0(P2,ABS(MSS(22+I)),AMTP)
      ENDDO
      DO I=1,2
        TEMP=TEMP+FBTRR(I)*SSG(P,ABS(MSS(26+I)),AMBT)
     $-2.*GBTRR(I)*ABS(MSS(26+I))*MBQ*SSB0(P2,ABS(MSS(26+I)),AMBT)
      ENDDO
      PITRTR=REAL(TEMP)/16./PI**2
      RETURN
      END
+EOD
+DECK,RKSTP,IF=NOCERN
C-----------------------------------------------------------------------
      SUBROUTINE RKSTP(N,H,X,Y,SUB,W)
C-----------------------------------------------------------------------
C
C     From CERN Program Library, routine D209, with error message for
C     N.LT.1 replaced by STOP 99 to eliminate Kernlib error routine.
C
      DIMENSION Y(N),W(N,3)
      LOGICAL MFLAG,RFLAG
      EXTERNAL SUB
C
C     ******************************************************************
C
C     THIS SUBROUTINE REPLACES X BY X+H AND ADVANCES THE SOLUTION OF THE
C     SYSTEM OF DIFFERENTIAL EQUATIONS DY/DX=F(X,Y) FROM Y(X) TO Y(X+H)
C     USING A FIFTH-ORDER RUNGE-KUTTA METHOD.
C
C     SUB IS THE NAME OF A SUBROUTINE SUB(X,Y,F) WHICH SETS THE VECTOR F
C     TO THE DERIVATIVE AT X OF THE VECTOR Y.
C
C     W IS A WORKING-SPACE ARRAY, TREATED AS CONSISTING OF THREE CONSEC-
C     UTIVE WORKING VECTORS OF LENGTH N.
C
C     ******************************************************************
C
C  START.
      IF (N.LT.1) STOP 99
      NLOCAL=N
      HLOCAL=H
      H2=0.5*HLOCAL
      H6=HLOCAL/6.
      XH=X+HLOCAL
      XH2=X+H2
      CALL SUB(X,Y,W(1,1))
      DO 1 J=1,NLOCAL
         W(J,2)=Y(J)+H2*W(J,1)
    1 CONTINUE
      CALL SUB(XH2,W(1,2),W(1,3))
      DO 2 J=1,NLOCAL
         W(J,1)=W(J,1)+2.*W(J,3)
         W(J,2)=Y(J)+H2*W(J,3)
    2 CONTINUE
      CALL SUB(XH2,W(1,2),W(1,3))
      DO 3 J=1,NLOCAL
         W(J,1)=W(J,1)+2.*W(J,3)
         W(J,2)=Y(J)+HLOCAL*W(J,3)
    3 CONTINUE
      CALL SUB(XH,W(1,2),W(1,3))
      DO 4 J=1,NLOCAL
         Y(J)=Y(J)+H6*(W(J,1)+W(J,3))
    4 CONTINUE
      X=XH
      RETURN
      END
+EOD
+DECK,SIG0L
        REAL FUNCTION SIG0L(P2,I,J,G1,G2,CHW)
C-----------------------------------------------------------------------
C          SIG0L: Neutralino mass matrix correction
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C     Programmed by Tadas Krupovnickas 1/2003
C          P2 = 4-momentum squared
C          CHW = Cos(theta_W) in DR bar scheme
C     Ordering: u=1,s=2,t=3,d=4,c=5,b=6,e=7,mu=8,tau=9,nue=10,num=11,nut=12
C     I and J are indexes in Pierce's base. To convert to ISAJET's basis
C     make the transformation 1->4, 2->3, 3->2, 4->1 for both inexes
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB1,AP0C0Z(4,4),AP0C0H(4,4,4)
      DOUBLE PRECISION TEMP,AP0FF(4,12,2),AP0CPW(4,2),AP0CPH(4,2,2)
      REAL AP0R(4,12),AP0L(4,12),AP0PPW(4,2),AP0P0Z(4,4)
     $,AP0PPH(4,2,2),AP0P0H(4,4,4),G1,G2
      REAL P2,CHW,COST,SINT,COSB,SINB,COSL,SINL,GG,GGP
      REAL YUR,YUL,YDR,YDL,YER,YEL,YNR,YNL,I3UL,I3DL,I3EL,I3NL
      REAL THX,THY,VMAT(2,2),UMAT(2,2),BE,FB,FT,FMIX(12,2,2)
      INTEGER THIW1,THIW2
      INTEGER I,J,II,III
      COMPLEX IMAG,N(4,4)
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FB=MBQ/VDQ
      FT=MTQ/VUQ
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          III=0
        ELSE
          III=1
        END IF
        N(II,1)=-IMAG**III*ZMIXSS(4,II)
        N(II,2)=-IMAG**III*ZMIXSS(3,II)
        N(II,3)=IMAG**III*ZMIXSS(2,II)
        N(II,4)=IMAG**III*ZMIXSS(1,II)
      ENDDO
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNR=0.
      YNL=-1.
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      DO II=1,4
        DO III=1,12
          AP0R(II,III)=0.
          AP0L(II,III)=0.
        ENDDO
      ENDDO
      AP0R(1,1)=GGP/SR2*YUR
      AP0R(1,2)=GGP/SR2*YUR
      AP0R(1,3)=GGP/SR2*YUR
      AP0R(1,4)=GGP/SR2*YDR
      AP0R(1,5)=GGP/SR2*YDR
      AP0R(1,6)=GGP/SR2*YDR
      AP0R(1,7)=GGP/SR2*YER
      AP0R(1,8)=GGP/SR2*YER
      AP0R(1,9)=GGP/SR2*YER
      AP0R(1,10)=GGP/SR2*YNR
      AP0R(1,11)=GGP/SR2*YNR
      AP0R(1,12)=GGP/SR2*YNR
      AP0L(3,6)=FB
      AP0L(4,3)=FT
      DO II=1,12
        FMIX(II,1,1)=1.
        FMIX(II,1,2)=0.
        FMIX(II,2,1)=0.
        FMIX(II,2,2)=1.
      ENDDO
      FMIX(3,1,1)=COST
      FMIX(3,1,2)=-SINT
      FMIX(3,2,1)=SINT
      FMIX(3,2,2)=COST
      FMIX(6,1,1)=COSB
      FMIX(6,1,2)=-SINB
      FMIX(6,2,1)=SINB
      FMIX(6,2,2)=COSB
      FMIX(9,1,1)=COSL
      FMIX(9,1,2)=-SINL
      FMIX(9,2,1)=SINL
      FMIX(9,2,2)=COSL
      DO II=1,4
        DO III=1,12
          AP0FF(II,III,1)=FMIX(III,1,1)*AP0L(II,III)
     $+FMIX(III,1,2)*AP0R(II,III)
          AP0FF(II,III,2)=FMIX(III,2,1)*AP0L(II,III)
     $+FMIX(III,2,2)*AP0R(II,III)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPW(II,III)=0.
        ENDDO
      ENDDO
      AP0PPW(2,1)=-GG
      AP0PPW(4,2)=GG/SR2
      DO II=1,4
        DO III=1,2
          AP0CPW(II,III)=VMAT(III,1)*AP0PPW(II,1)
     $+VMAT(III,2)*AP0PPW(II,2)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,4
          AP0P0Z(II,III)=0.
        ENDDO
      ENDDO
      AP0P0Z(3,3)=GG/2./CHW
      AP0P0Z(4,4)=-GG/2./CHW
      DO II=1,4
        DO III=1,4
          AP0C0Z(II,III)=N(III,3)*AP0P0Z(II,3)
     $+N(III,4)*AP0P0Z(II,4)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPH(II,III,1)=0.
          AP0PPH(II,III,2)=0.
        ENDDO
      ENDDO
      AP0PPH(1,2,1)=GGP/SR2
      AP0PPH(2,2,1)=GG/SR2
      AP0PPH(3,1,1)=-GG
      DO II=1,4
        DO III=1,2
          AP0CPH(II,III,1)=COS(BE)*(UMAT(III,1)*AP0PPH(II,1,1)
     $+UMAT(III,2)*AP0PPH(II,2,1))+SIN(BE)*(UMAT(III,1)*AP0PPH(II,1,2)
     $+UMAT(III,2)*AP0PPH(II,2,2))
          AP0CPH(II,III,2)=-SIN(BE)*(UMAT(III,1)*AP0PPH(II,1,1)
     $+UMAT(III,2)*AP0PPH(II,2,1))+COS(BE)*(UMAT(III,1)*AP0PPH(II,1,2)
     $+UMAT(III,2)*AP0PPH(II,2,2))
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,4
          AP0P0H(II,III,1)=0.
          AP0P0H(II,III,2)=0.
          AP0P0H(II,III,3)=0.
          AP0P0H(II,III,4)=0.
        ENDDO
      ENDDO
      AP0P0H(1,3,1)=-GGP/2.
      AP0P0H(1,4,2)=GGP/2.
      AP0P0H(2,3,1)=GG/2.
      AP0P0H(2,4,2)=-GG/2.
      AP0P0H(1,3,3)=-GGP/2.
      AP0P0H(1,4,4)=-GGP/2.
      AP0P0H(2,3,3)=GG/2.
      AP0P0H(2,4,4)=GG/2.
      AP0P0H(3,1,1)=-GGP/2.
      AP0P0H(4,1,2)=GGP/2.
      AP0P0H(3,2,1)=GG/2.
      AP0P0H(4,2,2)=-GG/2.
      AP0P0H(3,1,3)=-GGP/2.
      AP0P0H(4,1,4)=-GGP/2.
      AP0P0H(3,2,3)=GG/2.
      AP0P0H(4,2,4)=GG/2.
      DO II=1,4
        DO III=1,4
          AP0C0H(II,III,1)=(CONJG(N(III,1))*AP0P0H(II,1,1)
     $+CONJG(N(III,2))*AP0P0H(II,2,1)+CONJG(N(III,3))*AP0P0H(II,3,1)
     $+CONJG(N(III,4))*AP0P0H(II,4,1))*COS(ALFAH)
     $-(CONJG(N(III,1))*AP0P0H(II,1,2)+CONJG(N(III,2))*AP0P0H(II,2,2)
     $+CONJG(N(III,3))*AP0P0H(II,3,2)+CONJG(N(III,2))
     $*AP0P0H(II,4,2))*SIN(ALFAH)
          AP0C0H(II,III,2)=(CONJG(N(III,1))*AP0P0H(II,1,1)
     $+CONJG(N(III,2))*AP0P0H(II,2,1)+CONJG(N(III,3))*AP0P0H(II,3,1)
     $+CONJG(N(III,4))*AP0P0H(II,4,1))*SIN(ALFAH)
     $+(CONJG(N(III,1))*AP0P0H(II,1,2)+CONJG(N(III,2))*AP0P0H(II,2,2)
     $+CONJG(N(III,3))*AP0P0H(II,3,2)+CONJG(N(III,2))
     $*AP0P0H(II,4,2))*COS(ALFAH)
          AP0C0H(II,III,3)=(CONJG(N(III,1))*AP0P0H(II,1,3)
     $+CONJG(N(III,2))*AP0P0H(II,2,3)+CONJG(N(III,3))*AP0P0H(II,3,3)
     $+CONJG(N(III,4))*AP0P0H(II,4,3))*COS(BE)
     $+(CONJG(N(III,1))*AP0P0H(II,1,4)+CONJG(N(III,2))*AP0P0H(II,2,4)
     $+CONJG(N(III,3))*AP0P0H(II,3,4)+CONJG(N(III,2))
     $*AP0P0H(II,4,4))*SIN(BE)
          AP0C0H(II,III,4)=-(CONJG(N(III,1))*AP0P0H(II,1,3)
     $+CONJG(N(III,2))*AP0P0H(II,2,3)+CONJG(N(III,3))*AP0P0H(II,3,3)
     $+CONJG(N(III,4))*AP0P0H(II,4,3))*SIN(BE)
     $+(CONJG(N(III,1))*AP0P0H(II,1,4)+CONJG(N(III,2))*AP0P0H(II,2,4)
     $+CONJG(N(III,3))*AP0P0H(II,3,4)+CONJG(N(III,2))
     $*AP0P0H(II,4,4))*COS(BE)
        ENDDO
      ENDDO
      TEMP=DBLE(3.*(AP0FF(I,1,1)*AP0FF(J,1,1)
     $*SSB1(P2,AMUP,ABS(MSS(2)))
     $+AP0FF(I,1,2)*AP0FF(J,1,2)*SSB1(P2,AMUP,ABS(MSS(3)))
     $+AP0FF(I,2,1)*AP0FF(J,2,1)*SSB1(P2,AMST,ABS(MSS(6)))
     $+AP0FF(I,2,2)*AP0FF(J,2,2)*SSB1(P2,AMST,ABS(MSS(7)))
     $+AP0FF(I,3,1)*AP0FF(J,3,1)*SSB1(P2,AMTP,ABS(MSS(13)))
     $+AP0FF(I,3,2)*AP0FF(J,3,2)*SSB1(P2,AMTP,ABS(MSS(12)))
     $+AP0FF(I,4,1)*AP0FF(J,4,1)*SSB1(P2,AMDN,ABS(MSS(4)))
     $+AP0FF(I,4,2)*AP0FF(J,4,2)*SSB1(P2,AMDN,ABS(MSS(5)))
     $+AP0FF(I,5,1)*AP0FF(J,5,1)*SSB1(P2,AMCH,ABS(MSS(8)))
     $+AP0FF(I,5,2)*AP0FF(J,5,2)*SSB1(P2,AMCH,ABS(MSS(9)))
     $+AP0FF(I,6,1)*AP0FF(J,6,1)*SSB1(P2,AMBT,ABS(MSS(10)))
     $+AP0FF(I,6,2)*AP0FF(J,6,2)*SSB1(P2,AMBT,ABS(MSS(11))))
     $+AP0FF(I,7,1)*AP0FF(J,7,1)*SSB1(P2,AME,ABS(MSS(17)))
     $+AP0FF(I,7,2)*AP0FF(J,7,2)*SSB1(P2,AME,ABS(MSS(18)))
     $+AP0FF(I,8,1)*AP0FF(J,8,1)*SSB1(P2,AMMU,ABS(MSS(19)))
     $+AP0FF(I,8,2)*AP0FF(J,8,2)*SSB1(P2,AMMU,ABS(MSS(20)))
     $+AP0FF(I,9,1)*AP0FF(J,9,1)*SSB1(P2,AMTAU,ABS(MSS(21)))
     $+AP0FF(I,9,2)*AP0FF(J,9,2)*SSB1(P2,AMTAU,ABS(MSS(22)))
     $+2.*(AP0CPW(I,1)*AP0CPW(J,1)*SSB1(P2,ABS(MSS(27)),AMW)
     $+AP0CPW(I,2)*AP0CPW(J,2)*SSB1(P2,ABS(MSS(28)),AMW))
     $+CONJG(AP0C0Z(I,1))*AP0C0Z(J,1)*SSB1(P2,ABS(MSS(23)),AMZ)
     $+CONJG(AP0C0Z(I,2))*AP0C0Z(J,2)*SSB1(P2,ABS(MSS(24)),AMZ)
     $+CONJG(AP0C0Z(I,3))*AP0C0Z(J,3)*SSB1(P2,ABS(MSS(25)),AMZ)
     $+CONJG(AP0C0Z(I,4))*AP0C0Z(J,4)*SSB1(P2,ABS(MSS(26)),AMZ)
     $+AP0CPH(I,1,1)*AP0CPH(J,1,1)*SSB1(P2,ABS(MSS(27)),AMW)
     $+AP0CPH(I,1,2)*AP0CPH(J,1,2)*SSB1(P2,ABS(MSS(27)),ABS(MSS(32)))
     $+AP0CPH(I,2,1)*AP0CPH(J,2,1)*SSB1(P2,ABS(MSS(28)),AMW)
     $+AP0CPH(I,2,2)*AP0CPH(J,2,2)*SSB1(P2,ABS(MSS(28)),ABS(MSS(32)))
     $+(CONJG(AP0C0H(I,1,1))*AP0C0H(J,1,1)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(30)))
     $+CONJG(AP0C0H(I,1,2))*AP0C0H(J,1,2)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(29)))
     $+CONJG(AP0C0H(I,1,3))*AP0C0H(J,1,3)*SSB1(P2,ABS(MSS(23)),AMZ)
     $+CONJG(AP0C0H(I,1,4))*AP0C0H(J,1,4)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(31)))
     $+CONJG(AP0C0H(I,2,1))*AP0C0H(J,2,1)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(30)))
     $+CONJG(AP0C0H(I,2,2))*AP0C0H(J,2,2)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(29)))
     $+CONJG(AP0C0H(I,2,3))*AP0C0H(J,2,3)*SSB1(P2,ABS(MSS(24)),AMZ)
     $+CONJG(AP0C0H(I,2,4))*AP0C0H(J,2,4)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(31)))
     $+CONJG(AP0C0H(I,3,1))*AP0C0H(J,3,1)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(30)))
     $+CONJG(AP0C0H(I,3,2))*AP0C0H(J,3,2)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(29)))
     $+CONJG(AP0C0H(I,3,3))*AP0C0H(J,3,3)*SSB1(P2,ABS(MSS(25)),AMZ)
     $+CONJG(AP0C0H(I,3,4))*AP0C0H(J,3,4)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(31)))
     $+CONJG(AP0C0H(I,4,1))*AP0C0H(J,4,1)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(30)))
     $+CONJG(AP0C0H(I,4,2))*AP0C0H(J,4,2)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(29)))
     $+CONJG(AP0C0H(I,4,3))*AP0C0H(J,4,3)*SSB1(P2,ABS(MSS(26)),AMZ)
     $+CONJG(AP0C0H(I,4,4))*AP0C0H(J,4,4)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(31)))
     $)/2.)/16./PI**2
      SIG0L=TEMP
      RETURN
      END
+EOD
+DECK,SIG0R
        REAL FUNCTION SIG0R(P2,I,J,G1,G2,CHW)
C-----------------------------------------------------------------------
C          SIG0R: Neutralino mass matrix correction
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C     Programmed by Tadas Krupovnickas
C          P2 = 4-momentum squared
C          CHW = Cos(theta_W) in DR bar scheme
C     Ordering: u=1,s=2,t=3,d=4,c=5,b=6,e=7,mu=8,tau=9,nue=10,num=11,nut=12
C     I and J are indexes in Pierce's base. To convert to ISAJET's basis
C     make the transformation 1->4, 2->3, 3->2, 4->1 for both inexes
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB1,BP0C0Z(4,4),BP0C0H(4,4,4)
      DOUBLE PRECISION TEMP,BP0FF(4,12,2),BP0CPW(4,2),BP0CPH(4,2,2)
      REAL BP0R(4,12),BP0L(4,12),BP0PPW(4,2),BP0P0Z(4,4)
     $,BP0PPH(4,2,2),BP0P0H(4,4,4)
      REAL P2,G1,G2,CHW,COST,SINT,COSB,SINB,COSL,SINL,GG,GGP
      REAL YUR,YUL,YDR,YDL,YER,YEL,YNR,YNL,I3UL,I3DL,I3EL,I3NL
      REAL THX,THY,VMAT(2,2),UMAT(2,2),BE,FB,FT,FMIX(12,2,2)
      INTEGER THIW1,THIW2
      INTEGER I,J,II,III
      COMPLEX IMAG,N(4,4)
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FB=MBQ/VDQ
      FT=MTQ/VUQ
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          III=0
        ELSE
          III=1
        END IF
        N(II,1)=-IMAG**III*ZMIXSS(4,II)
        N(II,2)=-IMAG**III*ZMIXSS(3,II)
        N(II,3)=IMAG**III*ZMIXSS(2,II)
        N(II,4)=IMAG**III*ZMIXSS(1,II)
      ENDDO
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNR=0.
      YNL=-1.
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      DO II=1,4
        DO III=1,12
          BP0R(II,III)=0.
          BP0L(II,III)=0.
        ENDDO
      ENDDO
      BP0L(1,1)=GGP/SR2*YUL
      BP0L(1,2)=GGP/SR2*YUL
      BP0L(1,3)=GGP/SR2*YUL
      BP0L(1,4)=GGP/SR2*YDL
      BP0L(1,5)=GGP/SR2*YDL
      BP0L(1,6)=GGP/SR2*YDL
      BP0L(1,7)=GGP/SR2*YEL
      BP0L(1,8)=GGP/SR2*YEL
      BP0L(1,9)=GGP/SR2*YEL
      BP0L(1,10)=GGP/SR2*YNL
      BP0L(1,11)=GGP/SR2*YNL
      BP0L(1,12)=GGP/SR2*YNL
      BP0L(2,1)=SR2*GG*I3UL
      BP0L(2,2)=SR2*GG*I3UL
      BP0L(2,3)=SR2*GG*I3UL
      BP0L(2,4)=SR2*GG*I3DL
      BP0L(2,5)=SR2*GG*I3DL
      BP0L(2,6)=SR2*GG*I3DL
      BP0L(2,7)=SR2*GG*I3EL
      BP0L(2,8)=SR2*GG*I3EL
      BP0L(2,9)=SR2*GG*I3EL
      BP0L(2,10)=SR2*GG*I3NL
      BP0L(2,11)=SR2*GG*I3NL
      BP0L(2,12)=SR2*GG*I3NL
      BP0R(3,6)=FB
      BP0R(4,3)=FT
      DO II=1,12
        FMIX(II,1,1)=1.
        FMIX(II,1,2)=0.
        FMIX(II,2,1)=0.
        FMIX(II,2,2)=1.
      ENDDO
      FMIX(3,1,1)=COST
      FMIX(3,1,2)=-SINT
      FMIX(3,2,1)=SINT
      FMIX(3,2,2)=COST
      FMIX(6,1,1)=COSB
      FMIX(6,1,2)=-SINB
      FMIX(6,2,1)=SINB
      FMIX(6,2,2)=COSB
      FMIX(9,1,1)=COSL
      FMIX(9,1,2)=-SINL
      FMIX(9,2,1)=SINL
      FMIX(9,2,2)=COSL
      DO II=1,4
        DO III=1,12
          BP0FF(II,III,1)=FMIX(III,1,1)*BP0L(II,III)
     $+FMIX(III,1,2)*BP0R(II,III)
          BP0FF(II,III,2)=FMIX(III,2,1)*BP0L(II,III)
     $+FMIX(III,2,2)*BP0R(II,III)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          BP0PPW(II,III)=0.
        ENDDO
      ENDDO
      BP0PPW(2,1)=-GG
      BP0PPW(3,2)=-GG/SR2
      DO II=1,4
        DO III=1,2
          BP0CPW(II,III)=UMAT(III,1)*BP0PPW(II,1)
     $+UMAT(III,2)*BP0PPW(II,2)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,4
          BP0P0Z(II,III)=0.
        ENDDO
      ENDDO
      BP0P0Z(3,3)=-GG/2./CHW
      BP0P0Z(4,4)=GG/2./CHW
      DO II=1,4
        DO III=1,4
          BP0C0Z(II,III)=CONJG(N(III,3))*BP0P0Z(II,3)
     $+CONJG(N(III,4))*BP0P0Z(II,4)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          BP0PPH(II,III,1)=0.
          BP0PPH(II,III,2)=0.
        ENDDO
      ENDDO
      BP0PPH(1,2,2)=GGP/SR2
      BP0PPH(2,2,2)=GG/SR2
      BP0PPH(4,1,2)=GG
      DO II=1,4
        DO III=1,2
          BP0CPH(II,III,1)=COS(BE)*(VMAT(III,1)*BP0PPH(II,1,1)
     $+VMAT(III,2)*BP0PPH(II,2,1))+SIN(BE)*(VMAT(III,1)*BP0PPH(II,1,2)
     $+VMAT(III,2)*BP0PPH(II,2,2))
          BP0CPH(II,III,2)=-SIN(BE)*(VMAT(III,1)*BP0PPH(II,1,1)
     $+VMAT(III,2)*BP0PPH(II,2,1))+COS(BE)*(VMAT(III,1)*BP0PPH(II,1,2)
     $+VMAT(III,2)*BP0PPH(II,2,2))
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,4
          BP0P0H(II,III,1)=0.
          BP0P0H(II,III,2)=0.
          BP0P0H(II,III,3)=0.
          BP0P0H(II,III,4)=0.
        ENDDO
      ENDDO
      BP0P0H(1,3,1)=-GGP/2.
      BP0P0H(1,4,2)=GGP/2.
      BP0P0H(2,3,1)=GG/2.
      BP0P0H(2,4,2)=-GG/2.
      BP0P0H(1,3,3)=GGP/2.
      BP0P0H(1,4,4)=GGP/2.
      BP0P0H(2,3,3)=-GG/2.
      BP0P0H(2,4,4)=-GG/2.
      BP0P0H(3,1,1)=-GGP/2.
      BP0P0H(4,1,2)=GGP/2.
      BP0P0H(3,2,1)=GG/2.
      BP0P0H(4,2,2)=-GG/2.
      BP0P0H(3,1,3)=GGP/2.
      BP0P0H(4,1,4)=GGP/2.
      BP0P0H(3,2,3)=-GG/2.
      BP0P0H(4,2,4)=-GG/2.
      DO II=1,4
        DO III=1,4
          BP0C0H(II,III,1)=(N(III,1)*BP0P0H(II,1,1)
     $+N(III,2)*BP0P0H(II,2,1)+N(III,3)*BP0P0H(II,3,1)
     $+N(III,4)*BP0P0H(II,4,1))*COS(ALFAH)
     $-(N(III,1)*BP0P0H(II,1,2)+N(III,2)*BP0P0H(II,2,2)
     $+N(III,3)*BP0P0H(II,3,2)+N(III,2)
     $*BP0P0H(II,4,2))*SIN(ALFAH)
          BP0C0H(II,III,2)=(N(III,1)*BP0P0H(II,1,1)
     $+N(III,2)*BP0P0H(II,2,1)+N(III,3)*BP0P0H(II,3,1)
     $+N(III,4)*BP0P0H(II,4,1))*SIN(ALFAH)
     $+(N(III,1)*BP0P0H(II,1,2)+N(III,2)*BP0P0H(II,2,2)
     $+N(III,3)*BP0P0H(II,3,2)+N(III,2)
     $*BP0P0H(II,4,2))*COS(ALFAH)
          BP0C0H(II,III,3)=(N(III,1)*BP0P0H(II,1,3)
     $+N(III,2)*BP0P0H(II,2,3)+N(III,3)*BP0P0H(II,3,3)
     $+N(III,4)*BP0P0H(II,4,3))*COS(BE)
     $+(N(III,1)*BP0P0H(II,1,4)+N(III,2)*BP0P0H(II,2,4)
     $+N(III,3)*BP0P0H(II,3,4)+N(III,2)
     $*BP0P0H(II,4,4))*SIN(BE)
          BP0C0H(II,III,4)=-(N(III,1)*BP0P0H(II,1,3)
     $+N(III,2)*BP0P0H(II,2,3)+N(III,3)*BP0P0H(II,3,3)
     $+N(III,4)*BP0P0H(II,4,3))*SIN(BE)
     $+(N(III,1)*BP0P0H(II,1,4)+N(III,2)*BP0P0H(II,2,4)
     $+N(III,3)*BP0P0H(II,3,4)+N(III,2)
     $*BP0P0H(II,4,4))*COS(BE)
        ENDDO
      ENDDO
      TEMP=DBLE(3.*(BP0FF(I,1,1)*BP0FF(J,1,1)*SSB1(P2,AMUP,ABS(MSS(2)))
     $+BP0FF(I,1,2)*BP0FF(J,1,2)*SSB1(P2,AMUP,ABS(MSS(3)))
     $+BP0FF(I,2,1)*BP0FF(J,2,1)*SSB1(P2,AMST,ABS(MSS(6)))
     $+BP0FF(I,2,2)*BP0FF(J,2,2)*SSB1(P2,AMST,ABS(MSS(7)))
     $+BP0FF(I,3,1)*BP0FF(J,3,1)*SSB1(P2,AMTP,ABS(MSS(13)))
     $+BP0FF(I,3,2)*BP0FF(J,3,2)*SSB1(P2,AMTP,ABS(MSS(12)))
     $+BP0FF(I,4,1)*BP0FF(J,4,1)*SSB1(P2,AMDN,ABS(MSS(4)))
     $+BP0FF(I,4,2)*BP0FF(J,4,2)*SSB1(P2,AMDN,ABS(MSS(5)))
     $+BP0FF(I,5,1)*BP0FF(J,5,1)*SSB1(P2,AMCH,ABS(MSS(8)))
     $+BP0FF(I,5,2)*BP0FF(J,5,2)*SSB1(P2,AMCH,ABS(MSS(9)))
     $+BP0FF(I,6,1)*BP0FF(J,6,1)*SSB1(P2,AMBT,ABS(MSS(10)))
     $+BP0FF(I,6,2)*BP0FF(J,6,2)*SSB1(P2,AMBT,ABS(MSS(11))))
     $+BP0FF(I,7,1)*BP0FF(J,7,1)*SSB1(P2,AME,ABS(MSS(17)))
     $+BP0FF(I,7,2)*BP0FF(J,7,2)*SSB1(P2,AME,ABS(MSS(18)))
     $+BP0FF(I,8,1)*BP0FF(J,8,1)*SSB1(P2,AMMU,ABS(MSS(19)))
     $+BP0FF(I,8,2)*BP0FF(J,8,2)*SSB1(P2,AMMU,ABS(MSS(20)))
     $+BP0FF(I,9,1)*BP0FF(J,9,1)*SSB1(P2,AMTAU,ABS(MSS(21)))
     $+BP0FF(I,9,2)*BP0FF(J,9,2)*SSB1(P2,AMTAU,ABS(MSS(22)))
     $+BP0FF(I,10,1)*BP0FF(J,10,1)*SSB1(P2,0.,ABS(MSS(14)))
     $+BP0FF(I,11,1)*BP0FF(J,11,1)*SSB1(P2,0.,ABS(MSS(15)))
     $+BP0FF(I,12,1)*BP0FF(J,12,1)*SSB1(P2,0.,ABS(MSS(16)))
     $+2.*(BP0CPW(I,1)*BP0CPW(J,1)*SSB1(P2,ABS(MSS(27)),AMW)
     $+BP0CPW(I,2)*BP0CPW(J,2)*SSB1(P2,ABS(MSS(28)),AMW))
     $+CONJG(BP0C0Z(I,1))*BP0C0Z(J,1)*SSB1(P2,ABS(MSS(23)),AMZ)
     $+CONJG(BP0C0Z(I,2))*BP0C0Z(J,2)*SSB1(P2,ABS(MSS(24)),AMZ)
     $+CONJG(BP0C0Z(I,3))*BP0C0Z(J,3)*SSB1(P2,ABS(MSS(25)),AMZ)
     $+CONJG(BP0C0Z(I,4))*BP0C0Z(J,4)*SSB1(P2,ABS(MSS(26)),AMZ)
     $+BP0CPH(I,1,1)*BP0CPH(J,1,1)*SSB1(P2,ABS(MSS(27)),AMW)
     $+BP0CPH(I,1,2)*BP0CPH(J,1,2)*SSB1(P2,ABS(MSS(27)),ABS(MSS(32)))
     $+BP0CPH(I,2,1)*BP0CPH(J,2,1)*SSB1(P2,ABS(MSS(28)),AMW)
     $+BP0CPH(I,2,2)*BP0CPH(J,2,2)*SSB1(P2,ABS(MSS(28)),ABS(MSS(32)))
     $+(CONJG(BP0C0H(I,1,1))*BP0C0H(J,1,1)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,1,2))*BP0C0H(J,1,2)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,1,3))*BP0C0H(J,1,3)*SSB1(P2,ABS(MSS(23)),AMZ)
     $+CONJG(BP0C0H(I,1,4))*BP0C0H(J,1,4)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(31)))
     $+CONJG(BP0C0H(I,2,1))*BP0C0H(J,2,1)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,2,2))*BP0C0H(J,2,2)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,2,3))*BP0C0H(J,2,3)*SSB1(P2,ABS(MSS(24)),AMZ)
     $+CONJG(BP0C0H(I,2,4))*BP0C0H(J,2,4)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(31)))
     $+CONJG(BP0C0H(I,3,1))*BP0C0H(J,3,1)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,3,2))*BP0C0H(J,3,2)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,3,3))*BP0C0H(J,3,3)*SSB1(P2,ABS(MSS(25)),AMZ)
     $+CONJG(BP0C0H(I,3,4))*BP0C0H(J,3,4)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(31)))
     $+CONJG(BP0C0H(I,4,1))*BP0C0H(J,4,1)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,4,2))*BP0C0H(J,4,2)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,4,3))*BP0C0H(J,4,3)*SSB1(P2,ABS(MSS(26)),AMZ)
     $+CONJG(BP0C0H(I,4,4))*BP0C0H(J,4,4)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(31)))
     $)/2.)/16./PI**2
      SIG0R=TEMP
      RETURN
      END
+EOD
+DECK,SIG0S
        REAL FUNCTION SIG0S(P2,I,J,G1,G2,CHW)
C-----------------------------------------------------------------------
C          SIG0S: Neutralino mass matrix correction
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C     Programmed by Tadas Krupovnickas
C          P2 = 4-momentum squared
C          CHW = Cos(theta_W) in DR bar scheme
C     Ordering: u=1,s=2,t=3,d=4,c=5,b=6,e=7,mu=8,tau=9,nue=10,num=11,nut=12
C     I and J are indexes in Pierce's base. To convert to ISAJET's basis
C     make the transformation 1->4, 2->3, 3->2, 4->1 for both inexes
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,AP0C0Z(4,4),AP0C0H(4,4,4)
     $,BP0C0Z(4,4),BP0C0H(4,4,4)
      DOUBLE PRECISION TEMP,AP0FF(4,12,2),AP0CPW(4,2),AP0CPH(4,2,2)
     $,BP0FF(4,12,2),BP0CPW(4,2),BP0CPH(4,2,2)
      REAL AP0R(4,12),AP0L(4,12),AP0PPW(4,2),AP0P0Z(4,4),AP0P0H(4,4,4)
     $,BP0R(4,12),BP0L(4,12),BP0PPW(4,2),BP0P0Z(4,4),BP0P0H(4,4,4)
     $,AP0PPH(4,2,2),BP0PPH(4,2,2)
      REAL P2,G1,G2,CHW,COST,SINT,COSB,SINB,COSL,SINL,GG,GGP
      REAL YUR,YUL,YDR,YDL,YER,YEL,YNR,YNL,I3UL,I3DL,I3EL,I3NL
      REAL THX,THY,VMAT(2,2),UMAT(2,2),BE,FB,FT,FMIX(12,2,2)
      INTEGER THIW1,THIW2
      INTEGER I,J,II,III
      COMPLEX IMAG,N(4,4)
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FB=MBQ/VDQ
      FT=MTQ/VUQ
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          III=0
        ELSE
          III=1
        END IF
        N(II,1)=-IMAG**III*ZMIXSS(4,II)
        N(II,2)=-IMAG**III*ZMIXSS(3,II)
        N(II,3)=IMAG**III*ZMIXSS(2,II)
        N(II,4)=IMAG**III*ZMIXSS(1,II)
      ENDDO
      YUR=-4./3.
      YUL=1./3.
      YDR=2./3.
      YDL=1./3.
      YER=2.
      YEL=-1.
      YNR=0.
      YNL=-1.
      I3UL=1./2.
      I3DL=-1./2.
      I3EL=-1./2.
      I3NL=1./2.
      DO II=1,4
        DO III=1,12
          AP0R(II,III)=0.
          AP0L(II,III)=0.
          BP0R(II,III)=0.
          BP0L(II,III)=0.
        ENDDO
      ENDDO
      AP0R(1,1)=GGP/SR2*YUR
      AP0R(1,2)=GGP/SR2*YUR
      AP0R(1,3)=GGP/SR2*YUR
      AP0R(1,4)=GGP/SR2*YDR
      AP0R(1,5)=GGP/SR2*YDR
      AP0R(1,6)=GGP/SR2*YDR
      AP0R(1,7)=GGP/SR2*YER
      AP0R(1,8)=GGP/SR2*YER
      AP0R(1,9)=GGP/SR2*YER
      AP0R(1,10)=GGP/SR2*YNR
      AP0R(1,11)=GGP/SR2*YNR
      AP0R(1,12)=GGP/SR2*YNR
      BP0L(1,1)=GGP/SR2*YUL
      BP0L(1,2)=GGP/SR2*YUL
      BP0L(1,3)=GGP/SR2*YUL
      BP0L(1,4)=GGP/SR2*YDL
      BP0L(1,5)=GGP/SR2*YDL
      BP0L(1,6)=GGP/SR2*YDL
      BP0L(1,7)=GGP/SR2*YEL
      BP0L(1,8)=GGP/SR2*YEL
      BP0L(1,9)=GGP/SR2*YEL
      BP0L(1,10)=GGP/SR2*YNL
      BP0L(1,11)=GGP/SR2*YNL
      BP0L(1,12)=GGP/SR2*YNL
      BP0L(2,1)=SR2*GG*I3UL
      BP0L(2,2)=SR2*GG*I3UL
      BP0L(2,3)=SR2*GG*I3UL
      BP0L(2,4)=SR2*GG*I3DL
      BP0L(2,5)=SR2*GG*I3DL
      BP0L(2,6)=SR2*GG*I3DL
      BP0L(2,7)=SR2*GG*I3EL
      BP0L(2,8)=SR2*GG*I3EL
      BP0L(2,9)=SR2*GG*I3EL
      BP0L(2,10)=SR2*GG*I3NL
      BP0L(2,11)=SR2*GG*I3NL
      BP0L(2,12)=SR2*GG*I3NL
      AP0L(3,6)=FB
      BP0R(3,6)=FB
      AP0L(4,3)=FT
      BP0R(4,3)=FT
      DO II=1,12
        FMIX(II,1,1)=1.
        FMIX(II,1,2)=0.
        FMIX(II,2,1)=0.
        FMIX(II,2,2)=1.
      ENDDO
      FMIX(3,1,1)=COST
      FMIX(3,1,2)=-SINT
      FMIX(3,2,1)=SINT
      FMIX(3,2,2)=COST
      FMIX(6,1,1)=COSB
      FMIX(6,1,2)=-SINB
      FMIX(6,2,1)=SINB
      FMIX(6,2,2)=COSB
      FMIX(9,1,1)=COSL
      FMIX(9,1,2)=-SINL
      FMIX(9,2,1)=SINL
      FMIX(9,2,2)=COSL
      DO II=1,4
        DO III=1,12
          AP0FF(II,III,1)=FMIX(III,1,1)*AP0L(II,III)
     $+FMIX(III,1,2)*AP0R(II,III)
          AP0FF(II,III,2)=FMIX(III,2,1)*AP0L(II,III)
     $+FMIX(III,2,2)*AP0R(II,III)
          BP0FF(II,III,1)=FMIX(III,1,1)*BP0L(II,III)
     $+FMIX(III,1,2)*BP0R(II,III)
          BP0FF(II,III,2)=FMIX(III,2,1)*BP0L(II,III)
     $+FMIX(III,2,2)*BP0R(II,III)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPW(II,III)=0.
          BP0PPW(II,III)=0.
        ENDDO
      ENDDO
      AP0PPW(2,1)=-GG
      AP0PPW(4,2)=GG/SR2
      BP0PPW(2,1)=-GG
      BP0PPW(3,2)=-GG/SR2
      DO II=1,4
        DO III=1,2
          AP0CPW(II,III)=VMAT(III,1)*AP0PPW(II,1)
     $+VMAT(III,2)*AP0PPW(II,2)
          BP0CPW(II,III)=UMAT(III,1)*BP0PPW(II,1)
     $+UMAT(III,2)*BP0PPW(II,2)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,4
          AP0P0Z(II,III)=0.
          BP0P0Z(II,III)=0.
        ENDDO
      ENDDO
      AP0P0Z(3,3)=GG/2./CHW
      AP0P0Z(4,4)=-GG/2./CHW
      BP0P0Z(3,3)=-AP0P0Z(3,3)
      BP0P0Z(4,4)=-AP0P0Z(4,4)
      DO II=1,4
        DO III=1,4
          AP0C0Z(II,III)=N(III,3)*AP0P0Z(II,3)+N(III,4)*AP0P0Z(II,4)
          BP0C0Z(II,III)=CONJG(N(III,3))*BP0P0Z(II,3)
     $+CONJG(N(III,4))*BP0P0Z(II,4)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPH(II,III,1)=0.
          AP0PPH(II,III,2)=0.
          BP0PPH(II,III,1)=0.
          BP0PPH(II,III,2)=0.
        ENDDO
      ENDDO
      AP0PPH(1,2,1)=GGP/SR2
      AP0PPH(2,2,1)=GG/SR2
      AP0PPH(3,1,1)=-GG
      BP0PPH(1,2,2)=GGP/SR2
      BP0PPH(2,2,2)=GG/SR2
      BP0PPH(4,1,2)=GG
      DO II=1,4
        DO III=1,2
          AP0CPH(II,III,1)=COS(BE)*(UMAT(III,1)*AP0PPH(II,1,1)
     $+UMAT(III,2)*AP0PPH(II,2,1))+SIN(BE)*(UMAT(III,1)*AP0PPH(II,1,2)
     $+UMAT(III,2)*AP0PPH(II,2,2))
          AP0CPH(II,III,2)=-SIN(BE)*(UMAT(III,1)*AP0PPH(II,1,1)
     $+UMAT(III,2)*AP0PPH(II,2,1))+COS(BE)*(UMAT(III,1)*AP0PPH(II,1,2)
     $+UMAT(III,2)*AP0PPH(II,2,2))
          BP0CPH(II,III,1)=COS(BE)*(VMAT(III,1)*BP0PPH(II,1,1)
     $+VMAT(III,2)*BP0PPH(II,2,1))+SIN(BE)*(VMAT(III,1)*BP0PPH(II,1,2)
     $+VMAT(III,2)*BP0PPH(II,2,2))
          BP0CPH(II,III,2)=-SIN(BE)*(VMAT(III,1)*BP0PPH(II,1,1)
     $+VMAT(III,2)*BP0PPH(II,2,1))+COS(BE)*(VMAT(III,1)*BP0PPH(II,1,2)
     $+VMAT(III,2)*BP0PPH(II,2,2))
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,4
          AP0P0H(II,III,1)=0.
          AP0P0H(II,III,2)=0.
          AP0P0H(II,III,3)=0.
          AP0P0H(II,III,4)=0.
          BP0P0H(II,III,1)=0.
          BP0P0H(II,III,2)=0.
          BP0P0H(II,III,3)=0.
          BP0P0H(II,III,4)=0.
        ENDDO
      ENDDO
      AP0P0H(1,3,1)=-GGP/2.
      AP0P0H(1,4,2)=GGP/2.
      AP0P0H(2,3,1)=GG/2.
      AP0P0H(2,4,2)=-GG/2.
      AP0P0H(1,3,3)=-GGP/2.
      AP0P0H(1,4,4)=-GGP/2.
      AP0P0H(2,3,3)=GG/2.
      AP0P0H(2,4,4)=GG/2.
      AP0P0H(3,1,1)=-GGP/2.
      AP0P0H(4,1,2)=GGP/2.
      AP0P0H(3,2,1)=GG/2.
      AP0P0H(4,2,2)=-GG/2.
      AP0P0H(3,1,3)=-GGP/2.
      AP0P0H(4,1,4)=-GGP/2.
      AP0P0H(3,2,3)=GG/2.
      AP0P0H(4,2,4)=GG/2.
      BP0P0H(1,3,1)=-GGP/2.
      BP0P0H(1,4,2)=GGP/2.
      BP0P0H(2,3,1)=GG/2.
      BP0P0H(2,4,2)=-GG/2.
      BP0P0H(1,3,3)=GGP/2.
      BP0P0H(1,4,4)=GGP/2.
      BP0P0H(2,3,3)=-GG/2.
      BP0P0H(2,4,4)=-GG/2.
      BP0P0H(3,1,1)=-GGP/2.
      BP0P0H(4,1,2)=GGP/2.
      BP0P0H(3,2,1)=GG/2.
      BP0P0H(4,2,2)=-GG/2.
      BP0P0H(3,1,3)=GGP/2.
      BP0P0H(4,1,4)=GGP/2.
      BP0P0H(3,2,3)=-GG/2.
      BP0P0H(4,2,4)=-GG/2.
      DO II=1,4
        DO III=1,4
          AP0C0H(II,III,1)=(CONJG(N(III,1))*AP0P0H(II,1,1)
     $+CONJG(N(III,2))*AP0P0H(II,2,1)+CONJG(N(III,3))*AP0P0H(II,3,1)
     $+CONJG(N(III,4))*AP0P0H(II,4,1))*COS(ALFAH)
     $-(CONJG(N(III,1))*AP0P0H(II,1,2)+CONJG(N(III,2))*AP0P0H(II,2,2)
     $+CONJG(N(III,3))*AP0P0H(II,3,2)+CONJG(N(III,2))
     $*AP0P0H(II,4,2))*SIN(ALFAH)
          AP0C0H(II,III,2)=(CONJG(N(III,1))*AP0P0H(II,1,1)
     $+CONJG(N(III,2))*AP0P0H(II,2,1)+CONJG(N(III,3))*AP0P0H(II,3,1)
     $+CONJG(N(III,4))*AP0P0H(II,4,1))*SIN(ALFAH)
     $+(CONJG(N(III,1))*AP0P0H(II,1,2)+CONJG(N(III,2))*AP0P0H(II,2,2)
     $+CONJG(N(III,3))*AP0P0H(II,3,2)+CONJG(N(III,2))
     $*AP0P0H(II,4,2))*COS(ALFAH)
          AP0C0H(II,III,3)=(CONJG(N(III,1))*AP0P0H(II,1,3)
     $+CONJG(N(III,2))*AP0P0H(II,2,3)+CONJG(N(III,3))*AP0P0H(II,3,3)
     $+CONJG(N(III,4))*AP0P0H(II,4,3))*COS(BE)
     $+(CONJG(N(III,1))*AP0P0H(II,1,4)+CONJG(N(III,2))*AP0P0H(II,2,4)
     $+CONJG(N(III,3))*AP0P0H(II,3,4)+CONJG(N(III,2))
     $*AP0P0H(II,4,4))*SIN(BE)
          AP0C0H(II,III,4)=-(CONJG(N(III,1))*AP0P0H(II,1,3)
     $+CONJG(N(III,2))*AP0P0H(II,2,3)+CONJG(N(III,3))*AP0P0H(II,3,3)
     $+CONJG(N(III,4))*AP0P0H(II,4,3))*SIN(BE)
     $+(CONJG(N(III,1))*AP0P0H(II,1,4)+CONJG(N(III,2))*AP0P0H(II,2,4)
     $+CONJG(N(III,3))*AP0P0H(II,3,4)+CONJG(N(III,2))
     $*AP0P0H(II,4,4))*COS(BE)
          BP0C0H(II,III,1)=(N(III,1)*BP0P0H(II,1,1)
     $+N(III,2)*BP0P0H(II,2,1)+N(III,3)*BP0P0H(II,3,1)
     $+N(III,4)*BP0P0H(II,4,1))*COS(ALFAH)
     $-(N(III,1)*BP0P0H(II,1,2)+N(III,2)*BP0P0H(II,2,2)
     $+N(III,3)*BP0P0H(II,3,2)+N(III,2)
     $*BP0P0H(II,4,2))*SIN(ALFAH)
          BP0C0H(II,III,2)=(N(III,1)*BP0P0H(II,1,1)
     $+N(III,2)*BP0P0H(II,2,1)+N(III,3)*BP0P0H(II,3,1)
     $+N(III,4)*BP0P0H(II,4,1))*SIN(ALFAH)
     $+(N(III,1)*BP0P0H(II,1,2)+N(III,2)*BP0P0H(II,2,2)
     $+N(III,3)*BP0P0H(II,3,2)+N(III,2)
     $*BP0P0H(II,4,2))*COS(ALFAH)
          BP0C0H(II,III,3)=(N(III,1)*BP0P0H(II,1,3)
     $+N(III,2)*BP0P0H(II,2,3)+N(III,3)*BP0P0H(II,3,3)
     $+N(III,4)*BP0P0H(II,4,3))*COS(BE)
     $+(N(III,1)*BP0P0H(II,1,4)+N(III,2)*BP0P0H(II,2,4)
     $+N(III,3)*BP0P0H(II,3,4)+N(III,2)
     $*BP0P0H(II,4,4))*SIN(BE)
          BP0C0H(II,III,4)=-(N(III,1)*BP0P0H(II,1,3)
     $+N(III,2)*BP0P0H(II,2,3)+N(III,3)*BP0P0H(II,3,3)
     $+N(III,4)*BP0P0H(II,4,3))*SIN(BE)
     $+(N(III,1)*BP0P0H(II,1,4)+N(III,2)*BP0P0H(II,2,4)
     $+N(III,3)*BP0P0H(II,3,4)+N(III,2)
     $*BP0P0H(II,4,4))*COS(BE)
        ENDDO
      ENDDO
      TEMP=DBLE(2.*(3.*(
     $BP0FF(I,1,1)*AP0FF(J,1,1)*AMUP*SSB0(P2,AMUP,ABS(MSS(2)))
     $+BP0FF(I,1,2)*AP0FF(J,1,2)*AMUP*SSB0(P2,AMUP,ABS(MSS(3)))
     $+BP0FF(I,2,1)*AP0FF(J,2,1)*AMST*SSB0(P2,AMST,ABS(MSS(6)))
     $+BP0FF(I,2,2)*AP0FF(J,2,2)*AMST*SSB0(P2,AMST,ABS(MSS(7)))
     $+BP0FF(I,3,1)*AP0FF(J,3,1)*MTQ*SSB0(P2,AMTP,ABS(MSS(13)))
     $+BP0FF(I,3,2)*AP0FF(J,3,2)*MTQ*SSB0(P2,AMTP,ABS(MSS(12)))
     $+BP0FF(I,4,1)*AP0FF(J,4,1)*AMDN*SSB0(P2,AMDN,ABS(MSS(4)))
     $+BP0FF(I,4,2)*AP0FF(J,4,2)*AMDN*SSB0(P2,AMDN,ABS(MSS(5)))
     $+BP0FF(I,5,1)*AP0FF(J,5,1)*AMCH*SSB0(P2,AMCH,ABS(MSS(8)))
     $+BP0FF(I,5,2)*AP0FF(J,5,2)*AMCH*SSB0(P2,AMCH,ABS(MSS(9)))
     $+BP0FF(I,6,1)*AP0FF(J,6,1)*MBQ*SSB0(P2,AMBT,ABS(MSS(10)))
     $+BP0FF(I,6,2)*AP0FF(J,6,2)*MBQ*SSB0(P2,AMBT,ABS(MSS(11))))
     $+BP0FF(I,7,1)*AP0FF(J,7,1)*AME*SSB0(P2,AME,ABS(MSS(17)))
     $+BP0FF(I,7,2)*AP0FF(J,7,2)*AME*SSB0(P2,AME,ABS(MSS(18)))
     $+BP0FF(I,8,1)*AP0FF(J,8,1)*AMMU*SSB0(P2,AMMU,ABS(MSS(19)))
     $+BP0FF(I,8,2)*AP0FF(J,8,2)*AMMU*SSB0(P2,AMMU,ABS(MSS(20)))
     $+BP0FF(I,9,1)*AP0FF(J,9,1)*MLQ*SSB0(P2,AMTAU,ABS(MSS(21)))
     $+BP0FF(I,9,2)*AP0FF(J,9,2)*MLQ*SSB0(P2,AMTAU,ABS(MSS(22))))
     $-8.*(BP0CPW(I,1)*AP0CPW(J,1)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),AMW)
     $+BP0CPW(I,2)*AP0CPW(J,2)*ABS(MSS(28))*SSB0(P2,ABS(MSS(28)),AMW))
     $-4.*(CONJG(BP0C0Z(I,1))*AP0C0Z(J,1)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),AMZ)
     $+CONJG(BP0C0Z(I,2))*AP0C0Z(J,2)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),AMZ)
     $+CONJG(BP0C0Z(I,3))*AP0C0Z(J,3)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),AMZ)
     $+CONJG(BP0C0Z(I,4))*AP0C0Z(J,4)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),AMZ))
     $+2.*(BP0CPH(I,1,1)*AP0CPH(J,1,1)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),AMW)
     $+BP0CPH(I,1,2)*AP0CPH(J,1,2)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),ABS(MSS(32)))
     $+BP0CPH(I,2,1)*AP0CPH(J,2,1)*ABS(MSS(28))
     $*SSB0(P2,ABS(MSS(28)),AMW)
     $+BP0CPH(I,2,2)*AP0CPH(J,2,2)*ABS(MSS(28))
     $*SSB0(P2,ABS(MSS(28)),ABS(MSS(32))))
     $+CONJG(BP0C0H(I,1,1))*AP0C0H(J,1,1)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,1,2))*AP0C0H(J,1,2)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,1,3))*AP0C0H(J,1,3)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),AMZ)
     $+CONJG(BP0C0H(I,1,4))*AP0C0H(J,1,4)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),ABS(MSS(31)))
     $+CONJG(BP0C0H(I,2,1))*AP0C0H(J,2,1)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,2,2))*AP0C0H(J,2,2)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,2,3))*AP0C0H(J,2,3)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),AMZ)
     $+CONJG(BP0C0H(I,2,4))*AP0C0H(J,2,4)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),ABS(MSS(31)))
     $+CONJG(BP0C0H(I,3,1))*AP0C0H(J,3,1)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,3,2))*AP0C0H(J,3,2)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,3,3))*AP0C0H(J,3,3)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),AMZ)
     $+CONJG(BP0C0H(I,3,4))*AP0C0H(J,3,4)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),ABS(MSS(31)))
     $+CONJG(BP0C0H(I,4,1))*AP0C0H(J,4,1)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),ABS(MSS(30)))
     $+CONJG(BP0C0H(I,4,2))*AP0C0H(J,4,2)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),ABS(MSS(29)))
     $+CONJG(BP0C0H(I,4,3))*AP0C0H(J,4,3)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),AMZ)
     $+CONJG(BP0C0H(I,4,4))*AP0C0H(J,4,4)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),ABS(MSS(31)))
     $)/16./PI**2
      SIG0S=TEMP
      RETURN
      END
+EOD
+DECK,SIGPL
        REAL FUNCTION SIGPL(P2,I,J,G1,G2,CHW)
C-----------------------------------------------------------------------
C          SIGPL: Chargino mass matrix correction
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C     Programmed by Tadas Krupovnickas
C          P2 = 4-momentum squared
C          CHW = Cos(theta_W) in DR bar scheme
C     Ordering: u=1,s=2,t=3,d=4,c=5,b=6,e=7,mu=8,tau=9,nue=10,num=11,nut=12
C     I and J are indexes in Pierce's base. To convert to ISAJET's basis
C     transform the matrix elements in the following way:
C     11->11, 12->-21, 21->-12, 22->22
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB1,AC0PPW(4,2),AC0PPH(4,2,2)
      DOUBLE PRECISION TEMP,APPFF(2,12,2),APPCPZ(2,2)
      DOUBLE PRECISION APPCPG(2,2),APPCPH(2,2,4)
      REAL APPR(2,12),APPL(2,12),AP0PPW(4,2),APPPPZ(2,2)
     $,AP0PPH(4,2,2),APPPPH(2,2,4)
      REAL P2,G1,G2,CHW,COST,SINT,COSB,SINB,COSL,SINL,GG,GGP
      REAL THX,THY,VMAT(2,2),UMAT(2,2),BE,FB,FT,FMIX(12,2,2)
      INTEGER THIW1,THIW2
      INTEGER I,J,II,III
      COMPLEX IMAG,N(4,4)
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FB=MBQ/VDQ
      FT=MTQ/VUQ
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          III=0
        ELSE
          III=1
        END IF
        N(II,1)=-IMAG**III*ZMIXSS(4,II)
        N(II,2)=-IMAG**III*ZMIXSS(3,II)
        N(II,3)=IMAG**III*ZMIXSS(2,II)
        N(II,4)=IMAG**III*ZMIXSS(1,II)
      ENDDO
      DO II=1,2
        DO III=1,12
          APPR(II,III)=0.
          APPL(II,III)=0.
        ENDDO
      ENDDO
      APPL(1,4)=GG
      APPL(1,5)=GG
      APPL(1,6)=GG
      APPL(1,7)=GG
      APPL(1,8)=GG
      APPL(1,9)=GG
      APPL(2,3)=-FT
      APPR(2,6)=-FT
      DO II=1,12
        FMIX(II,1,1)=1.
        FMIX(II,1,2)=0.
        FMIX(II,2,1)=0.
        FMIX(II,2,2)=1.
      ENDDO
      FMIX(3,1,1)=COST
      FMIX(3,1,2)=-SINT
      FMIX(3,2,1)=SINT
      FMIX(3,2,2)=COST
      FMIX(6,1,1)=COSB
      FMIX(6,1,2)=-SINB
      FMIX(6,2,1)=SINB
      FMIX(6,2,2)=COSB
      FMIX(9,1,1)=COSL
      FMIX(9,1,2)=-SINL
      FMIX(9,2,1)=SINL
      FMIX(9,2,2)=COSL
      DO II=1,2
        DO III=1,12
          APPFF(II,III,1)=FMIX(III,1,1)*APPL(II,III)
     $+FMIX(III,1,2)*APPR(II,III)
          APPFF(II,III,2)=FMIX(III,2,1)*APPL(II,III)
     $+FMIX(III,2,2)*APPR(II,III)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPW(II,III)=0.
        ENDDO
      ENDDO
      AP0PPW(2,1)=-GG
      AP0PPW(4,2)=GG/SR2
      DO II=1,4
        DO III=1,2
          AC0PPW(II,III)=CONJG(N(II,1))*AP0PPW(1,III)
     $+CONJG(N(II,2))*AP0PPW(2,III)+CONJG(N(II,3))*AP0PPW(3,III)
     $+CONJG(N(II,4))*AP0PPW(4,III)
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          APPPPZ(II,III)=0.
        ENDDO
      ENDDO
      APPPPZ(1,1)=GG*CHW
      APPPPZ(2,2)=GG*(2.*CHW**2-1.)/2./CHW
      DO II=1,2
        DO III=1,2
          APPCPZ(II,III)=VMAT(II,1)*APPPPZ(1,III)
     $+VMAT(II,2)*APPPPZ(2,III)
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          APPCPG(II,III)=SQRT(4.*PI/137.036)*VMAT(III,II)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPH(II,III,1)=0.
          AP0PPH(II,III,2)=0.
        ENDDO
      ENDDO
      AP0PPH(1,2,1)=GGP/SR2
      AP0PPH(2,2,1)=GG/SR2
      AP0PPH(3,1,1)=-GG
      DO II=1,4
        DO III=1,2
          AC0PPH(II,III,1)=COS(BE)*(CONJG(N(II,1))*AP0PPH(1,III,1)
     $+CONJG(N(II,2))*AP0PPH(2,III,1)+CONJG(N(II,3))*AP0PPH(3,III,1)
     $+CONJG(N(II,4))*AP0PPH(4,III,1))+SIN(BE)
     $*(CONJG(N(II,1))*AP0PPH(1,III,2)
     $+CONJG(N(II,2))*AP0PPH(2,III,2)+CONJG(N(II,3))*AP0PPH(3,III,2)
     $+CONJG(N(II,4))*AP0PPH(4,III,2))
          AC0PPH(II,III,2)=-SIN(BE)*(CONJG(N(II,1))*AP0PPH(1,III,1)
     $+CONJG(N(II,2))*AP0PPH(2,III,1)+CONJG(N(II,3))*AP0PPH(3,III,1)
     $+CONJG(N(II,4))*AP0PPH(4,III,1))+COS(BE)
     $*(CONJG(N(II,1))*AP0PPH(1,III,2)
     $+CONJG(N(II,2))*AP0PPH(2,III,2)+CONJG(N(II,3))*AP0PPH(3,III,2)
     $+CONJG(N(II,4))*AP0PPH(4,III,2))
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          APPPPH(II,III,1)=0.
          APPPPH(II,III,2)=0.
          APPPPH(II,III,3)=0.
          APPPPH(II,III,4)=0.
        ENDDO
      ENDDO
      APPPPH(1,2,1)=GG/SR2
      APPPPH(2,1,2)=GG/SR2
      APPPPH(1,2,3)=GG/SR2
      APPPPH(2,1,4)=-GG/SR2
      DO II=1,2
        DO III=1,2
          APPCPH(II,III,1)=(UMAT(III,1)*APPPPH(II,1,1)
     $+UMAT(III,2)*APPPPH(II,2,1))*COS(ALFAH)
     $-(UMAT(III,1)*APPPPH(II,1,2)+UMAT(III,2)*APPPPH(II,2,2))
     $*SIN(ALFAH)
          APPCPH(II,III,2)=(UMAT(III,1)*APPPPH(II,1,1)
     $+UMAT(III,2)*APPPPH(II,2,1))*SIN(ALFAH)
     $+(UMAT(III,1)*APPPPH(II,1,2)+UMAT(III,2)*APPPPH(II,2,2))
     $*COS(ALFAH)
          APPCPH(II,III,3)=(UMAT(III,1)*APPPPH(II,1,3)
     $+UMAT(III,2)*APPPPH(II,2,3))*COS(BE)
     $+(UMAT(III,1)*APPPPH(II,1,4)+UMAT(III,2)*APPPPH(II,2,4))*SIN(BE)
          APPCPH(II,III,4)=-(UMAT(III,1)*APPPPH(II,1,3)
     $+UMAT(III,2)*APPPPH(II,2,3))*SIN(BE)
     $+(UMAT(III,1)*APPPPH(II,1,4)+UMAT(III,2)*APPPPH(II,2,4))*COS(BE)
        ENDDO
      ENDDO
      TEMP=DBLE((3.*(APPFF(I,1,1)*APPFF(J,1,1)
     $*SSB1(P2,AMUP,ABS(MSS(4)))
     $+APPFF(I,1,2)*APPFF(J,1,2)*SSB1(P2,AMUP,ABS(MSS(5)))
     $+APPFF(I,2,1)*APPFF(J,2,1)*SSB1(P2,AMST,ABS(MSS(8)))
     $+APPFF(I,2,2)*APPFF(J,2,2)*SSB1(P2,AMST,ABS(MSS(9)))
     $+APPFF(I,3,1)*APPFF(J,3,1)*SSB1(P2,AMTP,ABS(MSS(10)))
     $+APPFF(I,3,2)*APPFF(J,3,2)*SSB1(P2,AMTP,ABS(MSS(11)))
     $+APPFF(I,4,1)*APPFF(J,4,1)*SSB1(P2,AMDN,ABS(MSS(2)))
     $+APPFF(I,4,2)*APPFF(J,4,2)*SSB1(P2,AMDN,ABS(MSS(3)))
     $+APPFF(I,5,1)*APPFF(J,5,1)*SSB1(P2,AMCH,ABS(MSS(6)))
     $+APPFF(I,5,2)*APPFF(J,5,2)*SSB1(P2,AMCH,ABS(MSS(7)))
     $+APPFF(I,6,1)*APPFF(J,6,1)*SSB1(P2,AMBT,ABS(MSS(13)))
     $+APPFF(I,6,2)*APPFF(J,6,2)*SSB1(P2,AMBT,ABS(MSS(12))))
     $+APPFF(I,7,1)*APPFF(J,7,1)*SSB1(P2,AME,ABS(MSS(14)))
     $+APPFF(I,8,1)*APPFF(J,8,1)*SSB1(P2,AMMU,ABS(MSS(15)))
     $+APPFF(I,9,1)*APPFF(J,9,1)*SSB1(P2,AMTAU,ABS(MSS(16)))
     $+APPFF(I,10,1)*APPFF(J,10,1)*SSB1(P2,0.,ABS(MSS(17)))
     $+APPFF(I,10,2)*APPFF(J,10,2)*SSB1(P2,0.,ABS(MSS(18)))
     $+APPFF(I,11,1)*APPFF(J,11,1)*SSB1(P2,0.,ABS(MSS(19)))
     $+APPFF(I,11,2)*APPFF(J,11,2)*SSB1(P2,0.,ABS(MSS(20)))
     $+APPFF(I,12,1)*APPFF(J,12,1)*SSB1(P2,0.,ABS(MSS(21)))
     $+APPFF(I,12,2)*APPFF(J,12,2)*SSB1(P2,0.,ABS(MSS(22))))/2.
     $+CONJG(AC0PPW(1,I))*AC0PPW(1,J)*SSB1(P2,ABS(MSS(23)),AMW)
     $+CONJG(AC0PPW(2,I))*AC0PPW(2,J)*SSB1(P2,ABS(MSS(24)),AMW)
     $+CONJG(AC0PPW(3,I))*AC0PPW(3,J)*SSB1(P2,ABS(MSS(25)),AMW)
     $+CONJG(AC0PPW(4,I))*AC0PPW(4,J)*SSB1(P2,ABS(MSS(26)),AMW)
     $+APPCPZ(I,1)*APPCPZ(J,1)*SSB1(P2,ABS(MSS(27)),AMZ)
     $+APPCPZ(I,2)*APPCPZ(J,2)*SSB1(P2,ABS(MSS(28)),AMZ)
     $+APPCPG(I,1)*APPCPG(J,1)*SSB1(P2,ABS(MSS(27)),0.)
     $+APPCPG(I,2)*APPCPG(J,2)*SSB1(P2,ABS(MSS(28)),0.)
     $+(CONJG(AC0PPH(1,I,1))*AC0PPH(1,J,1)
     $*SSB1(P2,ABS(MSS(23)),AMW)
     $+CONJG(AC0PPH(1,I,2))*AC0PPH(1,J,2)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(32)))
     $+CONJG(AC0PPH(2,I,1))*AC0PPH(2,J,1)*SSB1(P2,ABS(MSS(24)),AMW)
     $+CONJG(AC0PPH(2,I,2))*AC0PPH(2,J,2)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(32)))
     $+CONJG(AC0PPH(3,I,1))*AC0PPH(3,J,1)*SSB1(P2,ABS(MSS(25)),AMW)
     $+CONJG(AC0PPH(3,I,2))*AC0PPH(3,J,2)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(32)))
     $+CONJG(AC0PPH(4,I,1))*AC0PPH(4,J,1)*SSB1(P2,ABS(MSS(26)),AMW)
     $+CONJG(AC0PPH(4,I,2))*AC0PPH(4,J,2)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(32))))/2.
     $+(APPCPH(I,1,1)*APPCPH(J,1,1)
     $*SSB1(P2,ABS(MSS(27)),ABS(MSS(30)))
     $+APPCPH(I,1,2)*APPCPH(J,1,2)
     $*SSB1(P2,ABS(MSS(27)),ABS(MSS(29)))
     $+APPCPH(I,1,3)*APPCPH(J,1,3)*SSB1(P2,ABS(MSS(27)),AMZ)
     $+APPCPH(I,1,4)*APPCPH(J,1,4)
     $*SSB1(P2,ABS(MSS(27)),ABS(MSS(31)))
     $+APPCPH(I,2,1)*APPCPH(J,2,1)
     $*SSB1(P2,ABS(MSS(28)),ABS(MSS(30)))
     $+APPCPH(I,2,2)*APPCPH(J,2,2)
     $*SSB1(P2,ABS(MSS(28)),ABS(MSS(29)))
     $+APPCPH(I,2,3)*APPCPH(J,2,3)*SSB1(P2,ABS(MSS(28)),AMZ)
     $+APPCPH(I,2,4)*APPCPH(J,2,4)
     $*SSB1(P2,ABS(MSS(28)),ABS(MSS(31))))/2.
     $)/16./PI**2
      SIGPL=TEMP
      RETURN
      END
+EOD
+DECK,SIGPR
        REAL FUNCTION SIGPR(P2,I,J,G1,G2,CHW)
C-----------------------------------------------------------------------
C          SIGPR: Chargino mass matrix correction
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C     Programmed by Tadas Krupovnickas
C          P2 = 4-momentum squared
C          CHW = Cos(theta_W) in DR bar scheme
C     Ordering: u=1,s=2,t=3,d=4,c=5,b=6,e=7,mu=8,tau=9,nue=10,num=11,nut=12
C     I and J are indexes in Pierce's base. To convert to ISAJET's basis
C     transform the matrix elements in the following way:
C     11->11, 12->-21, 21->-12, 22->22
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB1,BC0PPW(4,2),BC0PPH(4,2,2)
      DOUBLE PRECISION TEMP,BPPFF(2,12,2),BPPCPZ(2,2)
      DOUBLE PRECISION BPPCPG(2,2),BPPCPH(2,2,4)
      REAL BPPR(2,12),BPPL(2,12),BP0PPW(4,2),BPPPPZ(2,2)
     $,BP0PPH(4,2,2),BPPPPH(2,2,4)
      REAL P2,G1,G2,CHW,COST,SINT,COSB,SINB,COSL,SINL,GG,GGP
      REAL THX,THY,VMAT(2,2),UMAT(2,2),BE,FB,FT,FMIX(12,2,2)
      INTEGER THIW1,THIW2
      INTEGER I,J,II,III
      COMPLEX IMAG,N(4,4)
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FB=MBQ/VDQ
      FT=MTQ/VUQ
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          III=0
        ELSE
          III=1
        END IF
        N(II,1)=-IMAG**III*ZMIXSS(4,II)
        N(II,2)=-IMAG**III*ZMIXSS(3,II)
        N(II,3)=IMAG**III*ZMIXSS(2,II)
        N(II,4)=IMAG**III*ZMIXSS(1,II)
      ENDDO
      DO II=1,2
        DO III=1,12
          BPPR(II,III)=0.
          BPPL(II,III)=0.
        ENDDO
      ENDDO
      BPPL(1,1)=GG
      BPPL(1,2)=GG
      BPPL(1,3)=GG
      BPPL(1,10)=GG
      BPPL(1,11)=GG
      BPPL(1,12)=GG
      BPPL(2,6)=-FB
      BPPR(2,3)=-FB
      DO II=1,12
        FMIX(II,1,1)=1.
        FMIX(II,1,2)=0.
        FMIX(II,2,1)=0.
        FMIX(II,2,2)=1.
      ENDDO
      FMIX(3,1,1)=COST
      FMIX(3,1,2)=-SINT
      FMIX(3,2,1)=SINT
      FMIX(3,2,2)=COST
      FMIX(6,1,1)=COSB
      FMIX(6,1,2)=-SINB
      FMIX(6,2,1)=SINB
      FMIX(6,2,2)=COSB
      FMIX(9,1,1)=COSL
      FMIX(9,1,2)=-SINL
      FMIX(9,2,1)=SINL
      FMIX(9,2,2)=COSL
      DO II=1,2
        DO III=1,12
          BPPFF(II,III,1)=FMIX(III,1,1)*BPPL(II,III)
     $+FMIX(III,1,2)*BPPR(II,III)
          BPPFF(II,III,2)=FMIX(III,2,1)*BPPL(II,III)
     $+FMIX(III,2,2)*BPPR(II,III)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          BP0PPW(II,III)=0.
        ENDDO
      ENDDO
      BP0PPW(2,1)=-GG
      BP0PPW(3,2)=-GG/SR2
      DO II=1,4
        DO III=1,2
          BC0PPW(II,III)=N(II,1)*BP0PPW(1,III)
     $+N(II,2)*BP0PPW(2,III)+N(II,3)*BP0PPW(3,III)
     $+N(II,4)*BP0PPW(4,III)
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          BPPPPZ(II,III)=0.
        ENDDO
      ENDDO
      BPPPPZ(1,1)=GG*CHW
      BPPPPZ(2,2)=GG*(2.*CHW**2-1.)/2./CHW
      DO II=1,2
        DO III=1,2
          BPPCPZ(II,III)=UMAT(II,1)*BPPPPZ(1,III)
     $+UMAT(II,2)*BPPPPZ(2,III)
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          BPPCPG(II,III)=SQRT(4.*PI/137.036)*UMAT(III,II)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          BP0PPH(II,III,1)=0.
          BP0PPH(II,III,2)=0.
        ENDDO
      ENDDO
      BP0PPH(1,2,2)=GGP/SR2
      BP0PPH(2,2,2)=GG/SR2
      BP0PPH(4,1,2)=GG
      DO II=1,4
        DO III=1,2
          BC0PPH(II,III,1)=COS(BE)*(N(II,1)*BP0PPH(1,III,1)
     $+N(II,2)*BP0PPH(2,III,1)+N(II,3)*BP0PPH(3,III,1)
     $+N(II,4)*BP0PPH(4,III,1))+SIN(BE)*(N(II,1)*BP0PPH(1,III,2)
     $+N(II,2)*BP0PPH(2,III,2)+N(II,3)*BP0PPH(3,III,2)
     $+N(II,4)*BP0PPH(4,III,2))
          BC0PPH(II,III,2)=-SIN(BE)*(N(II,1)*BP0PPH(1,III,1)
     $+N(II,2)*BP0PPH(2,III,1)+N(II,3)*BP0PPH(3,III,1)
     $+N(II,4)*BP0PPH(4,III,1))+COS(BE)*(N(II,1)*BP0PPH(1,III,2)
     $+N(II,2)*BP0PPH(2,III,2)+N(II,3)*BP0PPH(3,III,2)
     $+N(II,4)*BP0PPH(4,III,2))
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          BPPPPH(II,III,1)=0.
          BPPPPH(II,III,2)=0.
          BPPPPH(II,III,3)=0.
          BPPPPH(II,III,4)=0.
        ENDDO
      ENDDO
      BPPPPH(2,1,1)=GG/SR2
      BPPPPH(1,2,2)=GG/SR2
      BPPPPH(2,1,3)=-GG/SR2
      BPPPPH(1,2,4)=GG/SR2
      DO II=1,2
        DO III=1,2
          BPPCPH(II,III,1)=(VMAT(III,1)*BPPPPH(II,1,1)
     $+VMAT(III,2)*BPPPPH(II,2,1))*COS(ALFAH)
     $-(VMAT(III,1)*BPPPPH(II,1,2)+VMAT(III,2)*BPPPPH(II,2,2)
     $)*SIN(ALFAH)
          BPPCPH(II,III,2)=(VMAT(III,1)*BPPPPH(II,1,1)
     $+VMAT(III,2)*BPPPPH(II,2,1))*SIN(ALFAH)
     $+(VMAT(III,1)*BPPPPH(II,1,2)+VMAT(III,2)*BPPPPH(II,2,2))
     $*COS(ALFAH)
          BPPCPH(II,III,3)=(VMAT(III,1)*BPPPPH(II,1,3)
     $+VMAT(III,2)*BPPPPH(II,2,3))*COS(BE)
     $+(VMAT(III,1)*BPPPPH(II,1,4)+VMAT(III,2)*BPPPPH(II,2,4))*SIN(BE)
          BPPCPH(II,III,4)=-(VMAT(III,1)*BPPPPH(II,1,3)
     $+VMAT(III,2)*BPPPPH(II,2,3))*SIN(BE)
     $+(VMAT(III,1)*BPPPPH(II,1,4)+VMAT(III,2)*BPPPPH(II,2,4))*COS(BE)
        ENDDO
      ENDDO
      TEMP=DBLE((3.*(BPPFF(I,1,1)*BPPFF(J,1,1)
     $*SSB1(P2,AMUP,ABS(MSS(4)))
     $+BPPFF(I,1,2)*BPPFF(J,1,2)*SSB1(P2,AMUP,ABS(MSS(5)))
     $+BPPFF(I,2,1)*BPPFF(J,2,1)*SSB1(P2,AMST,ABS(MSS(8)))
     $+BPPFF(I,2,2)*BPPFF(J,2,2)*SSB1(P2,AMST,ABS(MSS(9)))
     $+BPPFF(I,3,1)*BPPFF(J,3,1)*SSB1(P2,AMTP,ABS(MSS(10)))
     $+BPPFF(I,3,2)*BPPFF(J,3,2)*SSB1(P2,AMTP,ABS(MSS(11)))
     $+BPPFF(I,4,1)*BPPFF(J,4,1)*SSB1(P2,AMDN,ABS(MSS(2)))
     $+BPPFF(I,4,2)*BPPFF(J,4,2)*SSB1(P2,AMDN,ABS(MSS(3)))
     $+BPPFF(I,5,1)*BPPFF(J,5,1)*SSB1(P2,AMCH,ABS(MSS(6)))
     $+BPPFF(I,5,2)*BPPFF(J,5,2)*SSB1(P2,AMCH,ABS(MSS(7)))
     $+BPPFF(I,6,1)*BPPFF(J,6,1)*SSB1(P2,AMBT,ABS(MSS(13)))
     $+BPPFF(I,6,2)*BPPFF(J,6,2)*SSB1(P2,AMBT,ABS(MSS(12))))
     $+BPPFF(I,7,1)*BPPFF(J,7,1)*SSB1(P2,AME,ABS(MSS(14)))
     $+BPPFF(I,8,1)*BPPFF(J,8,1)*SSB1(P2,AMMU,ABS(MSS(15)))
     $+BPPFF(I,9,1)*BPPFF(J,9,1)*SSB1(P2,AMTAU,ABS(MSS(16)))
     $+BPPFF(I,10,1)*BPPFF(J,10,1)*SSB1(P2,0.,ABS(MSS(17)))
     $+BPPFF(I,10,2)*BPPFF(J,10,2)*SSB1(P2,0.,ABS(MSS(18)))
     $+BPPFF(I,11,1)*BPPFF(J,11,1)*SSB1(P2,0.,ABS(MSS(19)))
     $+BPPFF(I,11,2)*BPPFF(J,11,2)*SSB1(P2,0.,ABS(MSS(20)))
     $+BPPFF(I,12,1)*BPPFF(J,12,1)*SSB1(P2,0.,ABS(MSS(21)))
     $+BPPFF(I,12,2)*BPPFF(J,12,2)*SSB1(P2,0.,ABS(MSS(22))))/2.
     $+CONJG(BC0PPW(1,I))*BC0PPW(1,J)*SSB1(P2,ABS(MSS(23)),AMW)
     $+CONJG(BC0PPW(2,I))*BC0PPW(2,J)*SSB1(P2,ABS(MSS(24)),AMW)
     $+CONJG(BC0PPW(3,I))*BC0PPW(3,J)*SSB1(P2,ABS(MSS(25)),AMW)
     $+CONJG(BC0PPW(4,I))*BC0PPW(4,J)*SSB1(P2,ABS(MSS(26)),AMW)
     $+BPPCPZ(I,1)*BPPCPZ(J,1)*SSB1(P2,ABS(MSS(27)),AMZ)
     $+BPPCPZ(I,2)*BPPCPZ(J,2)*SSB1(P2,ABS(MSS(28)),AMZ)
     $+BPPCPG(I,1)*BPPCPG(J,1)*SSB1(P2,ABS(MSS(27)),0.)
     $+BPPCPG(I,2)*BPPCPG(J,2)*SSB1(P2,ABS(MSS(28)),0.)
     $+(CONJG(BC0PPH(1,I,1))*BC0PPH(1,J,1)*SSB1(P2,ABS(MSS(23)),AMW)
     $+CONJG(BC0PPH(1,I,2))*BC0PPH(1,J,2)
     $*SSB1(P2,ABS(MSS(23)),ABS(MSS(32)))
     $+CONJG(BC0PPH(2,I,1))*BC0PPH(2,J,1)*SSB1(P2,ABS(MSS(24)),AMW)
     $+CONJG(BC0PPH(2,I,2))*BC0PPH(2,J,2)
     $*SSB1(P2,ABS(MSS(24)),ABS(MSS(32)))
     $+CONJG(BC0PPH(3,I,1))*BC0PPH(3,J,1)*SSB1(P2,ABS(MSS(25)),AMW)
     $+CONJG(BC0PPH(3,I,2))*BC0PPH(3,J,2)
     $*SSB1(P2,ABS(MSS(25)),ABS(MSS(32)))
     $+CONJG(BC0PPH(4,I,1))*BC0PPH(4,J,1)*SSB1(P2,ABS(MSS(26)),AMW)
     $+CONJG(BC0PPH(4,I,2))*BC0PPH(4,J,2)
     $*SSB1(P2,ABS(MSS(26)),ABS(MSS(32))))/2.
     $+(BPPCPH(I,1,1)*BPPCPH(J,1,1)*SSB1(P2,ABS(MSS(27)),ABS(MSS(30)))
     $+BPPCPH(I,1,2)*BPPCPH(J,1,2)*SSB1(P2,ABS(MSS(27)),ABS(MSS(29)))
     $+BPPCPH(I,1,3)*BPPCPH(J,1,3)*SSB1(P2,ABS(MSS(27)),AMZ)
     $+BPPCPH(I,1,4)*BPPCPH(J,1,4)*SSB1(P2,ABS(MSS(27)),ABS(MSS(31)))
     $+BPPCPH(I,2,1)*BPPCPH(J,2,1)*SSB1(P2,ABS(MSS(28)),ABS(MSS(30)))
     $+BPPCPH(I,2,2)*BPPCPH(J,2,2)*SSB1(P2,ABS(MSS(28)),ABS(MSS(29)))
     $+BPPCPH(I,2,3)*BPPCPH(J,2,3)*SSB1(P2,ABS(MSS(28)),AMZ)
     $+BPPCPH(I,2,4)*BPPCPH(J,2,4)
     $*SSB1(P2,ABS(MSS(28)),ABS(MSS(31))))/2.
     $)/16./PI**2
      SIGPR=TEMP
      RETURN
      END
+EOD
+DECK,SIGPS
        REAL FUNCTION SIGPS(P2,I,J,G1,G2,CHW)
C-----------------------------------------------------------------------
C          SIGPS: Chargino mass matrix correction
C     Taken from Damien M. Pierce, Jonathan A. Bagger, Konstantin T. Matchev,
C     Ren-jie Zhang, Nucl.Phys.B491:3-67,1997, hep-ph/9606211
C     Programmed by Tadas Krupovnickas
C          P2 = 4-momentum squared
C          CHW = Cos(theta_W) in DR bar scheme
C     Ordering: u=1,s=2,t=3,d=4,c=5,b=6,e=7,mu=8,tau=9,nue=10,num=11,nut=12
C     I and J are indexes in Pierce's base. To convert to ISAJET's basis
C     transform the matrix elements in the following way:
C     11->11, 12->-21, 21->-12, 22->22
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
      COMPLEX*16 SSB0,AC0PPW(4,2),BC0PPW(4,2),AC0PPH(4,2,2)
     $,BC0PPH(4,2,2)
      DOUBLE PRECISION TEMP,BPPFF(2,12,2),BPPCPZ(2,2)
     $,APPFF(2,12,2),APPCPZ(2,2)
      DOUBLE PRECISION BPPCPG(2,2),BPPCPH(2,2,4)
     $,APPCPG(2,2),APPCPH(2,2,4)
      REAL APPR(2,12),APPL(2,12),AP0PPW(4,2),APPPPZ(2,2),APPPPH(2,2,4)
     $,BPPR(2,12),BPPL(2,12),BP0PPW(4,2),BPPPPZ(2,2),BPPPPH(2,2,4)
     $,AP0PPH(4,2,2),BP0PPH(4,2,2)
      REAL P2,G1,G2,CHW,COST,SINT,COSB,SINB,COSL,SINL,GG,GGP
      REAL THX,THY,VMAT(2,2),UMAT(2,2),BE,FB,FT,FMIX(12,2,2)
      INTEGER THIW1,THIW2
      INTEGER I,J,II,III
      COMPLEX IMAG,N(4,4)
      PARAMETER (IMAG=(0.,1.))
      REAL PI,SR2
      PI=4*ATAN(1.)
      SR2=SQRT(2.)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      GG=G2
      GGP=SQRT(3./5.)*G1
      BE=ATAN(VUQ/VDQ)
      FB=MBQ/VDQ
      FT=MTQ/VUQ
      THX=SIGN(1.,TAN(GAMMAL))
      THY=SIGN(1.,TAN(GAMMAR))
      IF (SIGN(1.,AMW1SS).EQ.1.) THEN
         THIW1=0
      ELSE
         THIW1=1
      END IF
      IF (SIGN(1.,AMW2SS).EQ.1.) THEN
         THIW2=0
      ELSE
         THIW2=1
      END IF
      UMAT(1,1)=-(-1)**THIW1*SIN(GAMMAR)
      UMAT(1,2)=(-1)**THIW1*COS(GAMMAR)
      UMAT(2,1)=-(-1)**THIW2*THY*COS(GAMMAR)
      UMAT(2,2)=-(-1)**THIW2*THY*SIN(GAMMAR)
      VMAT(1,1)=-SIN(GAMMAL)
      VMAT(1,2)=COS(GAMMAL)
      VMAT(2,1)=-THX*COS(GAMMAL)
      VMAT(2,2)=-THX*SIN(GAMMAL)
      DO II=1,4
        IF (SIGN(1.,AMZISS(II)).EQ.1.) THEN
          III=0
        ELSE
          III=1
        END IF
        N(II,1)=-IMAG**III*ZMIXSS(4,II)
        N(II,2)=-IMAG**III*ZMIXSS(3,II)
        N(II,3)=IMAG**III*ZMIXSS(2,II)
        N(II,4)=IMAG**III*ZMIXSS(1,II)
      ENDDO
      DO II=1,2
        DO III=1,12
          APPR(II,III)=0.
          APPL(II,III)=0.
          BPPR(II,III)=0.
          BPPL(II,III)=0.
        ENDDO
      ENDDO
      APPL(1,4)=GG
      APPL(1,5)=GG
      APPL(1,6)=GG
      APPL(1,7)=GG
      APPL(1,8)=GG
      APPL(1,9)=GG
      BPPL(1,1)=GG
      BPPL(1,2)=GG
      BPPL(1,3)=GG
      BPPL(1,10)=GG
      BPPL(1,11)=GG
      BPPL(1,12)=GG
      BPPL(2,6)=-FB
      BPPR(2,3)=-FB
      APPL(2,3)=-FT
      APPR(2,6)=-FT
      DO II=1,12
        FMIX(II,1,1)=1.
        FMIX(II,1,2)=0.
        FMIX(II,2,1)=0.
        FMIX(II,2,2)=1.
      ENDDO
      FMIX(3,1,1)=COST
      FMIX(3,1,2)=-SINT
      FMIX(3,2,1)=SINT
      FMIX(3,2,2)=COST
      FMIX(6,1,1)=COSB
      FMIX(6,1,2)=-SINB
      FMIX(6,2,1)=SINB
      FMIX(6,2,2)=COSB
      FMIX(9,1,1)=COSL
      FMIX(9,1,2)=-SINL
      FMIX(9,2,1)=SINL
      FMIX(9,2,2)=COSL
      DO II=1,2
        DO III=1,12
          APPFF(II,III,1)=FMIX(III,1,1)*APPL(II,III)
     $+FMIX(III,1,2)*APPR(II,III)
          APPFF(II,III,2)=FMIX(III,2,1)*APPL(II,III)
     $+FMIX(III,2,2)*APPR(II,III)
          BPPFF(II,III,1)=FMIX(III,1,1)*BPPL(II,III)
     $+FMIX(III,1,2)*BPPR(II,III)
          BPPFF(II,III,2)=FMIX(III,2,1)*BPPL(II,III)
     $+FMIX(III,2,2)*BPPR(II,III)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPW(II,III)=0.
          BP0PPW(II,III)=0.
        ENDDO
      ENDDO
      AP0PPW(2,1)=-GG
      AP0PPW(4,2)=GG/SR2
      BP0PPW(2,1)=-GG
      BP0PPW(3,2)=-GG/SR2
      DO II=1,4
        DO III=1,2
          AC0PPW(II,III)=CONJG(N(II,1))*AP0PPW(1,III)
     $+CONJG(N(II,2))*AP0PPW(2,III)+CONJG(N(II,3))*AP0PPW(3,III)
     $+CONJG(N(II,4))*AP0PPW(4,III)
          BC0PPW(II,III)=N(II,1)*BP0PPW(1,III)
     $+N(II,2)*BP0PPW(2,III)+N(II,3)*BP0PPW(3,III)
     $+N(II,4)*BP0PPW(4,III)
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          APPPPZ(II,III)=0.
          BPPPPZ(II,III)=0.
        ENDDO
      ENDDO
      APPPPZ(1,1)=GG*CHW
      APPPPZ(2,2)=GG*(2.*CHW**2-1.)/2./CHW
      BPPPPZ(1,1)=GG*CHW
      BPPPPZ(2,2)=GG*(2.*CHW**2-1.)/2./CHW
      DO II=1,2
        DO III=1,2
          APPCPZ(II,III)=VMAT(II,1)*APPPPZ(1,III)
     $+VMAT(II,2)*APPPPZ(2,III)
          BPPCPZ(II,III)=UMAT(II,1)*BPPPPZ(1,III)
     $+UMAT(II,2)*BPPPPZ(2,III)
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          APPCPG(II,III)=SQRT(4.*PI/137.036)*VMAT(III,II)
          BPPCPG(II,III)=SQRT(4.*PI/137.036)*UMAT(III,II)
        ENDDO
      ENDDO
      DO II=1,4
        DO III=1,2
          AP0PPH(II,III,1)=0.
          AP0PPH(II,III,2)=0.
          BP0PPH(II,III,1)=0.
          BP0PPH(II,III,2)=0.
        ENDDO
      ENDDO
      AP0PPH(1,2,1)=GGP/SR2
      AP0PPH(2,2,1)=GG/SR2
      AP0PPH(3,1,1)=-GG
      BP0PPH(1,2,2)=GGP/SR2
      BP0PPH(2,2,2)=GG/SR2
      BP0PPH(4,1,2)=GG
      DO II=1,4
        DO III=1,2
          AC0PPH(II,III,1)=COS(BE)*(CONJG(N(II,1))*AP0PPH(1,III,1)
     $+CONJG(N(II,2))*AP0PPH(2,III,1)+CONJG(N(II,3))*AP0PPH(3,III,1)
     $+CONJG(N(II,4))*AP0PPH(4,III,1))+SIN(BE)
     $*(CONJG(N(II,1))*AP0PPH(1,III,2)
     $+CONJG(N(II,2))*AP0PPH(2,III,2)+CONJG(N(II,3))*AP0PPH(3,III,2)
     $+CONJG(N(II,4))*AP0PPH(4,III,2))
          AC0PPH(II,III,2)=-SIN(BE)*(CONJG(N(II,1))*AP0PPH(1,III,1)
     $+CONJG(N(II,2))*AP0PPH(2,III,1)+CONJG(N(II,3))*AP0PPH(3,III,1)
     $+CONJG(N(II,4))*AP0PPH(4,III,1))+COS(BE)
     $*(CONJG(N(II,1))*AP0PPH(1,III,2)
     $+CONJG(N(II,2))*AP0PPH(2,III,2)+CONJG(N(II,3))*AP0PPH(3,III,2)
     $+CONJG(N(II,4))*AP0PPH(4,III,2))
          BC0PPH(II,III,1)=COS(BE)*(N(II,1)*BP0PPH(1,III,1)
     $+N(II,2)*BP0PPH(2,III,1)+N(II,3)*BP0PPH(3,III,1)
     $+N(II,4)*BP0PPH(4,III,1))+SIN(BE)*(N(II,1)*BP0PPH(1,III,2)
     $+N(II,2)*BP0PPH(2,III,2)+N(II,3)*BP0PPH(3,III,2)
     $+N(II,4)*BP0PPH(4,III,2))
          BC0PPH(II,III,2)=-SIN(BE)*(N(II,1)*BP0PPH(1,III,1)
     $+N(II,2)*BP0PPH(2,III,1)+N(II,3)*BP0PPH(3,III,1)
     $+N(II,4)*BP0PPH(4,III,1))+COS(BE)*(N(II,1)*BP0PPH(1,III,2)
     $+N(II,2)*BP0PPH(2,III,2)+N(II,3)*BP0PPH(3,III,2)
     $+N(II,4)*BP0PPH(4,III,2))
        ENDDO
      ENDDO
      DO II=1,2
        DO III=1,2
          APPPPH(II,III,1)=0.
          APPPPH(II,III,2)=0.
          APPPPH(II,III,3)=0.
          APPPPH(II,III,4)=0.
          BPPPPH(II,III,1)=0.
          BPPPPH(II,III,2)=0.
          BPPPPH(II,III,3)=0.
          BPPPPH(II,III,4)=0.
        ENDDO
      ENDDO
      APPPPH(1,2,1)=GG/SR2
      APPPPH(2,1,2)=GG/SR2
      APPPPH(1,2,3)=GG/SR2
      APPPPH(2,1,4)=-GG/SR2
      BPPPPH(2,1,1)=GG/SR2
      BPPPPH(1,2,2)=GG/SR2
      BPPPPH(2,1,3)=-GG/SR2
      BPPPPH(1,2,4)=GG/SR2
      DO II=1,2
        DO III=1,2
          APPCPH(II,III,1)=(UMAT(III,1)*APPPPH(II,1,1)
     $+UMAT(III,2)*APPPPH(II,2,1))*COS(ALFAH)
     $-(UMAT(III,1)*APPPPH(II,1,2)+UMAT(III,2)*APPPPH(II,2,2))
     $*SIN(ALFAH)
          APPCPH(II,III,2)=(UMAT(III,1)*APPPPH(II,1,1)
     $+UMAT(III,2)*APPPPH(II,2,1))*SIN(ALFAH)
     $+(UMAT(III,1)*APPPPH(II,1,2)+UMAT(III,2)*APPPPH(II,2,2))
     $*COS(ALFAH)
          APPCPH(II,III,3)=(UMAT(III,1)*APPPPH(II,1,3)
     $+UMAT(III,2)*APPPPH(II,2,3))*COS(BE)
     $+(UMAT(III,1)*APPPPH(II,1,4)+UMAT(III,2)*APPPPH(II,2,4))*SIN(BE)
          APPCPH(II,III,4)=-(UMAT(III,1)*APPPPH(II,1,3)
     $+UMAT(III,2)*APPPPH(II,2,3))*SIN(BE)
     $+(UMAT(III,1)*APPPPH(II,1,4)+UMAT(III,2)*APPPPH(II,2,4))*COS(BE)
          BPPCPH(II,III,1)=(VMAT(III,1)*BPPPPH(II,1,1)
     $+VMAT(III,2)*BPPPPH(II,2,1))*COS(ALFAH)
     $-(VMAT(III,1)*BPPPPH(II,1,2)+VMAT(III,2)*BPPPPH(II,2,2))
     $*SIN(ALFAH)
          BPPCPH(II,III,2)=(VMAT(III,1)*BPPPPH(II,1,1)
     $+VMAT(III,2)*BPPPPH(II,2,1))*SIN(ALFAH)
     $+(VMAT(III,1)*BPPPPH(II,1,2)+VMAT(III,2)*BPPPPH(II,2,2))
     $*COS(ALFAH)
          BPPCPH(II,III,3)=(VMAT(III,1)*BPPPPH(II,1,3)
     $+VMAT(III,2)*BPPPPH(II,2,3))*COS(BE)
     $+(VMAT(III,1)*BPPPPH(II,1,4)+VMAT(III,2)*BPPPPH(II,2,4))*SIN(BE)
          BPPCPH(II,III,4)=-(VMAT(III,1)*BPPPPH(II,1,3)
     $+VMAT(III,2)*BPPPPH(II,2,3))*SIN(BE)
     $+(VMAT(III,1)*BPPPPH(II,1,4)+VMAT(III,2)*BPPPPH(II,2,4))*COS(BE)
        ENDDO
      ENDDO
      TEMP=DBLE(3.*(BPPFF(I,1,1)*APPFF(J,1,1)*AMUP
     $*SSB0(P2,AMUP,ABS(MSS(4)))
     $+BPPFF(I,1,2)*APPFF(J,1,2)*AMUP*SSB0(P2,AMUP,ABS(MSS(5)))
     $+BPPFF(I,2,1)*APPFF(J,2,1)*AMST*SSB0(P2,AMST,ABS(MSS(8)))
     $+BPPFF(I,2,2)*APPFF(J,2,2)*AMST*SSB0(P2,AMST,ABS(MSS(9)))
     $+BPPFF(I,3,1)*APPFF(J,3,1)*MTQ*SSB0(P2,AMTP,ABS(MSS(10)))
     $+BPPFF(I,3,2)*APPFF(J,3,2)*MTQ*SSB0(P2,AMTP,ABS(MSS(11)))
     $+BPPFF(I,4,1)*APPFF(J,4,1)*AMDN*SSB0(P2,AMDN,ABS(MSS(2)))
     $+BPPFF(I,4,2)*APPFF(J,4,2)*AMDN*SSB0(P2,AMDN,ABS(MSS(3)))
     $+BPPFF(I,5,1)*APPFF(J,5,1)*AMCH*SSB0(P2,AMCH,ABS(MSS(6)))
     $+BPPFF(I,5,2)*APPFF(J,5,2)*AMCH*SSB0(P2,AMCH,ABS(MSS(7)))
     $+BPPFF(I,6,1)*APPFF(J,6,1)*MBQ*SSB0(P2,AMBT,ABS(MSS(13)))
     $+BPPFF(I,6,2)*APPFF(J,6,2)*MBQ*SSB0(P2,AMBT,ABS(MSS(12))))
     $+BPPFF(I,7,1)*APPFF(J,7,1)*AME*SSB0(P2,AME,ABS(MSS(14)))
     $+BPPFF(I,8,1)*APPFF(J,8,1)*AMMU*SSB0(P2,AMMU,ABS(MSS(15)))
     $+BPPFF(I,9,1)*APPFF(J,9,1)*MLQ*SSB0(P2,AMTAU,ABS(MSS(16)))
     $-4.*(CONJG(BC0PPW(1,I))*AC0PPW(1,J)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),AMW)
     $+CONJG(BC0PPW(2,I))*AC0PPW(2,J)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),AMW)
     $+CONJG(BC0PPW(3,I))*AC0PPW(3,J)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),AMW)
     $+CONJG(BC0PPW(4,I))*AC0PPW(4,J)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),AMW)
     $+BPPCPZ(I,1)*APPCPZ(J,1)*ABS(MSS(27))*SSB0(P2,ABS(MSS(27)),AMZ)
     $+BPPCPZ(I,2)*APPCPZ(J,2)*ABS(MSS(28))*SSB0(P2,ABS(MSS(28)),AMZ)
     $+BPPCPG(I,1)*APPCPG(J,1)*ABS(MSS(27))*SSB0(P2,ABS(MSS(27)),0.)
     $+BPPCPG(I,2)*APPCPG(J,2)*ABS(MSS(28))*SSB0(P2,ABS(MSS(28)),0.))
     $+CONJG(BC0PPH(1,I,1))*AC0PPH(1,J,1)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),AMW)
     $+CONJG(BC0PPH(1,I,2))*AC0PPH(1,J,2)*ABS(MSS(23))
     $*SSB0(P2,ABS(MSS(23)),ABS(MSS(32)))
     $+CONJG(BC0PPH(2,I,1))*AC0PPH(2,J,1)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),AMW)
     $+CONJG(BC0PPH(2,I,2))*AC0PPH(2,J,2)*ABS(MSS(24))
     $*SSB0(P2,ABS(MSS(24)),ABS(MSS(32)))
     $+CONJG(BC0PPH(3,I,1))*AC0PPH(3,J,1)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),AMW)
     $+CONJG(BC0PPH(3,I,2))*AC0PPH(3,J,2)*ABS(MSS(25))
     $*SSB0(P2,ABS(MSS(25)),ABS(MSS(32)))
     $+CONJG(BC0PPH(4,I,1))*AC0PPH(4,J,1)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),AMW)
     $+CONJG(BC0PPH(4,I,2))*AC0PPH(4,J,2)*ABS(MSS(26))
     $*SSB0(P2,ABS(MSS(26)),ABS(MSS(32)))
     $+BPPCPH(I,1,1)*APPCPH(J,1,1)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),ABS(MSS(30)))
     $+BPPCPH(I,1,2)*APPCPH(J,1,2)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),ABS(MSS(29)))
     $+BPPCPH(I,1,3)*APPCPH(J,1,3)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),AMZ)
     $+BPPCPH(I,1,4)*APPCPH(J,1,4)*ABS(MSS(27))
     $*SSB0(P2,ABS(MSS(27)),ABS(MSS(31)))
     $+BPPCPH(I,2,1)*APPCPH(J,2,1)*ABS(MSS(28))
     $*SSB0(P2,ABS(MSS(28)),ABS(MSS(30)))
     $+BPPCPH(I,2,2)*APPCPH(J,2,2)*ABS(MSS(28))
     $*SSB0(P2,ABS(MSS(28)),ABS(MSS(29)))
     $+BPPCPH(I,2,3)*APPCPH(J,2,3)*ABS(MSS(28))
     $*SSB0(P2,ABS(MSS(28)),AMZ)
     $+BPPCPH(I,2,4)*APPCPH(J,2,4)*ABS(MSS(28))
     $*SSB0(P2,ABS(MSS(28)),ABS(MSS(31)))
     $)/16./PI**2
      SIGPS=TEMP
      RETURN
      END
+EOD
+DECK,SSA0
      DOUBLE PRECISION FUNCTION SSA0(M)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      REAL M
      DOUBLE PRECISION MSQ
      MSQ=M**2
      IF(M.NE.0.) THEN
        SSA0=MSQ*(1.D0-DLOG(MSQ)+XLAM)
      ELSE
        SSA0=0.D0
      ENDIF
      RETURN
      END
+EOD
+DECK,SSALFS
      DOUBLE PRECISION FUNCTION SSALFS(Q2)  
C-----------------------------------------------------------------------
C     Strong coupling formula from page 201 of Barger and Phillips:
C     (using ALQCD4 for 4 flavor Lambda)
C
C     Bisset's STRCPLH
C-----------------------------------------------------------------------
+CDE,SSSM
C
      DOUBLE PRECISION Q2,AS,TH5,TH6,PI
      DATA PI/3.14159265D0/
C
      TH5=4*AMBT**2
      TH6=4*AMTP**2
      IF (Q2.LE.TH5)THEN
        AS=12*PI/(25*LOG(Q2/ALQCD4**2))
      ELSE IF(Q2.GT.TH5.AND.Q2.LE.TH6) THEN
        AS=25*LOG(Q2/ALQCD4**2)-2*LOG(Q2/TH5)
        AS=12*PI/AS
      ELSEIF(Q2.GT.TH6)THEN
        AS=25*LOG(Q2/ALQCD4**2)
        AS=AS-2*(LOG(Q2/TH5)+LOG(Q2/TH6))
        AS=12*PI/AS
      ENDIF
      SSALFS=AS
      RETURN
      END
+EOD
+DECK,SSB00
      DOUBLE PRECISION FUNCTION SSB00(M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      REAL M1,M2
      DOUBLE PRECISION M1SQ,M2SQ,MCAP,MREG
      M1SQ=M1*M1
      M2SQ=M2*M2
      IF(M1SQ.GT.M2SQ) THEN
        MCAP=M1SQ
        MREG=M2SQ
      ELSE
        MCAP=M2SQ
        MREG=M1SQ
      ENDIF
      IF(M1.NE.M2) THEN
        SSB00=1.+XLAM-DLOG(MCAP)+MREG/(MREG-MCAP)
     $*DLOG(MCAP/MREG)
      ELSE
        SSB00=XLAM-DLOG(M1SQ)
      ENDIF
      IF(MREG.EQ.0) THEN
        SSB00=1.D0+XLAM-DLOG(MCAP)
      ENDIF
      IF(MCAP.EQ.0) THEN
        SSB00=1.D0+XLAM-DLOG(MREG)
      ENDIF
C      IF(M1.NE.M2) THEN
C        SSB00=1.+XLAM-DLOG(M2SQ)+M1SQ/(M1SQ-M2SQ)
C     $*DLOG(M2SQ/M1SQ)
C      ELSE
C        SSB00=XLAM-DLOG(M2SQ)
C      ENDIF
C      IF(M1.EQ.0) THEN
C        SSB00=1.D0+XLAM-DLOG(M2SQ)
C      ENDIF
C      IF(M2.EQ.0) THEN
C        SSB00=1.D0+XLAM-DLOG(M1SQ)
C      ENDIF
      RETURN
      END
+EOD
+DECK,SSB0
      COMPLEX*16 FUNCTION SSB0(QSQ,M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      COMPLEX*16 SSF0
      REAL QSQ,M1,M2
      SSB0=XLAM*(1.D0,0.D0)-SSF0(QSQ,M1,M2)
      RETURN
      END
+EOD
+DECK,SSB1
      COMPLEX*16 FUNCTION SSB1(XS,XMI,XMJ)
C          Modified by M. Drees 10/26/95
+CDE,SSINF
      REAL XS,XMI,XMJ
      DOUBLE PRECISION S,MI,MJ,A0MI,A0MJ
      COMPLEX*16 SSB0
      S=XS
      MI=XMI
      MJ=XMJ
      IF(S.GT.1.D-4*(MI**2+MJ**2)) THEN
        IF(MI.GE.1.D-10) THEN
          A0MI = MI**2*( 1.D0 - LOG(MI**2) + XLAM )
        ELSE
          A0MI = 0.D0
        ENDIF
        IF(MJ.GE.1.D-10) THEN
          A0MJ = MJ**2*( 1.D0 - LOG(MJ**2) + XLAM )
        ELSE
          A0MJ = 0.D0
        ENDIF
        SSB1 = ( (S+MI**2-MJ**2)*SSB0(XS,XMI,XMJ) + A0MJ - A0MI )/2.D0/S
      ELSE IF(ABS(MI-MJ).GT.1.D-4*MJ) THEN
        IF(MI.GT.1.D-10.AND.MJ.GT.1.D-10) THEN
          SSB1 = -(LOG(MJ)*(MJ**4-2.*MJ**2*MI**2) + MI**4*LOG(MI)
     $    -MJ**4/4.D0-.75*MI**4 + MI**2*MJ**2) / (MI**2-MJ**2)**2
     $    + XLAM/2.D0
        ELSEIF(MI.GT.1.D-10) THEN
          SSB1 = -LOG(MI) + .75 + .5*XLAM
        ELSEIF(MJ.GT.1.D-10) THEN
          SSB1 = -LOG(MJ) + .25 + .5*XLAM
        ENDIF
      ELSE IF(MI.NE.0.D0) THEN
        SSB1 = -LOG(MI) + XLAM/2.D0
      ENDIF
      RETURN
      END
+EOD
+DECK,SSB1F
       COMPLEX*16 FUNCTION SSB1F(XS,XMI,XMJ)
C          Implemented by Javier 9/8/05 to remove the Log
C          thresholds already implemented in the RGEs
C          through step by step decoupling
+CDE,SSINF
       REAL XS,XMI,XMJ
       DOUBLE PRECISION S,MI,MJ
       COMPLEX*16 SSB1
       S=XS
       MI=XMI
       MJ=XMJ
       SSB1F=SSB1(XS,XMI,XMJ)+LOG(MAX(MI,MJ))-XLAM/2.D0
       RETURN
       END
+EOD
+DECK,SSBT20
      DOUBLE PRECISION FUNCTION SSBT20(M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      DOUBLE PRECISION SSA0,SSB00,M1SQ,M2SQ
      COMPLEX*16 SSB0
      REAL M1,M2
      M1SQ=M1*M1
      M2SQ=M2*M2
c      SSBT20=((SSA0(M1)+SSA0(M2))/2.D0+(M1SQ+M2SQ)
c     $*SSB00(M1,M2)+M1SQ+M2SQ)/6.D0
c     $-(SSA0(M1)+SSA0(M2))/4.D0
      SSBT20=DBLE(((SSA0(M1)+SSA0(M2))/2.D0+(M1SQ+M2SQ)
     $*SSB0(0.,M1,M2)+M1SQ+M2SQ)/6.D0
     $-(SSA0(M1)+SSA0(M2))/4.D0)
      RETURN
      END
+EOD
+DECK,SSBT22
      COMPLEX*16 FUNCTION SSBT22(P,M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      COMPLEX*16 SSB0
      DOUBLE PRECISION SSA0
      DOUBLE PRECISION M1SQ,M2SQ,P2
      REAL P,M1,M2
      M1SQ=M1*M1
      M2SQ=M2*M2
      P2=P*P
      SSBT22=((SSA0(M1)+SSA0(M2))/2.D0*(1.D0,0.D0)
     $+(M1SQ+M2SQ-P2/2.D0)*SSB0(P**2,M1,M2)+(M2SQ-M1SQ)/2.D0/P2
     $*((SSA0(M2)-SSA0(M1))*(1.D0,0.D0)-(M2SQ-M1SQ)
     $*SSB0(P**2,M1,M2))+(M1SQ+M2SQ-P2/3.D0)*(1.D0,0.D0))/6.D0
     $-(SSA0(M1)+SSA0(M2))/4.D0*(1.D0,0.D0)
      RETURN
      END
+EOD
+DECK,SSC0
      DOUBLE PRECISION FUNCTION SSC0(M1,M2,M3)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL M1,M2,M3
      DOUBLE PRECISION M1SQ,M2SQ,M3SQ
      M1SQ=M1*M1
      M2SQ=M2*M2
      M3SQ=M3*M3
      IF(M1.NE.M2.AND.M1.NE.M3) THEN
        SSC0=(M2SQ/(M1SQ-M2SQ)*DLOG(M2SQ/M1SQ)-M3SQ/(M1SQ-M3SQ)
     $*DLOG(M3SQ/M1SQ))/(M2SQ-M3SQ)
      ELSEIF(M1.EQ.M2.AND.M1.NE.M3) THEN
        SSC0=(-1.D0-M3SQ/(M1SQ-M3SQ)*DLOG(M3SQ/M1SQ))/(M2SQ-M3SQ)
      ELSEIF(M1.NE.M2.AND.M1.EQ.M3) THEN
        SSC0=(M2SQ/(M1SQ-M2SQ)*DLOG(M2SQ/M1SQ)+1.D0)/(M2SQ-M3SQ)
      ELSEIF(M1.EQ.M2.AND.M1.EQ.M3) THEN
        SSC0=0.D0
      ENDIF
      RETURN
      END
+EOD
+DECK,SSD0
      DOUBLE PRECISION FUNCTION SSD0(M1,M2,M3,M4)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL M1,M2,M3,M4
      DOUBLE PRECISION M1SQ,M2SQ,M3SQ,M4SQ,SSC134,SSC234
      M1SQ=M1*M1
      M2SQ=M2*M2
      M3SQ=M3*M3
      M4SQ=M4*M4
      IF(M1.NE.M3.AND.M1.NE.M4) THEN
        SSC134=(M3SQ/(M1SQ-M3SQ)*DLOG(M3SQ/M1SQ)-M4SQ/(M1SQ-M4SQ)
     $*DLOG(M4SQ/M1SQ))/(M3SQ-M4SQ)
      ELSEIF(M1.EQ.M3.AND.M1.NE.M4) THEN
        SSC134=(-1.D0-M4SQ/(M1SQ-M4SQ)*DLOG(M4SQ/M1SQ))/(M3SQ-M4SQ)
      ELSEIF(M1.NE.M3.AND.M1.EQ.M4) THEN
        SSC134=(M3SQ/(M1SQ-M3SQ)*DLOG(M3SQ/M1SQ)+1.D0)/(M3SQ-M4SQ)
      ELSEIF(M1.EQ.M3.AND.M1.EQ.M4) THEN
        SSC134=0.D0
      ENDIF
      IF(M2.NE.M3.AND.M2.NE.M4) THEN
        SSC234=(M3SQ/(M2SQ-M3SQ)*DLOG(M3SQ/M2SQ)-M4SQ/(M2SQ-M4SQ)
     $*DLOG(M4SQ/M2SQ))/(M3SQ-M4SQ)
      ELSEIF(M2.EQ.M3.AND.M2.NE.M4) THEN
        SSC234=(-1.D0-M4SQ/(M2SQ-M4SQ)*DLOG(M4SQ/M2SQ))/(M3SQ-M4SQ)
      ELSEIF(M2.NE.M3.AND.M2.EQ.M4) THEN
        SSC234=(M3SQ/(M2SQ-M3SQ)*DLOG(M3SQ/M2SQ)+1.D0)/(M3SQ-M4SQ)
      ELSEIF(M2.EQ.M3.AND.M2.EQ.M4) THEN
        SSC234=0.D0
      ENDIF
      IF(M1.NE.M2) THEN
        SSD0=(SSC134-SSC234)/(M1SQ-M2SQ)
      ELSE
        SSD0=0.D0
      ENDIF
      RETURN
      END
+EOD
+DECK,SSD27
      DOUBLE PRECISION FUNCTION SSD27(M1,M2,M3,M4)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL M1,M2,M3,M4
      DOUBLE PRECISION M1SQ,M2SQ,M3SQ,M4SQ,SSC134,SSC234
      M1SQ=M1*M1
      M2SQ=M2*M2
      M3SQ=M3*M3
      M4SQ=M4*M4
      IF(M1.NE.M3.AND.M1.NE.M4) THEN
        SSC134=(M3SQ/(M1SQ-M3SQ)*DLOG(M3SQ/M1SQ)-M4SQ/(M1SQ-M4SQ)
     $*DLOG(M4SQ/M1SQ))/(M3SQ-M4SQ)
      ELSEIF(M1.EQ.M3.AND.M1.NE.M4) THEN
        SSC134=(-1.D0-M4SQ/(M1SQ-M4SQ)*DLOG(M4SQ/M1SQ))/(M3SQ-M4SQ)
      ELSEIF(M1.NE.M3.AND.M1.EQ.M4) THEN
        SSC134=(M3SQ/(M1SQ-M3SQ)*DLOG(M3SQ/M1SQ)+1.D0)/(M3SQ-M4SQ)
      ELSEIF(M1.EQ.M3.AND.M1.EQ.M4) THEN
        SSC134=0.D0
      ENDIF
      IF(M2.NE.M3.AND.M2.NE.M4) THEN
        SSC234=(M3SQ/(M2SQ-M3SQ)*DLOG(M3SQ/M2SQ)-M4SQ/(M2SQ-M4SQ)
     $*DLOG(M4SQ/M2SQ))/(M3SQ-M4SQ)
      ELSEIF(M2.EQ.M3.AND.M2.NE.M4) THEN
        SSC234=(-1.D0-M4SQ/(M2SQ-M4SQ)*DLOG(M4SQ/M2SQ))/(M3SQ-M4SQ)
      ELSEIF(M2.NE.M3.AND.M2.EQ.M4) THEN
        SSC234=(M3SQ/(M2SQ-M3SQ)*DLOG(M3SQ/M2SQ)+1.D0)/(M3SQ-M4SQ)
      ELSEIF(M2.EQ.M3.AND.M2.EQ.M4) THEN
        SSC234=0.D0
      ENDIF
      IF(M1.NE.M2) THEN
        SSD27=(M1SQ*SSC134-M2SQ*SSC234)/(M1SQ-M2SQ)/4.
      ELSE
        SSD27=0.D0
      ENDIF
      RETURN
      END
+EOD
+DECK,SSDHLL
      SUBROUTINE SSDHLL(DELHLL)
C-----------------------------------------------------------------------
C
C          Calculates radiative correction to the
C          H_h-H_l-H_l vertex.
C          calculated by M. Bisset
C
C          This subroutine calculates the 
C          radiative correction to the 
C          H_h-H_l-H_l vertex which can be 
C          important in determining the 
C           H_h --> H_l H_l partial decay width.
C
C          Both top and bottom couplings are now 
C          included.  Non-degenerate mixed squark
C          masses and A-terms are also included.
C          The D-terms from the squark mass matrix
C          (terms prop. to g**2 * Yukawa coupling)
C          are included as an option: 
C                 INRAD = 1 ==> D-TERMS ON
C                 INRAD = 2 ==> D-TERMS OFF    .
C
C         10/18/93 D-terms are now turned on.
C                     INRAD = 1 
C
C         There is an arbitrary mass scale that must
C         chosen to avoid dimensionful logarithms.
C         The choice does not matter if D-terms are
C         not included, but it does matter if D-terms
C         are included. 
C     
C         10/18/93 arbitrary mass scale set to H_h mass
C                       QQQ = AMHH
C
C         It is assumed that the A-terms are real.
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
C
      REAL PI,PI2,SR2,G2,GP2,GGP,GG1,GG2
      REAL TANB,COTB,COSB,SINB,BE
      REAL SINB2,COSB2,COS2B,SIN2B
      REAL V2,VP2,V,VP,VVP,VPVM,VVPP,MT,MB
      REAL MT2,MB2,FT2,FB2,FT,FB,FT4,FB4
      REAL MW2,MZ2,ZAP,QQQ2,EP,EP2,RR,MHP2
      REAL ATI,ABI,ATR,ABR,AT2,AB2
      REAL MSTL2,MSTR2,MSBL2,MSBR2
      REAL TLRM,BLRM,TLRP,BLRP
      REAL MST1SQ,MST2SQ,MSB1SQ,MSB2SQ
      REAL RTT,RBB
C
      REAL A0,A1,A2,A1P,A2P,A3,A4
      REAL B0,B1,B2,B1P,B2P,B3,B4
      REAL MT1R,MT2R,MB1R,MB2R
      REAL MT1P,MT2P,MB1P,MB2P
      REAL MT1RR,MT2RR,MB1RR,MB2RR
      REAL MT1PP,MT2PP,MB1PP,MB2PP
      REAL MT1RP,MT2RP,MB1RP,MB2RP
      REAL MT1RRR,MT2RRR,MB1RRR,MB2RRR
      REAL MT1PRR,MT2PRR,MB1PRR,MB2PRR
      REAL MT1RPP,MT2RPP,MB1RPP,MB2RPP
      REAL MT1PPP,MT2PPP,MB1PPP,MB2PPP
C
      REAL SQVT1,SQVT2,SQVB1,SQVB2
      REAL SQVRRR,SQVPPP,SQVPRR,SQVRPP
      REAL FVRRR,FVPPP
      REAL VRRR,VPPP,VPRR,VRPP
C
      REAL ALPHAT,GGP1SQ,ALPHAB,GGP2SQ,TEMPSQ,BSQ
      REAL ASMB,MBMB,MBQP,ASMT,MTMT,MTQP,SUALFS,HIGFRZ
      DOUBLE PRECISION SSMQCD
C
      REAL CA2,SA2,DVHLL
      DOUBLE PRECISION DELHLL
C
      INTEGER INRAD,ISPECT,ISPECB
C
      MW2=AMW**2
      MZ2=AMZ**2
      HIGFRZ=SQRT(MAX(AMZ**2,AMTLSS*AMTRSS*SIGN(1.,AMTLSS*AMTRSS)))
      QQQ2=HIGFRZ**2
      INRAD=1
      ZAP=1.0
C
      PI=4.*ATAN(1.)
      PI2=PI**2
      SR2=SQRT(2.)
      G2=4.*PI*ALFAEM/SN2THW
      GP2=G2*SN2THW/(1.-SN2THW)
      ASMB=SUALFS(AMBT**2,.36,AMTP,3)
      MBMB=AMBT*(1.-4*ASMB/3./PI)
      MBQP=SSMQCD(DBLE(MBMB),DBLE(HIGFRZ))
      ASMT=SUALFS(AMTP**2,.36,AMTP,3)
      MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))*
     $(ASMT/PI)**2)
      MTQP=SSMQCD(DBLE(MTMT),DBLE(HIGFRZ))
      MT=MTQP
      MB=MBQP
      MT2=MT**2
      MB2=MB**2
      EP=TWOM1
      EP2=EP**2
      MHP2=AMHA**2
      RR=RV2V1
      TANB=1.0/RR
      COTB=RR
      BE=ATAN(1./RV2V1)
      SINB=SIN(BE)
      COSB=COS(BE)
      SINB2=SINB**2
      COSB2=COSB**2
      SIN2B=SIN(2.*BE)
      COS2B=COS(2.*BE)
      V2=2.0*MW2*SINB2/G2
      VP2=2.0*MW2*COSB2/G2
      V=SQRT(V2)
      VP=SQRT(VP2)
      VVP=SQRT(V2*VP2)
      VPVM=VP2-V2
      GGP=G2+GP2
      GG1=G2-5.0*GP2/3.0
      GG2=G2-GP2/3.0
      VVPP=2.0*AMZ**2/GGP
      FT2=MT2/V2
      FB2=MB2/VP2
      FT=SQRT(FT2)
      FB=SQRT(FB2)
      FT4 = FT2**2
      FB4 = FB2**2
C
C      (AAT and AAB are also assumed to be real)
C
      ATR=AAT
      ABR=AAB
      ATI=0.0
      ABI=0.0
      AT2=ATR**2+ATI**2
      AB2=ABR**2+ABI**2
C
      MSTL2=AMTLSS**2*SIGN(1.,AMTLSS)
      MSTR2=AMTRSS**2*SIGN(1.,AMTRSS)
      MSBL2=AMBLSS**2
      MSBR2=AMBRSS**2
      TLRM=MSTL2-MSTR2
      BLRM=MSBL2-MSBR2 
      TLRP=MSTL2+MSTR2
      BLRP=MSBL2+MSBR2 
C
C      UNFORTUNATELY, I HAVE USED MY OLD CONVENTION
C      FOR THE STOP AND SBOTTOM EIGENVALUES HERE 
C      (T1 <==> T2 OF NOTATION IN X. TATA'S AND OTHER
C      PEOPLE'S NOTATION).  SO THE NEXT FOUR LINES ARE
C      A FIX-UP UNTIL I GO THROUGH AND CHANGE THE
C      NOTATION THROUGHOUT THIS SUBROUTINE.
C
C
C     Calculate mt1,mt2,mb1,mb2 internally so masses consistent
C     with value of mbqp and mtqp used here
C
      MST2SQ=TLRP/2.+MZ2*COS2B/4.+MTQP**2-SQRT((TLRM/2.+COS2B/12.
     ,*(8*MW2-5*MZ2))**2+MTQP**2*(-AAT-EP*COTB)**2)
      MST1SQ=TLRP/2.+MZ2*COS2B/4.+MTQP**2+SQRT((TLRM/2.+COS2B/12.
     ,*(8*MW2-5*MZ2))**2+MTQP**2*(-AAT-EP*COTB)**2)
      MSB2SQ=BLRP/2.-MZ2*COS2B/4.+MBQP**2-SQRT((BLRM/2.-COS2B/12.
     ,*(4*MW2-MZ2))**2+MBQP**2*(-AAB-EP*TANB)**2)
      MSB1SQ=BLRP/2.-MZ2*COS2B/4.+MBQP**2+SQRT((BLRM/2.-COS2B/12.
     ,*(4*MW2-MZ2))**2+MBQP**2*(-AAB-EP*TANB)**2)
C
C
C      Calculation of radiative correction to 
C      the H_H-H_l-H_l vertex
C
C
C                  STOP TERMS
C
      ISPECT=0          
      RTT=(TLRM+VPVM*ZAP*GG1/4.0)**2
     $      +4.0*MT2*(EP*COTB+ATR)**2+4.0*MT2*ATI**2
C
      IF(RTT.GT.0.0) THEN
        A0=SQRT(RTT)
        A1=-V*ZAP*GG1*(TLRM+ZAP*VPVM*GG1/4.0)/SR2
        A1=A1+4.0*SR2*FT*MT*(AT2+EP*ATR*COTB)        
        A2=-ZAP*GG1*(TLRM+ZAP*VPVM*GG1/4.0)/2.0
        A2=A2 +V2*ZAP*GG1**2/4.0 +4.0*FT2*AT2
        A1P=VP*ZAP*GG1*(TLRM+ZAP*VPVM*GG1/4.0)/SR2
        A1P=A1P+4.0*SR2*FT*MT*EP*(ATR+EP*COTB)
        A2P=ZAP*GG1*(TLRM+ZAP*VPVM*GG1/4.0)/2.0
        A2P=A2P +VP2*ZAP*GG1**2/4.0 +4.0*FT2*EP2
        A3=SR2*ZAP*GG1**2/8.0
        A4=-VVP*ZAP*GG1**2/4.0 +4.0*FT2*EP*ATR
C        
        MT1R=SR2*FT*MT-SR2*V*ZAP*GGP/8.0 +A1/(4.0*A0)
        MT2R=SR2*FT*MT-SR2*V*ZAP*GGP/8.0 -A1/(4.0*A0)
        MT1P=SR2*VP*ZAP*GGP/8.0 +A1P/(4.0*A0)
        MT2P=SR2*VP*ZAP*GGP/8.0 -A1P/(4.0*A0)
        MT1RR=FT2 -ZAP*GGP/8.0 -A1**2/(8.0*A0**3) +A2/(4.0*A0)
        MT2RR=FT2 -ZAP*GGP/8.0 +A1**2/(8.0*A0**3) -A2/(4.0*A0)
        MT1PP=ZAP*GGP/8.0 -A1P**2/(8.0*A0**3) +A2P/(4.0*A0)
        MT2PP=ZAP*GGP/8.0 +A1P**2/(8.0*A0**3) -A2P/(4.0*A0)
        MT1RRR=3.0*A1**3/(16.0*A0**3) 
        MT1RRR=MT1RRR/(A0**2) -3.0*A1*A2/(8.0*A0**3) 
     $                            +3.0*V*A3/(4.0*A0)
        MT2RRR=-MT1RRR
        MT1PPP=3.0*A1P**3/(16.0*A0**3) 
        MT1PPP=MT1PPP/(A0**2) -3.0*A1P*A2P/(8.0*A0**3) 
     $                             +3.0*VP*A3/(4.0*A0)
        MT2PPP=-MT1PPP
        MT1RP=-A1*A1P/(8.0*A0**3) +A4/(4.0*A0)
        MT2RP=-MT1RP
        MT1PRR=3.0*A1P*A1**2/(16.0*A0**3)
        MT1PRR=MT1PRR/(A0**2)
     $          -(A2*A1P+2.0*A1*A4)/(8.0*A0**3) -VP*A3/(4.0*A0)
        MT2PRR=-MT1PRR
        MT1RPP=3.0*A1*A1P**2/(16.0*A0**3)
        MT1RPP=MT1RPP/(A0**2)
     $          -(A1*A2P+2.0*A1P*A4)/(8.0*A0**3) -V*A3/(4.0*A0)
        MT2RPP=-MT1RPP
      ELSEIF(RTT.EQ.0.0) THEN
        IF(INRAD.EQ.2.OR.TANB.EQ.1.0) THEN
          IF(EP.EQ.0.0.AND.TLRM.EQ.0.0) THEN
            IF(ATR.EQ.0.0.AND.ATI.EQ.0.0) THEN
              ISPECT=1
              MT1R=SR2*V*FT2
              MT2R=SR2*V*FT2
              MT1P=0.0
              MT2P=0.0
              MT1RR=FT2 
              MT2RR=FT2 
              MT1PP=0.0
              MT2PP=0.0
              MT1RRR=0.0
              MT2RRR=0.0
              MT1PPP=0.0
              MT2PPP=0.0
              MT1RP=0.0
              MT2RP=0.0
              MT1PRR=0.0
              MT2PRR=0.0
              MT1RPP=0.0
              MT2RPP=0.0
            ENDIF
          ENDIF
        ENDIF
      ENDIF
      IF(RTT.NE.0.0 .OR. ISPECT.EQ.1) THEN
        SQVT1=2.0*(3.0*MT1R*MT1RR+MST1SQ*MT1RRR)
        SQVT1=SQVT1*LOG(MST1SQ/QQQ2)
        SQVT1=SQVT1 +2.0*MT1R**3/MST1SQ +9.0*MT1R*MT1RR
        SQVT1=SQVT1+MST1SQ*MT1RRR
        SQVT2=2.0*(3.0*MT2R*MT2RR+MST2SQ*MT2RRR)
        SQVT2=SQVT2*LOG(MST2SQ/QQQ2)
        SQVT2=SQVT2 +2.0*MT2R**3/MST2SQ +9.0*MT2R*MT2RR
        SQVT2=SQVT2+MST2SQ*MT2RRR
        SQVRRR=SQVT1+SQVT2
C          
        SQVT1=2.0*(3.0*MT1P*MT1PP+MST1SQ*MT1PPP)
        SQVT1=SQVT1*LOG(MST1SQ/QQQ2)
        SQVT1=SQVT1 +2.0*MT1P**3/MST1SQ + 9.0*MT1P*MT1PP
        SQVT1=SQVT1+MST1SQ*MT1PPP
        SQVT2=2.0*(3.0*MT2P*MT2PP+MST2SQ*MT2PPP)
        SQVT2=SQVT2*LOG(MST2SQ/QQQ2)
        SQVT2=SQVT2 +2.0*MT2P**3/MST2SQ +9.0*MT2P*MT2PP
        SQVT2=SQVT2 +MST2SQ*MT2PPP
        SQVPPP = SQVT1 + SQVT2
C
        SQVT1=2.0*MT1R*MT1RP+MT1P*MT1RR+MST1SQ*MT1PRR
        SQVT1=2.0*SQVT1*LOG(MST1SQ/QQQ2)
        SQVT1=SQVT1 +2.0*MT1P*MT1R**2/MST1SQ 
        SQVT1=SQVT1+3.0*MT1P*MT1RR+6.0*MT1R*MT1RP
        SQVT1=SQVT1+MST1SQ*MT1PRR
        SQVT2=2.0*MT2R*MT2RP+MT2P*MT2RR+MST2SQ*MT2PRR
        SQVT2=2.0*SQVT2*LOG(MST2SQ/QQQ2)
        SQVT2=SQVT2 +2.0*MT2P*MT2R**2/MST2SQ 
        SQVT2=SQVT2+3.0*MT2P*MT2RR+6.0*MT2R*MT2RP
        SQVT2=SQVT2+MST2SQ*MT2PRR
        SQVPRR=SQVT1+SQVT2
C
        SQVT1=2.0*MT1P*MT1RP+MT1R*MT1PP+MST1SQ*MT1RPP
        SQVT1=2.0*SQVT1*LOG(MST1SQ/QQQ2)
        SQVT1=SQVT1 +2.0*MT1R*MT1P**2/MST1SQ 
        SQVT1=SQVT1+3.0*MT1R*MT1PP+6.0*MT1P*MT1RP
        SQVT1=SQVT1+MST1SQ*MT1RPP
        SQVT2=2.0*MT2P*MT2RP+MT2R*MT2PP+MST2SQ*MT2RPP
        SQVT2=2.0*SQVT2*LOG(MST2SQ/QQQ2)
        SQVT2=SQVT2 +2.0*MT2R*MT2P**2/MST2SQ 
        SQVT2=SQVT2+3.0*MT2R*MT2PP+6.0*MT2P*MT2RP
        SQVT2=SQVT2+MST2SQ*MT2RPP
        SQVRPP=SQVT1+SQVT2
C
        FVRRR=-2.0*SR2*FT4*V*(6.0*LOG(MT2/QQQ2) + 13.0)
      ENDIF
C
      IF(RTT.EQ.0.0 .AND. ISPECT.EQ.0) THEN
        ALPHAT=(MSTL2 + MSTR2)/2.0 + MT2
        ALPHAT=ALPHAT +VP2*(1.0-TANB**2)*ZAP*GGP/8.0
        GGP1SQ= ZAP*GGP**2 +ZAP*GG1**2
C
        SQVRRR=12.0*FT4*LOG(ALPHAT/MT2)
        TEMPSQ=-FT2*ZAP*GGP +GGP1SQ/16.0
        SQVRRR=SQVRRR +3.0*TEMPSQ*LOG(ALPHAT/QQQ2)
        SQVRRR=SQVRRR -8.0*FT4 -9.0*FT2*ZAP*GGP/2.0
        SQVRRR=SQVRRR +9.0*GGP1SQ/32.0
        TEMPSQ=8.0*V2*(FT2-ZAP*GGP/8.0)**2
        TEMPSQ=TEMPSQ +3.0*V2*ZAP*GG1**2/8.0
        TEMPSQ=TEMPSQ +6.0*FT2*EP2*COTB**2
        SQVRRR=SQVRRR +TEMPSQ*(FT2-ZAP*GGP/8.0)/ALPHAT
        SQVRRR=SQVRRR*SR2*V
C
        SQVPPP=3.0*GGP1SQ*(2.0*LOG(ALPHAT/QQQ2)+3.0)/32.0
        TEMPSQ=ZAP*GGP*(ZAP*GGP**2+3.0*GG1**2)*VP2/ALPHAT/64.0
        SQVPPP=SQVPPP+TEMPSQ
        TEMPSQ=3.0*FT2*EP2*ZAP*GGP/ALPHAT/4.0
        SQVPPP=(SQVPPP+TEMPSQ)*SR2*VP
C
        TEMPSQ=FT2*ZAP*GGP -GGP1SQ/8.0
        SQVPRR=TEMPSQ*(2.0*LOG(ALPHAT/QQQ2)+3.0)
        TEMPSQ=4.0*ZAP*GGP*(FT2-ZAP*GGP/8.0)-FT2*ZAP*GG1**2
        TEMPSQ=TEMPSQ +3.0*ZAP*GGP*GG1**2/16.0
        TEMPSQ=V2*TEMPSQ+EP2*FT2*ZAP*GGP*(2.0+COTB**2)
        TEMPSQ=TEMPSQ-16.0*EP2*FT4
        SQVPRR=(SQVPRR+TEMPSQ/ALPHAT)*SR2*VP/4.0
C
        TEMPSQ=FT2*ZAP*GGP -GGP1SQ/8.0
        SQVRPP=TEMPSQ*(2.0*LOG(ALPHAT/QQQ2)+3.0)
        TEMPSQ=GGP1SQ*(FT2-ZAP*GGP/8.0)-ZAP*GGP*GG1**2/4.0
        TEMPSQ=VP2*TEMPSQ/2.0 +8.0*EP2*FT4
        TEMPSQ=TEMPSQ+EP2*FT2*ZAP*GGP*(1.0+2.0*COTB**2)
        SQVRPP=(SQVRPP+TEMPSQ/ALPHAT)*SR2*V/4.0
C
        FVRRR = 0.0
C      
C        Fermion part (FRRR) is already combined 
C        with the squark part. 
C
      ENDIF     
C
C
C                  SBOTTOM TERMS
C
      ISPECB=0          
      RBB=(BLRM-VPVM*ZAP*GG2/4.0)**2
     $      +4.0*MB2*(EP*TANB+ABR)**2+4.0*MB2*ABI**2
C
      IF(RBB.GT.0.0) THEN      
        B0=SQRT(RBB)
        B1=V*ZAP*GG2*(BLRM-ZAP*VPVM*GG2/4.0)/SR2
        B1=B1+4.0*SR2*FB*MB*EP*(ABR+EP*TANB)
        B2=ZAP*GG2*(BLRM-ZAP*VPVM*GG2/4.0)/2.0
        B2=B2 +V2*ZAP*GG2**2/4.0 +4.0*FB2*EP2
        B1P=-VP*ZAP*GG2*(BLRM-ZAP*VPVM*GG2/4.0)/SR2
        B1P=B1P+4.0*SR2*FB*MB*(AB2+EP*ABR*TANB)
        B2P=-ZAP*GG2*(BLRM-ZAP*VPVM*GG2/4.0)/2.0
        B2P=B2P +VP2*ZAP*GG2**2/4.0 +4.0*FB2*AB2
        B3=SR2*ZAP*GG2**2/8.0
        B4=-VVP*ZAP*GG2**2/4.0 +4.0*FB2*EP*ABR
C
        MB1R=SR2*V*ZAP*GGP/8.0 +B1/(4.0*B0)
        MB2R=SR2*V*ZAP*GGP/8.0 -B1/(4.0*B0)
        MB1P=SR2*FB*MB -SR2*VP*ZAP*GGP/8.0 +B1P/(4.0*B0)
        MB2P=SR2*FB*MB -SR2*VP*ZAP*GGP/8.0 -B1P/(4.0*B0)
        MB1RR=ZAP*GGP/8.0 -B1**2/(8.0*B0**3) +B2/(4.0*B0)
        MB2RR=ZAP*GGP/8.0 +B1**2/(8.0*B0**3) -B2/(4.0*B0)
        MB1PP=FB2 -ZAP*GGP/8.0 
        MB2PP=MB1PP 
        MB1PP=MB1PP -B1P**2/(8.0*B0**3) +B2P/(4.0*B0)
        MB2PP=MB2PP +B1P**2/(8.0*B0**3) -B2P/(4.0*B0)
        MB1RRR=3.0*B1**3/(16.0*B0**3) 
        MB1RRR=MB1RRR/(B0**2) -3.0*B1*B2/(8.0*B0**3) 
     $                            +3.0*V*B3/(4.0*B0)
        MB2RRR=-MB1RRR
        MB1PPP=3.0*B1P**3/(16.0*B0**3) 
        MB1PPP=MB1PPP/(B0**2) -3.0*B1P*B2P/(8.0*B0**3) 
        MB1PPP=MB1PPP +3.0*VP*B3/(4.0*B0)
        MB2PPP=-MB1PPP 
        MB1RP=-B1*B1P/(8.0*B0**3) +B4/(4.0*B0)
        MB2RP=-MB1RP
        MB1PRR=3.0*B1P*B1**2/(16.0*B0**3)
        MB1PRR=MB1PRR/(B0**2) -(B2*B1P+2.0*B1*B4)/(8.0*B0**3)
        MB1PRR=MB1PRR -VP*B3/(4.0*B0)
        MB2PRR=-MB1PRR
        MB1RPP=3.0*B1*B1P**2/(16.0*B0**3)
        MB1RPP=MB1RPP/(B0**2) -(B1*B2P+2.0*B1P*B4)/(8.0*B0**3)
        MB1RPP=MB1RPP -V*B3/(4.0*B0)
        MB2RPP=-MB1RPP
      ELSEIF(RBB.EQ.0.0) THEN
        IF(INRAD.EQ.2.OR.TANB.EQ.1.0) THEN
          IF(EP.EQ.0.0.AND.BLRM.EQ.0.0) THEN
            IF(ABR.EQ.0.0.AND.ABI.EQ.0.0) THEN
              ISPECB=1
              MB1R=0.0
              MB2R=0.0
              MB1P=SR2*VP*FB2 
              MB2P=SR2*VP*FB2
              MB1RR=0.0
              MB2RR=0.0
              MB1PP=FB2
              MB2PP=FB2
              MB1RRR=0.0
              MB2RRR=0.0
              MB1PPP=0.0
              MB2PPP=0.0
              MB1RP=0.0
              MB2RP=0.0
              MB1PRR=0.0
              MB1PRR=0.0
              MB2PRR=0.0
              MB1RPP=0.0
              MB2RPP=0.0
            ENDIF
          ENDIF
        ENDIF
      ENDIF
C
      IF(RBB.NE.0.0 .OR. ISPECB.EQ.1) THEN
        SQVB1=2.0*(3.0*MB1R*MB1RR+MSB1SQ*MB1RRR)
        SQVB1=SQVB1*LOG(MSB1SQ/QQQ2)
        SQVB1=SQVB1 +2.0*MB1R**3/MSB1SQ +9.0*MB1R*MB1RR
        SQVB1=SQVB1+MSB1SQ*MB1RRR
        SQVB2=2.0*(3.0*MB2R*MB2RR+MSB2SQ*MB2RRR)
        SQVB2=SQVB2*LOG(MSB2SQ/QQQ2)
        SQVB2=SQVB2 +2.0*MB2R**3/MSB2SQ +9.0*MB2R*MB2RR
        SQVB2=SQVB2+MSB2SQ*MB2RRR
        SQVRRR = SQVRRR + SQVB1 + SQVB2
C
        SQVB1=2.0*(3.0*MB1P*MB1PP+MSB1SQ*MB1PPP)
        SQVB1=SQVB1*LOG(MSB1SQ/QQQ2)
        SQVB1=SQVB1 +2.0*MB1P**3/MSB1SQ +9.0*MB1P*MB1PP
        SQVB1=SQVB1+MSB1SQ*MB1PPP
        SQVB2=2.0*(3.0*MB2P*MB2PP+MSB2SQ*MB2PPP)
        SQVB2=SQVB2*LOG(MSB2SQ/QQQ2)
        SQVB2=SQVB2 +2.0*MB2P**3/MSB2SQ +9.0*MB2P*MB2PP
        SQVB2=SQVB2+MSB2SQ*MB2PPP
        SQVPPP= SQVPPP+SQVB1+SQVB2
C
        SQVB1=2.0*MB1R*MB1RP+MB1P*MB1RR+MSB1SQ*MB1PRR
        SQVB1=2.0*SQVB1*LOG(MSB1SQ/QQQ2)
        SQVB1=SQVB1 +2.0*MB1P*MB1R**2/MSB1SQ 
        SQVB1=SQVB1 +3.0*MB1P*MB1RR +6.0*MB1R*MB1RP
        SQVB1=SQVB1+MSB1SQ*MB1PRR
        SQVB2=2.0*MB2R*MB2RP+MB2P*MB2RR+MSB2SQ*MB2PRR
        SQVB2=2.0*SQVB2*LOG(MSB2SQ/QQQ2)
        SQVB2=SQVB2 +2.0*MB2P*MB2R**2/MSB2SQ 
        SQVB2=SQVB2 +3.0*MB2P*MB2RR +6.0*MB2R*MB2RP
        SQVB2=SQVB2+MSB2SQ*MB2PRR
        SQVPRR=SQVPRR+SQVB1+SQVB2
C
        SQVB1=2.0*MB1P*MB1RP+MB1R*MB1PP+MSB1SQ*MB1RPP
        SQVB1=2.0*SQVB1*LOG(MSB1SQ/QQQ2)
        SQVB1=SQVB1 +2.0*MB1R*MB1P**2/MSB1SQ 
        SQVB1=SQVB1+3.0*MB1R*MB1PP+6.0*MB1P*MB1RP
        SQVB1=SQVB1+MSB1SQ*MB1RPP
        SQVB2=2.0*MB2P*MB2RP+MB2R*MB2PP+MSB2SQ*MB2RPP
        SQVB2=2.0*SQVB2*LOG(MSB2SQ/QQQ2)
        SQVB2=SQVB2 +2.0*MB2R*MB2P**2/MSB2SQ 
        SQVB2=SQVB2 +3.0*MB2R*MB2PP +6.0*MB2P*MB2RP
        SQVB2=SQVB2+MSB2SQ*MB2RPP
        SQVRPP=SQVRPP+SQVB1+SQVB2
C
        IF(MB2.EQ.0.0) THEN
          FVPPP=0.0
        ELSE IF(MB2.NE.0.0) THEN
          FVPPP=-2.0*SR2*FB4*VP*(6.0*LOG(MB2/QQQ2)+13.0)
        ENDIF
C
      ENDIF
C
      IF(RBB.EQ.0.0 .AND. ISPECB.EQ.0) THEN
        ALPHAB=(MSBL2+MSBR2)/2.0 +MB2 
        ALPHAB=ALPHAB -VP2*(1.0-TANB**2)*ZAP*GGP/8.0
        GGP2SQ=ZAP*GGP**2 +ZAP*GG2**2
C
        BSQ=3.0*GGP2SQ*(2.0*LOG(ALPHAB/QQQ2)+3.0)/8.0
        TEMPSQ=V2*(ZAP*GGP**2 +3.0*ZAP*GG2**2)/16.0 
     $                                   +3.0*FB2*EP2
        BSQ=(BSQ +ZAP*GGP*TEMPSQ/ALPHAB)*SR2*V/4.0
        SQVRRR=SQVRRR+BSQ
C
        BSQ=12.0*FB4*LOG(ALPHAB/MB2) -8.0*FB4
        TEMPSQ=-FB2*ZAP*GGP +GGP2SQ/16.0
        BSQ=BSQ+3.0*TEMPSQ*(LOG(ALPHAB/QQQ2)+1.5)
        TEMPSQ=8.0*VP2*(FB2-ZAP*GGP/8.0)**2 
     $     +3.0*VP2*ZAP*GG2**2/8.0 +6.0*FB2*EP2*TANB**2
        BSQ=BSQ +(FB2-ZAP*GGP/8.0)*TEMPSQ/ALPHAB
        BSQ=BSQ*SR2*VP
        SQVPPP=SQVPPP+BSQ
C
        TEMPSQ=0.5*(FB2*ZAP*GGP -GGP2SQ/8.0)
        BSQ=TEMPSQ*(LOG(ALPHAB/QQQ2)+1.5)
        TEMPSQ=(FB2 -ZAP*GGP/8.0)*GGP2SQ -ZAP*GGP*GG2**2/4.0
        TEMPSQ=V2*TEMPSQ/4.0 +4.0*FB4*EP2 -FB2*EP2*ZAP*GGP/2.0
        TEMPSQ=(TEMPSQ-FB2*EP2*ZAP*GGP*TANB**2)/ALPHAB/2.0
        BSQ=(BSQ+TEMPSQ)*SR2*VP
        SQVPRR=SQVPRR+BSQ
C
        TEMPSQ=0.5*(FB2*ZAP*GGP -GGP2SQ/8.0)
        BSQ=TEMPSQ*(LOG(ALPHAB/QQQ2)+1.5)
        TEMPSQ=4.0*ZAP*GGP*(FB2 -ZAP*GGP/8.0)**2 
     $          -FB2*ZAP*GG2**2 +3.0*ZAP*GGP*GG2**2/16.0
        TEMPSQ=VP2*TEMPSQ-16.0*FB4*EP2 
        TEMPSQ=TEMPSQ+FB2*EP2*ZAP*GGP*(TANB**2 +0.5)
        BSQ=(BSQ +TEMPSQ/ALPHAB/4.0)*SR2*V
        SQVRPP=SQVRPP+BSQ
C
        FVPPP=0.0
C
C        Fermion part (FPPP) is already combined 
C        with the squark part. 
C
      ENDIF
C
C
      VRRR=3.0*(SQVRRR+FVRRR)/(32.0*PI2)
      VRRR=VRRR/6.0
C
      VPPP=3.0*(SQVPPP+FVPPP)/(32.0*PI2)
      VPPP=VPPP/6.0
C
      VPRR=3.0*(SQVPRR)/(32.0*PI2)
      VPRR=VPRR/2.0
C
      VRPP=3.0*(SQVRPP)/(32.0*PI2)
      VRPP=VRPP/2.0
C
C
C      Note in the following that the angle ALFAH
C      calculated in the subroutine SSMHN must
C      be input.
C
      CA2=(COS(ALFAH))**2
      SA2=(SIN(ALFAH))**2
      DVHLL=-VRRR*CA2*SIN(ALFAH)
      DVHLL=DVHLL +VPRR*(CA2-2.0*SA2)*COS(ALFAH)
      DVHLL=DVHLL +VRPP*(2.0*CA2-SA2)*SIN(ALFAH)
      DVHLL=DVHLL +VPPP*SA2*COS(ALFAH)
C
      DVHLL=3.0*DVHLL
      DVHLL=-DVHLL
C
C      Finally, multiply bt the coefficient of the
C      tree-level Lagrangian level term (COEFF.) 
C      so that the answer may be written as:  
C        DW = (COEFF.)**2 
C            * (TREE-LEVEL ANGULAR DEPENDENCE + DVHLL)
C
C              *(LAMBDA KINEMATIC FCN)**0.5/(8*PI*MHH**3)
C
C
      DVHLL=4.0*SQRT((1.-SN2THW)/G2)*DVHLL/AMZ
C
C
1000  DELHLL=DVHLL
      RETURN
      END
+EOD
+DECK,SSDINT
      DOUBLE PRECISION FUNCTION SSDINT(XL,F,XR)
C-----------------------------------------------------------------------
C          Integrate F over (XL,XR) using adaptive Gaussian quadrature.
C          TOLABS = 1e-35: absolute error for convergence.
C          TOLREL = 5e-5:  relative error for convergence.
C          TOLBIN = 1e-3:  relative bin size limit. Set contribution to
C                          zero if bin falls below this.
C     Note quadrature constants R and W have been converted to explicit
C     double precision (.xxxxxDxx) form.
C
C     Bisset's XINTH     
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
      EXTERNAL F
      INTEGER NMAX
      DOUBLE PRECISION TOLABS,TOLREL,TOLBIN,XMIN,XLIMS(100)
      DOUBLE PRECISION R(93),W(93)
      INTEGER PTR(4),NORD(4)
      INTEGER ICOUNT,IBAD
      DOUBLE PRECISION XL,XR,F
      DOUBLE PRECISION AA,BB,TVAL,VAL,TOL
      INTEGER NLIMS,I,J,KKK
C
      DATA PTR,NORD/4,10,22,46,  6,12,24,48/
      DATA (R(KKK),KKK=1,48)/
     $ .2386191860D0,.6612093865D0,.9324695142D0,.1252334085D0,
     $ .3678314990D0,.5873179543D0,.7699026742D0,.9041172563D0,
     $ .9815606342D0,.0640568929D0,.1911188675D0,.3150426797D0,
     $ .4337935076D0,.5454214714D0,.6480936519D0,.7401241916D0,
     $ .8200019860D0,.8864155270D0,.9382745520D0,.9747285560D0,
     $ .9951872200D0,.0323801710D0,.0970046992D0,.1612223561D0,
     $ .2247637903D0,.2873624873D0,.3487558863D0,.4086864820D0,
     $ .4669029048D0,.5231609747D0,.5772247261D0,.6288673968D0,
     $ .6778723796D0,.7240341309D0,.7671590325D0,.8070662040D0,
     $ .8435882616D0,.8765720203D0,.9058791367D0,.9313866907D0,
     $ .9529877032D0,.9705915925D0,.9841245837D0,.9935301723D0,
     $ .9987710073D0,.0162767488D0,.0488129851D0,.0812974955D0/
      DATA (R(KKK),KKK=49,93)/
     $ .1136958501D0,.1459737146D0,.1780968824D0,.2100313105D0,
     $ .2417431561D0,.2731988126D0,.3043649444D0,.3352085229D0,
     $ .3656968614D0,.3957976498D0,.4254789884D0,.4547094222D0,
     $ .4834579739D0,.5116941772D0,.5393881083D0,.5665104186D0,
     $ .5930323648D0,.6189258401D0,.6441634037D0,.6687183100D0,
     $ .6925645366D0,.7156768123D0,.7380306437D0,.7596023411D0,
     $ .7803690438D0,.8003087441D0,.8194003107D0,.8376235112D0,
     $ .8549590334D0,.8713885059D0,.8868945174D0,.9014606353D0,
     $ .9150714231D0,.9277124567D0,.9393703398D0,.9500327178D0,
     $ .9596882914D0,.9683268285D0,.9759391746D0,.9825172636D0,
     $ .9880541263D0,.9925439003D0,.9959818430D0,.9983643759D0,
     $ .9996895039/
        DATA (W(KKK),KKK=1,48)/
     $ .4679139346D0,.3607615730D0,.1713244924D0,.2491470458D0,
     $ .2334925365D0,.2031674267D0,.1600783285D0,.1069393260D0,
     $ .0471753364D0,.1279381953D0,.1258374563D0,.1216704729D0,
     $ .1155056681D0,.1074442701D0,.0976186521D0,.0861901615D0,
     $ .0733464814D0,.0592985849D0,.0442774388D0,.0285313886D0,
     $ .0123412298D0,.0647376968D0,.0644661644D0,.0639242386D0,
     $ .0631141923D0,.0620394232D0,.0607044392D0,.0591148397D0,
     $ .0572772921D0,.0551995037D0,.0528901894D0,.0503590356D0,
     $ .0476166585D0,.0446745609D0,.0415450829D0,.0382413511D0,
     $ .0347772226D0,.0311672278D0,.0274265097D0,.0235707608D0,
     $ .0196161605D0,.0155793157D0,.0114772346D0,.0073275539D0,
     $ .0031533461D0,.0325506145D0,.0325161187D0,.0324471637D0/
      DATA (W(KKK),KKK=49,93)/
     $ .0323438226D0,.0322062048D0,.0320344562D0,.0318287589D0,
     $ .0315893308D0,.0313164256D0,.0310103326D0,.0306713761D0,
     $ .0302999154D0,.0298963441D0,.0294610900D0,.0289946142D0,
     $ .0284974111D0,.0279700076D0,.0274129627D0,.0268268667D0,
     $ .0262123407D0,.0255700360D0,.0249006332D0,.0242048418D0,
     $ .0234833991D0,.0227370697D0,.0219666444D0,.0211729399D0,
     $ .0203567972D0,.0195190811D0,.0186606796D0,.0177825023D0,
     $ .0168854799D0,.0159705629D0,.0150387210D0,.0140909418D0,
     $ .0131282296D0,.0121516047D0,.0111621020D0,.0101607705D0,
     $ .0091486712D0,.0081268769D0,.0070964708D0,.0060585455D0,
     $ .0050142027D0,.0039645543D0,.0029107318D0,.0018539608D0,
     $ .0007967921/
C
      DATA TOLABS,TOLREL,TOLBIN,NMAX/1.D-35,5.D-5,1D-5,100/
C
      SSDINT=0
      NLIMS=2
      XLIMS(1)=XL
      XLIMS(2)=XR
      ICOUNT=0
      IBAD=0
      XMIN=TOLBIN*ABS(XR-XL)
C
10    AA=(XLIMS(NLIMS)-XLIMS(NLIMS-1))/2
      BB=(XLIMS(NLIMS)+XLIMS(NLIMS-1))/2
      TVAL=0
      DO 15 I=1,3
15    TVAL=TVAL+W(I)*(F(BB+AA*R(I))+F(BB-AA*R(I)))
      TVAL=TVAL*AA
      DO 25 J=1,4
        VAL=0
        DO 20 I=PTR(J),PTR(J)-1+NORD(J)
          ICOUNT=ICOUNT+1
          IF(ICOUNT.GT.1E5) THEN
            WRITE(LOUT,*) 'ERROR IN SSDINT: SET SSDINT = 0'
            SSDINT=0.
            RETURN
          ENDIF
20      VAL=VAL+W(I)*(F(BB+AA*R(I))+F(BB-AA*R(I)))
        VAL=VAL*AA
        TOL=MAX(TOLABS,TOLREL*ABS(VAL))
        IF(ABS(TVAL-VAL).LT.TOL) THEN
          SSDINT=SSDINT+VAL
          NLIMS=NLIMS-2
          IF (NLIMS.NE.0) GO TO 10
          GO TO 999
        ELSEIF(ABS(AA).LT.XMIN.AND.J.EQ.4) THEN
C           Bin is too small -- set VAL = 0. -- FEP
          IBAD=IBAD+1
          NLIMS=NLIMS-2
          IF (NLIMS.NE.0) GO TO 10
          GO TO 999
        ENDIF
25    TVAL=VAL
      IF(NMAX.EQ.2) THEN
        SSDINT=VAL
        GO TO 999
      ENDIF
      IF(NLIMS.GT.(NMAX-2)) THEN
        WRITE(LOUT,50) SSDINT,NMAX,BB-AA,BB+AA
50      FORMAT (' ERROR IN SSDINT, SSDINT,NMAX,XL,XR=',G15.7,I5,2G15.7)
        RETURN
      ENDIF
      XLIMS(NLIMS+1)=BB
      XLIMS(NLIMS+2)=BB+AA
      XLIMS(NLIMS)=BB
      NLIMS=NLIMS+2
      GO TO 10
C
999   IF(IBAD.GT.0) THEN
        WRITE(LOUT,*) 'WARNING IN SSDINT: BAD CONVERGENCE FOR ',IBAD,
     $  ' INTERVALS.'
      ENDIF
      RETURN
      END
+EOD
+DECK,SSDLAM
        DOUBLE PRECISION FUNCTION SSDLAM(A,B,C)
C-----------------------------------------------------------------------
C          Kinematic function
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
        DOUBLE PRECISION A,B,C
C            Rewrite SSDLAM=A**2+B**2+C**2-2*A*B-2*A*C-2*B*C
        IF(A.GE.B.AND.A.GE.C) THEN
          SSDLAM=(A-B-C)**2-4*B*C
        ELSEIF(B.GE.A.AND.B.GE.C) THEN
          SSDLAM=(B-A-C)**2-4*A*C
        ELSE
          SSDLAM=(C-A-B)**2-4*A*B
        ENDIF
        RETURN
        END
+EOD
+DECK,SSF0
      COMPLEX*16 FUNCTION SSF0(XQSQ,XM1,XM2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL XQSQ,XM1,XM2
      DOUBLE PRECISION QSQ,M1,M2,M1SQ,M2SQ,AQSQ,RE,XI,R
      DOUBLE PRECISION PI,T1,T2,BETA,XL,T
      DATA PI/3.14159265359D0/
      QSQ=XQSQ
      M1=XM1
      M2=XM2
      M1SQ=M1*M1
      M2SQ=M2*M2
      AQSQ=ABS(QSQ)
      IF(AQSQ.LT.1.D-6*(M1SQ+M2SQ)) THEN
        IF(ABS(M1-M2).LT.1.D-6*M1) THEN
          IF(M1SQ.LT.1.D-8) THEN
            RE=LOG(1.D-8)
          ELSE
            RE=LOG(M1SQ)+.5*(M2SQ/M1SQ-1.D0) -QSQ/(6.*M1SQ)
          ENDIF
        ELSE
          IF(M2SQ.LT.1.D-6*M1SQ) THEN
            RE=LOG(M1SQ)-1.D0
          ELSE IF(M1SQ.LT.1.D-6*M2SQ) THEN
            RE=LOG(M2SQ)-1.D0
          ELSEIF(M1SQ.GE.1.D-9*M2SQ) THEN
            RE=LOG(M1*M2)+(M1SQ+M2SQ)/(M1SQ-M2SQ)*LOG(M1/M2)-1.D0
     $      -QSQ*(.5*(M1SQ+M2SQ)-M1SQ*M2SQ*LOG(M2SQ/M1SQ)/(M2SQ-M1SQ))
     $      /(M1SQ-M2SQ)**2
          ENDIF
        ENDIF
        XI=0.D0
      ELSE
        IF(M1SQ.LT.1.D-6*AQSQ.OR.M2SQ.LT.1.D-6*AQSQ.OR.
     $  M1SQ+M2SQ.LT.1.D-5*AQSQ) THEN
          IF(M1SQ.LT.1.D-6*AQSQ) THEN
            R=M2SQ/QSQ
          ELSE
            R=M1SQ/QSQ
          ENDIF
          IF(ABS(R-1.D0).GT.1.D-6.AND.ABS(R).GT.1.D-6.AND.
     $    M1SQ+M2SQ.GT.1.D-5*AQSQ) THEN
            RE=LOG(R*QSQ)-2.D0+(1.D0-R)*LOG(ABS(1.D0-1.D0/R))
          ELSE
            RE=-2.D0+LOG(AQSQ)
          ENDIF
          IF(R.LT.1.D0.AND.R.GT.-1.D-10) THEN
            XI=-PI*(1.D0-R)
          ELSE
            XI=0.D0
          ENDIF
        ELSE
          T1=(M1-M2)*(M1-M2)
          T2=T1+4.0*M1*M2
          BETA=SQRT(ABS((1.D0-T1/QSQ)*(1.D0-T2/QSQ)))
          IF(QSQ.GT.T2.OR.QSQ.LT.T1) THEN
            XL=.5*BETA*LOG((QSQ*(1.D0+BETA)-M1SQ-M2SQ)/
     $      (QSQ*(1.D0-BETA)-M1SQ-M2SQ))
          ELSE
          T=M1SQ+M2SQ-QSQ
          IF(T.EQ.0.) T=1.D-10
            XL=BETA*ATAN(QSQ*BETA/T)
            IF(T.LT.0.D0) XL = XL + PI*BETA
          ENDIF
          RE=LOG(M1*M2)-(M1SQ-M2SQ)/QSQ*LOG(M2/M1)-2.D0+XL
          IF(QSQ.GT.T2) THEN
            XI=-PI*BETA
          ELSE
            XI=0.D0
          ENDIF
        ENDIF
      ENDIF
      SSF0=RE*(1.D0,0.D0)-XI*(0.D0,1.D0)
      RETURN
      END
+EOD
+DECK,SSF
      COMPLEX*16 FUNCTION SSF(P,M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      COMPLEX*16 SSB0
      DOUBLE PRECISION SSA0,M1SQ,M2SQ,P2
      REAL P,M1,M2
      M1SQ=M1*M1
      M2SQ=M2*M2
      P2=P*P
      SSF=SSA0(M1)-2.*SSA0(M2)-(2.*P2+2.*M1SQ-M2SQ)*SSB0(P**2,M1,M2)
      RETURN
      END
+EOD
+DECK,SSG
      COMPLEX*16 FUNCTION SSG(P,M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      COMPLEX*16 SSB0
      DOUBLE PRECISION SSA0,M1SQ,M2SQ,P2
      REAL P,M1,M2
      M1SQ=M1*M1
      M2SQ=M2*M2
      P2=P*P
      SSG=(P2-M1SQ-M2SQ)*SSB0(P**2,M1,M2)-SSA0(M1)-SSA0(M2)
      RETURN
      END
+EOD
+DECK,SSGLBF
        SUBROUTINE SSGLBF
C-----------------------------------------------------------------------
C
C       This subroutine gives gluino branching fractions to gauginos
C       according to Baer,Barger,Karatas,Tata (Phys.Rev.D36,96(1987)
C       (Now includes gluino->gluon+zino1,2,3,4 loop decays. Jan 1990)
C       Also includes contribution due to non-degenerate t1-t2 stops
C       Also includes contribution due to non-degenerate b_L and b_R
C       Updated to include mixed sbottom states b1 and b2: 10/9/96
C
C       Auxiliary functions are called SSGxyi, where normally x 
C       indicates the SUSY particle, y the SM particle(s), and i is
C       a counter.
C
C       Baer's GLUBF
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
+CDE,SSTYPE
C
      EXTERNAL SSGWQ1,SSGWQ2,SSGZG1,SSGZG2,SSGZG3,SSGZT
      EXTERNAL SSGWT1,SSGWT2,SSGWT3,SSGWT4,SSGWT5,SSGWT6,
     $SSGWT7,SSGWT8
      EXTERNAL SSGX1,SSGX2,SSGX3,SSGX4,SSGX5,SSGX6,SSGX7,SSGX8
     $,SSGX9
      REAL WIDU,WIDD,WIDI,WIDL,WIDR
      REAL SSXINT,SSXLAM,XUPPER,XTCON,SUM,GMQK,C,G,FT,GP
     $,UPPER,GS,FB,TANB,PI,SR2,UPPR,ALF3
      REAL MW1,MW2,SNW1,SNW2,XM,YM,THX,THY,COST,SINT,COSB,SINB
      REAL MZIZ,AUIZ,ADIZ,BUIZ,BDIZ
      REAL WID,SNIZ,FACT
      REAL XT1,XT2,XT3,XT4,XT5,XT6,XT7,XT8,XT9,AL1,AL2,BE1,BE2
      REAL XLL,XRR,XL1R1,XL2R2,XL1R2,XL2R1,XL1L2,XR1R2,XLR1
      REAL XMST1,XMST2,XMST12,XLR2,XMSB1,XMSB2,XMSB12
      REAL BW1,BW2,GT1,GT2,GT1T2,GB1,GB2,GT1B1,GT1B2,GT2B1,GT2B2
      REAL KUL,KUR,KDL,KDR,KCL,KCR,KSL,KSR,KBL,KBR,KT1,KT2
      REAL XKUL,XKUR,XKDL,XKDR,XKSL,XKSR,XKCL,XKCR,XKBL,XKBR,
     $XKT1,XKT2
      REAL XI1UL,XI1UR,XI1DL,XI1DR,XI1SL,XI1SR,XI1CL,XI1CR,
     $XI1BL,XI1BR,XI1T1,XI1T2,XIT1,XIT2
      REAL ALT1,ART1,ALT2,ART2,ALB1,ARB1,ALB2,ARB2
      REAL BETA,AMPL
      INTEGER IZ,ISZI(4),THIZ
      COMPLEX ZONE,ZI,ZAT1(2),ZAT2(2),ZADW1,ZADW2,ZAUW1,ZAUW2
      COMPLEX ZAUIZ,ZADIZ,ZBUIZ,ZBDIZ,Z1(2),Z2(2)
      DOUBLE PRECISION SSALFS
      SAVE ZONE,ZI
      DATA ZONE,ZI/(1.,0.),(0.,1.)/

C
C          Partly duplicated from SSMASS.
C
      AMPL=2.4E18
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      ALF3=SSALFS(DBLE(AMGLSS**2))
      GS=SQRT(4.*PI*ALF3)
      TANB=1./RV2V1
      BETA=ATAN(TANB)
      FB=G*MBQ/SR2/AMW/COS(BETA)
      FT=G*MTQ/SR2/AMW/SIN(BETA)
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
      SNW1=SIGN(1.,AMW1SS)
      SNW2=SIGN(1.,AMW2SS)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
C
      ZADW1=ZI*G*SNW1*SIN(GAMMAR)
      ZAUW1=ZI*G*SIN(GAMMAL)
      ZADW2=ZI*G*SNW2*COS(GAMMAR)*THY
      ZAUW2=ZI*G*COS(GAMMAL)*THX
      BW1=-FT*SNW1*COS(GAMMAR)
      BW2=FT*SNW2*SIN(GAMMAR)*THY
      ZAT1(1)=ZADW1*COST+ZI*BW1*SINT
      ZAT2(1)=ZADW1*SINT-ZI*BW1*COST
      ZAT1(2)=ZADW2*COST+ZI*BW2*SINT
      ZAT2(2)=ZADW2*SINT-ZI*BW2*COST
      C=SSALFS(DBLE(AMGLSS**2))*AMGLSS/8./PI**2
C
C          gluino --> w1 + qk + qb
C
C     Now includes sbottom as well as stop mixing/Yukawa effects
C     as of 3/31/97, thanks to M. Drees
      TMP(1)=MW1
      UPPR=(AMGLSS**2-MW1**2)/2./AMGLSS
      IF (AMGLSS.GT.(MW1+AMUP+AMDN)) THEN
        IF (AMGLSS.LT.AMULSS.AND.AMGLSS.LT.AMDLSS) THEN
          TMP(2)=AMULSS
          WIDU=ZADW1*CONJG(ZADW1)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMDLSS
          WIDD=ZAUW1*CONJG(ZAUW1)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMULSS
          TMP(3)=AMDLSS
          WIDI=-SGNM3*2*REAL(ZAUW1*ZADW1)*SSXINT(0.,SSGWQ2,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*(WIDU+WIDD+WIDI)
        ELSE IF (AMGLSS.LT.AMULSS.AND.AMGLSS.GE.AMDLSS) THEN
          TMP(2)=AMULSS
          WIDU=ZADW1*CONJG(ZADW1)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDU
        ELSE IF (AMGLSS.LT.AMDLSS.AND.AMGLSS.GE.AMULSS) THEN
          TMP(2)=AMDLSS
          WIDD=ZAUW1*CONJG(ZAUW1)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDD
        ELSE
          WID=0.
        END IF
        CALL SSSAVE(ISGL,WID,+ISW1,+IDDN,-IDUP,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*SIN(GAMMAR)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMULSS,Z1,Z2)
        Z1(1)=G*SIN(GAMMAL)*SNW1
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMDLSS,Z1,Z2)
        CALL SSSAVE(ISGL,WID,-ISW1,+IDUP,-IDDN,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*SIN(GAMMAL)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMDLSS,Z1,Z2)
        Z1(1)=G*SIN(GAMMAR)*SNW1
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMULSS,Z1,Z2)
      END IF
C
      IF (AMGLSS.GT.(MW1+AMST+AMCH)) THEN
        IF (AMGLSS.LT.AMCLSS.AND.AMGLSS.LT.AMSLSS) THEN
          TMP(2)=AMCLSS
          WIDU=ZADW1*CONJG(ZADW1)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMSLSS
          WIDD=ZAUW1*CONJG(ZAUW1)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMCLSS
          TMP(3)=AMSLSS
          WIDI=-SGNM3*2*REAL(ZAUW1*ZADW1)*SSXINT(0.,SSGWQ2,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*(WIDU+WIDD+WIDI)
        ELSE IF (AMGLSS.LT.AMCLSS.AND.AMGLSS.GE.AMSLSS) THEN
          TMP(2)=AMCLSS
          WIDU=ZADW1*CONJG(ZADW1)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDU
        ELSE IF (AMGLSS.LT.AMSLSS.AND.AMGLSS.GE.AMCLSS) THEN
          TMP(2)=AMSLSS
          WIDD=ZAUW1*CONJG(ZAUW1)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDD
        ELSE
          WID=0.
        END IF
        CALL SSSAVE(ISGL,WID,+ISW1,+IDST,-IDCH,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*SIN(GAMMAR)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMCLSS,Z1,Z2)
        Z1(1)=G*SIN(GAMMAL)*SNW1
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMSLSS,Z1,Z2)
        CALL SSSAVE(ISGL,WID,-ISW1,+IDCH,-IDST,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*SIN(GAMMAL)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMSLSS,Z1,Z2)
        Z1(1)=G*SIN(GAMMAR)*SNW1
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMCLSS,Z1,Z2)
      END IF
C
      IF (AMGLSS.GT.(MW1+AMTP+AMBT)) THEN
        ALT1=-G*SIN(GAMMAR)*COST+FT*COS(GAMMAR)*SINT
        ART1=-FB*COS(GAMMAL)*COST
        ALT2=-G*SIN(GAMMAR)*SINT-FT*COS(GAMMAR)*COST
        ART2=-FB*COS(GAMMAL)*SINT
        ALB1=-G*SIN(GAMMAL)*COSB+FB*COS(GAMMAL)*SINB
        ARB1=-FT*COS(GAMMAR)*COSB
        ALB2=-G*SIN(GAMMAL)*SINB-FB*COS(GAMMAL)*COSB
        ARB2=-FT*COS(GAMMAR)*SINB
        UPPER=(AMGLSS**2+AMTP**2-(MW1+AMBT)**2)/2./AMGLSS
        FACT=GS**2*PI**2/(2*PI)**5/2./AMGLSS
        TMP(1)=MW1
        TMP(2)=AMGLSS
        TMP(3)=AMTP
        IF (AMGLSS.LT.(AMTP+AMT1SS)) THEN
          TMP(6)=AMT1SS
          TMP(7)=AMT1SS
          GT1=(ALT1**2+ART1**2)*(SSXINT(AMTP,SSGWT1,UPPER)+
     ,        SIN(2*THETAT)*SSXINT(AMTP,SSGWT8,UPPER))
          TMP(7)=AMT2SS
          GT1T2=2*(ALT1*ALT2+ART1*ART2)*(SINT**2-COST**2)*
     ,          SSXINT(AMTP,SSGWT8,UPPER)
        ELSE
          GT1=0.
          GT1T2=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT2SS)) THEN
          TMP(6)=AMT2SS
          TMP(7)=AMT2SS
          GT2=(ALT2**2+ART2**2)*(SSXINT(AMTP,SSGWT1,UPPER)-
     ,        SIN(2*THETAT)*SSXINT(AMTP,SSGWT8,UPPER))
        ELSE
          GT2=0.
        END IF
        IF (AMGLSS.LT.(AMB1SS+AMBT)) THEN
          TMP(4)=AMB1SS
          TMP(8)=SNW1
C          Rewrite UPPR=(AMGLSS**2+AMBT**2-(AMTP+MW1)**2)/2./AMGLSS
          UPPR=((AMGLSS-AMTP-MW1)*(AMGLSS+AMTP+MW1)+AMBT**2)/(2*AMGLSS)
          GB1=(ALB1**2+ARB1**2)*SSXINT(AMBT,SSGWT2,UPPR)-
     ,        ALB1*ARB1*SSXINT(AMBT,SSGWT3,UPPR)
        ELSE
          GB1=0.
        END IF
        IF (AMGLSS.LT.(AMB2SS+AMBT)) THEN
          TMP(4)=AMB2SS
          TMP(8)=SNW1
C          Rewrite UPPR=(AMGLSS**2+AMBT**2-(AMTP+MW1)**2)/2./AMGLSS
          UPPR=((AMGLSS-AMTP-MW1)*(AMGLSS+AMTP+MW1)+AMBT**2)/(2*AMGLSS)
          GB2=(ALB2**2+ARB2**2)*SSXINT(AMBT,SSGWT2,UPPR)-
     ,        ALB2*ARB2*SSXINT(AMBT,SSGWT3,UPPR)
        ELSE
          GB2=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT1SS).AND.AMGLSS.LT.
     $    (AMB1SS+AMBT)) THEN
          TMP(4)=AMB1SS
          TMP(6)=AMT1SS
          TMP(8)=SNW1
          GT1B1=(COST*SINB*ART1*ALB1+SINT*COSB*ALT1*ARB1)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (COST*COSB*ALT1*ALB1+SINT*SINB*ART1*ARB1)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (COST*COSB*ALT1*ARB1+SINT*SINB*ART1*ALB1)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (COST*SINB*ART1*ARB1+SINT*COSB*ALT1*ALB1)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT1B1=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT1SS).AND.AMGLSS.LT.
     $    (AMB2SS+AMBT)) THEN
          TMP(4)=AMB2SS
          TMP(6)=AMT1SS
          TMP(8)=SNW1
          GT1B2=(-COST*COSB*ART1*ALB2+SINT*SINB*ALT1*ARB2)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (COST*SINB*ALT1*ALB2-SINT*COSB*ART1*ARB2)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (COST*SINB*ALT1*ARB2-SINT*COSB*ART1*ALB2)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (-COST*COSB*ART1*ARB2+SINT*SINB*ALT1*ALB2)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT1B2=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT2SS).AND.AMGLSS.LT.
     $    (AMB1SS+AMBT)) THEN
          TMP(4)=AMB1SS
          TMP(6)=AMT2SS
          TMP(8)=SNW1
          GT2B1=(SINT*SINB*ART2*ALB1-COST*COSB*ALT2*ARB1)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (SINT*COSB*ALT2*ALB1-COST*SINB*ART2*ARB1)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (SINT*COSB*ALT2*ARB1-COST*SINB*ART2*ALB1)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (SINT*SINB*ART2*ARB1-COST*COSB*ALT2*ALB1)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT2B1=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT2SS).AND.AMGLSS.LT.
     $    (AMB2SS+AMBT)) THEN
          TMP(4)=AMB2SS
          TMP(6)=AMT2SS
          TMP(8)=SNW1
          GT2B2=(-SINT*COSB*ART2*ALB2-COST*SINB*ALT2*ARB2)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (SINT*SINB*ALT2*ALB2+COST*COSB*ART2*ARB2)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (SINT*SINB*ALT2*ARB2+COST*COSB*ART2*ALB2)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (-SINT*COSB*ART2*ARB2-COST*SINB*ALT2*ALB2)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT2B2=0.
        END IF
        WID=GT1+GT2+GT1T2+GB1+GB2+GT1B1+GT1B2+GT2B1+GT2B2
        WID=FACT*WID
        IF (WID.GT.0.) THEN
        CALL SSSAVE(ISGL,WID,+ISW1,+IDBT,-IDTP,0,0)
        Z1(1)=SINT-COST
        Z1(2)=SINT+COST
        Z2(1)=ALT1+SNW1*ART1
        Z2(2)=ALT1-SNW1*ART1
        CALL SSME3(2,AMT1SS,Z1,Z2)
        Z1(1)=-COST-SINT
        Z1(2)=-COST+SINT
        Z2(1)=ALT2+SNW1*ART2
        Z2(2)=ALT2-SNW1*ART2
        CALL SSME3(2,AMT2SS,Z1,Z2)
        Z1(1)=SNW1*ALB1+ARB1
        Z1(2)=-SNW1*ALB1+ARB1
        Z2(1)=-COSB+SINB
        Z2(2)=-COSB-SINB
        CALL SSME3(3,AMB1SS,Z1,Z2)
        Z1(1)=SNW1*ALB2+ARB2
        Z1(2)=-SNW1*ALB2+ARB2
        Z2(1)=-SINB-COSB
        Z2(2)=-SINB+COSB
        CALL SSME3(3,AMB2SS,Z1,Z2)
        CALL SSSAVE(ISGL,WID,-ISW1,+IDTP,-IDBT,0,0)
        Z1(1)=SINB-COSB
        Z1(2)=SINB+COSB
        Z2(1)=ALB1+SNW1*ARB1
        Z2(2)=ALB1-SNW1*ARB1
        CALL SSME3(2,AMB1SS,Z1,Z2)
        Z1(1)=-COSB-SINB
        Z1(2)=-COSB+SINB
        Z2(1)=ALB2+SNW1*ARB2
        Z2(2)=ALB2-SNW1*ARB2
        CALL SSME3(2,AMB2SS,Z1,Z2)
        Z1(1)=SNW1*ALT1+ART1
        Z1(2)=-SNW1*ALT1+ART1
        Z2(1)=-COST+SINT
        Z2(2)=-COST-SINT
        CALL SSME3(3,AMT1SS,Z1,Z2)
        Z1(1)=SNW1*ALT2+ART2
        Z1(2)=-SNW1*ALT2+ART2
        Z2(1)=-SINT-COST
        Z2(2)=-SINT+COST
        CALL SSME3(3,AMT2SS,Z1,Z2)
        END IF
      END IF
C
C          gluino --> w2 + qk + qb
C
      TMP(1)=MW2
      UPPR=(AMGLSS**2-MW2**2)/2./AMGLSS
      IF (AMGLSS.GT.(MW2+AMUP+AMDN)) THEN
        IF (AMGLSS.LT.AMULSS.AND.AMGLSS.LT.AMDLSS) THEN
          TMP(2)=AMULSS
          WIDU=ZADW2*CONJG(ZADW2)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMDLSS
          WIDD=ZAUW2*CONJG(ZAUW2)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMULSS
          TMP(3)=AMDLSS
          WIDI=-SGNM3*2*REAL(ZAUW2*ZADW2)*SSXINT(0.,SSGWQ2,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*(WIDU+WIDD+WIDI)
        ELSE IF (AMGLSS.LT.AMULSS.AND.AMGLSS.GE.AMDLSS) THEN
          TMP(2)=AMULSS
          WIDU=ZADW2*CONJG(ZADW2)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDU
        ELSE IF (AMGLSS.LT.AMDLSS.AND.AMGLSS.GE.AMULSS) THEN
          TMP(2)=AMDLSS
          WIDD=ZAUW2*CONJG(ZAUW2)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDD
        ELSE
          WID=0.
        END IF
        CALL SSSAVE(ISGL,WID,+ISW2,+IDDN,-IDUP,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*THY*COS(GAMMAR)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMULSS,Z1,Z2)
        Z1(1)=G*THX*COS(GAMMAL)*SNW2
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMDLSS,Z1,Z2)
        CALL SSSAVE(ISGL,WID,-ISW2,+IDUP,-IDDN,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*THX*COS(GAMMAL)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMDLSS,Z1,Z2)
        Z1(1)=G*THY*COS(GAMMAR)*SNW2
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMULSS,Z1,Z2)
      END IF
C
      IF (AMGLSS.GT.(MW2+AMST+AMCH)) THEN
        IF (AMGLSS.LT.AMCLSS.AND.AMGLSS.LT.AMSLSS) THEN
          TMP(2)=AMCLSS
          WIDU=ZADW2*CONJG(ZADW2)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMSLSS
          WIDD=ZAUW2*CONJG(ZAUW2)*SSXINT(0.,SSGWQ1,UPPR)
          TMP(2)=AMCLSS
          TMP(3)=AMSLSS
          WIDI=-SGNM3*2*REAL(ZAUW2*ZADW2)*SSXINT(0.,SSGWQ2,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*(WIDU+WIDD+WIDI)
        ELSE IF (AMGLSS.LT.AMCLSS.AND.AMGLSS.GE.AMSLSS) THEN
          TMP(2)=AMCLSS
          WIDU=ZADW2*CONJG(ZADW2)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDU
        ELSE IF (AMGLSS.LT.AMSLSS.AND.AMGLSS.GE.AMCLSS) THEN
          TMP(2)=AMSLSS
          WIDD=ZAUW2*CONJG(ZAUW2)*SSXINT(0.,SSGWQ1,UPPR)
          WID=GS**2/2./AMGLSS/(2*PI)**5*WIDD
        ELSE
          WID=0.
        END IF
        CALL SSSAVE(ISGL,WID,+ISW2,+IDST,-IDCH,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*THY*COS(GAMMAR)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMCLSS,Z1,Z2)
        Z1(1)=G*THX*COS(GAMMAL)*SNW2
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMSLSS,Z1,Z2)
        CALL SSSAVE(ISGL,WID,-ISW2,+IDCH,-IDST,0,0)
        Z1(1)=1.
        Z1(2)=-Z1(1)
        Z2(1)=G*THX*COS(GAMMAL)
        Z2(2)=Z2(1)
        CALL SSME3(2,AMSLSS,Z1,Z2)
        Z1(1)=G*THY*COS(GAMMAR)*SNW2
        Z1(2)=-Z1(1)
        Z2(1)=1.
        Z2(2)=Z2(1)
        CALL SSME3(3,AMCLSS,Z1,Z2)
      END IF
C
      IF (AMGLSS.GT.(MW2+AMTP+AMBT)) THEN
        ALT1=-G*THY*COS(GAMMAR)*COST-FT*THY*SIN(GAMMAR)*SINT
        ART1=FB*THX*SIN(GAMMAL)*COST
        ALT2=-G*THY*COS(GAMMAR)*SINT+FT*THY*SIN(GAMMAR)*COST
        ART2=FB*THX*SIN(GAMMAL)*SINT
        ALB1=-G*THX*COS(GAMMAL)*COSB-FB*THX*SIN(GAMMAL)*SINB
        ARB1=FT*THY*SIN(GAMMAR)*COSB
        ALB2=-G*THX*COS(GAMMAL)*SINB+FB*THX*SIN(GAMMAL)*COSB
        ARB2=FT*THY*SIN(GAMMAR)*SINB
        UPPER=(AMGLSS**2+AMTP**2-(MW2+AMBT)**2)/2./AMGLSS
        FACT=GS**2*PI**2/(2*PI)**5/2./AMGLSS
        TMP(1)=MW2
        TMP(2)=AMGLSS
        TMP(3)=AMTP
        IF (AMGLSS.LT.(AMTP+AMT1SS)) THEN
          TMP(6)=AMT1SS
          TMP(7)=AMT1SS
          GT1=(ALT1**2+ART1**2)*(SSXINT(AMTP,SSGWT1,UPPER)+
     ,        SIN(2*THETAT)*SSXINT(AMTP,SSGWT8,UPPER))
          TMP(7)=AMT2SS
          GT1T2=2*(ALT1*ALT2+ART1*ART2)*(SINT**2-COST**2)*
     ,          SSXINT(AMTP,SSGWT8,UPPER)
        ELSE
          GT1=0.
          GT1T2=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT2SS)) THEN
          TMP(6)=AMT2SS
          TMP(7)=AMT2SS
          GT2=(ALT2**2+ART2**2)*(SSXINT(AMTP,SSGWT1,UPPER)-
     ,        SIN(2*THETAT)*SSXINT(AMTP,SSGWT8,UPPER))
        ELSE
          GT2=0.
        END IF
        IF (AMGLSS.LT.(AMB1SS+AMBT)) THEN
          TMP(4)=AMB1SS
          TMP(8)=SNW2
C          Rewrite UPPR=(AMGLSS**2+AMBT**2-(AMTP+MW2)**2)/2./AMGLSS
          UPPR=((AMGLSS-AMTP-MW2)*(AMGLSS+AMTP+MW2)+AMBT**2)/(2*AMGLSS)
          GB1=(ALB1**2+ARB1**2)*SSXINT(AMBT,SSGWT2,UPPR)-
     ,        ALB1*ARB1*SSXINT(AMBT,SSGWT3,UPPR)
        ELSE
          GB1=0.
        END IF
        IF (AMGLSS.LT.(AMB2SS+AMBT)) THEN
          TMP(4)=AMB2SS
          TMP(8)=SNW2
          UPPR=((AMGLSS-AMTP-MW2)*(AMGLSS+AMTP+MW2)+AMBT**2)/(2*AMGLSS)
          GB2=(ALB2**2+ARB2**2)*SSXINT(AMBT,SSGWT2,UPPR)-
     ,        ALB2*ARB2*SSXINT(AMBT,SSGWT3,UPPR)
        ELSE
          GB2=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT1SS).AND.AMGLSS.LT.
     $    (AMB1SS+AMBT)) THEN
          TMP(4)=AMB1SS
          TMP(6)=AMT1SS
          TMP(8)=SNW2
          GT1B1=(COST*SINB*ART1*ALB1+SINT*COSB*ALT1*ARB1)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (COST*COSB*ALT1*ALB1+SINT*SINB*ART1*ARB1)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (COST*COSB*ALT1*ARB1+SINT*SINB*ART1*ALB1)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (COST*SINB*ART1*ARB1+SINT*COSB*ALT1*ALB1)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT1B1=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT1SS).AND.AMGLSS.LT.
     $    (AMB2SS+AMBT)) THEN
          TMP(4)=AMB2SS
          TMP(6)=AMT1SS
          TMP(8)=SNW2
          GT1B2=(-COST*COSB*ART1*ALB2+SINT*SINB*ALT1*ARB2)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (COST*SINB*ALT1*ALB2-SINT*COSB*ART1*ARB2)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (COST*SINB*ALT1*ARB2-SINT*COSB*ART1*ALB2)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (-COST*COSB*ART1*ARB2+SINT*SINB*ALT1*ALB2)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT1B2=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT2SS).AND.AMGLSS.LT.
     $    (AMB1SS+AMBT)) THEN
          TMP(4)=AMB1SS
          TMP(6)=AMT2SS
          TMP(8)=SNW2
          GT2B1=(SINT*SINB*ART2*ALB1-COST*COSB*ALT2*ARB1)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (SINT*COSB*ALT2*ALB1-COST*SINB*ART2*ARB1)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (SINT*COSB*ALT2*ARB1-COST*SINB*ART2*ALB1)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (SINT*SINB*ART2*ARB1-COST*COSB*ALT2*ALB1)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT2B1=0.
        END IF
        IF (AMGLSS.LT.(AMTP+AMT2SS).AND.AMGLSS.LT.
     $    (AMB2SS+AMBT)) THEN
          TMP(4)=AMB2SS
          TMP(6)=AMT2SS
          TMP(8)=SNW2
          GT2B2=(-SINT*COSB*ART2*ALB2-COST*SINB*ALT2*ARB2)*
     ,           SSXINT(AMTP,SSGWT6,UPPER)-
     ,          (SINT*SINB*ALT2*ALB2+COST*COSB*ART2*ARB2)*
     ,           SSXINT(AMTP,SSGWT4,UPPER)+
     ,          (SINT*SINB*ALT2*ARB2+COST*COSB*ART2*ALB2)*
     ,           SSXINT(AMTP,SSGWT5,UPPER)-
     ,          (-SINT*COSB*ART2*ARB2-COST*SINB*ALT2*ALB2)*
     ,           SSXINT(AMTP,SSGWT7,UPPER)
        ELSE
          GT2B2=0.
        END IF
        WID=GT1+GT2+GT1T2+GB1+GB2+GT1B1+GT1B2+GT2B1+GT2B2
        WID=FACT*WID
        IF (WID.GT.0.) THEN
        CALL SSSAVE(ISGL,WID,+ISW2,+IDBT,-IDTP,0,0)
        Z1(1)=SINT-COST
        Z1(2)=SINT+COST
        Z2(1)=ALT1+SNW2*ART1
        Z2(2)=ALT1-SNW2*ART1
        CALL SSME3(2,AMT1SS,Z1,Z2)
        Z1(1)=-COST-SINT
        Z1(2)=-COST+SINT
        Z2(1)=ALT2+SNW2*ART2
        Z2(2)=ALT2-SNW2*ART2
        CALL SSME3(2,AMT2SS,Z1,Z2)
        Z1(1)=SNW2*ALB1+ARB1
        Z1(2)=-SNW2*ALB1+ARB1
        Z2(1)=-COSB+SINB
        Z2(2)=-COSB-SINB
        CALL SSME3(3,AMB1SS,Z1,Z2)
        Z1(1)=SNW2*ALB2+ARB2
        Z1(2)=-SNW2*ALB2+ARB2
        Z2(1)=-SINB-COSB
        Z2(2)=-SINB+COSB
        CALL SSME3(3,AMB2SS,Z1,Z2)
        CALL SSSAVE(ISGL,WID,-ISW2,+IDTP,-IDBT,0,0)
        Z1(1)=SINB-COSB
        Z1(2)=SINB+COSB
        Z2(1)=ALB1+SNW2*ARB1
        Z2(2)=ALB1-SNW2*ARB1
        CALL SSME3(2,AMB1SS,Z1,Z2)
        Z1(1)=-COSB-SINB
        Z1(2)=-COSB+SINB
        Z2(1)=ALB2+SNW2*ARB2
        Z2(2)=ALB2-SNW2*ARB2
        CALL SSME3(2,AMB2SS,Z1,Z2)
        Z1(1)=SNW2*ALT1+ART1
        Z1(2)=-SNW2*ALT1+ART1
        Z2(1)=-COST+SINT
        Z2(2)=-COST-SINT
        CALL SSME3(3,AMT1SS,Z1,Z2)
        Z1(1)=SNW2*ALT2+ART2
        Z1(2)=-SNW2*ALT2+ART2
        Z2(1)=-SINT-COST
        Z2(2)=-SINT+COST
        CALL SSME3(3,AMT2SS,Z1,Z2)
        END IF
      END IF
C
C       gluino --> zi decays, zi = z1, z2, z3, z4
C       the auiz etc, below are Atilde's etc. of PRD 42,1568 (1990)
C
      ISZI(1)=ISZ1
      ISZI(2)=ISZ2
      ISZI(3)=ISZ3
      ISZI(4)=ISZ4
      DO 100 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        AUIZ=G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ)
        ADIZ=-G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ)
        BUIZ=4*GP*ZMIXSS(4,IZ)/3./SR2
        BDIZ=-2*GP/3./SR2*ZMIXSS(4,IZ)
        SNIZ=SIGN(1.,AMZISS(IZ))
        THIZ=0
        IF (AMZISS(IZ).LT.0.) THIZ=1
        ZAUIZ=ZI**(THIZ-1)*SNIZ
     $  *(-G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBUIZ=ZI**(THIZ-1)*4*GP*ZMIXSS(4,IZ)/3./SR2
        ZADIZ=ZI**(THIZ-1)*SNIZ
     $  *(G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBDIZ=-2*ZI**(THIZ-1)*GP*ZMIXSS(4,IZ)/3./SR2
C          Radiative gluino --> gluon + zi loop decay
        IF (AMGLSS.GT.MZIZ) THEN
          IF (AMGLSS.LT.(AMT1SS+AMTP)) THEN
            TMP(1)=AMTP
            TMP(2)=MZIZ
            TMP(3)=AMT1SS
            XIT1=SSXINT(0.,SSGZG1,1.)
            XI1T1=SSXINT(0.,SSGZG2,1.)
            XKT1=SSXINT(0.,SSGZG3,1.)
          ELSE
            XIT1=0.
            XI1T1=0.
            XKT1=0.
          END IF
          IF (AMGLSS.LT.(AMT2SS+AMTP)) THEN
            TMP(1)=AMTP
            TMP(2)=MZIZ
            TMP(3)=AMT2SS
            XIT2=SSXINT(0.,SSGZG1,1.)
            XI1T2=SSXINT(0.,SSGZG2,1.)
            XKT2=SSXINT(0.,SSGZG3,1.)
          ELSE
            XIT2=0.
            XI1T2=0.
            XKT2=0.
          END IF
C         !!! NEEDS UPDATE FOR SBOTTOM MIXING !!!
          IF (AMGLSS.LT.(AMB1SS+AMBT)) THEN
            TMP(1)=AMBT
            TMP(2)=MZIZ
            TMP(3)=AMB1SS
            XI1BL=SSXINT(0.,SSGZG2,1.)
            XKBL=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1BL=0.
            XKBL=0.
          END IF
          IF (AMGLSS.LT.(AMB2SS+AMBT)) THEN
            TMP(1)=AMBT
            TMP(2)=MZIZ
            TMP(3)=AMB2SS
            XI1BR=SSXINT(0.,SSGZG2,1.)
            XKBR=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1BR=0.
            XKBR=0.
          END IF
          IF (AMGLSS.LT.(AMULSS+AMUP)) THEN
            TMP(1)=AMUP
            TMP(2)=MZIZ
            TMP(3)=AMULSS
            XI1UL=SSXINT(0.,SSGZG2,1.)
            XKUL=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1UL=0.
            XKUL=0.
          END IF
          IF (AMGLSS.LT.(AMURSS+AMUP)) THEN
            TMP(1)=AMUP
            TMP(2)=MZIZ
            TMP(3)=AMURSS
            XI1UR=SSXINT(0.,SSGZG2,1.)
            XKUR=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1UR=0.
            XKUR=0.
          END IF
          IF (AMGLSS.LT.(AMDLSS+AMDN)) THEN
            TMP(1)=AMDN
            TMP(2)=MZIZ
            TMP(3)=AMDLSS
            XI1DL=SSXINT(0.,SSGZG2,1.)
            XKDL=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1DL=0.
            XKDL=0.
          END IF
          IF (AMGLSS.LT.(AMDRSS+AMDN)) THEN
            TMP(1)=AMDN
            TMP(2)=MZIZ
            TMP(3)=AMDRSS
            XI1DR=SSXINT(0.,SSGZG2,1.)
            XKDR=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1DR=0.
            XKDR=0.
          END IF
          IF (AMGLSS.LT.(AMSLSS+AMST)) THEN
            TMP(1)=AMST
            TMP(2)=MZIZ
            TMP(3)=AMSLSS
            XI1SL=SSXINT(0.,SSGZG2,1.)
            XKSL=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1SL=0.
            XKSL=0.
          END IF
          IF (AMGLSS.LT.(AMSRSS+AMST)) THEN
            TMP(1)=AMST
            TMP(2)=MZIZ
            TMP(3)=AMSRSS
            XI1SR=SSXINT(0.,SSGZG2,1.)
            XKSR=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1SR=0.
            XKSR=0.
          END IF
          IF (AMGLSS.LT.(AMCLSS+AMCH)) THEN
            TMP(1)=AMCH
            TMP(2)=MZIZ
            TMP(3)=AMCLSS
            XI1CL=SSXINT(0.,SSGZG2,1.)
            XKCL=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1CL=0.
            XKCL=0.
          END IF
          IF (AMGLSS.LT.(AMCRSS+AMCH)) THEN
            TMP(1)=AMCH
            TMP(2)=MZIZ
            TMP(3)=AMCRSS
            XI1CR=SSXINT(0.,SSGZG2,1.)
            XKCR=SSXINT(0.,SSGZG3,1.)
          ELSE
            XI1CR=0.
            XKCR=0.
          END IF
          KUL=AUIZ*(XKUL*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1UL)
          KUR=-BUIZ*(XKUR*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1UR)
          KDL=ADIZ*(XKDL*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1DL)
          KDR=-BDIZ*(XKDR*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1DR)
          KCL=AUIZ*(XKCL*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1CL)
          KCR=-BUIZ*(XKCR*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1CR)
          KSL=ADIZ*(XKSL*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1SL)
          KSR=-BDIZ*(XKSR*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1SR)
          KBL=ADIZ*(XKBL*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1BL)
          KBR=-BDIZ*(XKBR*(MZIZ+SGNM3*SNIZ*AMGLSS)+MZIZ*XI1BR)
          KT1=(MZIZ*(XKT1+XI1T1)*(AUIZ*COST-FT*ZMIXSS(1,IZ)*SINT)
     $      +SGNM3*SNIZ*AMGLSS*XKT1*(AUIZ*COST-FT*ZMIXSS(1,IZ)*SINT)+
     $      SNIZ*AMTP*XIT1*(BUIZ*SINT+FT*ZMIXSS(1,IZ)*COST))*COST+
     $      (MZIZ*(XKT1+XI1T1)*(-BUIZ*SINT-FT*ZMIXSS(1,IZ)*COST)
     $      +SGNM3*SNIZ*AMGLSS*XKT1*(-BUIZ*SINT-FT*ZMIXSS(1,IZ)*COST)-
     $      SNIZ*AMTP*XIT1*(AUIZ*COST-FT*ZMIXSS(1,IZ)*SINT))*SINT
          KT2=(MZIZ*(XKT2+XI1T2)*(AUIZ*SINT+FT*ZMIXSS(1,IZ)*COST)
     $      +SGNM3*SNIZ*AMGLSS*XKT2*(AUIZ*SINT+FT*ZMIXSS(1,IZ)*COST)+
     $      SNIZ*AMTP*XIT2*(-BUIZ*COST+FT*ZMIXSS(1,IZ)*SINT))*SINT+
     $      (-MZIZ*(XKT2+XI1T2)*(BUIZ*COST-FT*ZMIXSS(1,IZ)*SINT)
     $      -SGNM3*SNIZ*AMGLSS*XKT2*(BUIZ*COST-FT*ZMIXSS(1,IZ)*SINT)+
     $      SNIZ*AMTP*XIT2*(AUIZ*SINT+FT*ZMIXSS(1,IZ)*COST))*COST
          SUM=(KUL+KUR+KDL+KDR+KSL+KSR+KCL+KCR+KBL+KBR+KT1+
     $         KT2)**2/AMGLSS**2
          WID=ALF3**2*AMGLSS*(1.-MZIZ**2/AMGLSS**2)/256./PI**3*SUM
          CALL SSSAVE(ISGL,WID,ISZI(IZ),IDGL,0,0,0)
        END IF
C          3 body gluino --> q + qb + zi decay, q=u,d
        UPPR=(AMGLSS**2-MZIZ**2)/2./AMGLSS
        IF (AMGLSS.GT.(MZIZ+2*AMUP)) THEN
          IF (AMGLSS.LT.AMULSS.AND.AMGLSS.LT.AMURSS) THEN
            TMP(1)=MZIZ
            TMP(2)=AMULSS
            TMP(3)=AMULSS
            WIDL=2*AUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            TMP(2)=AMURSS
            TMP(3)=AMURSS
            WIDR=2*BUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            WID=WIDL+WIDR
          ELSE IF (AMGLSS.LT.AMULSS.AND.AMGLSS.GE.AMURSS) THEN
            TMP(2)=AMULSS
            TMP(3)=AMULSS
            WID=2*AUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE IF (AMGLSS.LT.AMURSS.AND.AMGLSS.GE.AMULSS) THEN
            TMP(2)=AMURSS
            TMP(3)=AMURSS
            WID=2*BUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE
            WID=0.
          END IF
          WID=GS**2/AMGLSS/2./(2*PI)**5*WID
          IF (WID.GT.0.) THEN
            CALL SSSAVE(ISGL,WID,ISZI(IZ),IDUP,-IDUP,0,0)
C           Enter decay matrix element info
            Z1(1)=1.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)*(THIZ+1)*AUIZ)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMULSS,Z1,Z2)
            Z1(1)=1.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BUIZ)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMURSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)*(THIZ+1)*AUIZ
            Z1(2)=-Z1(1)
            Z2(1)=1.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMULSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BUIZ
            Z1(2)=Z1(1)
            Z2(1)=1.
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMURSS,Z1,Z2)
          END IF
        END IF
C
        IF (AMGLSS.GT.(MZIZ+2*AMDN)) THEN
          IF (AMGLSS.LT.AMDLSS.AND.AMGLSS.LT.AMDRSS) THEN
            TMP(1)=MZIZ
            TMP(2)=AMDLSS
            TMP(3)=AMDLSS
            WIDL=2*ADIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            TMP(2)=AMDRSS
            TMP(3)=AMDRSS
            WIDR=2*BDIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            WID=WIDL+WIDR
          ELSE IF (AMGLSS.LT.AMDLSS.AND.AMGLSS.GE.AMDRSS) THEN
            TMP(2)=AMDLSS
            TMP(3)=AMDLSS
            WID=2*ADIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE IF (AMGLSS.LT.AMDRSS.AND.AMGLSS.GE.AMDLSS) THEN
            TMP(2)=AMDRSS
            TMP(3)=AMDRSS
            WID=2*BDIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE
            WID=0.
          END IF
          WID=GS**2/AMGLSS/2./(2*PI)**5*WID
          IF (WID.GT.0.) THEN
          CALL SSSAVE(ISGL,WID,ISZI(IZ),IDDN,-IDDN,0,0)
C           Enter decay matrix element info
            Z1(1)=1.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)*(THIZ+1)*ADIZ)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMDLSS,Z1,Z2)
            Z1(1)=1.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BDIZ)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMDRSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)*(THIZ+1)*ADIZ
            Z1(2)=-Z1(1)
            Z2(1)=1.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMDLSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BDIZ
            Z1(2)=Z1(1)
            Z2(1)=1.
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMDRSS,Z1,Z2)
          END IF
        END IF
C          3 body gluino --> q + qb + zi decay, q=s
        IF (AMGLSS.GT.(MZIZ+2*AMST)) THEN
          IF (AMGLSS.LT.AMSLSS.AND.AMGLSS.LT.AMSRSS) THEN
            TMP(1)=MZIZ
            TMP(2)=AMSLSS
            TMP(3)=AMSLSS
            WIDL=2*ADIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            TMP(2)=AMSRSS
            TMP(3)=AMSRSS
            WIDR=2*BDIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            WID=WIDL+WIDR
          ELSE IF (AMGLSS.LT.AMSLSS.AND.AMGLSS.GE.AMSRSS) THEN
            TMP(2)=AMSLSS
            TMP(3)=AMSLSS
            WID=2*ADIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE IF (AMGLSS.LT.AMSRSS.AND.AMGLSS.GE.AMSLSS) THEN
            TMP(2)=AMSRSS
            TMP(3)=AMSRSS
            WID=2*BDIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE
            WID=0.
          END IF
          WID=GS**2/AMGLSS/2./(2*PI)**5*WID
          IF (WID.GT.0.) THEN
          CALL SSSAVE(ISGL,WID,ISZI(IZ),IDST,-IDST,0,0)
C           Enter decay matrix element info
            Z1(1)=1.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)*(THIZ+1)*ADIZ)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMDLSS,Z1,Z2)
            Z1(1)=1.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BDIZ)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMDRSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)*(THIZ+1)*ADIZ
            Z1(2)=-Z1(1)
            Z2(1)=1.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMDLSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BDIZ
            Z1(2)=Z1(1)
            Z2(1)=1.
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMDRSS,Z1,Z2)
          END IF
        END IF
C          3 body gluino --> q + qb + zi decay, q=c
        IF (AMGLSS.GT.(MZIZ+2*AMCH)) THEN
          IF (AMGLSS.LT.AMCLSS.AND.AMGLSS.LT.AMCRSS) THEN
            TMP(1)=MZIZ
            TMP(2)=AMCLSS
            TMP(3)=AMCLSS
            WIDL=2*AUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            TMP(2)=AMCRSS
            TMP(3)=AMCRSS
            WIDR=2*BUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
            WID=WIDL+WIDR
          ELSE IF (AMGLSS.LT.AMCLSS.AND.AMGLSS.GE.AMCRSS) THEN
            TMP(2)=AMCLSS
            TMP(3)=AMCLSS
            WID=2*AUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE IF (AMGLSS.LT.AMCRSS.AND.AMGLSS.GE.AMCLSS) THEN
            TMP(2)=AMCRSS
            TMP(3)=AMCRSS
            WID=2*BUIZ**2*(SSXINT(0.,SSGWQ1,UPPR)+SGNM3*SNIZ*
     $          SSXINT(0.,SSGWQ2,UPPR))
          ELSE
            WID=0.
          END IF
          WID=GS**2/AMGLSS/2./(2*PI)**5*WID
          IF (WID.GT.0.) THEN
          CALL SSSAVE(ISGL,WID,ISZI(IZ),IDCH,-IDCH,0,0)
C           Enter decay matrix element info
            Z1(1)=1.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)*(THIZ+1)*AUIZ)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMULSS,Z1,Z2)
            Z1(1)=1.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BUIZ)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMURSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)*(THIZ+1)*AUIZ
            Z1(2)=-Z1(1)
            Z2(1)=1.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMULSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BUIZ
            Z1(2)=Z1(1)
            Z2(1)=1.
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMURSS,Z1,Z2)
          END IF
        END IF
C          3 body gluino --> q + qb + zi decay, q=b 
        XTCON=ALF3/8./PI**4/AMGLSS
        IF (AMGLSS.GT.(MZIZ+2*AMBT).AND.AMGLSS.LT.
     $     (AMB1SS+AMBT)) THEN
          TMP(1)=AMGLSS
          TMP(2)=AMBT
          TMP(3)=MZIZ
          TMP(4)=AMB1SS
          TMP(5)=AMB1SS
          XUPPER=(AMGLSS**2+AMBT**2-(AMBT+MZIZ)**2)/2./AMGLSS
          XT1=SSXINT(AMBT,SSGX1,XUPPER)
          XT2=SSXINT(AMBT,SSGX2,XUPPER)
          XT3=SSXINT(AMBT,SSGX3,XUPPER)
          XT4=SSXINT(AMBT,SSGX4,XUPPER)
          XT5=SSXINT(AMBT,SSGX5,XUPPER)
          XT6=SSXINT(AMBT,SSGX6,XUPPER)
          XT7=SSXINT(AMBT,SSGX7,XUPPER)
          XT8=SSXINT(AMBT,SSGX8,XUPPER)
          XT9=SSXINT(AMBT,SSGX9,XUPPER)
          AL1=ADIZ*COSB-FB*ZMIXSS(2,IZ)*SINB
          BE1=FB*ZMIXSS(2,IZ)*COSB+BDIZ*SINB
C         ---- here, al2 is (-) al2 of tata notes-----
          AL2=BDIZ*SINB+FB*ZMIXSS(2,IZ)*COSB
          BE2=-FB*ZMIXSS(2,IZ)*SINB+ADIZ*COSB
          XLL=(AL1**2+BE1**2)*XT1-4*AMBT*MZIZ*SNIZ*AL1*
     $     BE1*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL1**2*XT2/AMGLSS/
     $     MZIZ+BE1**2*AMBT**2*XT5)-AL1*BE1*AMBT*(XT4-
     $     MZIZ**2*XT5))
          XRR=(AL2**2+BE2**2)*XT1-4*AMBT*MZIZ*SNIZ*AL2*
     $     BE2*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL2**2*XT2/AMGLSS/
     $     MZIZ+BE2**2*AMBT**2*XT5)-AL2*BE2*AMBT*(XT4-
     $     MZIZ**2*XT5))
          XL1R1=SGNM3*2*AMGLSS*AMBT*((AL1*AL2+BE1*BE2)*SNIZ*AMBT*
     $     MZIZ*XT6-(AL2*BE1+AL1*BE2)*XT7)
          XL2R2=XL1R1
          XL1R2=BE1*BE2*XT8+AL1*AL2*AMBT**2*XT4-AMBT*MZIZ*
     $     SNIZ*(AL1*BE2+AL2*BE1)*XT9
          XL2R1=XL1R2
          XMSB1=COSB**2*XLL+SINB**2*XRR-SINB*COSB*(XL1R1+XL1R2+
     $     XL2R1+XL2R2)
        ELSE
          XMSB1=0.
        END IF
        IF (AMGLSS.GT.(MZIZ+2*AMBT).AND.AMGLSS.LT.
     $     (AMB2SS+AMBT)) THEN
          TMP(1)=AMGLSS
          TMP(2)=AMBT
          TMP(3)=MZIZ
          TMP(4)=AMB2SS
          TMP(5)=AMB2SS
          XUPPER=(AMGLSS**2+AMBT**2-(AMBT+MZIZ)**2)/2./AMGLSS
          XT1=SSXINT(AMBT,SSGX1,XUPPER)
          XT2=SSXINT(AMBT,SSGX2,XUPPER)
          XT3=SSXINT(AMBT,SSGX3,XUPPER)
          XT4=SSXINT(AMBT,SSGX4,XUPPER)
          XT5=SSXINT(AMBT,SSGX5,XUPPER)
          XT6=SSXINT(AMBT,SSGX6,XUPPER)
          XT7=SSXINT(AMBT,SSGX7,XUPPER)
          XT8=SSXINT(AMBT,SSGX8,XUPPER)
          XT9=SSXINT(AMBT,SSGX9,XUPPER)
          AL1=ADIZ*SINB+FB*ZMIXSS(2,IZ)*COSB
          BE1=FB*ZMIXSS(2,IZ)*SINB-BDIZ*COSB
C         ---- here, al2 is (-) al2 of tata notes-----
          AL2=-BDIZ*COSB+FB*ZMIXSS(2,IZ)*SINB
          BE2=FB*ZMIXSS(2,IZ)*COSB+ADIZ*SINB
          XLL=(AL1**2+BE1**2)*XT1-4*AMBT*MZIZ*SNIZ*AL1*
     $     BE1*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL1**2*XT2/AMGLSS/
     $     MZIZ+BE1**2*AMBT**2*XT5)-AL1*BE1*AMBT*(XT4-
     $     MZIZ**2*XT5))
          XRR=(AL2**2+BE2**2)*XT1-4*AMBT*MZIZ*SNIZ*AL2*
     $     BE2*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL2**2*XT2/AMGLSS/
     $     MZIZ+BE2**2*AMBT**2*XT5)-AL2*BE2*AMBT*(XT4-
     $     MZIZ**2*XT5))
          XL1R1=SGNM3*2*AMGLSS*AMBT*((AL1*AL2+BE1*BE2)*SNIZ*AMBT*
     $     MZIZ*XT6-(AL2*BE1+AL1*BE2)*XT7)
          XL2R2=XL1R1
          XL1R2=BE1*BE2*XT8+AL1*AL2*AMBT**2*XT4-AMBT*MZIZ*
     $     SNIZ*(AL1*BE2+AL2*BE1)*XT9
          XL2R1=XL1R2
          XMSB2=SINB**2*XLL+COSB**2*XRR+SINB*COSB*(XL1R1+XL1R2+
     $     XL2R1+XL2R2)
        ELSE
          XMSB2=0.
        END IF
C       ----cross term between b_1 and b_2 graphs -----------
        IF (AMGLSS.GT.(MZIZ+2*AMBT).AND.AMGLSS.LT.
     $     (AMB1SS+AMBT)) THEN
          TMP(1)=AMGLSS
          TMP(2)=AMBT
          TMP(3)=MZIZ
          TMP(4)=AMB1SS
          TMP(5)=AMB2SS
          XUPPER=(AMGLSS**2+AMBT**2-(AMBT+MZIZ)**2)/2./AMGLSS
          XT1=SSXINT(AMBT,SSGX1,XUPPER)
          XT2=SSXINT(AMBT,SSGX2,XUPPER)
          XT3=SSXINT(AMBT,SSGX3,XUPPER)
          XT4=SSXINT(AMBT,SSGX4,XUPPER)
          XT5=SSXINT(AMBT,SSGX5,XUPPER)
          XT6=SSXINT(AMBT,SSGX6,XUPPER)
          XT7=SSXINT(AMBT,SSGX7,XUPPER)
          XT8=SSXINT(AMBT,SSGX8,XUPPER)
          XT9=SSXINT(AMBT,SSGX9,XUPPER)
          AL1=ADIZ*COSB-FB*ZMIXSS(2,IZ)*SINB
          AL2=ADIZ*SINB+FB*ZMIXSS(2,IZ)*COSB
          BE1=FB*ZMIXSS(2,IZ)*COSB+BDIZ*SINB
          BE2=FB*ZMIXSS(2,IZ)*SINB-BDIZ*COSB
          XL1L2=COSB*SINB*(2*(AL1*AL2+BE1*BE2)*XT1-4*SNIZ*AMBT*
     $     MZIZ*(AL1*BE2+AL2*BE1)*XT3+SGNM3*AMGLSS*(2*MZIZ*
     $     SNIZ*(AL1*AL2*XT2/AMGLSS/MZIZ+BE1*BE2*AMBT**2*
     $     XT5)-(AL1*BE2+AL2*BE1)*AMBT*(XT4-MZIZ**2*XT5)))
          AL1=-BDIZ*SINB-FB*ZMIXSS(2,IZ)*COSB
          AL2=BDIZ*COSB-FB*ZMIXSS(2,IZ)*SINB
          BE1=-FB*ZMIXSS(2,IZ)*SINB+ADIZ*COSB
          BE2=FB*ZMIXSS(2,IZ)*COSB+ADIZ*SINB
          XR1R2=-COSB*SINB*(2*(AL1*AL2+BE1*BE2)*XT1+4*SNIZ*AMBT*
     $     MZIZ*(AL1*BE2+AL2*BE1)*XT3+SGNM3*AMGLSS*(2*MZIZ*
     $     SNIZ*(AL1*AL2*XT2/AMGLSS/MZIZ+BE1*BE2*AMBT**2*
     $     XT5)+(AL1*BE2+AL2*BE1)*AMBT*(XT4-MZIZ**2*XT5)))
          AL1=ADIZ*COSB-FB*ZMIXSS(2,IZ)*SINB
          AL2=BDIZ*COSB-FB*ZMIXSS(2,IZ)*SINB
          BE1=FB*ZMIXSS(2,IZ)*COSB+BDIZ*SINB
          BE2=FB*ZMIXSS(2,IZ)*COSB+ADIZ*SINB
          XL1R1=-SGNM3*2*AMGLSS*AMBT*COSB**2*(SNIZ*(AL1*AL2-BE1*BE2)*
     $     AMBT*MZIZ*XT6-(AL2*BE1-AL1*BE2)*XT7)
          XL1R2=COSB**2*(BE1*BE2*XT8-AL1*AL2*AMBT**2*XT4+AMBT*
     $     MZIZ*SNIZ*XT9*(-AL1*BE2+BE1*AL2))
          XLR1=2*(XL1R1+XL1R2)
          AL1=ADIZ*SINB+FB*ZMIXSS(2,IZ)*COSB
          AL2=-BDIZ*SINB-FB*ZMIXSS(2,IZ)*COSB
          BE1=FB*ZMIXSS(2,IZ)*SINB-BDIZ*COSB
          BE2=-FB*ZMIXSS(2,IZ)*SINB+ADIZ*COSB
          TMP(4)=AMB2SS
          TMP(5)=AMB1SS
          XT8=SSXINT(AMBT,SSGX8,XUPPER)
          XT9=SSXINT(AMBT,SSGX9,XUPPER)
          XL1R1=-SGNM3*2*AMGLSS*AMBT*SINB**2*(SNIZ*(-AL1*AL2+BE1*BE2)*
     $     AMBT*MZIZ*XT6+(AL2*BE1-AL1*BE2)*XT7)
          XL1R2=-SINB**2*(BE1*BE2*XT8-AL1*AL2*AMBT**2*XT4+AMBT*
     $     MZIZ*SNIZ*XT9*(-AL1*BE2+BE1*AL2))
          XLR2=2*(XL1R1+XL1R2)
          XMSB12=XL1L2+XR1R2+XLR1+XLR2
        ELSE
          XMSB12=0.
        END IF
        WID=XTCON*(XMSB1+XMSB2+XMSB12)
        IF (WID.GT.0.) THEN
          CALL SSSAVE(ISGL,WID,ISZI(IZ),IDBT,-IDBT,0,0)
          Z1(1)=((ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-
     $           (ZI*ZBDIZ-FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.
          Z1(2)=((-ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-
     $           (ZI*ZBDIZ+FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.
          Z2(1)=(COSB-SINB)/2.
          Z2(2)=-(COSB+SINB)/2.
          CALL SSME3(3,AMB1SS,Z1,Z2)
          Z1(1)=(COSB-SINB)/2.
          Z1(2)=-(COSB+SINB)/2.
          Z2(1)=CONJG((ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-
     $           (ZI*ZBDIZ-FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.
          Z2(2)=-CONJG((-ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-
     $           (ZI*ZBDIZ+FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.
          CALL SSME3(2,AMB1SS,Z1,Z2)
          Z1(1)=((ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+
     $           (ZI*ZBDIZ-FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.
          Z1(2)=((-ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+
     $           (ZI*ZBDIZ+FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.
          Z2(1)=(COSB+SINB)/2.
          Z2(2)=(COSB-SINB)/2.
          CALL SSME3(3,AMB2SS,Z1,Z2)
          Z1(1)=(COSB+SINB)/2.
          Z1(2)=(COSB-SINB)/2.
          Z2(1)=CONJG((ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+
     $           (ZI*ZBDIZ-FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.
          Z2(2)=-CONJG((-ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+
     $           (ZI*ZBDIZ+FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.
          CALL SSME3(2,AMB2SS,Z1,Z2)
        END IF
C          3 body gluino --> q + qb + zi decay, q=t
        IF (AMGLSS.GT.(MZIZ+2*AMTP).AND.AMGLSS.LT.
     $     (AMT1SS+AMTP)) THEN
          TMP(1)=AMGLSS
          TMP(2)=AMTP
          TMP(3)=MZIZ
          TMP(4)=AMT1SS
          TMP(5)=AMT1SS
          XUPPER=(AMGLSS**2+AMTP**2-(AMTP+MZIZ)**2)/2./AMGLSS
          XT1=SSXINT(AMTP,SSGX1,XUPPER)
          XT2=SSXINT(AMTP,SSGX2,XUPPER)
          XT3=SSXINT(AMTP,SSGX3,XUPPER)
          XT4=SSXINT(AMTP,SSGX4,XUPPER)
          XT5=SSXINT(AMTP,SSGX5,XUPPER)
          XT6=SSXINT(AMTP,SSGX6,XUPPER)
          XT7=SSXINT(AMTP,SSGX7,XUPPER)
          XT8=SSXINT(AMTP,SSGX8,XUPPER)
          XT9=SSXINT(AMTP,SSGX9,XUPPER)
          AL1=AUIZ*COST-FT*ZMIXSS(1,IZ)*SINT
          BE1=FT*ZMIXSS(1,IZ)*COST+BUIZ*SINT
C         ---- here, al2 is (-) al2 of tata notes-----
          AL2=BUIZ*SINT+FT*ZMIXSS(1,IZ)*COST
          BE2=-FT*ZMIXSS(1,IZ)*SINT+AUIZ*COST
          XLL=(AL1**2+BE1**2)*XT1-4*AMTP*MZIZ*SNIZ*AL1*
     $     BE1*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL1**2*XT2/AMGLSS/
     $     MZIZ+BE1**2*AMTP**2*XT5)-AL1*BE1*AMTP*(XT4-
     $     MZIZ**2*XT5))
          XRR=(AL2**2+BE2**2)*XT1-4*AMTP*MZIZ*SNIZ*AL2*
     $     BE2*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL2**2*XT2/AMGLSS/
     $     MZIZ+BE2**2*AMTP**2*XT5)-AL2*BE2*AMTP*(XT4-
     $     MZIZ**2*XT5))
          XL1R1=SGNM3*2*AMGLSS*AMTP*((AL1*AL2+BE1*BE2)*SNIZ*AMTP*
     $     MZIZ*XT6-(AL2*BE1+AL1*BE2)*XT7)
          XL2R2=XL1R1
          XL1R2=BE1*BE2*XT8+AL1*AL2*AMTP**2*XT4-AMTP*MZIZ*
     $     SNIZ*(AL1*BE2+AL2*BE1)*XT9
          XL2R1=XL1R2
          XMST1=COST**2*XLL+SINT**2*XRR-SINT*COST*(XL1R1+XL1R2+
     $     XL2R1+XL2R2)
        ELSE
          XMST1=0.
        END IF
        IF (AMGLSS.GT.(MZIZ+2*AMTP).AND.AMGLSS.LT.
     $     (AMT2SS+AMTP)) THEN
          TMP(1)=AMGLSS
          TMP(2)=AMTP
          TMP(3)=MZIZ
          TMP(4)=AMT2SS
          TMP(5)=AMT2SS
          XUPPER=(AMGLSS**2+AMTP**2-(AMTP+MZIZ)**2)/2./AMGLSS
          XT1=SSXINT(AMTP,SSGX1,XUPPER)
          XT2=SSXINT(AMTP,SSGX2,XUPPER)
          XT3=SSXINT(AMTP,SSGX3,XUPPER)
          XT4=SSXINT(AMTP,SSGX4,XUPPER)
          XT5=SSXINT(AMTP,SSGX5,XUPPER)
          XT6=SSXINT(AMTP,SSGX6,XUPPER)
          XT7=SSXINT(AMTP,SSGX7,XUPPER)
          XT8=SSXINT(AMTP,SSGX8,XUPPER)
          XT9=SSXINT(AMTP,SSGX9,XUPPER)
          AL1=AUIZ*SINT+FT*ZMIXSS(1,IZ)*COST
          BE1=FT*ZMIXSS(1,IZ)*SINT-BUIZ*COST
C         ---- here, al2 is (-) al2 of tata notes-----
          AL2=-BUIZ*COST+FT*ZMIXSS(1,IZ)*SINT
          BE2=FT*ZMIXSS(1,IZ)*COST+AUIZ*SINT
          XLL=(AL1**2+BE1**2)*XT1-4*AMTP*MZIZ*SNIZ*AL1*
     $     BE1*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL1**2*XT2/AMGLSS/
     $     MZIZ+BE1**2*AMTP**2*XT5)-AL1*BE1*AMTP*(XT4-
     $     MZIZ**2*XT5))
          XRR=(AL2**2+BE2**2)*XT1-4*AMTP*MZIZ*SNIZ*AL2*
     $     BE2*XT3+SGNM3*AMGLSS*(SNIZ*MZIZ*(AL2**2*XT2/AMGLSS/
     $     MZIZ+BE2**2*AMTP**2*XT5)-AL2*BE2*AMTP*(XT4-
     $     MZIZ**2*XT5))
          XL1R1=SGNM3*2*AMGLSS*AMTP*((AL1*AL2+BE1*BE2)*SNIZ*AMTP*
     $     MZIZ*XT6-(AL2*BE1+AL1*BE2)*XT7)
          XL2R2=XL1R1
          XL1R2=BE1*BE2*XT8+AL1*AL2*AMTP**2*XT4-AMTP*MZIZ*
     $     SNIZ*(AL1*BE2+AL2*BE1)*XT9
          XL2R1=XL1R2
          XMST2=SINT**2*XLL+COST**2*XRR+SINT*COST*(XL1R1+XL1R2+
     $     XL2R1+XL2R2)
        ELSE
          XMST2=0.
        END IF
C       ----cross term between t_1 and t_2 graphs -----------
        IF (AMGLSS.GT.(MZIZ+2*AMTP).AND.AMGLSS.LT.
     $     (AMT1SS+AMTP)) THEN
          TMP(1)=AMGLSS
          TMP(2)=AMTP
          TMP(3)=MZIZ
          TMP(4)=AMT1SS
          TMP(5)=AMT2SS
          XUPPER=(AMGLSS**2+AMTP**2-(AMTP+MZIZ)**2)/2./AMGLSS
          XT1=SSXINT(AMTP,SSGX1,XUPPER)
          XT2=SSXINT(AMTP,SSGX2,XUPPER)
          XT3=SSXINT(AMTP,SSGX3,XUPPER)
          XT4=SSXINT(AMTP,SSGX4,XUPPER)
          XT5=SSXINT(AMTP,SSGX5,XUPPER)
          XT6=SSXINT(AMTP,SSGX6,XUPPER)
          XT7=SSXINT(AMTP,SSGX7,XUPPER)
          XT8=SSXINT(AMTP,SSGX8,XUPPER)
          XT9=SSXINT(AMTP,SSGX9,XUPPER)
          AL1=AUIZ*COST-FT*ZMIXSS(1,IZ)*SINT
          AL2=AUIZ*SINT+FT*ZMIXSS(1,IZ)*COST
          BE1=FT*ZMIXSS(1,IZ)*COST+BUIZ*SINT
          BE2=FT*ZMIXSS(1,IZ)*SINT-BUIZ*COST
          XL1L2=COST*SINT*(2*(AL1*AL2+BE1*BE2)*XT1-4*SNIZ*AMTP*
     $     MZIZ*(AL1*BE2+AL2*BE1)*XT3+SGNM3*AMGLSS*(2*MZIZ*
     $     SNIZ*(AL1*AL2*XT2/AMGLSS/MZIZ+BE1*BE2*AMTP**2*
     $     XT5)-(AL1*BE2+AL2*BE1)*AMTP*(XT4-MZIZ**2*XT5)))
          AL1=-BUIZ*SINT-FT*ZMIXSS(1,IZ)*COST
          AL2=BUIZ*COST-FT*ZMIXSS(1,IZ)*SINT
          BE1=-FT*ZMIXSS(1,IZ)*SINT+AUIZ*COST
          BE2=FT*ZMIXSS(1,IZ)*COST+AUIZ*SINT
          XR1R2=-COST*SINT*(2*(AL1*AL2+BE1*BE2)*XT1+4*SNIZ*AMTP*
     $     MZIZ*(AL1*BE2+AL2*BE1)*XT3+SGNM3*AMGLSS*(2*MZIZ*
     $     SNIZ*(AL1*AL2*XT2/AMGLSS/MZIZ+BE1*BE2*AMTP**2*
     $     XT5)+(AL1*BE2+AL2*BE1)*AMTP*(XT4-MZIZ**2*XT5)))
          AL1=AUIZ*COST-FT*ZMIXSS(1,IZ)*SINT
          AL2=BUIZ*COST-FT*ZMIXSS(1,IZ)*SINT
          BE1=FT*ZMIXSS(1,IZ)*COST+BUIZ*SINT
          BE2=FT*ZMIXSS(1,IZ)*COST+AUIZ*SINT
          XL1R1=-SGNM3*2*AMGLSS*AMTP*COST**2*(SNIZ*(AL1*AL2-BE1*BE2)*
     $     AMTP*MZIZ*XT6-(AL2*BE1-AL1*BE2)*XT7)
          XL1R2=COST**2*(BE1*BE2*XT8-AL1*AL2*AMTP**2*XT4+AMTP*
     $     MZIZ*SNIZ*XT9*(-AL1*BE2+BE1*AL2))
          XLR1=2*(XL1R1+XL1R2)
          AL1=AUIZ*SINT+FT*ZMIXSS(1,IZ)*COST
          AL2=-BUIZ*SINT-FT*ZMIXSS(1,IZ)*COST
          BE1=FT*ZMIXSS(1,IZ)*SINT-BUIZ*COST
          BE2=-FT*ZMIXSS(1,IZ)*SINT+AUIZ*COST
          TMP(4)=AMT2SS
          TMP(5)=AMT1SS
          XT8=SSXINT(AMTP,SSGX8,XUPPER)
          XT9=SSXINT(AMTP,SSGX9,XUPPER)
          XL1R1=-SGNM3*2*AMGLSS*AMTP*SINT**2*(SNIZ*(-AL1*AL2+BE1*BE2)*
     $     AMTP*MZIZ*XT6+(AL2*BE1-AL1*BE2)*XT7)
          XL1R2=-SINT**2*(BE1*BE2*XT8-AL1*AL2*AMTP**2*XT4+AMTP*
     $     MZIZ*SNIZ*XT9*(-AL1*BE2+BE1*AL2))
          XLR2=2*(XL1R1+XL1R2)
          XMST12=XL1L2+XR1R2+XLR1+XLR2
        ELSE
          XMST12=0.
        END IF
          WID=XTCON*(XMST1+XMST2+XMST12)
        IF (WID.GT.0.) THEN
          CALL SSSAVE(ISGL,WID,ISZI(IZ),IDTP,-IDTP,0,0)
          Z1(1)=((ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*COST-
     $           (ZI*ZBUIZ-FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*SINT)/2.
          Z1(2)=((-ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*COST-
     $           (ZI*ZBUIZ+FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*SINT)/2.
          Z2(1)=(COST-SINT)/2.
          Z2(2)=-(COST+SINT)/2.
          CALL SSME3(3,AMT1SS,Z1,Z2)
          Z1(1)=(COST-SINT)/2.
          Z1(2)=-(COST+SINT)/2.
          Z2(1)=CONJG((ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*COST-
     $           (ZI*ZBUIZ-FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*SINT)/2.
          Z2(2)=-CONJG((-ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*COST-
     $           (ZI*ZBUIZ+FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*SINT)/2.
          CALL SSME3(2,AMT1SS,Z1,Z2)
          Z1(1)=((ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*SINT+
     $           (ZI*ZBUIZ-FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*COST)/2.
          Z1(2)=((-ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*SINT+
     $           (ZI*ZBUIZ+FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*COST)/2.
          Z2(1)=(COST+SINT)/2.
          Z2(2)=(COST-SINT)/2.
          CALL SSME3(3,AMT2SS,Z1,Z2)
          Z1(1)=(COST+SINT)/2.
          Z1(2)=(COST-SINT)/2.
          Z2(1)=CONJG((ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*SINT+
     $           (ZI*ZBUIZ-FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*COST)/2.
          Z2(2)=-CONJG((-ZI*ZAUIZ-FT*ZMIXSS(1,IZ)*ZI**THIZ)*SINT+
     $           (ZI*ZBUIZ+FT*ZMIXSS(1,IZ)*(-ZI)**THIZ)*COST)/2.
          CALL SSME3(2,AMT2SS,Z1,Z2)
        END IF
100   CONTINUE
C
C          gluino --> quark + squark mode
C     
      IF (AMGLSS.GT.(AMULSS+AMUP)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMUP**2/AMGLSS**2-AMULSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMUP**2/AMGLSS**2,AMULSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISUPL,+IDUP,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISUPL,-IDUP,0,0,0)
      END IF
      IF (AMGLSS.GT.(AMDLSS+AMDN)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMDN**2/AMGLSS**2-AMDLSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMDN**2/AMGLSS**2,AMDLSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISDNL,+IDDN,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISDNL,-IDDN,0,0,0)
      END IF
      IF (AMGLSS.GT.(AMURSS+AMUP)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMUP**2/AMGLSS**2-AMURSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMUP**2/AMGLSS**2,AMURSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISUPR,+IDUP,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISUPR,-IDUP,0,0,0)
      END IF
      IF (AMGLSS.GT.(AMDRSS+AMDN)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMDN**2/AMGLSS**2-AMDRSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMDN**2/AMGLSS**2,AMDRSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISDNR,+IDDN,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISDNR,-IDDN,0,0,0)
      END IF
C
      IF (AMGLSS.GT.(AMSLSS+AMST)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMST**2/AMGLSS**2-AMSLSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMST**2/AMGLSS**2,AMSLSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISSTL,+IDST,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISSTL,-IDST,0,0,0)
      END IF
      IF (AMGLSS.GT.(AMSRSS+AMST)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMST**2/AMGLSS**2-AMSRSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMST**2/AMGLSS**2,AMSRSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISSTR,+IDST,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISSTR,-IDST,0,0,0)
      END IF
C     
      IF (AMGLSS.GT.(AMCLSS+AMCH)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMCH**2/AMGLSS**2-AMCLSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMCH**2/AMGLSS**2,AMCLSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISCHL,+IDCH,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISCHL,-IDCH,0,0,0)
      END IF
      IF (AMGLSS.GT.(AMCRSS+AMCH)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMCH**2/AMGLSS**2-AMCRSS**2/AMGLSS**2)*
     $  SQRT(SSXLAM(1.,AMCH**2/AMGLSS**2,AMCRSS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISCHR,+IDCH,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISCHR,-IDCH,0,0,0)
      END IF
C     
      IF (AMGLSS.GT.(AMB1SS+AMBT)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMBT**2/AMGLSS**2-AMB1SS**2/AMGLSS**2+
     $   SGNM3*2*SIN(2*THETAB)*AMBT/AMGLSS)*
     $  SQRT(SSXLAM(1.,AMBT**2/AMGLSS**2,AMB1SS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISBT1,+IDBT,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISBT1,-IDBT,0,0,0)
      END IF
C     
      IF (AMGLSS.GT.(AMB2SS+AMBT)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMBT**2/AMGLSS**2-AMB2SS**2/AMGLSS**2-
     $   SGNM3*2*SIN(2*THETAB)*AMBT/AMGLSS)*
     $  SQRT(SSXLAM(1.,AMBT**2/AMGLSS**2,AMB2SS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISBT2,+IDBT,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISBT2,-IDBT,0,0,0)
      END IF
C     
      IF (AMGLSS.GT.(AMT1SS+AMTP)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMTP**2/AMGLSS**2-AMT1SS**2/AMGLSS**2+
     $   SGNM3*2*SIN(2*THETAT)*AMTP/AMGLSS)*
     $  SQRT(SSXLAM(1.,AMTP**2/AMGLSS**2,AMT1SS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISTP1,+IDTP,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISTP1,-IDTP,0,0,0)
      END IF
C     
      IF (AMGLSS.GT.(AMT2SS+AMTP)) THEN
        GMQK=ALF3*AMGLSS*(1.+AMTP**2/AMGLSS**2-AMT2SS**2/AMGLSS**2-
     $   SGNM3*2*SIN(2*THETAT)*AMTP/AMGLSS)*
     $  SQRT(SSXLAM(1.,AMTP**2/AMGLSS**2,AMT2SS**2/AMGLSS**2))/8.
        CALL SSSAVE(ISGL,GMQK,-ISTP2,+IDTP,0,0,0)
        CALL SSSAVE(ISGL,GMQK,+ISTP2,-IDTP,0,0,0)
      END IF
C
C     Decay to gravitino
C
      IF (AMGLSS.GT.AMGVSS) THEN
        WID=AMGLSS**5/48./PI/(AMGVSS*AMPL)**2
        CALL SSSAVE(ISGL,WID,91,IDGL,0,0,0)
      END IF
C
C          Normalize branching ratios
C
      CALL SSNORM(ISGL)
C
      RETURN
      END
+EOD
+DECK,SSGWQ1
        REAL FUNCTION SSGWQ1(Q)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + qk + qb
C          The function psi of PRD36, 96 (1987); Eq. 3.2
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL Q,PI
        DOUBLE PRECISION MZ,MG,MS,QS,MGS,MSS,MZS,FUN
        PI=4*ATAN(1.)
        MZ=TMP(1)
        MS=TMP(2)
        MG=AMGLSS
        QS=Q*Q
        MGS=MG*MG
        MZS=MZ*MZ
        MSS=MS*MS
        FUN=QS*(MGS-2*MG*Q-MZS)**2/(MGS-2*MG*Q-MSS)**2/(MGS-2*MG*Q)
        SSGWQ1=PI**2*MG*FUN
        RETURN
        END
+EOD
+DECK,SSGWQ2
        REAL FUNCTION SSGWQ2(Q)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + qk + qb
C          The function phi of PRD36, 96 (1987); Eq. 3.2
C          Modified for non-degenerate squarks 4/6/01
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL Q,PI
        DOUBLE PRECISION MZ,MG,MS1,MS2,QS,MGS,MS1S,MS2S,MZS,FUN,TERM
        PI=4*ATAN(1.)
        MZ=TMP(1)
        MS1=TMP(2)
        MS2=TMP(3)
        MG=AMGLSS
        QS=Q*Q
        MGS=MG*MG
        MZS=MZ*MZ
        MS1S=MS1*MS1
        MS2S=MS2*MS2
        TERM=(MS2S*MG-2*MS2S*Q-MG*MZS)/(MG-2*Q)/(MS2S-2*MG*Q-MZS)
        IF (TERM.LE.0.D0) THEN
          SSGWQ2=0.
          RETURN
        ELSE
        FUN=(-Q*(MGS-MZS-2*MG*Q)/(MGS-2*Q*MG)-(2*MG*Q-MS2S+MZS)*
     $   DLOG(TERM)/2.D0/MG)/(MGS-MS1S-2*MG*Q)
        SSGWQ2=PI**2*MG*MZ/2.*FUN
        RETURN
        END IF
        END
+EOD
+DECK,SSGWT1
        REAL FUNCTION SSGWT1(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Baer's FTBW1
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION MWI,MG,MT,DFTBW,PT,ET,MST1,MST2,TOP,BOT
C
        ET=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MST1=TMP(6)
        MST2=TMP(7)
C
C            Rewrite PT=DSQRT(ET**2-MT**2)
        PT=DSQRT((ET-MT)*(ET+MT))
        TOP=(MG**2+MT**2-2*MG*ET-MWI**2)**2*ET*PT
        BOT=(MG**2+MT**2-2*MG*ET-MST1**2)*(MG**2+MT**2-2*MG*ET-
     $      MST2**2)*(MG**2+MT**2-2*ET*MG)
        DFTBW=MG*TOP/BOT
        SSGWT1=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT2
        REAL FUNCTION SSGWT2(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Drees' G_2
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION MWI,MG,MT,DFTBW,EB,TOP,BOT,MSB
        DOUBLE PRECISION SSDLAM,TERM
C
        EB=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MSB=TMP(4)
C
        TOP=EB**2*(MG**2+AMBT**2-2*MG*EB-MWI**2-MT**2)
        BOT=(MG**2+AMBT**2-2*MG*EB-MSB**2)**2*
     $       (MG**2+AMBT**2-2*EB*MG)
        TERM=SSDLAM((MG**2+AMBT**2-2*MG*EB),MWI**2,MT**2)
        IF(TERM.GT.0.D0) THEN
          DFTBW=MG*TOP/BOT*DSQRT(TERM)
        ELSE
          DFTBW=0.D0
        ENDIF
        SSGWT2=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT3
        REAL FUNCTION SSGWT3(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Drees' G_3
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION MWI,MG,MT,EB,BOT,MSB
        DOUBLE PRECISION SSDLAM,TERM,SN,DFTBW
C
        EB=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MSB=TMP(4)
        SN=TMP(8)
C
        
        BOT=(MG**2+AMBT**2-2*MG*EB-MSB**2)**2*
     $       (MG**2+AMBT**2-2*EB*MG)
        TERM=SSDLAM((MG**2+AMBT**2-2*MG*EB),MWI**2,MT**2)
        IF(TERM.GT.0.D0) THEN
          DFTBW=4*MG*MWI*MT*SN*EB*EB/BOT*DSQRT(TERM)
        ELSE
          DFTBW=0.D0
        ENDIF
        SSGWT3=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT4
        REAL FUNCTION SSGWT4(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Baer's FTBW12; EQ. A.3D OF BTW, MODIFIED FOR MB=/0
C          Drees' G_4
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION ET,MWI,MG,MT,MSB,MST,PT,EBMX
        DOUBLE PRECISION BOT,TOP,DFTBW,EBMN,XX
        DOUBLE PRECISION MB,Z,RDL,DEN,R1,R2,R3,SSDLAM,SN
C
        ET=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MSB=TMP(4)
        MST=TMP(6)
        SN=TMP(8)
        MB=AMBT
C
C            Rewrite PT=DSQRT(ET**2-MT**2)
        PT=DSQRT((ET-MT)*(ET+MT))
        Z=(MG**2+MT**2-2*MG*ET+MB**2-MWI**2)/2.
        R1=1.D0+MT**2/MG**2-2.D0*ET/MG
        R2=MB**2/MG**2
        R3=MWI**2/MG**2
        RDL=DSQRT(DMAX1(0.D0,SSDLAM(R1,R2,R3)))
        DEN=MG**2+MT**2-2*ET*MG
        EBMX=(2*Z*(1.D0-ET/MG)+PT*MG*RDL)*MG/2.D0/DEN
        EBMN=(2*Z*(1.D0-ET/MG)-PT*MG*RDL)*MG/2.D0/DEN
        XX=(MSB**2+2*MG*EBMX-MG**2)/(MSB**2+2*MG*EBMN-MG**2)
        TOP=EBMX-EBMN-(MSB**2-2*MG*ET+MT**2-MWI**2)*DLOG(XX)/2.D0/MG
        BOT=(MG**2+MT**2-2*MG*ET-MST**2)
        DFTBW=SGNM3*SN*MG*MWI*TOP/BOT
        SSGWT4=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT5
        REAL FUNCTION SSGWT5(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Baer's FTBW12; EQ. A.3D OF BTW, MODIFIED FOR MB=/0
C          Drees' G_5
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION ET,MWI,MG,MT,MSB,MST,PT,EBMX
        DOUBLE PRECISION BOT,TOP,DFTBW,EBMN,XX
        DOUBLE PRECISION MB,Z,RDL,DEN,R1,R2,R3,SSDLAM
C
        ET=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MSB=TMP(4)
        MST=TMP(6)
        MB=AMBT
C
C            Rewrite PT=DSQRT(ET**2-MT**2)
        PT=DSQRT((ET-MT)*(ET+MT))
        Z=(MG**2+MT**2-2*MG*ET+MB**2-MWI**2)/2.
        R1=1.D0+MT**2/MG**2-2.D0*ET/MG
        R2=MB**2/MG**2
        R3=MWI**2/MG**2
        RDL=DSQRT(DMAX1(0.D0,SSDLAM(R1,R2,R3)))
        DEN=MG**2+MT**2-2*ET*MG
        EBMX=(2*Z*(1.D0-ET/MG)+PT*MG*RDL)*MG/2.D0/DEN
        EBMN=(2*Z*(1.D0-ET/MG)-PT*MG*RDL)*MG/2.D0/DEN
        XX=(MSB**2+2*MG*EBMX-MG**2)/(MSB**2+2*MG*EBMN-MG**2)
        TOP=(MG**2+MT**2-2*MG*ET-MWI**2)*DLOG(XX)
        BOT=MG**2+MT**2-2*MG*ET-MST**2
        DFTBW=SGNM3*MT/2.*TOP/BOT
        SSGWT5=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT6
        REAL FUNCTION SSGWT6(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Baer's FTBW23/Drees' G_6
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION ET,MWI,MG,MT,MSB,MST,PT,EBMX
        DOUBLE PRECISION DEN,T1,DFTBW,EBMN,XX,XL
        DOUBLE PRECISION MB,Z,RDL,DENO,R1,R2,R3,SSDLAM
C
        ET=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MSB=TMP(4)
        MST=TMP(6)
        MB=AMBT
C
C            Rewrite PT=DSQRT(ET**2-MT**2)
        PT=DSQRT((ET-MT)*(ET+MT))
        Z=(MG**2+MT**2-2*MG*ET+MB**2-MWI**2)/2.
        R1=1.D0+MT**2/MG**2-2.D0*ET/MG
        R2=MB**2/MG**2
        R3=MWI**2/MG**2
        RDL=DSQRT(DMAX1(0.D0,SSDLAM(R1,R2,R3)))
        DENO=MG**2+MT**2-2*ET*MG
        EBMX=(2*Z*(1.D0-ET/MG)+PT*MG*RDL)*MG/2.D0/DENO
        EBMN=(2*Z*(1.D0-ET/MG)-PT*MG*RDL)*MG/2.D0/DENO
        XX=(MSB**2+2*MG*EBMX-MG**2)/(MSB**2+2*MG*EBMN-MG**2)
        XL=DLOG(XX)
        DEN=MG**2-2*MG*ET+MT**2-MST**2
        T1=(MG*(MG**2+MT**2-2*MG*ET-MWI**2)-(MSB**2-MG**2)*
     $      (2*ET*MG-MT**2-MG**2)/MG)*XL+2*(2*ET*MG-MT**2-MG**2)*
     $      (EBMX-EBMN)
        DFTBW=.5D0*T1/DEN
        SSGWT6=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT7
        REAL FUNCTION SSGWT7(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Baer's FTBW23/Drees' G_7
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION ET,MWI,MG,MT,MSB,MST,PT,EBMX
        DOUBLE PRECISION DEN,T1,SN,DFTBW,EBMN,XX,XL
        DOUBLE PRECISION MB,Z,RDL,DENO,R1,R2,R3,SSDLAM
C
        ET=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MSB=TMP(4)
        MST=TMP(6)
        SN=TMP(8)
        MB=AMBT
C
C            Rewrite PT=DSQRT(ET**2-MT**2)
        PT=DSQRT((ET-MT)*(ET+MT))
        Z=(MG**2+MT**2-2*MG*ET+MB**2-MWI**2)/2.
        R1=1.D0+MT**2/MG**2-2.D0*ET/MG
        R2=MB**2/MG**2
        R3=MWI**2/MG**2
        RDL=DSQRT(DMAX1(0.D0,SSDLAM(R1,R2,R3)))
        DENO=MG**2+MT**2-2*ET*MG
        EBMX=(2*Z*(1.D0-ET/MG)+PT*MG*RDL)*MG/2.D0/DENO
        EBMN=(2*Z*(1.D0-ET/MG)-PT*MG*RDL)*MG/2.D0/DENO
        XX=(MSB**2+2*MG*EBMX-MG**2)/(MSB**2+2*MG*EBMN-MG**2)
        XL=DLOG(XX)
        DEN=MG**2-2*MG*ET+MT**2-MST**2
        T1=2*(EBMX-EBMN)-(MSB**2-MG**2)*XL/MG
        DFTBW=.5*SN*MWI*MT*T1/DEN
        SSGWT7=DFTBW
        RETURN
        END
+EOD
+DECK,SSGWT8
        REAL FUNCTION SSGWT8(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> wiss + tp + bb
C          Baer's FTBW13/  Drees' G_8
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL E
        DOUBLE PRECISION ET,MWI,MG,MT,MST1,MST2,PT,EBMX,EBMN
        DOUBLE PRECISION TOP,BOT,DFTBW
        DOUBLE PRECISION MB,Z,RDL,DEN,R1,R2,R3,SSDLAM
C
        ET=E
        MWI=TMP(1)
        MG=TMP(2)
        MT=TMP(3)
        MST1=TMP(6)
        MST2=TMP(7)
        MB=AMBT
C
C            Rewrite PT=DSQRT(ET**2-MT**2)
        PT=DSQRT((ET-MT)*(ET+MT))
        Z=(MG**2+MT**2-2*MG*ET+MB**2-MWI**2)/2.
        R1=1.D0+MT**2/MG**2-2.D0*ET/MG
        R2=MB**2/MG**2
        R3=MWI**2/MG**2
        RDL=DSQRT(DMAX1(0.D0,SSDLAM(R1,R2,R3)))
        DEN=MG**2+MT**2-2*ET*MG
        EBMX=(2*Z*(1.D0-ET/MG)+PT*MG*RDL)*MG/2.D0/DEN
        EBMN=(2*Z*(1.D0-ET/MG)-PT*MG*RDL)*MG/2.D0/DEN
        TOP=(MG**2+MT**2-2*MG*ET-MWI**2)*(EBMX-EBMN)
        BOT=(MG**2+MT**2-2*MG*ET-MST1**2)*
     $  (MG**2+MT**2-2*MG*ET-MST2**2)
        DFTBW=SGNM3*MG*MT*TOP/BOT
        SSGWT8=DFTBW
        RETURN
        END
+EOD
+DECK,SSGX10
        REAL FUNCTION SSGX10(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT10
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL MG,MT,MZ,MST1,MST2,ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT10
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM
        DOUBLE PRECISION PI
        DATA PI/3.14159265D0/
        MG=TMP(1)
        MT=TMP(2)
        MZ=TMP(3)
        MST1=TMP(4)
        MST2=TMP(5)
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*ET/MG
        MUT=(MT/MG)**2
        MUZ=(MZ/MG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*MG/2.D0
        EMAX=XMAX*MG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT2**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT2**2
        DXT10=(EMAX-EMIN-(DMG**2-2*DMG*DET+DMT2**2-DMT**2)/2.D0/DMG*
     $      DLOG(TOP/BOT))*PI**2/2.D0/(DMG**2+DMT**2-2*DMG*DET-DMT1**2)
        SSGX10=DXT10
        RETURN
        END
+EOD
+DECK,SSGX11
        REAL FUNCTION SSGX11(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT11
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL MG,MT,MZ,MST1,MST2,ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT11
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM
        DOUBLE PRECISION PI
        DATA PI/3.14159265D0/
        MG=TMP(1)
        MT=TMP(2)
        MZ=TMP(3)
        MST1=TMP(4)
        MST2=TMP(5)
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*ET/MG
        MUT=(MT/MG)**2
        MUZ=(MZ/MG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*MG/2.D0
        EMAX=XMAX*MG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT2**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT2**2
        DXT11=-PI**2*DET*DLOG(TOP/BOT)/2.D0/(DMG**2-2*DMG*DET+DMT**2
     $         -DMT1**2)
        SSGX11=DXT11
        RETURN
        END
+EOD
+DECK,SSGX1
        REAL FUNCTION SSGX1(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT1 - PSI- eq. a.6.a of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP
        DOUBLE PRECISION BOT,PT,DXT1,SSDLAM,PI,TOPS
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        PT=DSQRT(DET**2-DMT**2)
        TOPS=SSDLAM(DMG**2+DMT**2-2*DMG*DET,DMT**2,DMZ**2)
        TOP=DSQRT(DMAX1(0.D0,TOPS))
        BOT=(DMG**2+DMT**2-2*DMG*DET-DMT1**2)*
     $   (DMG**2+DMT**2-2*DMG*DET-DMT2**2)
        DXT1=PI**2*DMG*DET*PT*(DMG**2-DMZ**2-2*DMG*DET)*TOP/BOT/
     $       (DMG**2-2*DMG*DET+DMT**2)
        SSGX1=DXT1
        RETURN
        END
+EOD
+DECK,SSGX2
        REAL FUNCTION SSGX2(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT2 - PHI- eq. a.6.b of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT2
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM,PI
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*DET/DMG
        MUT=(DMT/DMG)**2
        MUZ=(DMZ/DMG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*DMG/2.D0
        EMAX=XMAX*DMG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT2**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT2**2
        DXT2=(-(EMAX-EMIN)-(2*DET*DMG+DMZ**2-DMT**2-DMT2**2)/2.D0/DMG*
     $      DLOG(TOP/BOT))*PI**2/2.D0*DMG*DMZ/
     $      (DMG**2+DMT**2-DMT1**2-2*DMG*DET)
        SSGX2=DXT2
        RETURN
        END
+EOD
+DECK,SSGX3
        REAL FUNCTION SSGX3(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT3 - CHI- eq. a.6.c of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT
        DOUBLE PRECISION PT,DXT3,SSDLAM,PI,TOPS
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        TOPS=SSDLAM(DMG**2+DMT**2-2*DMG*DET,DMT**2,DMZ**2)
        TOP=DSQRT(DMAX1(1.D0,TOPS))
        BOT=(DMG**2+DMT**2-2*DMG*DET-DMT1**2)*
     $      (DMG**2+DMT**2-2*DMG*DET-DMT2**2)
        PT=DSQRT(DET**2-DMT**2)
        DXT3=PI**2*DMG*DET*PT*TOP/BOT/(DMG**2-2*DMG*DET+DMT**2)
        SSGX3=DXT3
        RETURN
        END
+EOD
+DECK,SSGX4
        REAL FUNCTION SSGX4(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT4 - XI- eq. a.6.d of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT4
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM,PI
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*ET/DMG
        MUT=(DMT/DMG)**2
        MUZ=(DMZ/DMG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*DMG/2.D0
        EMAX=XMAX*DMG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT2**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT2**2
        DXT4=(EMAX-EMIN-(DMG**2-2*DMG*DET+DMT2**2-DMT**2)/2.D0/DMG*
     $      DLOG(TOP/BOT))*PI**2/2.D0/(DMG**2+DMT**2-2*DMG*DET-DMT1**2)
        SSGX4=DXT4
        RETURN
        END
+EOD
+DECK,SSGX5
        REAL FUNCTION SSGX5(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT5 - RHO- eq. a.6.e of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT5
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM
        DOUBLE PRECISION PI
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*ET/DMG
        MUT=(DMT/DMG)**2
        MUZ=(DMZ/DMG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*DMG/2.D0
        EMAX=XMAX*DMG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT2**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT2**2
        DXT5=-PI**2*DLOG(TOP/BOT)/2.D0/DMG/(DMG**2-2*DMG*DET+DMT**2
     $         -DMT1**2)
        SSGX5=DXT5
        RETURN
        END
+EOD
+DECK,SSGX6
        REAL FUNCTION SSGX6(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT6 - ZETA- eq. a.6.f of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,T1,T2,DXT6
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM
        DOUBLE PRECISION PI
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*DET/DMG
        MUT=(DMT/DMG)**2
        MUZ=(DMZ/DMG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*DMG/2.D0
        EMAX=XMAX*DMG/2.D0
        T1=DMG**2+DMT**2-2*DMG*DET-DMT1**2
        T2=DMG**2+DMT**2-2*DMG*DET-DMT2**2
        DXT6=PI**2*(EMAX-EMIN)/T1/T2
        SSGX6=DXT6
        RETURN
        END
+EOD
+DECK,SSGX7
        REAL FUNCTION SSGX7(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT7 - X- eq. a.6.g of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP
        DOUBLE PRECISION BOT,PT,DXT7,SSDLAM,PI,TOPS
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        PT=DSQRT(DET**2-DMT**2)
        TOPS=SSDLAM(DMG**2+DMT**2-2*DMG*DET,DMT**2,DMZ**2)
        TOP=DSQRT(DMAX1(0.D0,TOPS))
        BOT=(DMG**2+DMT**2-2*DMG*DET-DMT1**2)*
     $      (DMG**2+DMT**2-2*DMG*DET-DMT2**2)
        DXT7=PI**2/2.D0*PT*(DMG**2-DMZ**2-2*DMG*DET)/
     $      (DMG**2-2*DMG*DET+DMT**2)*TOP/BOT
        SSGX7=DXT7
        RETURN
        END
+EOD
+DECK,SSGX8
        REAL FUNCTION SSGX8(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT8 - Y- eq. a.6.h of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT8
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM
        DOUBLE PRECISION PI
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*DET/DMG
        MUT=(DMT/DMG)**2
        MUZ=(DMZ/DMG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*DMG/2.D0
        EMAX=XMAX*DMG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT2**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT2**2
        DXT8=((EMAX-EMIN)*(DMG**2-2*DMG*DET+DMT**2)+
     $        (DMZ**2*DMG**2-DMT2**2*DMG**2+2*DMT2**2*DMG*DET+DMT**4
     $         -DMT2**2*DMT**2)/2.D0/DMG*DLOG(TOP/BOT))*PI**2/2.D0/
     $         (DMG**2+DMT**2-2*DMG*DET-DMT1**2)
        SSGX8=DXT8
        RETURN
        END
+EOD
+DECK,SSGX9
        REAL FUNCTION SSGX9(ET)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's XT9 - XI'- eq. a.6.i of prd45,142 (1992)
C          Modified for t_1 and t_2 eigenstates
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL ET
        DOUBLE PRECISION DET,DMG,DMT,DMZ,DMT1,DMT2,TOP,BOT,DXT9
        DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX,SSDLAM
        DOUBLE PRECISION PI
        DATA PI/3.14159265D0/
        DET=ET
        DMG=TMP(1)
        DMT=TMP(2)
        DMZ=TMP(3)
        DMT1=TMP(4)
        DMT2=TMP(5)
        XT=2*DET/DMG
        MUT=(DMT/DMG)**2
        MUZ=(DMZ/DMG)**2
        XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT(DMAX1(0.D0,
     $   (XT**2-4*MUT)*SSDLAM((1.D0+MUT-XT),MUT,MUZ))))
     $   /2.D0/(1.D0-XT+MUT)
        EMIN=XMIN*DMG/2.D0
        EMAX=XMAX*DMG/2.D0
        TOP=DMG**2-2*DMG*EMAX+DMT**2-DMT1**2
        BOT=DMG**2-2*DMG*EMIN+DMT**2-DMT1**2
        DXT9=-PI**2*DET*DLOG(TOP/BOT)/2.D0/(DMG**2-2*DMG*DET+DMT**2
     $         -DMT2**2)
        SSGX9=DXT9
        RETURN
        END
+EOD
+DECK,SSGZG1
        REAL FUNCTION SSGZG1(XARG)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + gl
C          Baer's FUNI- removed mass dependence to simplify
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL XARG
        DOUBLE PRECISION TOP,BOT,XX,F,MQ,MX,MS,MG
C
        MQ=TMP(1)
        MX=TMP(2)
        MS=TMP(3)
        MG=AMGLSS
C
        XX=XARG
        TOP=-MG**2*XX*(1.D0-XX)+MS**2*XX+MQ**2*(1.D0-XX)
        BOT=-MX**2*XX*(1.D0-XX)+MS**2*XX+MQ**2*(1.D0-XX)
        F=DLOG(TOP/BOT)/XX
        SSGZG1=F
        RETURN
        END
+EOD
+DECK,SSGZG2
        REAL FUNCTION SSGZG2(XARG)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + gl
C          Baer's FUNI1- removed masses to simplify
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL XARG
        DOUBLE PRECISION TOP,BOT,XX,F,MQ,MX,MS,MG
C
        MQ=TMP(1)
        MX=TMP(2)
        MS=TMP(3)
        MG=AMGLSS
C
        XX=XARG
        TOP=-MG**2*XX*(1.D0-XX)+MS**2*XX+MQ**2*(1.D0-XX)
        BOT=-MX**2*XX*(1.D0-XX)+MS**2*XX+MQ**2*(1.D0-XX)
        F=DLOG(TOP/BOT)
        SSGZG2=F
        RETURN
        END
+EOD
+DECK,SSGZG3
        REAL FUNCTION SSGZG3(XARG)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + gl
C          Baer's FUNK - remove masses to simplify
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL XARG
        DOUBLE PRECISION TOP,BOT,XX,F,MQ,MX,MS,MG
C
        MQ=TMP(1)
        MX=TMP(2)
        MS=TMP(3)
        MG=AMGLSS
C
        XX=XARG
        TOP=-MG**2*XX*(1.D0-XX)+MS**2*XX+MQ**2*(1.D0-XX)
        BOT=-MX**2*XX*(1.D0-XX)+MS**2*XX+MQ**2*(1.D0-XX)
        F=-1.D0-BOT/(MG**2-MX**2)/XX/(1.D0-XX)*DLOG(TOP/BOT)
        SSGZG3=F
        RETURN
        END
+EOD
+DECK,SSGZT
        REAL FUNCTION SSGZT(E)
C-----------------------------------------------------------------------
C          SSGLBF: glss -> ziss + tp + tb
C          Baer's TOPINT
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL E
      DOUBLE PRECISION MG,MT,MS,MZ,SSDLAM,P,PSI,XLOG,PHI,SN,C1,C2
      DOUBLE PRECISION XT,MUT,MUZ,XMIN,XMAX,EMIN,EMAX
C          Convert to double precision
      MG=AMGLSS
      C1=TMP(1)
      C2=TMP(2)
      MS=TMP(3)
      MT=TMP(4)
      MZ=TMP(5)
      SN=TMP(6)
C
      XT=2*E/MG
      MUT=(MT/MG)**2
      MUZ=(MZ/MG)**2
      XMIN=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)-DSQRT((XT**2-4*MUT)*
     $SSDLAM((1.D0+MUT-XT),MUT,MUZ)))/2.D0/(1.D0-XT+MUT)
      XMAX=((2.D0-XT)*(1.D0+2*MUT-MUZ-XT)+DSQRT((XT**2-4*MUT)*
     $SSDLAM((1.D0+MUT-XT),MUT,MUZ)))/2.D0/(1.D0-XT+MUT)
      EMIN=XMIN*MG/2.D0
      EMAX=XMAX*MG/2.D0
      P=SQRT(E**2-MT**2)
      PSI=P*E*(MG**2-MZ**2-2*MG*E)*
     $DSQRT(SSDLAM((MG**2+MT**2-2*MG*E),MZ**2,MT**2))/MG/
     $(MG**2+MT**2-2*MG*E)/(MG**2+MT**2-2*MG*E-MS**2)**2
      XLOG=DLOG((MG**2+MT**2-2*MG*EMAX-MS**2)/
     $(MG**2+MT**2-2*MG*EMIN-MS**2))
      PHI=MZ*(-(EMAX-EMIN)-(2*E*MG+MZ**2-MT**2-MS**2)*
     $XLOG/2.D0/MG)/
     $2.D0/MG/(MG**2+MT**2-MS**2-2*MG*E)
      SSGZT=C1*PSI+SN*C2*PHI
      RETURN
      END
+EOD
+DECK,SSH0
      DOUBLE PRECISION FUNCTION SSH0(M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      DOUBLE PRECISION SSA0,SSB00,M1SQ,M2SQ
      COMPLEX*16 SSB0
      REAL M1,M2
      M1SQ=M1*M1
      M2SQ=M2*M2
C      SSH0=4.D0*(((SSA0(M1)+SSA0(M2))/2.D0+(M1SQ+M2SQ)
C     $*SSB00(M1,M2)+M1SQ+M2SQ)/6.D0)
C     $+(-M1SQ-M2SQ)*SSB00(M1,M2)-SSA0(M1)-SSA0(M2)
      SSH0=4.D0*(((SSA0(M1)+SSA0(M2))/2.D0+(M1SQ+M2SQ)
     $*SSB0(0.,M1,M2)+M1SQ+M2SQ)/6.D0)
     $+(-M1SQ-M2SQ)*SSB0(0.,M1,M2)-SSA0(M1)-SSA0(M2)
      RETURN
      END
+EOD
+DECK,SSH
      COMPLEX*16 FUNCTION SSH(P,M1,M2)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSINF
      COMPLEX*16 SSB0
      DOUBLE PRECISION SSA0,M1SQ,M2SQ,P2
      REAL P,M1,M2
      M1SQ=M1*M1
      M2SQ=M2*M2
      P2=P*P
      SSH=4.D0*(((SSA0(M1)+SSA0(M2))/2.D0*(1.D0,0.D0)
     $+(M1SQ+M2SQ-P2/2.D0)*SSB0(P**2,M1,M2)+(M2SQ-M1SQ)/2.D0/P2
     $*((SSA0(M2)-SSA0(M1))*(1.D0,0.D0)
     $-(M2SQ-M1SQ)*SSB0(P**2,M1,M2))
     $+(M1SQ+M2SQ-P2/3.D0)*(1.D0,0.D0))/6.D0)
     $+(P2-M1SQ-M2SQ)*SSB0(P**2,M1,M2)
     $-(SSA0(M1)+SSA0(M2))*(1.D0,0.D0)
      RETURN
      END
+EOD
+DECK,SSHCC
      SUBROUTINE SSHCC
C-----------------------------------------------------------------------
C     Calculates the decay widths of all neutral Higgses into all
C     possible pairs of charginos.
C
C     Bisset's CHGINO
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTYPE
C
      DOUBLE PRECISION PI,SR2,XM,THETX,YM,THETY,SGL,CGL,SGR,CGR
     $,MW1,MW2,THETM,THETP,G2,GP2,BETA,ALPHA,T1,MH,M1,M2,LAMB
     $,DWID,TEMP,TEMPXY
      DOUBLE PRECISION MHI(3),IDHI(3),SHP(3),SHM(3),SH(3),PH(3)
      DOUBLE PRECISION SSDLAM
      REAL WID
      INTEGER NUMH,IDHHA
C
      PI=4.*ATAN(1.D0)
      SR2=SQRT(2.D0)
      XM=1./TAN(GAMMAL)
      THETX=SIGN(1.D0,XM)
      YM=1./TAN(GAMMAR)
      THETY=SIGN(1.D0,YM)
      SGL=1/(DSQRT(1+XM**2))
      CGL=SGL*XM
      SGR=1/(DSQRT(1+YM**2))
      CGR=SGR*YM
      MW1=DBLE(ABS(AMW1SS))
      MW2=DBLE(ABS(AMW2SS))
      THETM=SIGN(1.,AMW1SS)
      THETP=SIGN(1.,AMW2SS)
      G2=4*PI*ALFAEM/SN2THW
      GP2=4*PI*ALFAEM/(1-SN2THW)
      BETA=ATAN(1.0/RV2V1)
      ALPHA=ALFAH
C
C          Arrays for loops
C
      MHI(1)=AMHL
      MHI(2)=AMHH
      MHI(3)=AMHA
      IDHI(1)=ISHL
      IDHI(2)=ISHH
      IDHI(3)=ISHA
C          The following came from Bisset's MASZIN, but with L,H,P
C          replaced by a generic H and a subscript.
      TEMPXY=0.5*THETX*THETY*(-THETP)
      SHP(1)=SIN(ALPHA)*CGR*SGL+COS(ALPHA)*CGL*SGR
      SHP(1)=SHP(1)*TEMPXY
      SHM(1)=SIN(ALPHA)*SGR*CGL+COS(ALPHA)*SGL*CGR
      SHM(1)=SHM(1)*0.5*THETM
      SH(1)=-THETX*SGR*SGL*SIN(ALPHA)*THETM
      PH(1)=-SH(1)
      T1=THETX*CGL*CGR*COS(ALPHA)*THETM
      SH(1)=SH(1)+T1
      PH(1)=PH(1)-T1
      T1=THETY*SGL*SGR*COS(ALPHA)*THETP
      SH(1)=SH(1)-T1
      PH(1)=PH(1)-T1
      T1=THETY*CGL*CGR*SIN(ALPHA)*THETP
      SH(1)=SH(1)+T1
      PH(1)=PH(1)+T1
      SH(1)=0.5*SH(1)
      PH(1)=0.5*PH(1)
      SHP(2)=COS(ALPHA)*CGR*SGL-SIN(ALPHA)*CGL*SGR
      SHP(2)=SHP(2)*TEMPXY
      SHM(2)=COS(ALPHA)*SGR*CGL-SIN(ALPHA)*SGL*CGR
      SHM(2)=SHM(2)*0.5*THETM
      SH(2)=-THETX*SGR*SGL*COS(ALPHA)*THETM
      PH(2)=-SH(2)
      T1=THETX*CGL*CGR*SIN(ALPHA)*THETM
      SH(2)=SH(2)-T1
      PH(2)=PH(2)+T1
      T1=THETY*SGL*SGR*SIN(ALPHA)*THETP
      SH(2)=SH(2)+T1
      PH(2)=PH(2)+T1
      T1=THETY*CGL*CGR*COS(ALPHA)*THETP
      SH(2)=SH(2)+T1
      PH(2)=PH(2)+T1
      SH(2)=0.5*SH(2)
      PH(2)=0.5*PH(2)
      SHP(3)=SIN(BETA)*CGR*SGL+COS(BETA)*CGL*SGR
      SHP(3)=SHP(3)*0.5*THETX*THETY*(-THETP)
      SHM(3)=SIN(BETA)*SGR*CGL+COS(BETA)*SGL*CGR
      SHM(3)=SHM(3)*0.5*THETM
      SH(3)=-THETX*SGR*SGL*SIN(BETA)*THETM
      PH(3)=-SH(3)
      T1=THETX*CGL*CGR*COS(BETA)*THETM
      SH(3)=SH(3)+T1
      PH(3)=PH(3)-T1
      T1=THETY*SGL*SGR*COS(BETA)*THETP
      SH(3)=SH(3)+T1
      PH(3)=PH(3)+T1
      T1=THETY*CGL*CGR*SIN(BETA)*THETP
      SH(3)=SH(3)-T1
      PH(3)=PH(3)-T1
      SH(3)=0.5*SH(3)
      PH(3)=0.5*PH(3)
C
C          Loop over neutral Higgs
C
      DO 100 NUMH=1,3
        MH=MHI(NUMH)
        IDHHA=IDHI(NUMH)
C          w1 + w1
        M1=ABS(AMW1SS)
        M2=M1
        IF(MH.GT.M1+M2) THEN
          LAMB=SSDLAM(MH**2,M1**2,M2**2)
          TEMP=1-4*M1**2/MH**2
          DWID=G2*MH*SHM(NUMH)**2/(4.0*PI)
          IF (NUMH.EQ.3) THEN
            DWID=DWID*SQRT(TEMP)
          ELSE
            DWID=DWID*SQRT(TEMP**3)
          END IF
          WID=DWID
          CALL SSSAVE(IDHHA,WID,ISW1,-ISW1,0,0,0)
        ENDIF
C          w2 + w2
        M1=ABS(AMW2SS)
        M2=M1
        IF(MH.GT.M1+M2) THEN
          TEMP=1-4*M1**2/MH**2
          DWID=G2*MH*SHP(NUMH)**2/(4*PI)
          IF (NUMH.EQ.3) THEN
            DWID=DWID*SQRT(TEMP)
          ELSE
            DWID=DWID*SQRT(TEMP**3)
          END IF
          WID=DWID
          CALL SSSAVE(IDHHA,WID,ISW2,-ISW2,0,0,0)
        ENDIF
C          w1 + w2
        M1=ABS(AMW1SS)
        M2=ABS(AMW2SS)
        IF(MH.GT.M1+M2) THEN
          LAMB=SSDLAM(MH**2,M1**2,M2**2)
          DWID=PH(NUMH)**2*(MH**2-(M1-M2)**2)
          DWID=DWID+SH(NUMH)**2*(MH**2-(M1+M2)**2)
          DWID=DWID*G2*SQRT(LAMB)/(16.0*PI*(MH**3))
          WID=DWID
          CALL SSSAVE(IDHHA,WID,ISW1,-ISW2,0,0,0)
          CALL SSSAVE(IDHHA,WID,-ISW1,ISW2,0,0,0)
        ENDIF
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SSHFF1
      DOUBLE PRECISION FUNCTION SSHFF1(MH,MF,NUMH)
C-----------------------------------------------------------------------
C     Calculate QCD radiative correction factor, the square brackets
C     in (4.5) of Drees and Hikasa, Phys. Lett. B240, 455 (1990).
C
C     Bisset's QCDRAD (partial)
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
      DOUBLE PRECISION MH,MF
      DOUBLE PRECISION BETA00,LIXX,LI2PP,LI2MM,TEMP,DELTAP,AS,CF
     $,INPOL,PI,ACAP,DELTAH
      DOUBLE PRECISION DDILOG,SSALFS
      INTEGER NUMH
C
      PI=4*ATAN(1.D0)
      BETA00=SQRT(1-4*MF**2/MH**2)
      LIXX=(1-BETA00)/(1+BETA00)
      LI2PP=DDILOG(LIXX)
      LI2MM=DDILOG(-LIXX)
      TEMP=-3*LOG(1/LIXX)*LOG(2/(1+BETA00))
      TEMP=TEMP-2*LOG(BETA00)*LOG(1/LIXX)
      TEMP=TEMP+4*LI2PP+2*LI2MM
      ACAP=(1+BETA00**2)*TEMP
      ACAP=ACAP-3*BETA00*LOG(4/(1-BETA00**2))
      ACAP=ACAP-4*BETA00*LOG(BETA00)       
      IF (NUMH.EQ.3) THEN
         TEMP=19+2*BETA00**2+3*BETA00**4
         TEMP=TEMP*LOG(1/LIXX)/(16*BETA00)
         DELTAP=TEMP+3*(7-BETA00**2)/8
         DELTAP=DELTAP+ACAP/BETA00
       ELSE
         TEMP=3+34*BETA00**2-13*BETA00**4
         TEMP=TEMP*LOG(1/LIXX)/(16*BETA00**3)
         DELTAH=3*(-1+7*BETA00**2)/(8*BETA00**2)
         DELTAH=DELTAH+TEMP+ACAP/BETA00
       ENDIF
       IF (NUMH.EQ.3) THEN
         INPOL=DELTAP+1.5D0*LOG(MH**2/MF**2)
       ELSE
         INPOL=DELTAH+1.5D0*LOG(MH**2/MF**2)
       ENDIF
       AS=SSALFS(MH**2)
       CF=4.D0/3.D0
       SSHFF1=INPOL*CF*AS/PI+1
      RETURN
      END
+EOD
+DECK,SSHFF
      SUBROUTINE SSHFF(IMODEL)
C-----------------------------------------------------------------------
C
C     Calculate all decays higgs -> f fbar, including QCD radiative
C     corrections for quarks.
C
C     Bisset's SETFAC, WDHFFN, QCDRAD
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SUGPAS
C
      DOUBLE PRECISION PI,SR2,DWID,XG2,MHIH,BETA,BEFAC,ALFAC,MH,MF
     $,MFRUN,FACTOR,ALAM,MF1,MF2,SUM,MF1RUN,MF2RUN,COLOR,TEMP1
     $,QCDFAC
      DOUBLE PRECISION MFIFF(9),MFIF1(6),MFIF2(6)
      DOUBLE PRECISION SSDLAM,SSMQCD,SSHFF1
      REAL WID,COSB,MBMA
      INTEGER IH,IDIH,IFF,IDF,ID1,ID2
      INTEGER IDIFF(9),IDIF1(6),IDIF2(6),IMODEL
C
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      BETA=ATAN(1./RV2V1)
      COSB=COS(BETA)
      XG2=4.0*PI*ALFAEM/SN2THW
      MBMA=FBMA*COSB*VEV
C
C          Loop over HL, HH, HA and fermions
C
      MFIFF(1)=AME
      IDIFF(1)=IDE
      MFIFF(2)=AMMU
      IDIFF(2)=IDMU
      MFIFF(3)=AMTAU
      IDIFF(3)=IDTAU
      MFIFF(4)=AMDN
      IDIFF(4)=IDDN
      MFIFF(5)=AMST
      IDIFF(5)=IDST
      MFIFF(6)=AMBT
      IDIFF(6)=IDBT
      MFIFF(7)=AMUP
      IDIFF(7)=IDUP
      MFIFF(8)=AMCH
      IDIFF(8)=IDCH
      MFIFF(9)=AMTP
      IDIFF(9)=IDTP
C
      DO 100 IH=1,3
        IF(IH.EQ.1) THEN
          MH=AMHL
          IDIH=ISHL
          BEFAC=COS(BETA)
          ALFAC=SIN(ALFAH)
        ELSEIF(IH.EQ.2) THEN
          MH=AMHH
          IDIH=ISHH
          BEFAC=COS(BETA)
          ALFAC=COS(ALFAH)
        ELSE
          MH=AMHA
          IDIH=ISHA
          BEFAC=1/TAN(BETA)
          ALFAC=1.
        ENDIF
C
C          Down type fermions
C
        DO 110 IFF=1,6
          MF=MFIFF(IFF)
          IDF=IDIFF(IFF)
          FACTOR=1.-4.*MF**2/MH**2
          IF(FACTOR.LE.0) GO TO 110
          FACTOR=SQRT(FACTOR)
          IF(IFF.GE.4) THEN
             COLOR=3.
             IF (IMODEL.NE.0.AND.IFF.EQ.6.AND.IH.GE.2) THEN
               MFRUN=MBMA
             ELSE
               MFRUN=SSMQCD(MF,MH)
             END IF
             QCDFAC=SSHFF1(MH,MF,IH)
          ELSE
             COLOR=1.
             MFRUN=MF
             QCDFAC=1.
          ENDIF
          DWID=XG2*MFRUN**2*MH*ALFAC**2/(32.*PI*AMW**2*BEFAC**2)
          IF(IH.EQ.1.OR.IH.EQ.2) THEN
            DWID=DWID*FACTOR**3
          ELSEIF(IH.EQ.3) THEN
            DWID=DWID*FACTOR
          ENDIF
          DWID=DWID*COLOR*QCDFAC
          WID=DWID
          CALL SSSAVE(IDIH,WID,IDF,-IDF,0,0,0)
110     CONTINUE
C
C          Up type fermions
C
        IF(IH.EQ.1) THEN
          BEFAC=SIN(BETA)
          ALFAC=COS(ALFAH)
        ELSEIF(IH.EQ.2) THEN
          BEFAC=SIN(BETA)
          ALFAC=SIN(ALFAH)
        ELSE
          BEFAC=TAN(BETA)
          ALFAC=1.
        ENDIF
        DO 120 IFF=7,9
          MF=MFIFF(IFF)
          IDF=IDIFF(IFF)
          FACTOR=1.-4.*MF**2/MH**2
          IF(FACTOR.LE.0) GO TO 120
          FACTOR=SQRT(FACTOR)
          MFRUN=SSMQCD(MF,MH)
          QCDFAC=SSHFF1(MH,MF,IH)
          DWID=XG2*MFRUN**2*MH*ALFAC**2/(32.*PI*AMW**2*BEFAC**2)
          IF(IH.EQ.1.OR.IH.EQ.2) THEN
            DWID=DWID*FACTOR**3
          ELSEIF(IH.EQ.3) THEN
            DWID=DWID*FACTOR
          ENDIF
          DWID=3.*DWID*QCDFAC
          WID=DWID
          CALL SSSAVE(IDIH,WID,IDF,-IDF,0,0,0)
120     CONTINUE
100   CONTINUE
C
C           HC decays. F1 has Iz=+1/2, F2 has Iz=-1/2
C
      MFIF1(1)=0
      IDIF1(1)=IDNE
      MFIF2(1)=AME
      IDIF2(1)=IDE
      MFIF1(2)=0
      IDIF1(2)=IDNM
      MFIF2(2)=AMMU
      IDIF2(2)=IDMU
      MFIF1(3)=0
      IDIF1(3)=IDNT
      MFIF2(3)=AMTAU
      IDIF2(3)=IDTAU
      MFIF1(4)=AMUP
      IDIF1(4)=IDUP
      MFIF2(4)=AMDN
      IDIF2(4)=IDDN
      MFIF1(5)=AMCH
      IDIF1(5)=IDCH
      MFIF2(5)=AMST
      IDIF2(5)=IDST
      MFIF1(6)=AMTP
      IDIF1(6)=IDTP
      MFIF2(6)=AMBT
      IDIF2(6)=IDBT
      MH=AMHC
C
      DO 200 IFF=1,6
        MF1=MFIF1(IFF)
        MF2=MFIF2(IFF)
        ID1=IDIF1(IFF)
        ID2=IDIF2(IFF)
        SUM=MF1+MF2
        ALAM=SSDLAM(MH**2,MF1**2,MF2**2)
        IF(ALAM.LE.0.OR.SUM.GE.MH) GO TO 200
        IF(IFF.LE.3) THEN
          MF1RUN=MF1
          MF2RUN=MF2
          COLOR=1
        ELSE
          MF1RUN=SSMQCD(MF1,MH)
          IF (MF2.EQ.AMBT) THEN
            MF2RUN=MBMA
          ELSE
            MF2RUN=SSMQCD(MF2,MH)
          END IF
          COLOR=3
        ENDIF
        TEMP1=MF1RUN**2*1./TAN(BETA)**2+MF2RUN**2*TAN(BETA)**2
        TEMP1=TEMP1*(MH**2-MF1**2-MF2**2)-4.*MF1**2*MF2**2
        IF (TEMP1.LT.0.0) GO TO 200
        DWID=XG2*COLOR*SQRT(ALAM)*TEMP1/MH**3/(32.0*PI*AMW**2)
        WID=DWID
        CALL SSSAVE(ISHC,WID,ID1,-ID2,0,0,0)
200   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SSHGL
      SUBROUTINE SSHGL
C-----------------------------------------------------------------------
C
C     Calculate H -> gl gl decays including both SM particles and
C     SUSY particles in loop.
C
C     This subroutine uses the tau variable of the Higgs Hunters'
C     Guide.  Many other authors, including the paper cited in 
C     Higgs Hunters' Guide (PR. D. 38(11): 3481) and Collider Physics
C     by Barger and Phillips use the variable lambda
C          LAMBDA = ( MASS OF PARTICLE IN LOOP / MASS OF HIGGS )**2
C          TAU = 4.0 * LAMBDA 
C
C     Bisset's HGLGL
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
C
      DOUBLE PRECISION ETAH,IITOT,RITOT,TAU,IFFF,RFFF
     $,IFHALF,RFHALF,IF1,RF1,IF0,RF0,TW2,RHF,RHSF,RHSFL,RHSFR
     $,IIHF,RIHF,IIHSFL,RIHSFL,IIHSFR,RIHSFR,AS,SUMISQ,DW
     $,RHSF1,RHSF2,IIHSF1,IIHSF2,RIHSF1,RIHSF2
      DOUBLE PRECISION PI,SR2,XM,THETX,YM,THETY,SGL,CGL,SGR,CGR
     $,MW1,MW2,THETM,THETP,G2,BETA,ALPHA,SW2,CW2,MH,AMSQ
      DOUBLE PRECISION MFL(3),MFD(3),MFU(3)
      DOUBLE PRECISION SSALFS
      REAL WID
      INTEGER IJ,II,NUMOUT,NUMH,IDHHA
C
C          Mass matrix parameters
C
      PI=4.*ATAN(1.D0)
      SR2=SQRT(2.D0)
      XM=1./TAN(GAMMAL)
      THETX=SIGN(1.D0,XM)
      YM=1./TAN(GAMMAR)
      THETY=SIGN(1.D0,YM)
      SGL=1/(DSQRT(1+XM**2))
      CGL=SGL*XM
      SGR=1/(DSQRT(1+YM**2))
      CGR=SGR*YM
      MW1=DBLE(ABS(AMW1SS))
      MW2=DBLE(ABS(AMW2SS))
      THETM=SIGN(1.,AMW1SS)
      THETP=SIGN(1.,AMW2SS)
      G2=4.0*PI*ALFAEM/SN2THW
      BETA=ATAN(1.0/RV2V1)
      ALPHA=ALFAH
      SW2=SN2THW
      CW2=1.-SN2THW
C
C          Loop over neutral Higgs bosons
C
      DO 100 NUMH=1,3
        IF(NUMH.EQ.1) THEN
          MH=AMHL
          IDHHA=ISHL
        ELSEIF(NUMH.EQ.2) THEN
          MH=AMHH
          IDHHA=ISHH
        ELSE
          MH=AMHA
          IDHHA=ISHA
        ENDIF
        ETAH=1.0
        IITOT=0.0
        RITOT=0.0
C
C
      MFL(1)=DBLE(AME)
      MFL(2)=DBLE(AMMU)
      MFL(3)=DBLE(AMTAU)
      MFD(1)=DBLE(AMDN)
      MFD(2)=DBLE(AMST)
      MFD(3)=DBLE(MBQ)
      MFU(1)=DBLE(AMUP)
      MFU(2)=DBLE(AMCH)
      MFU(3)=DBLE(MTQ)
C
C
C          Down-type quark loops
C
        DO 20 II=1,3
          TAU=4.0*MFD(II)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IFHALF=0.5*TAU*(1.0-TAU*ETAH)*IFFF
          RFHALF=0.5*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
          IF(NUMH.EQ.1) THEN
            RHF=SIN(ALPHA)/COS(BETA)
          ELSEIF(NUMH.EQ.2) THEN
            RHF=COS(ALPHA)/COS(BETA)
          ELSE
            RHF=TAN(BETA)
          ENDIF
          IIHF=RHF*IFHALF
          RIHF=RHF*RFHALF
          IITOT=IITOT+IIHF
          RITOT=RITOT+RIHF
20      CONTINUE 
C
C          Up-type quark loops
C
        DO 30 II=1,2
          TAU=4.0*MFU(II)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IFHALF=0.5*TAU*(1.0-TAU*ETAH)*IFFF
          RFHALF=0.5*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
          IF(NUMH.EQ.1) THEN
            RHF=COS(ALPHA)/SIN(BETA)
          ELSEIF(NUMH.EQ.2) THEN
            RHF=-SIN(ALPHA)/SIN(BETA)
          ELSE
            RHF=TAN(BETA)
          ENDIF
          IIHF=RHF*IFHALF
          RIHF=RHF*RFHALF
          IITOT=IITOT+IIHF
          RITOT=RITOT+RIHF
30      CONTINUE 
C
        TAU=4.0*MTQ**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IFHALF=0.5*TAU*(1.0-TAU*ETAH)*IFFF
        RFHALF=0.5*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
        IF(NUMH.EQ.1) THEN
          RHF=COS(ALPHA)/SIN(BETA)
        ELSEIF(NUMH.EQ.2) THEN
          RHF=-SIN(ALPHA)/SIN(BETA)
        ELSE
          RHF=1.0/TAN(BETA)
        ENDIF
        IIHF=RHF*IFHALF
        RIHF=RHF*RFHALF
        IITOT=IITOT+IIHF
        RITOT=RITOT+RIHF
C
C          Down-type squark loops
C          Mixing between the sbottom squarks is included, so  
C          masses used here are the mixed masses (AMB1SS & AMB2SS)
C          First do d_L and s_L squarks
        TW2=SW2/CW2
        DO 50 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=2.0*(MFD(II)/AMW)**2*SIN(ALPHA)/COS(BETA)
            RHSFL=(-1.0-TW2/3.0)*SIN(BETA-ALPHA)-RHSF
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=2.0*(MFD(II)/AMW)**2*COS(ALPHA)/COS(BETA)
            RHSFL=(-1.0-TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
          ELSE
            RHSF=0
            RHSFL=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMDLSS
          IF (II.EQ.2) AMSQ=AMSLSS
          TAU=4.0*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFL=RHSFL*IF0*(AMW/AMSQ)**2/8.0
          RIHSFL=RHSFL*RF0*(AMW/AMSQ)**2/8.0
          IITOT=IITOT+IIHSFL
          RITOT=RITOT+RIHSFL
50      CONTINUE
c       Next, do R squarks
        DO 51 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=2.0*(MFD(II)/AMW)**2*SIN(ALPHA)/COS(BETA)
            RHSFR=(-2.0*TW2/3.0)*SIN(BETA-ALPHA)-RHSF
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=2.0*(MFD(II)/AMW)**2*COS(ALPHA)/COS(BETA)
            RHSFR=(-2.0*TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
          ELSE
            RHSF=0
            RHSFR=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMDRSS
          IF (II.EQ.2) AMSQ=AMSRSS
          TAU=4.0*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFR=RHSFR*IF0*(AMW/AMSQ)**2/8.0
          RIHSFR=RHSFR*RF0*(AMW/AMSQ)**2/8.0
          IITOT=IITOT+IIHSFR
          RITOT=RITOT+RIHSFR
51      CONTINUE
        IF(NUMH.EQ.1) THEN
          RHSF=2.0*(MBQ/AMW)**2*SIN(ALPHA)/COS(BETA)
          RHSFL=(-1.0-TW2/3.0)*SIN(BETA-ALPHA)-RHSF
          RHSFR=(-2.0*TW2/3.0)*SIN(BETA-ALPHA)-RHSF
        ELSEIF(NUMH.EQ.2) THEN
          RHSF=2.0*(MBQ/AMW)**2*COS(ALPHA)/COS(BETA)
          RHSFL=(-1.0-TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
          RHSFR=(-2.0*TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
        ELSE
          RHSF=0
          RHSFL=0
          RHSFR=0
        ENDIF
        RHSF1=RHSFL*COS(THETAB)-RHSFR*SIN(THETAB)
        RHSF2=RHSFL*SIN(THETAB)+RHSFR*COS(THETAB)
        TAU=4.0*AMB1SS**2/MH**2 
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)    
        IIHSF1=RHSF1*IF0*(AMW/AMB1SS)**2/8.0
        RIHSF1=RHSF1*RF0*(AMW/AMB1SS)**2/8.0
        IITOT=IITOT+IIHSF1
        RITOT=RITOT+RIHSF1
        TAU=4.0*AMB2SS**2/MH**2 
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)    
        IIHSF2=RHSF2*IF0*(AMW/AMB2SS)**2/8.0
        RIHSF2=RHSF2*RF0*(AMW/AMB2SS)**2/8.0
        IITOT=IITOT+IIHSF2
        RITOT=RITOT+RIHSF2
C
C          Up-type squark loops
C          Mixing between the stop squarks is included, so  
C          masses used here are the mixed masses (AMT1SS & AMT2SS)
C          First do u_L and c_L
        DO 60 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=2.0*(MFU(II)/AMW)**2*COS(ALPHA)/SIN(BETA)
            RHSFL=(1.0-TW2/3.0)*SIN(BETA-ALPHA)-RHSF
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=2.0*(MFU(II)/AMW)**2
            RHSF=RHSF*(-1.0)*SIN(ALPHA)/SIN(BETA)
            RHSFL=(1.0-TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
          ELSE
            RHSF=0
            RHSFL=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMULSS
          IF (II.EQ.2) AMSQ=AMCLSS
          TAU=4.0*(AMSQ)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFL=RHSFL*IF0*(AMW/AMSQ)**2/8.0
          RIHSFL=RHSFL*RF0*(AMW/AMSQ)**2/8.0
          IITOT=IITOT+IIHSFL
          RITOT=RITOT+RIHSFL
60      CONTINUE
C          Next, do u_R and c_R
        DO 61 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=2.0*(MFU(II)/AMW)**2*COS(ALPHA)/SIN(BETA)
            RHSFR=(4.0*TW2/3.0)*SIN(BETA-ALPHA)-RHSF
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=2.0*(MFU(II)/AMW)**2
            RHSF=RHSF*(-1.0)*SIN(ALPHA)/SIN(BETA)
            RHSFR=(4.0*TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
          ELSE
            RHSF=0
            RHSFR=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMURSS
          IF (II.EQ.2) AMSQ=AMCRSS
          TAU=4.0*(AMSQ)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFR=RHSFR*IF0*(AMW/AMSQ)**2/8.0
          RIHSFR=RHSFR*RF0*(AMW/AMSQ)**2/8.0
          IITOT=IITOT+IIHSFR
          RITOT=RITOT+RIHSFR
61      CONTINUE
C
        IF(NUMH.EQ.1) THEN
          RHSF=2.0*(MTQ/AMW)**2*COS(ALPHA)/SIN(BETA)
          RHSFL=(1.0-TW2/3.0)*SIN(BETA-ALPHA)-RHSF
          RHSFR=(4.0*TW2/3.0)*SIN(BETA-ALPHA)-RHSF
        ELSEIF(NUMH.EQ.2) THEN
          RHSF=2.0*(MTQ/AMW)**2
          RHSF=RHSF*(-1.0)*SIN(ALPHA)/SIN(BETA)
          RHSFL=(1.0-TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
          RHSFR=(4.0*TW2/3.0)*(-1.0)*COS(BETA-ALPHA)-RHSF
        ELSE
          RHSF=0
          RHSFL=0
          RHSFR=0
        ENDIF
        RHSF1=RHSFL*COS(THETAT)-RHSFR*SIN(THETAT)
        RHSF2=RHSFL*SIN(THETAT)+RHSFR*COS(THETAT)
        TAU=4.0*AMT1SS**2/MH**2 
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)    
        IIHSF1=RHSF1*IF0*(AMW/AMT1SS)**2/8.0
        RIHSF1=RHSF1*RF0*(AMW/AMT1SS)**2/8.0
        IITOT=IITOT+IIHSF1
        RITOT=RITOT+RIHSF1
        TAU=4.0*AMT2SS**2/MH**2 
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)    
        IIHSF2=RHSF2*IF0*(AMW/AMT2SS)**2/8.0
        RIHSF2=RHSF2*RF0*(AMW/AMT2SS)**2/8.0
        IITOT=IITOT+IIHSF2
        RITOT=RITOT+RIHSF2
C
C           IITOT and RITOT now contain the total imaginary and
C           real parts of the I function
C
        SUMISQ=IITOT**2+RITOT**2
        AS=SSALFS(MH**2)
        DW=AS**2*G2*MH**3/(32.0*(PI**3)*AMW**2) 
        WID=DW*SUMISQ
        CALL SSSAVE(IDHHA,WID,IDGL,IDGL,0,0,0)
100   CONTINUE
C
       RETURN
       END
+EOD
+DECK,SSHGM1
      SUBROUTINE SSHGM1(TAU,IFFF,RFFF)
C-----------------------------------------------------------------------
C
C     This subroutine uses the tau variable of the Higgs Hunters'
C     Guide.  Many other authors, including the paper cited in 
C     Higgs Hunters' Guide (PR. D. 38(11): 3481) and Collider Physics
C     by Barger and Phillips use the variable lambda
C          LAMBDA = ( MASS OF PARTICLE IN LOOP / MASS OF HIGGS )**2
C          TAU = 4.0 * LAMBDA
C     Note also that what is defined as the f function by different 
C     authors varies by a constant factor.  For example,
C          f(Barger and Phillips) = -2 * f(Higgs Hunters' Guide)
C
C     Bisset's FFF
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      DOUBLE PRECISION TAU,IFFF,RFFF,ETAP,ETAM,PI
C
      PI=3.1415926536
      IFFF=0.0
      RFFF=0.0
      IF(TAU.GE.1.0) THEN
        RFFF=(DASIN(DSQRT(1.0/TAU)))**2
        IFFF=0.0D0
      ELSE IF (TAU.LT.1.0) THEN
        ETAP=1.0D0+SQRT(1.0D0-TAU)
        ETAM=1.0D0-SQRT(1.0D0-TAU)
        RFFF=-((DLOG(ETAP/ETAM))**2-PI**2)/4.0D0
        IFFF=PI*DLOG(ETAP/ETAM)/2.0D0
      ENDIF
      RETURN 
      END
+EOD
+DECK,SSHGM
      SUBROUTINE SSHGM
C-----------------------------------------------------------------------
C
C     Calculate H -> gm gm decays including both SM particles and
C     SUSY particles in loop.
C
C     This subroutine uses the tau variable of the Higgs Hunters'
C     Guide.  Many other authors, including the paper cited in 
C     Higgs Hunters' Guide (PR. D. 38(11): 3481) and Collider Physics
C     by Barger and Phillips use the variable lambda
C          LAMBDA = ( MASS OF PARTICLE IN LOOP / MASS OF HIGGS )**2
C          TAU = 4.0 * LAMBDA 
C
C     Bisset's HGAMGAM
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
C
      DOUBLE PRECISION MW1,MW2
      DOUBLE PRECISION MFL(3),MFD(3),MFU(3)
      DOUBLE PRECISION ETAH,IITOT,RITOT,TAU,IFFF,RFFF,IFHALF,RFHALF
     $,IF1,RF1,IF0,RF0,NCC,EF,TEMPCH,RHF,RHW,RHCH,RHSF,RHSFL,RHSFR
     $,TEMP,RHCNO,IIHF,RIHF,IIHW,RIHW,IIHCH,RIHCH,IIHSFL,RIHSFL
     $,IIHSFR,RIHSFR,IIHCNO,RIHCNO
     $,RHSF1,RHSF2,IIHSF1,IIHSF2,RIHSF1,RIHSF2
      DOUBLE PRECISION U11,U12,U21,U22,V11,V12,V21,V22,S11,Q11,S22,Q22
     $,SUMISQ,DW
      DOUBLE PRECISION PI,SR2,XM,YM,CGL,SGL,CGR,SGR,G2,MH,BETA,ALPHA
     $,THETX,THETY,THETM,THETP,CW2,AMSQ
      REAL WID
      INTEGER NUMH,IJ,II,NUMOUT,IDHHA       
C
C          Mass matrix parameters
C
      PI=4.*ATAN(1.D0)
      SR2=SQRT(2.D0)
      XM=1./TAN(GAMMAL)
      THETX=SIGN(1.D0,XM)
      YM=1./TAN(GAMMAR)
      THETY=SIGN(1.D0,YM)
      SGL=1/(DSQRT(1+XM**2))
      CGL=SGL*XM
      SGR=1/(DSQRT(1+YM**2))
      CGR=SGR*YM
      MW1=DBLE(ABS(AMW1SS))
      MW2=DBLE(ABS(AMW2SS))
      THETM=SIGN(1.,AMW1SS)
      THETP=SIGN(1.,AMW2SS)
      G2=4.0*PI*ALFAEM/SN2THW
      BETA=ATAN(1.0/RV2V1)
      ALPHA=ALFAH
      CW2=1.-SN2THW
C
C          Loop over neutral Higgs bosons
C
      DO 100 NUMH=1,3
        IF(NUMH.EQ.1) THEN
           MH=AMHL
           IDHHA=ISHL
        ELSEIF(NUMH.EQ.2) THEN
           MH=AMHH
           IDHHA=ISHH
        ELSE
           MH=AMHA
           IDHHA=ISHA
        ENDIF
        ETAH=1.0
        IITOT=0.0
        RITOT=0.0
C
C
      MFL(1)=DBLE(AME)
      MFL(2)=DBLE(AMMU)
      MFL(3)=DBLE(AMTAU)
      MFD(1)=DBLE(AMDN)
      MFD(2)=DBLE(AMST)
      MFD(3)=DBLE(MBQ)
      MFU(1)=DBLE(AMUP)
      MFU(2)=DBLE(AMCH)
      MFU(3)=DBLE(MTQ)
C
C            Charged lepton loops
C
        DO 10 II=1,3
          TAU=4*MFL(II)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IFHALF=-2.0*TAU*(1.0-TAU*ETAH)*IFFF
          RFHALF=-2.0*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
          NCC=1.0
          EF=-1.0
          IF(NUMH.EQ.1) THEN
            RHF=SIN(ALPHA)/COS(BETA)
          ELSEIF(NUMH.EQ.2) THEN
            RHF=COS(ALPHA)/COS(BETA)
          ELSE
            RHF=TAN(BETA)
          ENDIF
          IIHF=NCC*EF**2*RHF*IFHALF
          RIHF=NCC*EF**2*RHF*RFHALF
          IITOT=IITOT+IIHF
          RITOT=RITOT+RIHF
10      CONTINUE 
C
C            Down-type quark loops
C
        DO 20 II=1,3
          TAU=4*MFD(II)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IFHALF=-2.0*TAU*(1.0-TAU*ETAH)*IFFF
          RFHALF=-2.0*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
          NCC=3.0
          EF=-1.0/3.0
          IF(NUMH.EQ.1) THEN
            RHF=SIN(ALPHA)/COS(BETA)
          ELSEIF(NUMH.EQ.2) THEN
            RHF=COS(ALPHA)/COS(BETA)
          ELSE
            RHF=DTAN(BETA)
          ENDIF
          IIHF=NCC*EF**2*RHF*IFHALF
          RIHF=NCC*EF**2*RHF*RFHALF
          IITOT=IITOT+IIHF
          RITOT=RITOT+RIHF
20      CONTINUE 
C           
C            Up-type quark loops
C
        DO 30 II=1,2
          TAU=4*MFU(II)**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IFHALF=-2.0*TAU*(1.0-TAU*ETAH)*IFFF
          RFHALF=-2.0*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
          NCC=3.0
          EF=2.0/3.0
          IF(NUMH.EQ.1) THEN
            RHF=COS(ALPHA)/SIN(BETA)
          ELSEIF(NUMH.EQ.2) THEN
            RHF=-SIN(ALPHA)/SIN(BETA)
          ELSE
            RHF=1.0/TAN(BETA)
          ENDIF
          IIHF=NCC*EF**2*RHF*IFHALF
          RIHF=NCC*EF**2*RHF*RFHALF
          IITOT=IITOT+IIHF
          RITOT=RITOT+RIHF
30      CONTINUE 
C
        TAU=4*MFU(3)**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IFHALF=-2.0*TAU*(1.0-TAU*ETAH)*IFFF
        RFHALF=-2.0*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
        NCC=3.0
        EF=2.0/3.0
        IF(NUMH.EQ.1) THEN
          RHF=COS(ALPHA)/SIN(BETA)
        ELSEIF(NUMH.EQ.2) THEN
          RHF=-SIN(ALPHA)/SIN(BETA)
        ELSE
          RHF=1.0/TAN(BETA)
        ENDIF
        IIHF=NCC*EF**2*RHF*IFHALF
        RIHF=NCC*EF**2*RHF*RFHALF
        IITOT=IITOT+IIHF
        RITOT=RITOT+RIHF
C
C            W-boson loop
C           
        TAU=4*AMW**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF1=3.0*TAU*(2.0-TAU)*IFFF
        RF1=2.0+3.0*TAU+3.0*TAU*(2.0-TAU)*RFFF
        IF(NUMH.EQ.1) THEN
          RHW=SIN(BETA+ALPHA)
        ELSEIF(NUMH.EQ.2) THEN
          RHW=COS(BETA+ALPHA)
        ELSE
          RHW=0
        ENDIF
        IIHW=RHW*IF1
        RIHW=RHW*RF1
        IITOT=IITOT+IIHW
        RITOT=RITOT+RIHW
C
C            Charged Higgs loop
C 
        TAU=4*AMHC**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IF(NUMH.EQ.1) THEN
          TEMPCH=SIN(BETA-ALPHA)*COS(2.0*BETA)
          TEMPCH=TEMPCH/(2.0*CW2)
          RHCH=TEMPCH+SIN(BETA+ALPHA)
        ELSEIF(NUMH.EQ.2) THEN
          TEMPCH=-COS(BETA-ALPHA)*COS(2.0*BETA)
          TEMPCH=TEMPCH/(2.0*CW2)
          RHCH=COS(BETA+ALPHA)+TEMPCH
        ELSE
          RHCH=0
        ENDIF
        IIHCH=RHCH*IF0*AMW**2/AMHC**2
        RIHCH=RHCH*RF0*AMW**2/AMHC**2
        IITOT=IITOT+IIHCH
        RITOT=RITOT+RIHCH
C
C         Slepton loops
C         The 3 L-type sneutrinos can be omitted since the sfermion
C         decay width is proportional to the sfermion charge.
C         ==> There are two sets of 3 degenerate sleptons.
C
        NCC=1.0
        EF=-1.0
C         First, do e_L and mu_L sleptons
        DO 40 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=(MFL(II)/AMZ)**2*SIN(ALPHA)/COS(BETA)
            TEMP=(-0.5-EF*SN2THW)*SIN(BETA-ALPHA)
            RHSFL=RHSF-TEMP
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=(MFL(II)/AMZ)**2*COS(ALPHA)/COS(BETA)
            TEMP=(-0.5-EF*SN2THW)*COS(BETA-ALPHA)
            RHSFL=RHSF-TEMP
          ELSE
            RHSF=0
            RHSFL=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMELSS
          IF (II.EQ.2) AMSQ=AMMLSS
          TAU=4*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFL=NCC*(EF**2)*RHSFL*IF0*(AMZ/AMSQ)**2
          RIHSFL=NCC*(EF**2)*RHSFL*RF0*(AMZ/AMSQ)**2
          IITOT=IITOT+IIHSFL
          RITOT=RITOT+RIHSFL
40      CONTINUE
C         Next, do e_R and mu_R
        DO 41 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=(MFL(II)/AMZ)**2*SIN(ALPHA)/COS(BETA)
            TEMP=-1.0*EF*SN2THW*SIN(BETA-ALPHA)
            RHSFR=RHSF+TEMP
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=(MFL(II)/AMZ)**2*COS(ALPHA)/COS(BETA)
            TEMP=-1.0*EF*SN2THW*COS(BETA-ALPHA)
            RHSFR=RHSF+TEMP
          ELSE
            RHSF=0
            RHSFR=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMERSS
          IF (II.EQ.2) AMSQ=AMMRSS
          TAU=4*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFR=NCC*(EF**2)*RHSFR*IF0*(AMZ/AMSQ)**2
          RIHSFR=NCC*(EF**2)*RHSFR*RF0*(AMZ/AMSQ)**2
          IITOT=IITOT+IIHSFR
          RITOT=RITOT+RIHSFR
41      CONTINUE
C         Next, do stau_1 and stau_2 contribution
        IF(NUMH.EQ.1) THEN
          RHSF=(AMTAU/AMZ)**2*SIN(ALPHA)/COS(BETA)
          TEMP=(-0.5-EF*SN2THW)*SIN(BETA-ALPHA)
          RHSFL=RHSF-TEMP
          TEMP=-1.0*EF*SN2THW*SIN(BETA-ALPHA)
          RHSFR=RHSF+TEMP
        ELSEIF(NUMH.EQ.2) THEN
          RHSF=(AMTAU/AMZ)**2*COS(ALPHA)/COS(BETA)
          TEMP=(-0.5-EF*SN2THW)*COS(BETA-ALPHA)
          RHSFL=RHSF-TEMP
          TEMP=-1.0*EF*SN2THW*COS(BETA-ALPHA)
          RHSFR=RHSF+TEMP
        ELSE
          RHSF=0
          RHSFL=0
          RHSFR=0
        ENDIF
        RHSF1=RHSFL*COS(THETAL)-RHSFR*SIN(THETAL)
        RHSF2=RHSFL*SIN(THETAL)+RHSFR*COS(THETAL)
        TAU=4*AML1SS**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IIHSF1=NCC*(EF**2)*RHSF1*IF0*(AMZ/AML1SS)**2
        RIHSF1=NCC*(EF**2)*RHSF1*RF0*(AMZ/AML1SS)**2
        IITOT=IITOT+IIHSF1
        RITOT=RITOT+RIHSF1
        TAU=4*AML2SS**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IIHSF2=NCC*(EF**2)*RHSF2*IF0*(AMZ/AML2SS)**2
        RIHSF2=NCC*(EF**2)*RHSF2*RF0*(AMZ/AML2SS)**2
        IITOT=IITOT+IIHSF2
        RITOT=RITOT+RIHSF2
C
C          Down-type squark loops
C          Mixing between the sbottom squarks is also included, so  
C          masses used here are the mixed masses (AMB1SS & AMB2SS)
C
        NCC=3.0
        EF=-1.0/3.0
C          First, do d_L and s_L squarks
        DO 50 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=(MFD(II)/AMZ)**2*SIN(ALPHA)/COS(BETA)
            TEMP=(-0.5-EF*SN2THW)*SIN(BETA-ALPHA)
            RHSFL=RHSF-TEMP
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=(MFD(II)/AMZ)**2*COS(ALPHA)/COS(BETA)
            TEMP=(-0.5-EF*SN2THW)*COS(BETA-ALPHA)
            RHSFL=RHSF-TEMP
          ELSE
            RHSF=0
            RHSFL=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMDLSS
          IF (II.EQ.2) AMSQ=AMSLSS
          TAU=4*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFL=NCC*(EF**2)*RHSFL*IF0*(AMZ/AMSQ)**2
          RIHSFL=NCC*(EF**2)*RHSFL*RF0*(AMZ/AMSQ)**2
          IITOT=IITOT+IIHSFL
          RITOT=RITOT+RIHSFL
50      CONTINUE
C         Next, do d_R and s_R squarks
        DO 51 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=(MFD(II)/AMZ)**2*SIN(ALPHA)/COS(BETA)
            TEMP=-1.0*EF*SN2THW*SIN(BETA-ALPHA)
            RHSFR=RHSF+TEMP
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=(MFD(II)/AMZ)**2*COS(ALPHA)/COS(BETA)
            TEMP=-1.0*EF*SN2THW*COS(BETA-ALPHA)
            RHSFR=RHSF+TEMP
          ELSE
            RHSF=0
            RHSFR=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMDRSS
          IF (II.EQ.2) AMSQ=AMSRSS
          TAU=4*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFR=NCC*(EF**2)*RHSFR*IF0*(AMZ/AMSQ)**2
          RIHSFR=NCC*(EF**2)*RHSFR*RF0*(AMZ/AMSQ)**2
          IITOT=IITOT+IIHSFR
          RITOT=RITOT+RIHSFR
51      CONTINUE
C
        NCC=3.0
        EF=-1.0/3.0
        IF(NUMH.EQ.1) THEN
          RHSF=(MBQ/AMZ)**2*SIN(ALPHA)/COS(BETA)
          TEMP=(-0.5-EF*SN2THW)*SIN(BETA-ALPHA)
          RHSFL=RHSF-TEMP
          TEMP=-1.0*EF*SN2THW*SIN(BETA-ALPHA)
          RHSFR=RHSF+TEMP
        ELSEIF(NUMH.EQ.2) THEN
          RHSF=(MBQ/AMZ)**2*COS(ALPHA)/COS(BETA)
          TEMP=(-0.5-EF*SN2THW)*COS(BETA-ALPHA)
          RHSFL=RHSF-TEMP
          TEMP=-1.0*EF*SN2THW*COS(BETA-ALPHA)
          RHSFR=RHSF+TEMP
        ELSE
          RHSF=0
          RHSFL=0
          RHSFR=0
        ENDIF
        RHSF1=RHSFL*COS(THETAB)-RHSFR*SIN(THETAB)
        RHSF2=RHSFL*SIN(THETAB)+RHSFR*COS(THETAB)
        TAU=4*AMB1SS**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IIHSF1=NCC*(EF**2)*RHSF1*IF0*(AMZ/AMB1SS)**2
        RIHSF1=NCC*(EF**2)*RHSF1*RF0*(AMZ/AMB1SS)**2
        IITOT=IITOT+IIHSF1
        RITOT=RITOT+RIHSF1
        TAU=4*AMB2SS**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IIHSF2=NCC*(EF**2)*RHSF2*IF0*(AMZ/AMB2SS)**2
        RIHSF2=NCC*(EF**2)*RHSF2*RF0*(AMZ/AMB2SS)**2
        IITOT=IITOT+IIHSF2
        RITOT=RITOT+RIHSF2
C
C         Up-type squark loops
C         Mixing between the stop squarks is also included, so  
C         masses used here are the mixed masses (AMT1SS & AMT2SS)
C
        NCC=3.0
        EF=2.0/3.0            
C         First, do u_L and c_L squarks
        DO 60 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=(MFU(II)/AMZ)**2*COS(ALPHA)/SIN(BETA)
            TEMP=(0.5-EF*SN2THW)*SIN(BETA-ALPHA)
            RHSFL=RHSF-TEMP
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=(MFU(II)/AMZ)**2*(-1.0)*SIN(ALPHA)/SIN(BETA)
            TEMP=(0.5-EF*SN2THW)*COS(BETA-ALPHA)
            RHSFL=RHSF-TEMP
          ELSE
            RHSF=0
            RHSFL=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMULSS
          IF (II.EQ.2) AMSQ=AMCLSS
          TAU=4*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFL=NCC*(EF**2)*RHSFL*IF0*(AMZ/AMSQ)**2
          RIHSFL=NCC*(EF**2)*RHSFL*RF0*(AMZ/AMSQ)**2
          IITOT=IITOT+IIHSFL
          RITOT=RITOT+RIHSFL
60      CONTINUE
C          Next, do u_R and c_R squarks
        DO 61 II=1,2
          IF(NUMH.EQ.1) THEN
            RHSF=(MFU(II)/AMZ)**2*COS(ALPHA)/SIN(BETA)
            TEMP=-1.0*EF*SN2THW*SIN(BETA-ALPHA)
            RHSFR=RHSF+TEMP
          ELSEIF(NUMH.EQ.2) THEN
            RHSF=(MFU(II)/AMZ)**2*(-1.0)*SIN(ALPHA)/SIN(BETA)
            TEMP=-1.0*EF*SN2THW*COS(BETA-ALPHA)
            RHSFR=RHSF+TEMP
          ELSE
            RHSF=0
            RHSFR=0
          ENDIF
          IF (II.EQ.1) AMSQ=AMURSS
          IF (II.EQ.2) AMSQ=AMCRSS
          TAU=4*AMSQ**2/MH**2                  
          CALL SSHGM1(TAU,IFFF,RFFF)         
          IF0=-TAU*TAU*IFFF          
          RF0=TAU*(1.0-TAU*RFFF)          
          IIHSFR=NCC*(EF**2)*RHSFR*IF0*(AMZ/AMSQ)**2
          RIHSFR=NCC*(EF**2)*RHSFR*RF0*(AMZ/AMSQ)**2
          IITOT=IITOT+IIHSFR
          RITOT=RITOT+RIHSFR
61      CONTINUE
C
        NCC=3.0
        EF=2.0/3.0
        IF(NUMH.EQ.1) THEN
          RHSF=(MTQ/AMZ)**2*COS(ALPHA)/SIN(BETA)
          TEMP=(0.5-EF*SN2THW)*SIN(BETA-ALPHA)
          RHSFL=RHSF-TEMP
          TEMP=-1.0*EF*SN2THW*SIN(BETA-ALPHA)
          RHSFR=RHSF+TEMP
        ELSEIF(NUMH.EQ.2) THEN
          RHSF=(MTQ/AMZ)**2*(-1.0)*SIN(ALPHA)/SIN(BETA)
          TEMP=(0.5-EF*SN2THW)*COS(BETA-ALPHA)
          RHSFL=RHSF-TEMP
          TEMP=-1.0*EF*SN2THW*COS(BETA-ALPHA)
          RHSFR=RHSF+TEMP
        ELSE
          RHSF=0
          RHSFL=0
          IIHSFL=0
          RIHSFL=0
        ENDIF
        RHSF1=RHSFL*COS(THETAB)-RHSFR*SIN(THETAB)
        RHSF2=RHSFL*SIN(THETAB)+RHSFR*COS(THETAB)
        TAU=4*AMT1SS**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IIHSF1=NCC*(EF**2)*RHSF1*IF0*(AMZ/AMT1SS)**2
        RIHSF1=NCC*(EF**2)*RHSF1*RF0*(AMZ/AMT1SS)**2
        IITOT=IITOT+IIHSF1
        RITOT=RITOT+RIHSF1
        TAU=4*AMT2SS**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IF0=-TAU*TAU*IFFF          
        RF0=TAU*(1.0-TAU*RFFF)          
        IIHSF2=NCC*(EF**2)*RHSF2*IF0*(AMZ/AMT2SS)**2
        RIHSF2=NCC*(EF**2)*RHSF2*RF0*(AMZ/AMT2SS)**2
        IITOT=IITOT+IIHSF2
        RITOT=RITOT+RIHSF2
C
C            Chargino loops
C
        TAU=4.0*(MW1)**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IFHALF=-2.0*TAU*(1.0-TAU*ETAH)*IFFF
        RFHALF=-2.0*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
        U11=SGL
        U12=-CGL
        V11=THETM*SGR
        V12=-THETM*CGR
        S11=U11*V12/SR2
        Q11=U12*V11/SR2
        RHCNO=2.0*(S11*COS(ALPHA)+Q11*SIN(ALPHA))
        IIHCNO=RHCNO*IFHALF*AMW/MW1 
        RIHCNO=RHCNO*RFHALF*AMW/MW1 
        IITOT=IITOT+IIHCNO
        RITOT=RITOT+RIHCNO
C
        TAU=4.0*(MW2)**2/MH**2                  
        CALL SSHGM1(TAU,IFFF,RFFF)         
        IFHALF=-2.0*TAU*(1.0-TAU*ETAH)*IFFF
        RFHALF=-2.0*TAU*(ETAH+(1.0-TAU*ETAH)*RFFF)
        U21=THETX*CGL
        U22=THETX*SGL
        V21=THETP*THETY*CGR
        V22=THETP*THETY*SGR
        S22=U21*V22/SR2
        Q22=U22*V21/SR2
        RHCNO=2.0*(S22*COS(ALPHA)+Q22*SIN(ALPHA))
        IIHCNO=RHCNO*IFHALF*AMW/MW2 
        RIHCNO=RHCNO*RFHALF*AMW/MW2 
        IITOT=IITOT+IIHCNO
        RITOT=RITOT+RIHCNO
C
C          IITOT and RITOT now contain the total imaginary and real
C          parts of the I function
C
        SUMISQ=IITOT**2+RITOT**2
        DW=ALFAEM**2*G2*MH**3/(1024.0*(PI**3)*AMW**2) 
        WID=DW*SUMISQ
        CALL SSSAVE(IDHHA,WID,IDGM,IDGM,0,0,0)
100   CONTINUE
C
      RETURN
      END
+EOD
+DECK,SSHHX
      SUBROUTINE SSHHX
C-----------------------------------------------------------------------
C     Calculates the decays Hi -> Hj + X.
C
C     Includes vertex corrections for triple Higgs couplings due
C     to top and stop quarks effects.
C     See Kunszt and Zwirner CERN-TH.6150/91 for all but hh-hc-hc
C     correction which is in our Higgs-->SUSY paper:
C     Baer et. al. FSU-HEP-920630 or UH-511-749-92.
C 
C     The hh-hl-hl vertex correction now includes both 
C        top & bottom and stop and sbottom squark
C        (non-degenerate with mixing) effects.  
C        A-terms and mu=-2m1 are also included.
C
C
C     Bisset's HIGPRO
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTYPE
C
      DOUBLE PRECISION PI,SR2,G2,GP2,BETA,ALPHA,SW2,CW2,LGTST,CBMA
     $,SBMA,LAMB1,DWID,DELLPP,MH,M1,M2,LAMB,TEMP,DTEMPL,DTEMPR
     $,DELHLL,DELHPP,DELHCC,CAB2,SAB2
      DOUBLE PRECISION SSDLAM
      REAL WID,HIGFRZ,AMTLSQ,AMTRSQ
C
      PI=4.*ATAN(1.D0)
      SR2=SQRT(2.D0)
      G2=4.0*PI*ALFAEM/SN2THW
      GP2=4*PI*ALFAEM/(1-SN2THW)
      HIGFRZ=SQRT(MAX(AMZ**2,AMTLSS*AMTRSS*SIGN(1.,AMTLSS*AMTRSS)))
C
      BETA=ATAN(1.0/RV2V1)
      ALPHA=ALFAH
      SW2=SN2THW
      CW2=1.-SN2THW
C
      AMTRSQ=AMTRSS**2*SIGN(1.,AMTRSS)
      AMTLSQ=AMTLSS**2*SIGN(1.,AMTLSS)
      LGTST=(1+AMTLSQ/MTQ/MTQ)*(1+AMTRSQ/MTQ/MTQ)
C     TURN VERTEX CORRECTION OFF IF ARGUMNET OF LOG IS NEGATIVE
      IF (LGTST.LE.0.D0) THEN
        LGTST=0.D0
      ELSE
        LGTST=LOG(LGTST)
      END IF
      SBMA=SIN(BETA-ALPHA)
      CBMA=COS(BETA-ALPHA)
      CAB2=(DCOS(ALPHA+BETA))**2             
      SAB2=1.0-CAB2
C
C          hl0 -> ha0 + ha0
C
      IF(AMHL.GT.2*AMHA) THEN
        LAMB1=AMHL**2-4.0*AMHA**2
        DWID=SBMA*COS(2.0*BETA) 
C          Now add hl-hp-hp vertex correction
        DELLPP=3.0*G2*CW2*(MTQ**4)*COS(ALPHA)
        DELLPP=DELLPP*(COS(BETA)**2)/(16.0*(PI**2))
        DELLPP=DELLPP/((AMW**4)*(SIN(BETA))**3)
        DELLPP=DELLPP*LGTST
        DWID=(DWID+DELLPP)**2
        DWID=DWID*G2*(AMZ**2)/(128.0*PI*CW2*(AMHL**2))
        DWID=DWID*SQRT(LAMB1)
        WID=DWID
        CALL SSSAVE(ISHL,WID,ISHA,ISHA,0,0,0)
      ENDIF
C
C          hh -> ha + z
C
      IF(AMHH.GT.AMHA+AMZ) THEN
        MH=AMHH
        M1=AMHA
        M2=AMZ
        LAMB=SSDLAM(MH**2,M1**2,M2**2)
        DWID=SQRT(G2*CW2)+SQRT(GP2*SW2)
        DWID=DWID**2*SAB2*SQRT(LAMB)
        DWID=DWID/(64.0*PI*(AMZ**2)*(AMHH**3))
        DWID=DWID*LAMB
        WID=DWID
        CALL SSSAVE(ISHH,WID,ISHA,IDZ,0,0,0)
      ENDIF
C
C          hh -> hl + hl
C
      IF(AMHH.GT.2*AMHL) THEN
        LAMB1=AMHH**2-4.0*AMHL**2
        TEMP=CBMA*COS(2.0*ALPHA)
        TEMP=TEMP+2.0*SBMA*SIN(2.0*ALPHA)
C
C          Now add hh-hl-hl vertex correction
C
C        The following 8 lines calculate the radiative
C        hh-hl-hl vertex correction including only
C        effects from tops and stop squarks.
C
C        DTEMPL=3.0*LOG(1.0+(AMTLSS/MTQ)**2)
C        DTEMPL=DTEMPL-2.0*AMTLSS**2/(AMTLSS**2+MTQ**2)
C        DTEMPR=3.0*LOG(1.0+(AMTRSS/MTQ)**2)
C        DTEMPR=DTEMPR-2.0*AMTRSS**2/(AMTRSS**2+MTQ**2)
C        DELHLL=3.0*G2*CW2*(MTQ**4)*SIN(ALPHA)
C        DELHLL=DELHLL*(COS(ALPHA)**2)/(PI**2)
C        DELHLL=DELHLL/(16.0*(AMW**4)*(SIN(BETA))**3)
C        DELHLL=DELHLL*(DTEMPL+DTEMPR)                  
C
C        The subroutine SSHL calculates the radiative
C        hh-hl-hl vertex correction including both 
C        top & bottom and stop and sbottom squark
C        (non-degenerate with mixing) effects.  
C        A-terms and mu=-2m1 are also included.
C
        CALL SSDHLL(DELHLL)
C
C        Note:  the variable TEMP in the line below 
C        this is the Lagrangian term (as noted on 
C        page 27 of Prof. Tata's personal Lagrangian
C        term notes.  Thus DELHLL must also be the 
C        Lagrangian entry - not the potential entry.
C        The subroutine SSHLL IS set up to yield the
C        the Lagrangian entry. (We must be very careful
C        about the relative sign between TEMP and DELHLL.)
C 
        DWID=G2*(AMZ**2)*(TEMP+DELHLL)**2
        DWID=DWID/(128.0*PI*CW2*(AMHH**2))
        DWID=DWID*SQRT(LAMB1)
        WID=DWID
        CALL SSSAVE(ISHH,WID,ISHL,ISHL,0,0,0)
      ENDIF
C
C          hh -> ha + ha
C
      IF(AMHH.GT.2*AMHA) THEN
        LAMB1=AMHH**2-4.0*AMHA**2
        DWID=CBMA*COS(2*BETA)
C          Now add hh-hp-hp vertex correction
        DELHPP=3.0*G2*CW2*(MTQ**4)*SIN(ALPHA)
        DELHPP=DELHPP*(COS(BETA)**2)/(16.0*(PI**2))
        DELHPP=DELHPP/((AMW**4)*(SIN(BETA))**3)
        DELHPP=DELHPP*LGTST
        DWID=G2*(AMZ**2)*(DWID+DELHPP)**2
        DWID=DWID/(128.0*PI*CW2*(AMHH**2))
        DWID=DWID*SQRT(LAMB1)
        WID=DWID
        CALL SSSAVE(ISHH,WID,ISHA,ISHA,0,0,0)
      ENDIF
C
C          hh -> hc+ + hc-
C
      IF(AMHH.GT.2*AMHC) THEN
        LAMB1=1.0-4.0*(AMHC**2)/(AMHH**2)
        DWID=CBMA*COS(2.0*BETA)/(2.0*CW2)
        DWID=COS(BETA+ALPHA)-DWID                   
C          Now add hh-hc-hc vertex correction
        DELHCC=3.0*G2*MTQ**4*SIN(ALPHA)
        DELHCC=DELHCC/( SIN(BETA)*(DTAN(BETA))**2 )
        DELHCC=DELHCC/(32.0*PI**2*AMW**4)
        DELHCC=DELHCC*LGTST
        DWID=G2*AMW**2*(-DWID+DELHCC)**2
        DWID=DWID*SQRT(LAMB1)/(16.0*PI*AMHH)
        WID=DWID
        CALL SSSAVE(ISHH,WID,ISHC,-ISHC,0,0,0)
      ENDIF
C
C          ha -> hl + z
C
      IF(AMHA.GT.AMHL+AMZ) THEN
         MH=AMHA
         M1=AMHL
         M2=AMZ
         LAMB=SSDLAM(MH**2,M1**2,M2**2)
         DWID=SQRT(G2*CW2)+SQRT(GP2*SW2)
         DWID=DWID**2*CAB2*SQRT(LAMB)
         DWID=DWID/(64.0*PI*(AMZ**2)*(AMHA**3))
         DWID=DWID*LAMB
         WID=DWID
         CALL SSSAVE(ISHA,WID,ISHL,IDZ,0,0,0)
      ENDIF
C
C          hc+ -> w+ + hl
C
      IF(AMHC.GT.AMW+AMHL) THEN
        MH=AMHC
        M1=AMW
        M2=AMHL
        LAMB=SSDLAM(MH**2,M1**2,M2**2)
        DWID=G2*CAB2*SQRT(LAMB)
        DWID=DWID/( 64.0*PI*(AMW**2)*(AMHC**3) )
        DWID=DWID*LAMB
        WID=DWID
        CALL SSSAVE(ISHC,WID,ISHL,IDW,0,0,0)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,SSHIBF
      SUBROUTINE SSHIBF(IMODEL)
C-----------------------------------------------------------------------
C
C     This subroutine calculates the decay widths for decays of the 
C     Higgs scalars present in the minimal SUSY model.
C
C     NOTE: Decays into sfermions are not yet incorporated.
C
C     Standard model parameters are hard wired in  SSMSSM. To get
C     the 1987-8 values corresponding to the Gunion et al. papers
C     (Intl. J. Mod. Phys. 2(4):1035; Nucl. Phys. B307:445) you must
C     change
C          ALFA3 = 0.12  --> 0.136
C          AMW   = 80.0  --> 81.3
C          AMZ   = 91.17 --> 92.7
C
C     2/9/91:
C     I've modified the program slightly.  The ALPHA3 = 0.12 value
C     above is the recent empirical value from LEP. Using the equation
C     from page 220 in Barger and Phillips yields ALPHA3 = 0.136.
C
C     10/1/92:
C     Now includes vertex corrections for triple Higgs couplings.
C     (See Kunszt and Zwirner, CERN-TH.6150/91 for all but HH-HC-HC
C     correction which is in our Higgs --> SUSY paper: Baer et al. 
C     FSU-HEP-920630 or UH-511-749-92)
C
C     Bisset's HIGSBF
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSTYPE
      INTEGER IMODEL
C
C          Decays into fermions
      CALL SSHFF(IMODEL)
C          Loop decays into photons and gluons
      CALL SSHGM
      CALL SSHGL
C          Decays into WW(*), ZZ(*)
      CALL SSHWW
C          Decays into neutralinos and charginos
      CALL SSHNN
      CALL SSHCC
C          Decays into other Higgs bosons
      CALL SSHHX
C          Decays to sfermions
      CALL SSHSF
C          Normalize branching ratios
C
      CALL SSNORM(ISHL)
      CALL SSNORM(ISHH)
      CALL SSNORM(ISHA)
      CALL SSNORM(ISHC)
C
      RETURN
      END
+EOD
+DECK,SSHNN
      SUBROUTINE SSHNN
C-----------------------------------------------------------------------
C     Calculates the decay widths of all neutral Higgses into all
C     possible pairs of neutralinos, and the decay widths of the
C     charged Higgs into any neutralino and any chargino
C
C     Bisset's NEUINO
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTYPE
C
      DOUBLE PRECISION XIJ,XJI,DIJ,TEMP,DWZN,TEMP2,T2,RWZ,SWZ
     $,PI,SR2,XM,THETX,YM,THETY,SGL,CGL,SGR,CGR,MW1,MW2,THETM,THETP
     $,G2,GP2,BETA,ALPHA,MH,M1,M2
      DOUBLE PRECISION SN1,SN2,DWID,LAMB
      DOUBLE PRECISION A(4,4),MHI(3)
      DOUBLE PRECISION SSDLAM
      REAL WID
      INTEGER II,NUMH,I1,I2,IZ,IW,ID1,ID2,IDHHA
      INTEGER IDHI(3),IDZI(4)
C
C          Mass matrix parameters
C
      PI=4.*ATAN(1.D0)
      SR2=SQRT(2.D0)
      XM=1./TAN(GAMMAL)
      THETX=SIGN(1.D0,XM)
      YM=1./TAN(GAMMAR)
      THETY=SIGN(1.D0,YM)
      SGL=1/(DSQRT(1+XM**2))
      CGL=SGL*XM
      SGR=1/(DSQRT(1+YM**2))
      CGR=SGR*YM
      MW1=DBLE(ABS(AMW1SS))
      MW2=DBLE(ABS(AMW2SS))
      THETM=SIGN(1.,AMW1SS)
      THETP=SIGN(1.,AMW2SS)
      G2=4*PI*ALFAEM/SN2THW
      GP2=4*PI*ALFAEM/(1-SN2THW)
      BETA=ATAN(1.0/RV2V1)
      ALPHA=ALFAH
C          The following was calculated in Bisset's MASZIN
      DO 10 II=1,4
         TEMP=SQRT(G2)*ZMIXSS(3,II)+SQRT(GP2)*ZMIXSS(4,II)
         TEMP=TEMP/SR2
         A(1,II)=-TEMP*SGR-SQRT(G2)*ZMIXSS(1,II)*CGR
         A(2,II)=TEMP*CGR-SQRT(G2)*ZMIXSS(1,II)*SGR
         A(3,II)=-TEMP*SGL+SQRT(G2)*ZMIXSS(2,II)*CGL
         A(4,II)=TEMP*CGL+SQRT(G2)*ZMIXSS(2,II)*SGL
10    CONTINUE
C
C          Arrays for loops
C
      MHI(1)=AMHL
      MHI(2)=AMHH
      MHI(3)=AMHA
      IDHI(1)=ISHL
      IDHI(2)=ISHH
      IDHI(3)=ISHA
      IDZI(1)=ISZ1
      IDZI(2)=ISZ2
      IDZI(3)=ISZ3
      IDZI(4)=ISZ4
C
C          Loop over neutral Higgs decays h(numh) into neutralino
C          pairs zi(i1) and zi(i2)
C
      DO 100 NUMH=1,3
        MH=MHI(NUMH)
        IDHHA=IDHI(NUMH)
        DO 110 I1=1,4
          M1=ABS(AMZISS(I1))
          ID1=IDZI(I1)
          DO 120 I2=I1,4
            M2=ABS(AMZISS(I2))
            ID2=IDZI(I2)
            IF(M1+M2.GE.MH) GO TO 120
            LAMB=SSDLAM(MH**2,M1**2,M2**2)
            IF(I1.EQ.I2) THEN
              DIJ = 0.5
            ELSE
              DIJ = 1.0
            ENDIF
            TEMP=-0.5*SIGN(1.,AMZISS(I1))*SIGN(1.,AMZISS(I2))
            XIJ=TEMP*(SQRT(G2)*ZMIXSS(3,I2)-SQRT(GP2)*ZMIXSS(4,I2))
            XJI=TEMP*(SQRT(G2)*ZMIXSS(3,I1)-SQRT(GP2)*ZMIXSS(4,I1))
            IF(NUMH.EQ.1) THEN
              XIJ=XIJ*(ZMIXSS(2,I1)*SIN(ALPHA)-ZMIXSS(1,I1)*COS(ALPHA))
              XJI=XJI*(ZMIXSS(2,I2)*SIN(ALPHA)-ZMIXSS(1,I2)*COS(ALPHA))
            ELSEIF (NUMH .EQ. 2) THEN
              XIJ=XIJ*(ZMIXSS(2,I1)*COS(ALPHA)+ZMIXSS(1,I1)*SIN(ALPHA))
              XJI=XJI*(ZMIXSS(2,I2)*COS(ALPHA)+ZMIXSS(1,I2)*SIN(ALPHA))
            ELSEIF(NUMH.EQ.3) THEN
              XIJ=-XIJ*(ZMIXSS(2,I1)*SIN(BETA)-ZMIXSS(1,I1)*COS(BETA))
              XJI=-XJI*(ZMIXSS(2,I2)*SIN(BETA)-ZMIXSS(1,I2)*COS(BETA))
            ENDIF
            DWID=DIJ*(XIJ+XJI)**2
            DWID=DWID*SQRT(LAMB)/(8.0*PI*(MH**3))
            IF(NUMH.EQ.1.OR.NUMH.EQ.2) THEN
              TEMP2 = ((MH**2)-(M1-2.0*TEMP*M2)**2)
            ELSEIF(NUMH.EQ.3) THEN
              TEMP2=((MH**2)-(M1+2.0*TEMP*M2)**2)
            ENDIF
            DWID=DWID*TEMP2
            WID=DWID
            CALL SSSAVE(IDHHA,WID,ID1,ID2,0,0,0)
120       CONTINUE
110     CONTINUE
100   CONTINUE
C
C          Loop over h+ decays into wi(iw) + zi(iz)
C
      MH=AMHC
      DO 210 IW=1,2
        IF(IW.EQ.1) THEN
          M1=ABS(AMW1SS)
          ID1=ISW1
          SN1=SIGN(1.,AMW1SS)
        ELSE
          M1=ABS(AMW2SS)
          ID1=ISW2
          SN1=SIGN(1.,AMW2SS)
        ENDIF
        DO 220 IZ=1,4
          M2=ABS(AMZISS(IZ))
          ID2=IDZI(IZ)
          SN2=SIGN(1.,AMZISS(IZ))
          IF(M1+M2.GE.MH) GO TO 220
          LAMB=SSDLAM(MH**2,M1**2,M2**2)
          T2=MH**2-M1**2-M2**2
          IF(IW.EQ.1) THEN
            RWZ=COS(BETA)*A(2,IZ)*SN1
            TEMP=SIN(BETA)*A(4,IZ)*SN2
            SWZ=0.5*(RWZ+TEMP)
            RWZ=0.5*(RWZ-TEMP)
          ELSE
            RWZ=COS(BETA)*A(1,IZ)*THETY*SN1
            TEMP=SIN(BETA)*A(3,IZ)*THETX*SN2
            SWZ=0.5*(RWZ+TEMP)
            RWZ=0.5*(RWZ-TEMP)
          ENDIF
          DWID=RWZ**2+SWZ**2
          DWID=DWID*T2
          TEMP=2*M1*M2*(RWZ**2-SWZ**2)
          DWID=(DWID-TEMP)/(8.0*PI*(MH**3))
          DWID=DWID*SQRT(LAMB)
          WID=DWID
          CALL SSSAVE(ISHC,WID,ID1,ID2,0,0,0)
220     CONTINUE
210   CONTINUE
      RETURN
      END
+EOD
+DECK,SSHSF
      SUBROUTINE SSHSF
C-----------------------------------------------------------------------
C
C          Calculates the partial decay widths of 
C          the Higgs bosons into sfermions.
C          calculated by X. Tata
C          program by M. Bisset
C
C          10/23/93: modified by H. Baer, 10/8/96
C          Intra-flavor sfermion mixing is neglected
C          for all flavors EXCEPT for stops, sbottoms and staus.
C
C
C         10/23/93
C          It is assumed that the A-terms are real.
C          In addition, all coefficients of the sfermion
C          trilinear terms from the superpotential 
C          EXCEPT the stop (AAT), sbottom (AAB) and stau (AAL)
C          coefficients are set to zero.
C
C     ===> Code for the general case removing all these 
C          artificial restrictions is present below.  
C          The preceeding restrictions are specified
C          by giving special values to some variables
C          This is discussed in two sections beginning
C          with the symbols  (*@&*)  in the code below.
C
C          Corrected old bug in A-> sfermion decays to be
C          consistent with Appendix C of Baer/Tata book: 6/3/04 (HB)
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
C
C
      REAL SR2,PI,GG,TW2,BETA,DSA,DCA,DSB,DCB,MH
      REAL EP,TANB,COTB,ATERM,MSFMIX,THETSF,SIN2B
      REAL TEMP,TEMP1,TEMP2,YA1,YA2
      REAL SINA,COSA,SINA2,COSA2,M1,M2,M12,LAMB
      REAL SINAU,COSAU,SINAD,COSAD
      REAL A11,A22,A12,B11,B22,B12,C11,C12,C21,C22
      REAL ASQ,BSQ,CSQ,DWSF
      REAL DWSFL,DWSFH,DWSFP,DWSFC,SSXLAM
      DIMENSION ATERM(12),MSFMIX(12,2),THETSF(12)
      DIMENSION ASQ(10,3),BSQ(9),CSQ(6,4)
      DIMENSION DWSF(12,4),DWSFL(12,4),DWSFH(12,4)
      DIMENSION DWSFP(12,4),DWSFC(6,4)
      INTEGER II,IJ,JJ,IC,IJU,IJD,NUMH
C
C
      SR2=SQRT(2.0)
      PI=4.0*ATAN(1.0)
      TW2=SN2THW/(1.0-SN2THW)
      GG=SQRT(4.0*PI*ALFAEM/SN2THW)
      EP=TWOM1        
C
      TANB=1.0/RV2V1
      COTB=RV2V1
      BETA=ATAN(1.0/RV2V1)
      DSA=SIN(ALFAH)
      DCA=COS(ALFAH)
      DSB=SIN(BETA)
      DCB=COS(BETA)
      SIN2B=2.0*DSB*DCB
C      
C      Set A-terms.
C      (all A-terms are assumed to be real)
C      The A-terms are loaded into the array ATERM(12)
C      in the following way: 
C          ATERM(1)=selectron A-term
C          ATERM(2)=smuon A-term
C          ATERM(3)=stau A-term
C          ATERM(4)=up squark A-term
C          ATERM(5)=charm squark A-term
C          ATERM(6)=down squark A-term
C          ATERM(7)=strange squark A-term
C          ATERM(8)=sbottom A-term
C          ATERM(9)=stop A-term
C          ATERM(10)=selectronic sneutrino A-term
C          ATERM(11)=smuonic sneutrino A-term
C          ATERM(12)=stauonic sneutrino A-term
C
      DO 10 II=1,7
        ATERM(II)=0.0
10    CONTINUE
      ATERM(3)=AAL
      ATERM(8)=AAB
      ATERM(9)=AAT  
      DO 20 II=10,12
        ATERM(II)=0.0
20    CONTINUE
C
C      Set mixing parameters.
C      The intra-flavor-mixed sfermion masses are loaded into
C      the array MSFMIX(12,2) where (#,1) is the lighter 
C      mixed sfermion mass of a given flavor and (#,2) is the 
C      heavier sfermion mass.  The sfermionic mixing angles are
C      loaded into the array THETSF(12).  The identities of the
C      elements of these arrays are given below:
C        MSFMIX(1,*)=mixed selectron masses  
C                                 THETSF(1)=selectron mixing angle
C        MSFMIX(2,*)=mixed smuon masses   
C                                 THETSF(2)=smuon mixing angle
C        MSFMIX(3,*)=mixed stau masses  
C                                 THETSF(3)=stau mixing angle
C        MSFMIX(4,*)=mixed up squark masses 
C                                 THETSF(4)=up squark mixing angle
C        MSFMIX(5,*)=mixed charm squark masses 
C                                 THETSF(5)=charm squark mixing angle
C        MSFMIX(6,*)=mixed down squark masses 
C                                 THETSF(6)=down squark mixing angle
C        MSFMIX(7,*)=mixed strange squark masses  
C                                 THETSF(7)=strange squark mixing angle
C        MSFMIX(8,*)=mixed sbottom masses 
C                                 THETSF(8)=sbottom mixing angle
C        MSFMIX(9,*)=mixed stop masses  
C                                 THETSF(9)=stop mixing angle
C        For sneuterinos MSFMIX(#,2)=0.0, THETSF(#)=0.0 ; #=10-12
C        Yukawa contributions from D-terms to the sneutrino masses
C        are supposed to be added in here. 
C        MSFMIX(10,1)= selectronic sneutrino mass with D-terms 
C        MSFMIX(11,1)= smuonic sneutrino mass with D-terms
C        MSFMIX(12,1)= stauonic sneutrino mass with D-terms
C
      DO 30 II=10,12
        MSFMIX(II,2)=0.0
        THETSF(II)=0.0
30    CONTINUE
C
C
C       (*@&*) 10/24/93 - Special conditions used ---
C        set all mixing angles EXCEPT stop, sbottom, stau to zero.
C        For all EXCEPT st, sb and stau, set mixed sfermion masses
C        to bare sfermion masses:
C            MSFMIX(#,1) = Left sfermion mass
C            MSFMIX(#,2) = Right sfermion mass  ;  # = 1-8
C         but
C            MSFMIX(9,1) = AMT1SS  
C            MSFMIX(9,2) = AMT2SS              , etc.
C
C        (The choice of which to call Left and which to call
C         Right is based on the definition of the sfermion
C         mixing angle theta_sf :
C            sfermion_1 = cos(theta_sf) * sfermion_L
C                            - sin(theta_sf) * sfermion_R
C            sfermion_2 = sin(theta_sf) * sfermion_L
C                            + cos(theta_sf) * sfermion_R
C          Thus if we set theta_sf = 0, then
C                 sfermion_1 = sfermion_L
C           and   sfermion_2 = sfermion_R .               )
C
      DO 40 II=1,7
        THETSF(II)=0.0
40    CONTINUE
      MSFMIX(1,1)=AMELSS
      MSFMIX(1,2)=AMERSS
      MSFMIX(2,1)=AMMLSS
      MSFMIX(2,2)=AMMRSS
      MSFMIX(3,1)=AML1SS
      MSFMIX(3,2)=AML2SS
      THETSF(3)=THETAL
      MSFMIX(4,1)=AMULSS
      MSFMIX(4,2)=AMURSS
      MSFMIX(5,1)=AMCLSS
      MSFMIX(5,2)=AMCRSS
      MSFMIX(6,1)=AMDLSS
      MSFMIX(6,2)=AMDRSS
      MSFMIX(7,1)=AMSLSS
      MSFMIX(7,2)=AMSRSS
      MSFMIX(8,1)=AMB1SS
      MSFMIX(8,2)=AMB2SS
      THETSF(8)=THETAB
      MSFMIX(9,1)=AMT1SS
      MSFMIX(9,2)=AMT2SS
      THETSF(9)=THETAT
      MSFMIX(10,1)=AMN1SS
      MSFMIX(11,1)=AMN2SS
      MSFMIX(12,1)=AMN3SS
C
      DO 1000 NUMH=1,4
        IF(NUMH.EQ.1) THEN
          MH=AMHL
        ELSE IF(NUMH.EQ.2) THEN
          MH=AMHH
        ELSE IF(NUMH.EQ.3) THEN
          MH=AMHA
          GO TO 233
        ELSE IF(NUMH.EQ.4) THEN
          MH=AMHC
          GO TO 333
        ENDIF
C
C         Scalar neutral Higgses --> sfermions 
C          partial decay widths
C
        IF(NUMH.EQ.1) THEN
          TEMP=GG*AMW*SIN(BETA-ALFAH)/2.0
          YA1=DCA
          YA2=DSA
        ELSE IF(NUMH.EQ.2) THEN
          TEMP=-GG*AMW*COS(BETA-ALFAH)/2.0
          YA1=-DSA
          YA2=DCA
        ENDIF
C
        TEMP1=TEMP*(1.0-TW2/3.0)
        TEMP2=GG*YA1/(AMW*DSB)
        ASQ(4,1)=TEMP1-TEMP2*AMUP**2
        ASQ(5,1)=TEMP1-TEMP2*AMCH**2
        ASQ(9,1)=TEMP1-TEMP2*MTQ**2
C
        TEMP1=-TEMP*(1.0+TW2/3.0)
        TEMP2=GG*YA2/(AMW*DCB)
        ASQ(6,1)=-TEMP1-TEMP2*AMDN**2
        ASQ(7,1)=-TEMP1-TEMP2*AMST**2
        ASQ(8,1)=-TEMP1-TEMP2*MBQ**2
C
        ASQ(10,1)=TEMP*(1.0+TW2)
        TEMP1=TEMP*(TW2-1.0)
        TEMP2=GG*YA2/(AMW*DCB)
        ASQ(1,1)=TEMP1-TEMP2*AME**2
        ASQ(2,1)=TEMP1-TEMP2*AMMU**2
        ASQ(3,1)=TEMP1-TEMP2*AMTAU**2
C
        TEMP1=4.0*TEMP*TW2/3.0
        TEMP2=GG*YA1/(AMW*DSB)
        ASQ(4,2)=TEMP1-TEMP2*AMUP**2
        ASQ(5,2)=TEMP1-TEMP2*AMCH**2
        ASQ(9,2)=TEMP1-TEMP2*MTQ**2
C
        TEMP1=-2.0*TEMP*TW2/3.0
        TEMP2=GG*YA2/(AMW*DCB)
        ASQ(6,2)=TEMP1-TEMP2*AMDN**2
        ASQ(7,2)=TEMP1-TEMP2*AMST**2
        ASQ(8,2)=TEMP1-TEMP2*MBQ**2
C
        ASQ(10,2)=0.0
        TEMP1=-2.0*TEMP*TW2
        TEMP2=GG*YA2/(AMW*DCB)
        ASQ(1,2)=TEMP1-TEMP2*AME**2
        ASQ(2,2)=TEMP1-TEMP2*AMMU**2
        ASQ(3,2)=TEMP1-TEMP2*AMTAU**2
C
        TEMP1=GG/(2.0*AMW*DSB)
        ASQ(4,3)=(EP*YA2 + ATERM(4)*YA1)*TEMP1*AMUP
        ASQ(5,3)=(EP*YA2 + ATERM(5)*YA1)*TEMP1*AMCH 
        ASQ(9,3)=(EP*YA2 + ATERM(9)*YA1)*TEMP1*MTQ 
C
        TEMP1=GG/(2.0*AMW*DCB)
        ASQ(6,3)=(ATERM(6)*YA2 + EP*YA1)*TEMP1*AMDN
        ASQ(7,3)=(ATERM(7)*YA2 + EP*YA1)*TEMP1*AMST
        ASQ(8,3)=(ATERM(8)*YA2 + EP*YA1)*TEMP1*MBQ
C
        ASQ(10,3)=0.0
        ASQ(1,3)=(ATERM(1)*YA2 + EP*YA1)*TEMP1*AME
        ASQ(2,3)=(ATERM(2)*YA2 + EP*YA1)*TEMP1*AMMU
        ASQ(3,3)=(ATERM(3)*YA2 + EP*YA1)*TEMP1*AMTAU
C
C
        DO 150 IJ=1,9
          IF(IJ.LT.4) THEN
            TEMP1=1.0/(16.0*PI*MH**3)
          ELSE 
            TEMP1=3.0/(16.0*PI*MH**3)
          ENDIF
          SINA=SIN(THETSF(IJ))
          COSA=COS(THETSF(IJ))
          SINA2=SINA**2
          COSA2=COSA**2
          M1=MSFMIX(IJ,1)
          M2=MSFMIX(IJ,1)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            A11=ASQ(IJ,1)*COSA2+ASQ(IJ,2)*SINA2 
     $              -2.0*ASQ(IJ,3)*SINA*COSA
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSF(IJ,1)=TEMP1*SQRT(LAMB)*A11**2
          ELSE IF(MH.LE.M12) THEN
            DWSF(IJ,1)=0.0
          ENDIF
C
          M1=MSFMIX(IJ,2)
          M2=MSFMIX(IJ,2)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            A22=ASQ(IJ,1)*SINA2+ASQ(IJ,2)*COSA2 
     $                 +2.0*ASQ(IJ,3)*SINA*COSA
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSF(IJ,2)=TEMP1*SQRT(LAMB)*A22**2
          ELSE IF(MH.LE.M12) THEN
            DWSF(IJ,2)=0.0
          ENDIF
C          
          M1=MSFMIX(IJ,1)
          M2=MSFMIX(IJ,2)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            A12=(ASQ(IJ,1)-ASQ(IJ,2))*SINA*COSA 
     $                +ASQ(IJ,3)*(COSA2-SINA2)
            LAMB=SSXLAM(MH**2,M1**2,M2**2)         
            DWSF(IJ,3)=TEMP1*SQRT(LAMB)*A12**2
          ELSE IF(MH.LE.M12) THEN
               DWSF(IJ,3)=0.0
          ENDIF
C
          DWSF(IJ,4)=DWSF(IJ,3)
C
          IF(NUMH.EQ.1) THEN
            DO 121 JJ=1,4
              DWSFL(IJ,JJ)=DWSF(IJ,JJ)  
121         CONTINUE
          ELSE IF(NUMH.EQ.2) THEN
            DO 122 JJ=1,4
              DWSFH(IJ,JJ)=DWSF(IJ,JJ)  
122         CONTINUE
          ENDIF
C
150     CONTINUE
C
C          Now take care of sneutrinos. 
C    
        DO 155 IJ=10,12
          M1=MSFMIX(IJ,1)
          M2=MSFMIX(IJ,1)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSF(IJ,1)=SQRT(LAMB)*(ASQ(10,1))**2
     $                           /(16.0*PI*MH**3) 
          ELSE IF(MH.LE.M12) THEN
            DWSF(IJ,1) = 0.0
          ENDIF
          DWSF(IJ,2)=0.0
          DWSF(IJ,3)=0.0
          DWSF(IJ,4)=0.0
          IF(NUMH.EQ.1) THEN
            DO 151 JJ=1,4
              DWSFL(IJ,JJ)=DWSF(IJ,JJ)  
151         CONTINUE
          ELSE IF(NUMH.EQ.2) THEN
            DO 152 JJ=1,4
              DWSFH(IJ,JJ)=DWSF(IJ,JJ)  
152         CONTINUE
          ENDIF
C
155     CONTINUE 
        GO TO 1000
C
C
C          Pseudocalar neutral Higgses --> sfermions 
C           partial decay widths
C
233     TEMP1=GG/(2.0*AMW)
        BSQ(1)=TEMP1*AME*(EP-TANB*ATERM(1)) 
        BSQ(2)=TEMP1*AMMU*(EP-TANB*ATERM(2)) 
        BSQ(3)=TEMP1*AMTAU*(EP-TANB*ATERM(3)) 
        BSQ(4)=TEMP1*AMUP*(EP-COTB*ATERM(4)) 
        BSQ(5)=TEMP1*AMCH*(EP-COTB*ATERM(5)) 
        BSQ(6)=TEMP1*AMDN*(EP-TANB*ATERM(6)) 
        BSQ(7)=TEMP1*AMST*(EP-TANB*ATERM(7)) 
        BSQ(8)=TEMP1*MBQ*(EP-TANB*ATERM(8)) 
        BSQ(9)=TEMP1*MTQ*(EP-COTB*ATERM(9))
C
        DO 260 IJ=1,9
          IF(IJ.LT.4) THEN
            TEMP1=1.0/(16.0*PI*MH**3)
          ELSE 
            TEMP1=3.0/(16.0*PI*MH**3)
          ENDIF
          M1=MSFMIX(IJ,1)
          M2=MSFMIX(IJ,2)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            B12=BSQ(IJ)
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSFP(IJ,3)=TEMP1*SQRT(LAMB)*B12**2
          ELSE IF(MH.LE.M12) THEN
            DWSFP(IJ,3)=0.0
          ENDIF  
          DWSFP(IJ,4)=DWSFP(IJ,3)
260     CONTINUE
        DO 265 IJ=10,12
           DO 264 JJ=1,4
             DWSFP(IJ,JJ)=0.0
264        CONTINUE
265     CONTINUE
        GO TO 1000
C
C          Charged Higgses --> sfermions 
C           partial decay widths
C
333     TEMP1=-AMW*SIN2B
        CSQ(1,1)=GG*(TEMP1+(TANB*AMDN**2 + COTB*AMUP**2)/AMW)/SR2
        CSQ(2,1)=GG*(TEMP1+(TANB*AMST**2 + COTB*AMCH**2)/AMW)/SR2
        CSQ(3,1)=GG*(TEMP1+(TANB*MBQ**2 + COTB*MTQ**2)/AMW)/SR2
        CSQ(4,1)=GG*(TEMP1 + (TANB*AME**2)/AMW)/SR2
        CSQ(5,1)=GG*(TEMP1 + (TANB*AMMU**2)/AMW)/SR2
        CSQ(6,1)=GG*(TEMP1 + (TANB*AMTAU**2)/AMW)/SR2
C
        TEMP1=GG*(COTB+TANB)/(SR2*AMW)
        CSQ(1,2)=TEMP1*AMUP*AMDN         
        CSQ(2,2)=TEMP1*AMCH*AMST
        CSQ(3,2)=TEMP1*MTQ*MBQ
        CSQ(4,2)=0.0
        CSQ(5,2)=0.0
        CSQ(6,2)=0.0
C
        TEMP1=GG/(SR2*AMW)
        CSQ(1,3)=TEMP1*AMUP*(EP-COTB*ATERM(4))
        CSQ(2,3)=TEMP1*AMCH*(EP-COTB*ATERM(5))
        CSQ(3,3)=TEMP1*MTQ*(EP-COTB*ATERM(9))
        CSQ(4,3)=0.0
        CSQ(5,3)=0.0
        CSQ(6,3)=0.0
C
        CSQ(1,4)=TEMP1* AMDN*(EP-TANB*ATERM(6))
        CSQ(2,4)=TEMP1* AMST*(EP-TANB*ATERM(7))
        CSQ(3,4)=TEMP1* MBQ*(EP-TANB*ATERM(8))
        CSQ(4,4)=TEMP1* AME*(EP-TANB*ATERM(1))
        CSQ(5,4)=TEMP1* AMMU*(EP-TANB*ATERM(2))
        CSQ(6,4)=TEMP1* AMTAU*(EP-TANB*ATERM(3))
C
        DO 350 IC=1,3
          TEMP1=3.0/(16.0*PI*MH**3)
          IF(IC.EQ.1) THEN
            IJU=4
            IJD=6
          ELSE IF(IC.EQ.2) THEN
            IJU=5
            IJD=7
          ELSE IF(IC.EQ.3) THEN
            IJU=9
            IJD=8
          ENDIF
          SINAU=SIN(THETSF(IJU))
          COSAU=COS(THETSF(IJU))
          SINAD=SIN(THETSF(IJD))
          COSAD=COS(THETSF(IJD))
C
          M1=MSFMIX(IJU,1)
          M2=MSFMIX(IJD,1)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            C11=COSAU*COSAD*CSQ(IC,1) 
     $            + SINAU*SINAD*CSQ(IC,2)
     $                - SINAU*COSAD*CSQ(IC,3) 
     $                    - COSAU*SINAD*CSQ(IC,4)     
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSFC(IC,1)=TEMP1*SQRT(LAMB)*C11**2
          ELSE IF(MH.LE.M12) THEN
            DWSFC(IC,1) = 0.0
          ENDIF  
C
          M1=MSFMIX(IJU,1)
          M2=MSFMIX(IJD,2)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            C12=COSAU*SINAD*CSQ(IC,1) 
     $            - SINAU*COSAD*CSQ(IC,2)
     $                - SINAU*SINAD*CSQ(IC,3) 
     $                    + COSAU*COSAD*CSQ(IC,4)
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSFC(IC,2)=TEMP1*SQRT(LAMB)*C12**2
          ELSE IF(MH.LE.M12) THEN
            DWSFC(IC,2)=0.0
          ENDIF  
C
          M1=MSFMIX(IJU,2)
          M2=MSFMIX(IJD,1)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            C21=SINAU*COSAD*CSQ(IC,1) 
     $            - COSAU*SINAD*CSQ(IC,2)
     $                + COSAU*COSAD*CSQ(IC,3) 
     $                    - SINAU*SINAD*CSQ(IC,4) 
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSFC(IC,3)=TEMP1*SQRT(LAMB)*C21**2
          ELSE IF(MH.LE.M12) THEN
            DWSFC(IC,3)=0.0
          ENDIF  
C
          M1=MSFMIX(IJU,2)
          M2=MSFMIX(IJD,2)
          M12=M1+M2
          IF(MH.GT.M12) THEN
            C22=SINAU*SINAD*CSQ(IC,1) 
     $            + COSAU*COSAD*CSQ(IC,2)
     $                + COSAU*SINAD*CSQ(IC,3) 
     $                    + SINAU*COSAD*CSQ(IC,4) 
            LAMB=SSXLAM(MH**2,M1**2,M2**2)
            DWSFC(IC,4)=TEMP1*SQRT(LAMB)*C22**2
          ELSE IF(MH.LE.M12) THEN
            DWSFC(IC,4)=0.0
          ENDIF
C
350     CONTINUE
C
C
C         Now calculate the sleptonic
C          partial decay widths of the 
C          charged Higgs.
C
        DO 355 IC = 4,6
          TEMP1=1.0/(16.0*PI*MH**3)
            IF(IC.EQ.4) THEN
              IJU=10
              IJD=1
            ELSE IF(IC.EQ.5) THEN
              IJU=11
              IJD=2
            ELSE IF(IC.EQ.6) THEN
              IJU=12
              IJD=3
            ENDIF
            SINAD=SIN(THETSF(IJD))
            COSAD=COS(THETSF(IJD))
C
            M1=MSFMIX(IJU,1)
            M2=MSFMIX(IJD,1)
            M12=M1+M2
            IF(MH.GT.M12) THEN
              C11=COSAD*CSQ(IC,1)-SINAD*CSQ(IC,4)
              LAMB=SSXLAM(MH**2,M1**2,M2**2)
              DWSFC(IC,1)=TEMP1*SQRT(LAMB)*C11**2
            ELSE IF(MH.LE.M12) THEN
              DWSFC(IC,1)=0.0
            ENDIF
C
            M1=MSFMIX(IJU,1)
            M2=MSFMIX(IJD,2)
            M12=M1+M2
            IF(MH.GT.M12) THEN
              C12=SINAD*CSQ(IC,1)+COSAD*CSQ(IC,4)  
              LAMB=SSXLAM(MH**2,M1**2,M2**2)
              DWSFC(IC,2)=TEMP1*SQRT(LAMB)*C12**2
            ELSE IF(MH.LE.M12) THEN
              DWSFC(IC,2)=0.0
            ENDIF  
            DWSFC(IC,3)=0.0
            DWSFC(IC,4)=0.0
355     CONTINUE
1000  CONTINUE
C          H_l decays
      CALL SSSAVE(ISHL,DWSFL(1,1),ISEL,-ISEL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(1,2),ISER,-ISER,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(2,1),ISMUL,-ISMUL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(2,2),ISMUR,-ISMUR,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(3,1),ISTAU1,-ISTAU1,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(3,2),ISTAU2,-ISTAU2,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(3,3),ISTAU1,-ISTAU2,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(3,4),ISTAU2,-ISTAU1,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(4,1),ISUPL,-ISUPL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(4,2),ISUPR,-ISUPR,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(5,1),ISCHL,-ISCHL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(5,2),ISCHR,-ISCHR,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(6,1),ISDNL,-ISDNL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(6,2),ISDNR,-ISDNR,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(7,1),ISSTL,-ISSTL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(7,2),ISSTR,-ISSTR,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(8,1),ISBT1,-ISBT1,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(8,2),ISBT2,-ISBT2,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(8,3),ISBT1,-ISBT2,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(8,4),ISBT2,-ISBT1,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(9,1),ISTP1,-ISTP1,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(9,2),ISTP2,-ISTP2,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(9,3),ISTP1,-ISTP2,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(9,4),ISTP2,-ISTP1,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(10,1),ISNEL,-ISNEL,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(11,1),ISNML,-ISNML,0,0,0)
      CALL SSSAVE(ISHL,DWSFL(12,1),ISNTL,-ISNTL,0,0,0)
C         H_h decays
      CALL SSSAVE(ISHH,DWSFH(1,1),ISEL,-ISEL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(1,2),ISER,-ISER,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(2,1),ISMUL,-ISMUL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(2,2),ISMUR,-ISMUR,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(3,1),ISTAU1,-ISTAU1,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(3,2),ISTAU2,-ISTAU2,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(3,3),ISTAU1,-ISTAU2,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(3,4),ISTAU2,-ISTAU1,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(4,1),ISUPL,-ISUPL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(4,2),ISUPR,-ISUPR,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(5,1),ISCHL,-ISCHL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(5,2),ISCHR,-ISCHR,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(6,1),ISDNL,-ISDNL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(6,2),ISDNR,-ISDNR,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(7,1),ISSTL,-ISSTL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(7,2),ISSTR,-ISSTR,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(8,1),ISBT1,-ISBT1,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(8,2),ISBT2,-ISBT2,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(8,3),ISBT1,-ISBT2,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(8,4),ISBT2,-ISBT1,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(9,1),ISTP1,-ISTP1,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(9,2),ISTP2,-ISTP2,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(9,3),ISTP1,-ISTP2,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(9,4),ISTP2,-ISTP1,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(10,1),ISNEL,-ISNEL,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(11,1),ISNML,-ISNML,0,0,0)
      CALL SSSAVE(ISHH,DWSFH(12,1),ISNTL,-ISNTL,0,0,0)
C          Decay of H_p
      CALL SSSAVE(ISHA,DWSFP(1,3),ISEL,-ISER,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(1,4),ISER,-ISEL,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(2,3),ISMUL,-ISMUR,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(2,4),ISMUR,-ISMUL,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(3,3),ISTAU1,-ISTAU2,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(3,4),ISTAU2,-ISTAU1,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(4,3),ISUPL,-ISUPR,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(4,4),ISUPR,-ISUPL,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(5,3),ISCHL,-ISCHR,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(5,4),ISCHR,-ISCHL,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(6,3),ISDNL,-ISDNR,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(6,4),ISDNR,-ISDNL,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(7,3),ISSTL,-ISSTR,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(7,4),ISSTR,-ISSTL,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(8,3),ISBT1,-ISBT2,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(8,4),ISBT2,-ISBT1,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(9,3),ISTP1,-ISTP2,0,0,0)
      CALL SSSAVE(ISHA,DWSFP(9,4),ISTP2,-ISTP1,0,0,0)
C          Decay of H+
      CALL SSSAVE(ISHC,DWSFC(1,1),ISUPL,-ISDNL,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(1,2),ISUPR,-ISDNR,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(2,1),ISCHL,-ISSTL,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(2,2),ISCHR,-ISSTR,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(3,1),ISTP1,-ISBT1,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(3,2),ISTP1,-ISBT2,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(3,3),ISTP2,-ISBT1,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(3,4),ISTP2,-ISBT2,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(4,1),-ISEL,ISNEL,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(5,1),-ISMUL,ISNML,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(6,1),-ISTAU1,ISNTL,0,0,0)
      CALL SSSAVE(ISHC,DWSFC(6,2),-ISTAU2,ISNTL,0,0,0)
      RETURN
      END
+EOD
+DECK,SSHWW1
      DOUBLE PRECISION FUNCTION SSHWW1(XX)
C-----------------------------------------------------------------------
C     SSHWW: hi -> w + w*
C     Bisset's FUNWW
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTMP
C
      DOUBLE PRECISION XX,EPLN,PROP,TEMP,FN,AAA,MW,DELTAW,MH
C
      MW=AMW
      DELTAW=GAMW
      MH=TMP(1)
C
      EPLN=MW/MH
      PROP=(1.D0-XX)**2 
      PROP=PROP+(EPLN**2)*DELTAW**2/MH**2
      TEMP=XX**2-12*XX*EPLN**2 
      TEMP=TEMP+8*EPLN**2+12*EPLN**4
      AAA=XX**2-4*EPLN**2
      IF(AAA.LT.0) THEN
         AAA=0 
      ENDIF
      FN=TEMP*SQRT(AAA)/PROP
      SSHWW1=FN
      RETURN
      END        
+EOD
+DECK,SSHWW2
      DOUBLE PRECISION FUNCTION SSHWW2(XX)
C-----------------------------------------------------------------------
C     SSHWW: hi -> z + z*
C     Bisset's FUNZZ
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTMP
C
      DOUBLE PRECISION XX,EPLN,PROP,TEMP,FN,AAA,MZ,DELTAZ,MH
C
C
      MZ=AMZ
      DELTAZ=GAMZ
      MH=TMP(1)
C
      EPLN=MZ/MH
      PROP=(1.D0-XX)**2 
      PROP=PROP+(EPLN**2)*DELTAZ**2/MH**2
      TEMP=XX**2-12*XX*EPLN**2 
      TEMP=TEMP+8*EPLN**2+12*EPLN**4 
      AAA=XX**2-4*EPLN**2
      IF(AAA.LT.0) THEN
        AAA=0
      ENDIF
      FN=TEMP*SQRT(AAA)/PROP
      SSHWW2=FN
      RETURN
      END
+EOD
+DECK,SSHWW
      SUBROUTINE SSHWW
C-----------------------------------------------------------------------
C     Calculate HL, HH -> WW, ZZ, using either the on-shell matrix 
C     element if kinematically allowed or the WW* or ZZ* matrix
C     element from Eqn.(6) for Keung and Marciano (PRD. 84: 248).
C     For the latter, save the mode as W(Z) f fbar, and require that
C     MH > MW + 2 * MB.
C
C     Bisset's GBDCY
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSPAR
+CDE,SSSM
+CDE,SSTMP
+CDE,SSTYPE
C
      EXTERNAL SSHWW1,SSHWW2
      DOUBLE PRECISION SSHWW1,SSHWW2
      DOUBLE PRECISION PI,SR2,G2,BETA,ALPHA,SW2,CW2,CAB2,SAB2,MW,MZ
     $,MH,COUPL,LOWER,UPPER,FWW1,FWW2,FWW3,FWW,DWID,FZZ
      DOUBLE PRECISION SSDINT,SSDLAM
      REAL WID
      REAL BRZN,BRZL,BRZU,BRZD,BRWL,BRWQ
      INTEGER IDHHA,IH
C          Hard wired Z branching ratios
      DATA BRZN,BRZL,BRZU,BRZD/.06839,.03442,.11792,.15191/
      DATA BRWL,BRWQ/.11111,.33333/
C
C          Mass matrix parameters
C
      PI=4*ATAN(1.D0)
      SR2=SQRT(2.D0)
      G2=4*PI*ALFAEM/SN2THW
      BETA=ATAN(1.0/RV2V1)
      ALPHA=ALFAH
      SW2=SN2THW
      CW2=1.-SN2THW
      CAB2=(DCOS(ALPHA+BETA))**2
      SAB2=1.0-CAB2
      MW=AMW
      MZ=AMZ
C
C          WW* and ZZ* decays
C
      DO 100 IH=1,2
        IF(IH.EQ.1) THEN
          MH=AMHL
          IDHHA=ISHL
          COUPL=SAB2
        ELSE
          MH=AMHH
          IDHHA=ISHH
          COUPL=CAB2
        ENDIF
C          H -> W + W* -> W + f + fbar
        TMP(1)=MH
        IF(MH.GT.MW+2*AMBT.AND.MH.LE.2*MW) THEN
          LOWER=2*MW/MH
          UPPER=1+MW**2/MH**2
          IF (LOWER.LT.0.998D0) THEN
            IF (UPPER.LE.1.001D0) THEN
              FWW1=SSDINT(LOWER,SSHWW1,0.998D0)
              FWW2=SSDINT(0.998D0,SSHWW1,UPPER)
              FWW=FWW1+FWW2
            ELSEIF(UPPER.GT.1.001D0) THEN
              FWW1=SSDINT(LOWER,SSHWW1,0.998D0)
              FWW2=SSDINT(0.998D0,SSHWW1,1.001D0)
              FWW3=SSDINT(1.001D0,SSHWW1,UPPER)
              FWW=FWW1+FWW2+FWW3
            ENDIF
          ELSE IF (0.998D0.LT.LOWER.AND.LOWER.LT.1.001D0) THEN
            IF (UPPER.LE.1.001D0) THEN
              FWW=SSDINT(LOWER,SSHWW1,UPPER)
            ELSEIF(UPPER.GT.1.001D0) THEN
              FWW1=SSDINT(LOWER,SSHWW1,1.001D0)
              FWW2=SSDINT(1.001D0,SSHWW1,UPPER)
              FWW=FWW1+FWW2
            ENDIF
          ELSE IF (LOWER.GT.1.001D0) THEN
            FWW=SSDINT(LOWER,SSHWW1,UPPER)
          END IF
          DWID=3*(G2**2)*MH*FWW/(512.0*PI**3)
          WID=DWID*COUPL
          CALL SSSAVE(IDHHA,0.5*BRWL*WID,IDW,IDE,-IDNE,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWL*WID,IDW,IDMU,-IDNM,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWL*WID,IDW,IDTAU,-IDNT,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWQ*WID,IDW,-IDUP,IDDN,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWQ*WID,IDW,-IDCH,IDST,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWL*WID,-IDW,-IDE,IDNE,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWL*WID,-IDW,-IDMU,IDNM,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWL*WID,-IDW,-IDTAU,IDNT,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWQ*WID,-IDW,IDUP,-IDDN,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,0.5*BRWQ*WID,-IDW,IDCH,-IDST,0,0)
          CALL SSSVME(9)
        ENDIF
C          H -> Z + Z* -> Z + f + fbar
        IF(MH.GT.MZ+2*AMBT.AND.MH.LE.2*MZ) THEN
          LOWER=2*MZ/MH
          UPPER=1+MZ**2/MH**2
          FZZ=SSDINT(LOWER,SSHWW2,UPPER)
          DWID=7.0-40*SW2/3+160*SW2**2/9
          DWID=DWID/CW2**2             
          DWID=DWID*G2**2*MH*FZZ/(2048*PI**3)
          WID=DWID*COUPL
          CALL SSSAVE(IDHHA,BRZN*WID,IDZ,IDNE,-IDNE,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZN*WID,IDZ,IDNM,-IDNM,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZN*WID,IDZ,IDNT,-IDNT,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZL*WID,IDZ,IDE,-IDE,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZL*WID,IDZ,IDMU,-IDMU,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZL*WID,IDZ,IDTAU,-IDTAU,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZU*WID,IDZ,IDUP,-IDUP,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZU*WID,IDZ,IDCH,-IDCH,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZD*WID,IDZ,IDDN,-IDDN,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZD*WID,IDZ,IDST,-IDST,0,0)
          CALL SSSVME(9)
          CALL SSSAVE(IDHHA,BRZD*WID,IDZ,IDBT,-IDBT,0,0)
          CALL SSSVME(9)
        ENDIF
100   CONTINUE
C
C          HH -> WW, ZZ
C          If these are allowed, the WW* and ZZ* are not.
C
      MH=AMHH
      IF(MH.GT.2*MW) THEN
        DWID=3+(MH/MW)**4/4-(MH/MW)**2
        DWID=DWID*G2*CAB2*MW**2/(16.0*PI*MH**3)
        WID=DWID*SQRT(SSDLAM(MH**2,MW**2,MW**2))
        CALL SSSAVE(ISHH,WID,IDW,-IDW,0,0,0)
      ENDIF
      IF(MH.GT.2*MZ) THEN
        DWID=3+(MH/MZ)**4/4-(MH/MZ)**2
        DWID=DWID*G2*CAB2*MW**2/(16.0*PI*MH**3)/(2.0*CW2**2)
        WID=DWID*SQRT(SSDLAM(MH**2,MZ**2,MZ**2))
        CALL SSSAVE(ISHH,WID,IDZ,IDZ,0,0,0)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,SSL1ST
        REAL FUNCTION SSL1ST(SS)
C-----------------------------------------------------------------------
C          SSL1ST: l_1 -> stau_1+nu_l+nutaubar: TATA F FUNCTION
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL SS
        DOUBLE PRECISION S,M1,M2,MST1,ML1,WID
        S=SS
        M1=TMP(1)
        M2=TMP(2)
        MST1=TMP(3)
        ML1=TMP(4)
        WID=(S-MST1**2)**2/(S-M1**2)/(S-M2**2)*(S-ML1**2)**2
     $       /S/ML1**2
        SSL1ST=WID
        RETURN
        END
+EOD
+DECK,SSLPBF
        SUBROUTINE SSLPBF
C--------------------------------------------------------
C
C        This program gives slepton branching fractions to gauginos
C        according to Baer,Bartl,Karatas,Majerotto,Tata 
C        (Int. J. Mod. Phys. A4,4111 (1989); updated 10/21/96
C
C
C-------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SSTMP
C
      EXTERNAL SSLRT1,SSL1ST,SSN1ST,SSSNWS
      REAL SSXLAM,SSXINT,SSLRT1,SSN1ST,SSL1ST,SSSNWS
      REAL WID,SNZI,THIZ,XM,YM,THX,THY,BPLWI(2),CS2THW
      REAL VS,PI,SR2,G,GP,VP,V,TANB,ANWI(2),ALWI(2)
      REAL ANIZ,AEIZ,BEIZ,MZIZ,SINL,COSL,BETA,FL,AMPL
      REAL MW1,MW2,TN2THW,SNW1,SNW2,AS,BS,BH,COSA,SINA,A
      REAL XLO,SUM1,SUM2,AEJZ,TERM,WID1,WID2,SINB,COSB,COS2B,ANJZ,EMAX
      REAL MEME,MEMB,MEMZ,MMMM,MMUMB,MMUMZ,TANTHE,TANTHM,THETAE,THETAM
      REAL AAE,FE,AAM,FM,AME1,AML1,APE1,APL1,TM1,TM2,TM3,AMM1,APM1
      REAL BME1,BPE1,SUALFE,MTAMZ
      INTEGER IZ,JZ
      INTEGER ISZIZ(4)
      COMPLEX ZI,ZONE,ZA,ZB,ZALIZ,ZBLIZ,ZPP,ZPM
      DATA ZONE/(1.,0.)/,ZI/(0.,1.)/
C
C          Partly duplicated from SSMASS
C
      AMPL=2.4E18
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      CS2THW=1.-SN2THW
      TN2THW=SN2THW/CS2THW
      VS=2*AMW**2/G/G/(1.+RV2V1**2)
      V=SQRT(VS)
      VP=RV2V1*V
      TANB=1./RV2V1
      BETA=ATAN(TANB)
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
      SINB=SIN(BETA)
      COSB=COS(BETA)
      COS2B=COS(2*BETA)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      MEME=AME*(1.-SUALFE(AME**2)/PI)
      MEMB=MEME*(SUALFE(AMBT**2)/SUALFE(AME**2))**(-27./76.)
      MEMZ=MEMB*(SUALFE(AMZ**2)/SUALFE(AMBT**2))**(-27./80.)
      FE=G*MEMZ/SR2/AMW/COS(BETA)
C     SINCE A_e not defined in ISAJET, use A_tau as approximation
      AAE=AAL
      TANTHE=(AMERSS**2-MEMZ**2+AMZ**2*COS2B*(.5-SN2THW)-
     $AMELSS**2)/MEMZ/(TWOM1*SINB/COSB+AAE)
      THETAE=ATAN(TANTHE)
      MMMM=AMMU*(1.-SUALFE(AMMU**2)/PI)
      MMUMB=MMMM*(SUALFE(AMBT**2)/SUALFE(AMMU**2))**(-27./76.)
      MMUMZ=MMUMB*(SUALFE(AMZ**2)/SUALFE(AMBT**2))**(-27./80.)
      FM=G*MMUMZ/SR2/AMW/COS(BETA)
      AAM=AAL
      TANTHM=(AMMRSS**2-MMUMZ**2+AMZ**2*COS2B*(.5-SN2THW)-
     $AMMLSS**2)/MMUMZ/(TWOM1*SINB/COSB+AAM)
      THETAM=ATAN(TANTHM)
      MTAMZ=MLQ
      FL=G*MTAMZ/SR2/AMW/COS(BETA)
      SINL=SIN(THETAL)
      COSL=COS(THETAL)
      SNW1=SIGN(1.,AMW1SS)
      SNW2=SIGN(1.,AMW2SS)
      BPLWI(1)=-FL*COS(GAMMAL)
      BPLWI(2)=FL*THX*SIN(GAMMAL)
      ANWI(1)=G*SIN(GAMMAL)
      ALWI(1)=SNW1*G*SIN(GAMMAR)
      ANWI(2)=G*THX*COS(GAMMAL)
      ALWI(2)=SNW2*G*THY*COS(GAMMAR)
C          Reconstruct masses from SSMASS
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
C
C          Compute slepton branching fractions to zi
C
      ISZIZ(1)=ISZ1
      ISZIZ(2)=ISZ2
      ISZIZ(3)=ISZ3
      ISZIZ(4)=ISZ4
      DO 100 IZ=1,4
        SNZI=SIGN(1.,AMZISS(IZ))
        IF (SNZI.EQ.1.) THEN
           THIZ=0.
        ELSE
           THIZ=1.
        END IF
        MZIZ=ABS(AMZISS(IZ))
        ANIZ=G/SR2*ZMIXSS(3,IZ)-GP/SR2*ZMIXSS(4,IZ)
        AEIZ=G/SR2*ZMIXSS(3,IZ)+GP/SR2*ZMIXSS(4,IZ)
        BEIZ=SR2*GP*ZMIXSS(4,IZ)
        ZALIZ=ZI**(THIZ-1.)*SNZI
     $  *(G/SR2*ZMIXSS(3,IZ)+GP/SR2*ZMIXSS(4,IZ))
        ZBLIZ=-1*ZI**(THIZ-1.)*SR2*GP*ZMIXSS(4,IZ)
        ZPP=ZI**THIZ
        ZPM=(-ZI)**THIZ
C          sLEPTON --> LEPTON + zi
        IF (AMELSS.GT.(MZIZ+AME)) THEN
          WID=AEIZ**2*(AMELSS**2-MZIZ**2-AME**2)/AMELSS**3
     $        /16./PI*SQRT(SSXLAM(AMELSS**2,MZIZ**2,AME**2))
          CALL SSSAVE(ISEL,WID,ISZIZ(IZ),IDE,0,0,0)
        ENDIF
        IF (AMMLSS.GT.(MZIZ+AMMU)) THEN
          WID=AEIZ**2*(AMMLSS**2-MZIZ**2-AMMU**2)/AMMLSS**3
     $        /16./PI*SQRT(SSXLAM(AMMLSS**2,MZIZ**2,AMMU**2))
          CALL SSSAVE(ISMUL,WID,ISZIZ(IZ),IDMU,0,0,0)
        ENDIF
        IF (AMN1SS.GT.MZIZ) THEN
          WID=ANIZ**2*AMN1SS*(1.-MZIZ**2/AMN1SS**2)**2/16./PI
          CALL SSSAVE(ISNEL,WID,ISZIZ(IZ),IDNE,0,0,0)
        ENDIF
        IF (AMN2SS.GT.MZIZ) THEN
          WID=ANIZ**2*AMN2SS*(1.-MZIZ**2/AMN2SS**2)**2/16./PI
          CALL SSSAVE(ISNML,WID,ISZIZ(IZ),IDNM,0,0,0)
        ENDIF
        IF (AMN3SS.GT.MZIZ) THEN
          WID=ANIZ**2*AMN3SS*(1.-MZIZ**2/AMN3SS**2)**2/16./PI
          CALL SSSAVE(ISNTL,WID,ISZIZ(IZ),IDNT,0,0,0)
        ENDIF
        IF (AMERSS.GT.(MZIZ+AME)) THEN
          WID=BEIZ**2*(AMERSS**2-MZIZ**2-AME**2)/AMERSS**3
     $        /16./PI*SQRT(SSXLAM(AMERSS**2,MZIZ**2,AME**2))
          CALL SSSAVE(ISER,WID,ISZIZ(IZ),IDE,0,0,0)
        ENDIF
        IF (AMMRSS.GT.(MZIZ+AMMU)) THEN
          WID=BEIZ**2*(AMMRSS**2-MZIZ**2-AMMU**2)/AMMRSS**3
     $        /16./PI*SQRT(SSXLAM(AMMRSS**2,MZIZ**2,AMMU**2))
          CALL SSSAVE(ISMUR,WID,ISZIZ(IZ),IDMU,0,0,0)
        ENDIF
C          sTAU_1 --> TAU + zi
        IF (AML1SS.GT.(MZIZ+AMTAU)) THEN
          ZA=((ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*COSL
     $     -(ZI*ZBLIZ-ZPM*FL*ZMIXSS(2,IZ))*SINL)/2.
          ZB=((-ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*COSL
     $     -(ZI*ZBLIZ+ZPM*FL*ZMIXSS(2,IZ))*SINL)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=(AS*(AML1SS**2-(AMTAU+MZIZ)**2)+BS*(AML1SS**2-
     $     (MZIZ-AMTAU)**2))/8./PI/AML1SS**3*
     $     SQRT(SSXLAM(AML1SS**2,MZIZ**2,AMTAU**2))
          CALL SSSAVE(ISTAU1,WID,ISZIZ(IZ),IDTAU,0,0,0)
        END IF
        IF (AML2SS.GT.(MZIZ+AMTAU)) THEN
          ZA=((ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*SINL
     $     +(ZI*ZBLIZ-ZPM*FL*ZMIXSS(2,IZ))*COSL)/2.
          ZB=((-ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*SINL
     $     +(ZI*ZBLIZ+ZPM*FL*ZMIXSS(2,IZ))*COSL)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=(AS*(AML2SS**2-(AMTAU+MZIZ)**2)+BS*(AML2SS**2-
     $     (MZIZ-AMTAU)**2))/8./PI/AML2SS**3*
     $     SQRT(SSXLAM(AML2SS**2,MZIZ**2,AMTAU**2))
          CALL SSSAVE(ISTAU2,WID,ISZIZ(IZ),IDTAU,0,0,0)
        END IF
100   CONTINUE
C
C           Compute branching fractions to wi --- theta-C = 0
C
      IF (AMELSS.GT.MW1) THEN
        WID=ANWI(1)**2*AMELSS*(1.-MW1**2/AMELSS**2)**2/16./PI
        CALL SSSAVE(ISEL,WID,-ISW1,IDNE,0,0,0)
      END IF
      IF (AMMLSS.GT.MW1) THEN
        WID=ANWI(1)**2*AMMLSS*(1.-MW1**2/AMMLSS**2)**2/16./PI
        CALL SSSAVE(ISMUL,WID,-ISW1,IDNM,0,0,0)
      END IF
      IF (AML1SS.GT.MW1) THEN
        AS=(-ANWI(1)*COSL-BPLWI(1)*SINL)**2
        WID=AS*AML1SS*(1.-MW1**2/AML1SS**2)**2/16./PI
        CALL SSSAVE(ISTAU1,WID,-ISW1,IDNT,0,0,0)
      END IF
      IF (AML2SS.GT.MW1) THEN
        AS=(-ANWI(1)*SINL+BPLWI(1)*COSL)**2
        WID=AS*AML2SS*(1.-MW1**2/AML2SS**2)**2/16./PI
        CALL SSSAVE(ISTAU2,WID,-ISW1,IDNT,0,0,0)
      END IF
C
      IF (AMN1SS.GT.(MW1+AME)) THEN
        WID=ALWI(1)**2*(AMN1SS**2-MW1**2-AME**2)*
     $      SQRT(SSXLAM(AMN1SS**2,MW1**2,AME**2))/16./PI/AMN1SS**3
        CALL SSSAVE(ISNEL,WID,ISW1,IDE,0,0,0)
      END IF
      IF (AMN2SS.GT.(MW1+AMMU)) THEN
        WID=ALWI(1)**2*(AMN2SS**2-MW1**2-AMMU**2)*
     $      SQRT(SSXLAM(AMN2SS**2,MW1**2,AMMU**2))/16./PI/AMN2SS**3
        CALL SSSAVE(ISNML,WID,ISW1,IDMU,0,0,0)
      END IF
C
      IF (AMN3SS.GT.(MW1+AMTAU)) THEN
        WID=((ALWI(1)**2+BPLWI(1)**2)*(AMN3SS**2-MW1**2-AMTAU**2)+
     $     4*MW1*AMTAU*BPLWI(1)*ALWI(1))*
     $     SQRT(SSXLAM(AMN3SS**2,MW1**2,AMTAU**2))/16./PI/AMN3SS**3
        CALL SSSAVE(ISNTL,WID,ISW1,IDTAU,0,0,0)
      END IF
C
C
      IF (AMELSS.GT.MW2) THEN
        WID=ANWI(2)**2*AMELSS*(1.-MW2**2/AMELSS**2)**2/16./PI
        CALL SSSAVE(ISEL,WID,-ISW2,IDNE,0,0,0)
      END IF
      IF (AMMLSS.GT.MW2) THEN
        WID=ANWI(2)**2*AMMLSS*(1.-MW2**2/AMMLSS**2)**2/16./PI
        CALL SSSAVE(ISMUL,WID,-ISW2,IDNM,0,0,0)
      END IF
      IF (AML1SS.GT.MW2) THEN
        AS=(-ANWI(2)*COSL-BPLWI(2)*SINL)**2
        WID=AS*AML1SS*(1.-MW2**2/AML1SS**2)**2/16./PI
        CALL SSSAVE(ISTAU1,WID,-ISW2,IDNT,0,0,0)
      END IF
      IF (AML2SS.GT.MW2) THEN
        AS=(-ANWI(2)*SINL+BPLWI(2)*COSL)**2
        WID=AS*AML2SS*(1.-MW2**2/AML2SS**2)**2/16./PI
        CALL SSSAVE(ISTAU2,WID,-ISW2,IDNT,0,0,0)
      END IF
C
      IF (AMN1SS.GT.(MW2+AME)) THEN
        WID=ALWI(2)**2*(AMN1SS**2-MW2**2-AME**2)*
     $      SQRT(SSXLAM(AMN1SS**2,MW2**2,AME**2))/16./PI/AMN1SS**3
        CALL SSSAVE(ISNEL,WID,ISW2,IDE,0,0,0)
      END IF
      IF (AMN2SS.GT.(MW2+AMMU)) THEN
        WID=ALWI(2)**2*(AMN2SS**2-MW2**2-AMMU**2)*
     $      SQRT(SSXLAM(AMN2SS**2,MW2**2,AMMU**2))/16./PI/AMN2SS**3
        CALL SSSAVE(ISNML,WID,ISW2,IDMU,0,0,0)
      END IF
C
      IF (AMN3SS.GT.(MW2+AMTAU)) THEN
        WID=((ALWI(2)**2+BPLWI(2)**2)*(AMN3SS**2-MW2**2-AMTAU**2)+
     $     4*MW2*AMTAU*BPLWI(2)*ALWI(2))*
     $     SQRT(SSXLAM(AMN3SS**2,MW2**2,AMTAU**2))/16./PI/AMN3SS**3
        CALL SSSAVE(ISNTL,WID,ISW2,IDTAU,0,0,0)
      END IF
C
C      DECAYS TO VECTOR BOSONS
C
      IF (AMELSS.GT.(AMN1SS+AMW)) THEN
        WID=G*G*(SSXLAM(AMELSS**2,AMN1SS**2,AMW**2))**1.5/
     $      32./PI/AMELSS**3/AMW**2
        CALL SSSAVE(ISEL,WID,-IDW,ISNEL,0,0,0)
      END IF
C
      IF (AMMLSS.GT.(AMN2SS+AMW)) THEN
        WID=G*G*(SSXLAM(AMMLSS**2,AMN2SS**2,AMW**2))**1.5/
     $      32./PI/AMMLSS**3/AMW**2
        CALL SSSAVE(ISMUL,WID,-IDW,ISNML,0,0,0)
      END IF
C
      IF (AML1SS.GT.(AMN3SS+AMW)) THEN
        WID=G*G*(SSXLAM(AML1SS**2,AMN3SS**2,AMW**2))**1.5/
     $      32./PI/AML1SS**3/AMW**2*COSL**2
        CALL SSSAVE(ISTAU1,WID,-IDW,ISNTL,0,0,0)
      END IF
C
      IF (AML2SS.GT.(AMN3SS+AMW)) THEN
        WID=G*G*(SSXLAM(AML2SS**2,AMN3SS**2,AMW**2))**1.5/
     $      32./PI/AML2SS**3/AMW**2*SINL**2
        CALL SSSAVE(ISTAU2,WID,-IDW,ISNTL,0,0,0)
      END IF
C
      IF (AMN1SS.GT.(AMELSS+AMW)) THEN
        WID=G*G*(SSXLAM(AMN1SS**2,AMELSS**2,AMW**2))**1.5/
     $      32./PI/AMN1SS**3/AMW**2
        CALL SSSAVE(ISNEL,WID,IDW,ISEL,0,0,0)
      END IF
C
      IF (AMN2SS.GT.(AMMLSS+AMW)) THEN
        WID=G*G*(SSXLAM(AMN2SS**2,AMMLSS**2,AMW**2))**1.5/
     $      32./PI/AMN2SS**3/AMW**2
        CALL SSSAVE(ISNML,WID,IDW,ISMUL,0,0,0)
      END IF
C
      IF (AMN3SS.GT.(AML1SS+AMW)) THEN
        WID=G*G*(SSXLAM(AMN3SS**2,AML1SS**2,AMW**2))**1.5/
     $      32./PI/AMN3SS**3/AMW**2*COSL**2
        CALL SSSAVE(ISNTL,WID,IDW,ISTAU1,0,0,0)
      END IF
C
      IF (AMN3SS.GT.(AML2SS+AMW)) THEN
        WID=G*G*(SSXLAM(AMN3SS**2,AML2SS**2,AMW**2))**1.5/
     $      32./PI/AMN3SS**3/AMW**2*SINL**2
        CALL SSSAVE(ISNTL,WID,IDW,ISTAU2,0,0,0)
      END IF
C
      IF (AML2SS.GT.(AML1SS+AMZ)) THEN
        WID=G*G*(SSXLAM(AML2SS**2,AML1SS**2,AMZ**2))**1.5/
     $      64./PI/AML2SS**3/CS2THW/AMZ**2*SINL**2*COSL**2
        CALL SSSAVE(ISTAU2,WID,IDZ,ISTAU1,0,0,0)
      END IF
C
C     3-body decay of l_R -> l+tau+stau_1
C
      XLO=(AML1SS+AMTAU)**2
      SUM1=0.
      SUM2=0.
      IF (AMERSS.GT.(AML1SS+AMTAU+AME)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMERSS
            TMP(2)=-SR2*GP*ZMIXSS(4,IZ)
            TMP(3)=-SR2*GP*ZMIXSS(4,JZ)
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(4)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(5)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(6)=TMP(2)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=TMP(3)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMERSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMERSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMERSS**2)/AMERSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            IF (AMERSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMERSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMERSS**2)/AMERSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMERSS/(2*PI)**5
        WID2=SUM2/2./AMERSS/(2*PI)**5
        CALL SSSAVE(ISER,WID1,ISTAU1,IDE,-IDTAU,0,0)
        CALL SSSAVE(ISER,WID2,-ISTAU1,IDE,IDTAU,0,0)
      END IF
      SUM1=0.
      SUM2=0.
      IF (AMMRSS.GT.(AML1SS+AMTAU+AMMU)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMMRSS
            TMP(2)=-SR2*GP*ZMIXSS(4,IZ)
            TMP(3)=-SR2*GP*ZMIXSS(4,JZ)
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(4)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(5)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(6)=TMP(2)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=TMP(3)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMMRSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMMRSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMMRSS**2)/AMMRSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            IF (AMMRSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMMRSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMMRSS**2)/AMMRSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMMRSS/(2*PI)**5
        WID2=SUM2/2./AMMRSS/(2*PI)**5
        CALL SSSAVE(ISMUR,WID1,ISTAU1,IDMU,-IDTAU,0,0)
        CALL SSSAVE(ISMUR,WID2,-ISTAU1,IDMU,IDTAU,0,0)
      END IF
C
C     3-body decay of l_L -> l+tau+stau_1
C
      SUM1=0.
      SUM2=0.
      IF (AMELSS.GT.(AML1SS+AMTAU+AME)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMELSS
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(2)=AEIZ
            TMP(3)=AEJZ
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(4)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(5)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMELSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMELSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMELSS**2)/AMELSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            IF (AMELSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMELSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMELSS**2)/AMELSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMELSS/(2*PI)**5
        WID2=SUM2/2./AMELSS/(2*PI)**5
        CALL SSSAVE(ISEL,WID1,ISTAU1,IDE,-IDTAU,0,0)
        CALL SSSAVE(ISEL,WID2,-ISTAU1,IDE,IDTAU,0,0)
      END IF
      SUM1=0.
      SUM2=0.
      IF (AMMLSS.GT.(AML1SS+AMTAU+AMMU)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMMLSS
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(2)=AEIZ
            TMP(3)=AEJZ
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(4)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(5)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMMLSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMMLSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMMLSS**2)/AMMLSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            IF (AMMLSS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMMLSS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMMLSS**2)/AMMLSS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMMLSS/(2*PI)**5
        WID2=SUM2/2./AMMLSS/(2*PI)**5
        CALL SSSAVE(ISMUL,WID1,ISTAU1,IDMU,-IDTAU,0,0)
        CALL SSSAVE(ISMUL,WID2,-ISTAU1,IDMU,IDTAU,0,0)
      END IF
C
C     3-body decay of nu_eL -> nu_e+tau+stau_1
C
      SUM1=0.
      SUM2=0.
      IF (AMN1SS.GT.(AML1SS+AMTAU)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMN1SS
            ANIZ=(G*ZMIXSS(3,IZ)-GP*ZMIXSS(4,IZ))/SR2
            ANJZ=(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/SR2
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(2)=ANIZ
            TMP(3)=ANJZ
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(4)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(5)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMN1SS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMN1SS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMN1SS**2)/AMN1SS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            IF (AMN1SS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMN1SS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMN1SS**2)/AMN1SS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMN1SS/(2*PI)**5
        WID2=SUM2/2./AMN1SS/(2*PI)**5
        CALL SSSAVE(ISNEL,WID1,ISTAU1,IDNE,-IDTAU,0,0)
        CALL SSSAVE(ISNEL,WID2,-ISTAU1,IDNE,IDTAU,0,0)
      END IF
C
C     3-body decay of nu_muL -> nu_mu+tau+stau_1
C
      SUM1=0.
      SUM2=0.
      IF (AMN2SS.GT.(AML1SS+AMTAU)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMN2SS
            ANIZ=(G*ZMIXSS(3,IZ)-GP*ZMIXSS(4,IZ))/SR2
            ANJZ=(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/SR2
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(2)=ANIZ
            TMP(3)=ANJZ
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(4)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(5)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMN2SS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMN2SS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMN2SS**2)/AMN2SS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            IF (AMN2SS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMN2SS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMN2SS**2)/AMN2SS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMN2SS/(2*PI)**5
        WID2=SUM2/2./AMN2SS/(2*PI)**5
        CALL SSSAVE(ISNML,WID1,ISTAU1,IDNM,-IDTAU,0,0)
        CALL SSSAVE(ISNML,WID2,-ISTAU1,IDNM,IDTAU,0,0)
      END IF
C
C     3-body decay of nu_tauL -> nu_tau+tau+stau_1
C     Here, we include decay via Z_i, W_i and W*, but neglect
C     some interference terms (Z_i-W* and W_i-W* and Z_i-W_i)
C     until a future date. HB 8/24/98
C
      AME1=-G*SIN(GAMMAL)*COS(THETAE)+FE*COS(GAMMAL)*SIN(THETAE)
      AML1=-G*SIN(GAMMAL)*COS(THETAL)+FL*COS(GAMMAL)*SIN(THETAL)
      APE1=-G*THX*COS(GAMMAL)*COS(THETAE)-FE*THX*SIN(GAMMAL)*
     $       SIN(THETAE)
      APL1=-G*THX*COS(GAMMAL)*COS(THETAL)-FL*THX*SIN(GAMMAL)*
     $       SIN(THETAL)
      SUM1=0.
      SUM2=0.
      IF (AMN3SS.GT.(AML1SS+AMTAU)) THEN
        DO IZ=1,4
          DO JZ=IZ,4
            TMP(1)=AMN3SS
            ANIZ=(G*ZMIXSS(3,IZ)-GP*ZMIXSS(4,IZ))/SR2
            ANJZ=(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/SR2
            AEIZ=-(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))/SR2
            AEJZ=-(G*ZMIXSS(3,JZ)+GP*ZMIXSS(4,JZ))/SR2
            TMP(2)=ANIZ
            TMP(3)=ANJZ
            TMP(6)=AEIZ*COSL-FL*ZMIXSS(2,IZ)*SINL
            TMP(7)=AEJZ*COSL-FL*ZMIXSS(2,JZ)*SINL
            TMP(4)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(5)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            TMP(8)=AMZISS(IZ)
            TMP(9)=AMZISS(JZ)
            IF (AMN3SS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMN3SS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMN3SS**2)/AMN3SS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM1=SUM1+TERM
            TMP(4)=TMP(6)
            TMP(5)=TMP(7)
            TMP(6)=-SR2*GP*ZMIXSS(4,IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
            TMP(7)=-SR2*GP*ZMIXSS(4,JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
            IF (AMN3SS.LT.ABS(AMZISS(IZ)).AND.
     ,          AMN3SS.LT.ABS(AMZISS(JZ))) THEN
              TERM=2*PI**2*SSXINT(XLO,SSLRT1,AMN3SS**2)/AMN3SS
            ELSE
              TERM=0.
            END IF
            IF (IZ.EQ.JZ) TERM=TERM/2.
            SUM2=SUM2+TERM
          END DO
        END DO
        WID1=SUM1/2./AMN3SS/(2*PI)**5
        WID2=SUM2/2./AMN3SS/(2*PI)**5
C-----COMPUTE SNU_TAU --> TAU +STAU_1BAR +NU_TAU via W_i DECAYS --------------
        BME1=-FL*COS(GAMMAL)
        BPE1=FL*THX*SIN(GAMMAL)
        TMP(1)=MW1
        TMP(2)=MW1
        TMP(3)=AML1SS
        TMP(4)=AMN3SS
        IF (AMN3SS.LT.MW1) THEN
        TM1=AML1**2*(AME1**2*MW1**2*SSXINT(AML1SS**2,SSN1ST,AMN3SS**2)
     $+BME1**2*SSXINT(AML1SS**2,SSL1ST,AMN3SS**2))
        TMP(2)=MW2
        TM2=2*AML1*APL1*(SNW1*SNW2*AME1*APE1*
     $ SSXINT(AML1SS**2,SSN1ST,AMN3SS**2)+BME1*BPE1*
     $ SSXINT(AML1SS**2,SSL1ST,AMN3SS**2))
        ELSE
        TM1=0.
        TM2=0.
        END IF
        TMP(1)=MW2
        TMP(2)=MW2
        IF (AMN3SS.LT.MW2) THEN
        TM3=APL1**2*(APE1**2*MW2**2*SSXINT(AML1SS**2,SSN1ST,AMN3SS**2)
     $+BPE1**2*SSXINT(AML1SS**2,SSL1ST,AMN3SS**2))
        ELSE
        TM3=0.
        END IF
        WID=PI**2*(TM1+TM2+TM3)/8./2./AMN3SS/(2.*PI)**5
        CALL SSSAVE(ISNTL,WID1+WID,-ISTAU1,IDNT,IDTAU,0,0)
C-----COMPUTE SNU_TAU --> TAUBAR +STAU_1 +NU_TAU via W* DECAYS --
        EMAX=(AML1SS**2+AMN3SS**2)/2./AMN3SS
        TMP(1)=AMW
        TMP(2)=AMW
        TMP(3)=AML1SS
        TMP(4)=AMN3SS
        IF (AMN3SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AML1SS,SSSNWS,EMAX)
        ELSE
        TM1=0.
        END IF
        WID=2*PI**2*TM1/3./2./AMN3SS/(2.*PI)**5
        CALL SSSAVE(ISNTL,WID2+WID,ISTAU1,IDNT,-IDTAU,0,0)
      END IF
C-----Now impose all sneutrino 3 body decays via W* ------------
        TMP(1)=AMW
        TMP(2)=AMW
        TMP(3)=AML1SS
        TMP(4)=AMN3SS
        EMAX=(AML1SS**2+AMN3SS**2)/2./AMN3SS
      IF (AMN3SS.GT.(AML1SS+AME).AND.AMN3SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AML1SS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN3SS/(2.*PI)**5
        CALL SSSAVE(ISNTL,WID,ISTAU1,IDNE,-IDE,0,0)
      END IF
      IF (AMN3SS.GT.(AML1SS+AMMU).AND.AMN3SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AML1SS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN3SS/(2.*PI)**5
        CALL SSSAVE(ISNTL,WID,ISTAU1,IDNM,-IDMU,0,0)
      END IF
      IF (AMN3SS.GT.(AML1SS+AMUP+AMDN).AND.AMN3SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AML1SS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN3SS/(2.*PI)**5
        CALL SSSAVE(ISNTL,3*WID,ISTAU1,IDUP,-IDDN,0,0)
      END IF
      IF (AMN3SS.GT.(AML1SS+AMCH+AMST).AND.AMN3SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AML1SS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN3SS/(2.*PI)**5
        CALL SSSAVE(ISNTL,3*WID,ISTAU1,IDCH,-IDST,0,0)
      END IF
      TMP(4)=AMN2SS
      EMAX=(AMMLSS**2+AMN2SS**2)/2./AMN2SS
      IF (AMN2SS.GT.(AMMLSS+AME).AND.AMN2SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMMLSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN2SS/(2.*PI)**5
        CALL SSSAVE(ISNML,WID,ISMUL,IDNE,-IDE,0,0)
      END IF
      IF (AMN2SS.GT.(AMMLSS+AMMU).AND.AMN2SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMMLSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN2SS/(2.*PI)**5
        CALL SSSAVE(ISNML,WID,ISMUL,IDNM,-IDMU,0,0)
      END IF
      IF (AMN2SS.GT.(AMMLSS+AMUP+AMDN).AND.AMN2SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMMLSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN2SS/(2.*PI)**5
        CALL SSSAVE(ISNML,3*WID,ISMUL,IDUP,-IDDN,0,0)
      END IF
      IF (AMN2SS.GT.(AMMLSS+AMCH+AMST).AND.AMN2SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMMLSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN2SS/(2.*PI)**5
        CALL SSSAVE(ISNML,3*WID,ISMUL,IDCH,-IDST,0,0)
      END IF
      TMP(4)=AMN1SS
      EMAX=(AMELSS**2+AMN1SS**2)/2./AMN1SS
      IF (AMN1SS.GT.(AMELSS+AME).AND.AMN1SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMELSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN1SS/(2.*PI)**5
        CALL SSSAVE(ISNEL,WID,ISEL,IDNE,-IDE,0,0)
      END IF
      IF (AMN1SS.GT.(AMELSS+AMMU).AND.AMN1SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMELSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN1SS/(2.*PI)**5
        CALL SSSAVE(ISNEL,WID,ISEL,IDNM,-IDMU,0,0)
      END IF
      IF (AMN1SS.GT.(AMELSS+AMUP+AMDN).AND.AMN1SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMELSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN1SS/(2.*PI)**5
        CALL SSSAVE(ISNEL,3*WID,ISEL,IDUP,-IDDN,0,0)
      END IF
      IF (AMN1SS.GT.(AMELSS+AMCH+AMST).AND.AMN1SS.LT.(AMW+AML1SS)) THEN
        TM1=G**4*COS(THETAL)**2*SSXINT(AMELSS,SSSNWS,EMAX)
        WID=2*PI**2*TM1/3./2./AMN1SS/(2.*PI)**5
        CALL SSSAVE(ISNEL,3*WID,ISEL,IDCH,-IDST,0,0)
      END IF
C-----COMPUTE ER AND MUR--> STAU_1+NEUTRINOS DECAYS --------------
      IF (AMERSS.LT.AMELSS.AND.AMERSS.GT.AML1SS) THEN
        TMP(1)=MW1
        TMP(2)=MW1
        TMP(3)=AML1SS
        TMP(4)=AMERSS
        IF (AMERSS.LT.MW1) THEN
        TM1=AML1**2*AME1**2*SSXINT(AML1SS**2,SSL1ST,AMERSS**2)
        TMP(2)=MW2
        TM2=2*AML1*AME1*APL1*APE1*SSXINT(AML1SS**2,SSL1ST,AMERSS**2)
        ELSE
        TM1=0.
        TM2=0.
        END IF
        IF (AMERSS.LT.MW2) THEN
        TMP(1)=MW2
        TMP(2)=MW2
        TM3=APL1**2*APE1**2*SSXINT(AML1SS**2,SSL1ST,AMERSS**2)
        ELSE
        TM3=0.
        END IF
        WID=PI**2*(TM1+TM2+TM3)/8./2./AMERSS/(2.*PI)**5
        CALL SSSAVE(ISER,WID,ISTAU1,IDNE,-IDNT,0,0)
      END IF
      IF (AMMRSS.LT.AMMLSS.AND.AMMRSS.GT.AML1SS) THEN
        AMM1=-G*SIN(GAMMAL)*COS(THETAM)+FM*COS(GAMMAL)*SIN(THETAM)
        AML1=-G*SIN(GAMMAL)*COS(THETAL)+FL*COS(GAMMAL)*SIN(THETAL)
        APM1=-G*THX*COS(GAMMAL)*COS(THETAM)-FM*THX*SIN(GAMMAL)*
     $       SIN(THETAM)
        APL1=-G*THX*COS(GAMMAL)*COS(THETAL)-FL*THX*SIN(GAMMAL)*
     $       SIN(THETAL)
        TMP(1)=MW1
        TMP(2)=MW1
        TMP(3)=AML1SS
        TMP(4)=AMMRSS
        IF (AMMRSS.LT.MW1) THEN
        TM1=AML1**2*AMM1**2*SSXINT(AML1SS**2,SSL1ST,AMMRSS**2)
        TMP(2)=MW2
        TM2=2*AML1*AMM1*APL1*APM1*SSXINT(AML1SS**2,SSL1ST,AMMRSS**2)
        ELSE
        TM1=0.
        TM2=0.
        END IF
        IF (AMMRSS.LT.MW2) THEN
        TMP(1)=MW2
        TMP(2)=MW2
        TM3=APL1**2*APM1**2*SSXINT(AML1SS**2,SSL1ST,AMMRSS**2)
        ELSE
        TM3=0.
        END IF
        WID=PI**2*(TM1+TM2+TM3)/8./2./AMMRSS/(2.*PI)**5
        CALL SSSAVE(ISMUR,WID,ISTAU1,IDNM,-IDNT,0,0)
      END IF
C-----COMPUTE SNU_E --> E +STAU_1BAR +NU_TAU DECAYS --------------
      AME1=-G*SIN(GAMMAL)
      AML1=-G*SIN(GAMMAL)*COS(THETAL)+FL*COS(GAMMAL)*SIN(THETAL)
      APE1=-G*THX*COS(GAMMAL)
      APL1=-G*THX*COS(GAMMAL)*COS(THETAL)-FL*THX*SIN(GAMMAL)*
     $       SIN(THETAL)
      IF (AMN1SS.GT.(AME+AML1SS)) THEN
        BME1=-FE*COS(GAMMAL)
        BPE1=FE*THX*SIN(GAMMAL)
        TMP(1)=MW1
        TMP(2)=MW1
        TMP(3)=AML1SS
        TMP(4)=AMN1SS
        IF (AMN1SS.LT.MW1) THEN
        TM1=AML1**2*(AME1**2*MW1**2*SSXINT(AML1SS**2,SSN1ST,AMN1SS**2)
     $+BME1**2*SSXINT(AML1SS**2,SSL1ST,AMN1SS**2))
        TMP(2)=MW2
        TM2=2*AML1*APL1*(SNW1*SNW2*AME1*APE1*
     $ SSXINT(AML1SS**2,SSN1ST,AMN1SS**2)+BME1*BPE1*
     $ SSXINT(AML1SS**2,SSL1ST,AMN1SS**2))
        ELSE
        TM1=0.
        TM2=0.
        END IF
        TMP(1)=MW2
        TMP(2)=MW2
        IF (AMN1SS.LT.MW2) THEN
        TM3=APL1**2*(APE1**2*MW2**2*SSXINT(AML1SS**2,SSN1ST,AMN1SS**2)
     $+BPE1**2*SSXINT(AML1SS**2,SSL1ST,AMN1SS**2))
        ELSE
        TM3=0.
        END IF
        WID=PI**2*(TM1+TM2+TM3)/8./2./AMN1SS/(2.*PI)**5
        CALL SSSAVE(ISNEL,WID,-ISTAU1,IDE,IDNT,0,0)
      END IF
C-----COMPUTE SNU_M --> MU +STAU_1BAR +NU_TAU DECAYS --------------
      IF (AMN2SS.GT.(AMMU+AML1SS)) THEN
        BME1=-FM*COS(GAMMAL)
        BPE1=FM*THX*SIN(GAMMAL)
        TMP(1)=MW1
        TMP(2)=MW1
        TMP(3)=AML1SS
        TMP(4)=AMN2SS
        IF (AMN2SS.LT.MW1) THEN
        TM1=AML1**2*(AME1**2*MW1**2*SSXINT(AML1SS**2,SSN1ST,AMN2SS**2)
     $+BME1**2*SSXINT(AML1SS**2,SSL1ST,AMN2SS**2))
        TMP(2)=MW2
        TM2=2*AML1*APL1*(SNW1*SNW2*AME1*APE1*
     $ SSXINT(AML1SS**2,SSN1ST,AMN2SS**2)+BME1*BPE1*
     $ SSXINT(AML1SS**2,SSL1ST,AMN2SS**2))
        ELSE
        TM1=0.
        TM2=0.
        END IF
        TMP(1)=MW2
        TMP(2)=MW2
        IF (AMN2SS.LT.MW2) THEN
        TM3=APL1**2*(APE1**2*MW2**2*SSXINT(AML1SS**2,SSN1ST,AMN2SS**2)
     $+BPE1**2*SSXINT(AML1SS**2,SSL1ST,AMN2SS**2))
        ELSE
        TM3=0.
        END IF
        WID=PI**2*(TM1+TM2+TM3)/8./2./AMN2SS/(2.*PI)**5
        CALL SSSAVE(ISNML,WID,-ISTAU1,IDMU,IDNT,0,0)
      END IF
C
C
C     decay to neutral higgs bosons
C
      IF (AML2SS.GT.(AMHL+AML1SS)) THEN
        BH=G*AMW*SIN(BETA-ALFAH)*(-1.+3*TN2THW)*SINL*COSL/2.+G*
     $  AMTAU*(TWOM1*COSA+AAL*SINA)*COS(2*THETAL)/2./AMW/COS(BETA)
        WID=BH**2*SQRT(SSXLAM(AML2SS**2,AMHL**2,AML1SS**2))/
     $      16./PI/AML2SS**3
        CALL SSSAVE(ISTAU2,WID,ISHL,ISTAU1,0,0,0)
      ENDIF
C
      IF (AML2SS.GT.(AMHA+AML1SS)) THEN
        BH=G*AMTAU*(TWOM1-AAL*TANB)/2./AMW
        WID=BH**2*SQRT(SSXLAM(AML2SS**2,AMHA**2,AML1SS**2))/
     $      16./PI/AML2SS**3
        CALL SSSAVE(ISTAU2,WID,ISHA,ISTAU1,0,0,0)
      ENDIF
C
      IF (AML2SS.GT.(AMHH+AML1SS)) THEN
        BH=-G*AMW*COS(BETA-ALFAH)*(-1.+3*TN2THW)*SINL*COSL/2.+G*
     $  AMTAU*(-TWOM1*SINA+AAL*COSA)*COS(2*THETAL)/2./AMW/COS(BETA)
        WID=BH**2*SQRT(SSXLAM(AML2SS**2,AMHH**2,AML1SS**2))/
     $      16./PI/AML2SS**3
        CALL SSSAVE(ISTAU2,WID,ISHH,ISTAU1,0,0,0)
      ENDIF
C
C     stau_i -> H^- stau_j
C
      IF (AMN3SS.GT.(AML1SS+AMHC)) THEN
        A=G/SR2/AMW*((AMTAU**2*TANB-AMW**2*SIN(2*BETA))*COSL-
     $    AMTAU*(TWOM1-AAL*TANB)*SINL)
        WID=A*A*SQRT(SSXLAM(AMN3SS**2,AML1SS**2,AMHC**2))/
     $      16./PI/AMN3SS**3
        CALL SSSAVE(ISNTL,WID,ISHC,ISTAU1,0,0,0)
      END IF
C
      IF (AMN3SS.GT.(AML2SS+AMHC)) THEN
        A=G/SR2/AMW*((AMTAU**2*TANB-AMW**2*SIN(2*BETA))*SINL+
     $    AMTAU*(TWOM1-AAL*TANB)*COSL)
        WID=A*A*SQRT(SSXLAM(AMN3SS**2,AML2SS**2,AMHC**2))/
     $      16./PI/AMN3SS**3
        CALL SSSAVE(ISNTL,WID,ISHC,ISTAU2,0,0,0)
      END IF
C
      IF (AML1SS.GT.(AMN3SS+AMHC)) THEN
        A=G/SR2/AMW*((AMTAU**2*TANB-AMW**2*SIN(2*BETA))*COSL-
     $    AMTAU*(TWOM1-AAL*TANB)*SINL)
        WID=A*A*SQRT(SSXLAM(AML1SS**2,AMN3SS**2,AMHC**2))/
     $      16./PI/AML1SS**3
        CALL SSSAVE(ISTAU1,WID,-ISHC,ISNTL,0,0,0)
      END IF
C
      IF (AML2SS.GT.(AMN3SS+AMHC)) THEN
        A=G/SR2/AMW*((AMTAU**2*TANB-AMW**2*SIN(2*BETA))*SINL+
     $    AMTAU*(TWOM1-AAL*TANB)*COSL)
        WID=A*A*SQRT(SSXLAM(AML2SS**2,AMN3SS**2,AMHC**2))/
     $      16./PI/AML2SS**3
        CALL SSSAVE(ISTAU2,WID,-ISHC,ISNTL,0,0,0)
      END IF
C
C     Gauge mediated SUSY breaking model decays to gravitino
      IF (AMERSS.GT.(AME+AMGVSS)) THEN
        WID=(AMERSS**2-AME**2)**4/48./PI/AMERSS**3/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISER,WID,IDE,91,0,0,0)
      END IF
      IF (AMMRSS.GT.(AMMU+AMGVSS)) THEN
        WID=(AMMRSS**2-AMMU**2)**4/48./PI/AMMRSS**3/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISMUR,WID,IDMU,91,0,0,0)
      END IF
      IF (AML1SS.GT.(AMTAU+AMGVSS)) THEN
        WID=(AML1SS**2-AMTAU**2)**4/48./PI/AML1SS**3/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISTAU1,WID,IDTAU,91,0,0,0)
      END IF
      IF (AMELSS.GT.(AME+AMGVSS)) THEN
        WID=(AMELSS**2-AME**2)**4/48./PI/AMELSS**3/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISEL,WID,IDE,91,0,0,0)
      END IF
      IF (AMMLSS.GT.(AMMU+AMGVSS)) THEN
        WID=(AMMLSS**2-AMMU**2)**4/48./PI/AMMLSS**3/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISMUL,WID,IDMU,91,0,0,0)
      END IF
      IF (AMN1SS.GT.AMGVSS) THEN
        WID=AMN1SS**5/48./PI/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISNEL,WID,IDNE,91,0,0,0)
      END IF
      IF (AMN2SS.GT.AMGVSS) THEN
        WID=AMN2SS**5/48./PI/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISNML,WID,IDNM,91,0,0,0)
      END IF
      IF (AMN3SS.GT.AMGVSS) THEN
        WID=AMN3SS**5/48./PI/(AMPL*AMGVSS)**2
        CALL SSSAVE(ISNTL,WID,IDNT,91,0,0,0)
      END IF
C
C          Normalize branching ratios 
C
      CALL SSNORM(ISEL)
      CALL SSNORM(ISMUL)
      CALL SSNORM(ISTAU1)
      CALL SSNORM(ISER)
      CALL SSNORM(ISMUR)
      CALL SSNORM(ISTAU2)
      CALL SSNORM(ISNEL)
      CALL SSNORM(ISNML)
      CALL SSNORM(ISNTL)
C
       RETURN
       END
+EOD
+DECK,SSLRT1
        REAL FUNCTION SSLRT1(SS)
C-----------------------------------------------------------------------
C          SSLRT1: l_R -> l+tau+stau_1
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL SS
        DOUBLE PRECISION ETMX,ETMN,S,MT1,MT,MLR,BEZI,BEZJ,TM,
     ,AI,AJ,BI,BJ,MZI,MZJ,SNZI,SNZJ,XL,BK1,BK2,BK3,BK,WID,SSDLAM
        S=SS
        MT1=AML1SS
        MT=AMTAU
        MLR=TMP(1)
        BEZI=TMP(2)
        BEZJ=TMP(3)
        AI=TMP(4)
        AJ=TMP(5)
        BI=TMP(6)
        BJ=TMP(7)
        MZI=ABS(TMP(8))
        MZJ=ABS(TMP(9))
        SNZI=SIGN(1.0,TMP(8))
        SNZJ=SIGN(1.0,TMP(9))
        TM=SSDLAM(S,MT**2,MT1**2)
        XL=DSQRT(MAX(0.D0,TM))
        ETMN=(S+MT**2-MT1**2-XL*(MLR**2-S)/(MLR**2+S))*(MLR**2+S)/
     ,       (2*S)/(2*MLR)
        ETMX=(S+MT**2-MT1**2+XL*(MLR**2-S)/(MLR**2+S))*(MLR**2+S)/
     ,       (2*S)/(2*MLR)
        BK1=-(ETMX-ETMN)*((ETMX+ETMN)*MLR*S-
     ,       (S+MT**2-MT1**2)*MLR**2)/2.D0
        BK2=(ETMX-ETMN)*((ETMX+ETMN)*MLR-S-MT**2+MT1**2)/2.D0
        BK3=SNZJ*BI*AJ*MZJ+SNZI*BJ*AI*MZI
        BK=BI*BJ*BK1+AI*AJ*MZI*MZJ*SNZI*SNZJ*BK2+BK3*MT*(MLR**2-S)*
     ,     (ETMX-ETMN)/2.D0
        WID=BEZI*BEZJ*BK/(S-MZI**2)/(S-MZJ**2)
        SSLRT1=WID
        RETURN
        END
+EOD
+DECK,SSM1LP
      SUBROUTINE SSM1LP(M1,M2,IALLOW)
C-----------------------------------------------------------------------
C
C          Recalculate sparticle masses including
C          radiative corrections
C          from T. Krupovnickas and H. Baer
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SSINF
C
      COMPLEX*16 SSB0,SSB1
      DOUBLE PRECISION SSA0
      REAL PI,SR2,GP,G1,G2,G3,CS2THW,CTHW,AMTLSQ,AMTRSQ,XX,
     $APD,ADMBC,BETA,SINB,COSB,HIGFRZ,
     $PITLTL,PITRTR,PITLTR,PIBLBL,PIBLBR,PIBRBR,PILLLL,PILLLR,PILRLR,
     $PIELEL,PIERER,PINENE
      INTEGER IALLOW
      REAL SIG0L,SIG0R,SIG0S,SIGPL,SIGPR,SIGPS
     $,SSIG0L(4,4),SSIG0R(4,4),SSIG0S(4,4),SSIGPL(2,2),SSIGPR(2,2)
     $,SSIGPS(2,2)
      REAL AR(4,4),NEWAR(4,4),WR(4),TEMP,WORK(4),V,VP,M1,M2
     $,MPPTRE(2,2),MPP(2,2),MPP2(2,2),ZMIX(4,4)
      REAL TMZ1SS,TMZ2SS,TMZ3SS,TMZ4SS,TMW1SS,TMW2SS
      REAL M2P,MUP,MWP,COSBEP,SINBEP,COS2BP,SIN2BP,INOSCL,ZETA,
     $ZETAS,XM,YM,THX,THY
      INTEGER I,J,K,IERR

      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
C     We will use msbar couplings at M_Z here for now
C     to give consistency between MSSM and SUGRA solutions
      G2=SQRT(4.*PI*ALFAEM/SN2THW)
      GP=G2*SQRT(SN2THW/(1.-SN2THW))
      G1=SQRT(5./3.)*GP
      G3=SQRT(4*PI*.118)
      CS2THW=1.-SN2THW
      CTHW=SQRT(CS2THW)
      V=VUQ
      VP=VDQ
      BETA=ATAN(VUQ/VDQ)
      SINB=SIN(BETA)
      COSB=COS(BETA)
      HIGFRZ=SQRT(MAX(AMZ**2,AMTLSS*AMTRSS*SIGN(1.,AMTLSS*AMTRSS)))
C
C
C     Refill MSS() for input to self energy routines
C
      MSS(1)=AMGLSS
      MSS(2)=AMULSS
      MSS(3)=AMURSS
      MSS(4)=AMDLSS
      MSS(5)=AMDRSS
      MSS(6)=AMSLSS
      MSS(7)=AMSRSS
      MSS(8)=AMCLSS
      MSS(9)=AMCRSS
      MSS(10)=AMB1SS
      MSS(11)=AMB2SS
      MSS(12)=AMT1SS
      MSS(13)=AMT2SS
      MSS(14)=AMN1SS
      MSS(15)=AMN2SS
      MSS(16)=AMN3SS
      MSS(17)=AMELSS
      MSS(18)=AMERSS
      MSS(19)=AMMLSS
      MSS(20)=AMMRSS
      MSS(21)=AML1SS
      MSS(22)=AML2SS
      MSS(23)=AMZ1SS
      MSS(24)=AMZ2SS
      MSS(25)=AMZ3SS
      MSS(26)=AMZ4SS
      MSS(27)=AMW1SS
      MSS(28)=AMW2SS
      MSS(29)=AMHL
      MSS(30)=AMHH
      MSS(31)=AMHA
      MSS(32)=AMHC
C
C     Neutralino masses
C
      AR(1,1)=0.
      AR(1,2)=-TWOM1
      AR(1,3)=-G2*V/SR2
      AR(1,4)=SQRT(3./5.)*G1*V/SR2
      AR(2,1)=-TWOM1
      AR(2,2)=0.
      AR(2,3)=G2*VP/SR2
      AR(2,4)=-SQRT(3./5.)*G1*VP/SR2
      AR(3,1)=-G2*V/SR2
      AR(3,2)=G2*VP/SR2
      AR(3,3)=M2
      AR(3,4)=0.
      AR(4,1)=SQRT(3./5.)*G1*V/SR2
      AR(4,2)=-SQRT(3./5.)*G1*VP/SR2
      AR(4,3)=0.
      AR(4,4)=M1
      XLAM=DLOG(DBLE(HIGFRZ**2))
C     Set renormalization scale to INOSCL for -ino mass computation
      INOSCL=AMZ1SS**2
      DO I=1,4
        DO J=1,4
          SSIG0L(I,J)=SIG0L(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0R(I,J)=SIG0R(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0S(I,J)=SIG0S(INOSCL,5-I,5-J,G1,G2,CTHW)
          NEWAR(I,J)=AR(I,J)
        ENDDO
      ENDDO
      DO I=1,4
        DO J=1,4
          DO K=1,4
            NEWAR(I,J)=NEWAR(I,J)-(SSIG0R(I,K)*AR(K,J)
     $+AR(I,K)*SSIG0L(K,J)
     $+SSIG0R(J,K)*AR(K,I)+AR(J,K)*SSIG0L(K,I))/2.
          ENDDO
          NEWAR(I,J)=NEWAR(I,J)-(SSIG0S(I,J)+SSIG0S(J,I))/2.
        ENDDO
      ENDDO
      CALL EISRS1(4,4,NEWAR,WR,ZMIX,IERR,WORK)
C     Sort eigenvectors and eigenvalues according to masses
      DO I=1,3
        DO J=I+1,4
          IF (ABS(WR(I)).GT.ABS(WR(J))) THEN
            TEMP=WR(J)
            WR(J)=WR(I)
            WR(I)=TEMP
            DO K=1,4
              TEMP=ZMIX(K,J)
              ZMIX(K,J)=ZMIX(K,I)
              ZMIX(K,I)=TEMP
            ENDDO
          END IF
        ENDDO
      ENDDO
      TMZ1SS=WR(1)
C     Write over with radiatively corrected -ino mixing elements 
      DO I=1,4
        DO J=1,4
          ZMIXSS(I,J)=ZMIX(I,J)
        END DO
      END DO
C
C
      INOSCL=AMZ2SS**2
      DO I=1,4
        DO J=1,4
          SSIG0L(I,J)=SIG0L(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0R(I,J)=SIG0R(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0S(I,J)=SIG0S(INOSCL,5-I,5-J,G1,G2,CTHW)
          NEWAR(I,J)=AR(I,J)
        ENDDO
      ENDDO
      DO I=1,4
        DO J=1,4
          DO K=1,4
            NEWAR(I,J)=NEWAR(I,J)-(SSIG0R(I,K)*AR(K,J)
     $+AR(I,K)*SSIG0L(K,J)
     $+SSIG0R(J,K)*AR(K,I)+AR(J,K)*SSIG0L(K,I))/2.
          ENDDO
          NEWAR(I,J)=NEWAR(I,J)-(SSIG0S(I,J)+SSIG0S(J,I))/2.
        ENDDO
      ENDDO
      CALL EISRS1(4,4,NEWAR,WR,ZMIX,IERR,WORK)
C     Sort eigenvectors and eigenvalues according to masses
      DO I=1,3
        DO J=I+1,4
          IF (ABS(WR(I)).GT.ABS(WR(J))) THEN
            TEMP=WR(J)
            WR(J)=WR(I)
            WR(I)=TEMP
            DO K=1,4
              TEMP=ZMIX(K,J)
              ZMIX(K,J)=ZMIX(K,I)
              ZMIX(K,I)=TEMP
            ENDDO
          END IF
        ENDDO
      ENDDO
      TMZ2SS=WR(2)
C
      INOSCL=AMZ3SS**2
      DO I=1,4
        DO J=1,4
          SSIG0L(I,J)=SIG0L(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0R(I,J)=SIG0R(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0S(I,J)=SIG0S(INOSCL,5-I,5-J,G1,G2,CTHW)
          NEWAR(I,J)=AR(I,J)
        ENDDO
      ENDDO
      DO I=1,4
        DO J=1,4
          DO K=1,4
            NEWAR(I,J)=NEWAR(I,J)-(SSIG0R(I,K)*AR(K,J)
     $+AR(I,K)*SSIG0L(K,J)
     $+SSIG0R(J,K)*AR(K,I)+AR(J,K)*SSIG0L(K,I))/2.
          ENDDO
          NEWAR(I,J)=NEWAR(I,J)-(SSIG0S(I,J)+SSIG0S(J,I))/2.
        ENDDO
      ENDDO
      CALL EISRS1(4,4,NEWAR,WR,ZMIX,IERR,WORK)
C     Sort eigenvectors and eigenvalues according to masses
      DO I=1,3
        DO J=I+1,4
          IF (ABS(WR(I)).GT.ABS(WR(J))) THEN
            TEMP=WR(J)
            WR(J)=WR(I)
            WR(I)=TEMP
            DO K=1,4
              TEMP=ZMIX(K,J)
              ZMIX(K,J)=ZMIX(K,I)
              ZMIX(K,I)=TEMP
            ENDDO
          END IF
        ENDDO
      ENDDO
      TMZ3SS=WR(3)
C
      INOSCL=AMZ4SS**2
      DO I=1,4
        DO J=1,4
          SSIG0L(I,J)=SIG0L(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0R(I,J)=SIG0R(INOSCL,5-I,5-J,G1,G2,CTHW)
          SSIG0S(I,J)=SIG0S(INOSCL,5-I,5-J,G1,G2,CTHW)
          NEWAR(I,J)=AR(I,J)
        ENDDO
      ENDDO
      DO I=1,4
        DO J=1,4
          DO K=1,4
            NEWAR(I,J)=NEWAR(I,J)-(SSIG0R(I,K)*AR(K,J)
     $+AR(I,K)*SSIG0L(K,J)
     $+SSIG0R(J,K)*AR(K,I)+AR(J,K)*SSIG0L(K,I))/2.
          ENDDO
          NEWAR(I,J)=NEWAR(I,J)-(SSIG0S(I,J)+SSIG0S(J,I))/2.
        ENDDO
      ENDDO
      CALL EISRS1(4,4,NEWAR,WR,ZMIX,IERR,WORK)
C     Sort eigenvectors and eigenvalues according to masses
      DO I=1,3
        DO J=I+1,4
          IF (ABS(WR(I)).GT.ABS(WR(J))) THEN
            TEMP=WR(J)
            WR(J)=WR(I)
            WR(I)=TEMP
            DO K=1,4
              TEMP=ZMIX(K,J)
              ZMIX(K,J)=ZMIX(K,I)
              ZMIX(K,I)=TEMP
            ENDDO
          END IF
        ENDDO
      ENDDO
      TMZ4SS=WR(4)
C
C     Charginos
C
      INOSCL=AMW1SS**2
      DO I=1,2
        DO J=1,2
          IF(I.NE.J) THEN
            SSIGPL(I,J)=-SIGPL(INOSCL,J,I,G1,G2,CTHW)
            SSIGPR(I,J)=-SIGPR(INOSCL,J,I,G1,G2,CTHW)
            SSIGPS(I,J)=-SIGPS(INOSCL,J,I,G1,G2,CTHW)
          ELSE
            SSIGPL(I,J)=SIGPL(INOSCL,I,J,G1,G2,CTHW)
            SSIGPR(I,J)=SIGPR(INOSCL,I,J,G1,G2,CTHW)
            SSIGPS(I,J)=SIGPS(INOSCL,I,J,G1,G2,CTHW)
          ENDIF
          MPP(I,J)=0.
        ENDDO
      ENDDO
      MPPTRE(1,1)=M2
      MPPTRE(1,2)=-G2*VP
      MPPTRE(2,1)=-G2*V
      MPPTRE(2,2)=TWOM1
      DO I=1,2
        DO J=1,2
          MPP(I,J)=MPPTRE(I,J)
        ENDDO
      ENDDO
      DO I=1,2
        DO J=1,2
          DO K=1,2
            MPP(I,J)=MPP(I,J)-SSIGPR(I,K)*MPPTRE(K,J)
     $-MPPTRE(I,K)*SSIGPL(K,J)
          ENDDO
          MPP(I,J)=MPP(I,J)-SSIGPS(I,J)
        ENDDO
      ENDDO
      DO I=1,2
        DO J=1,2
          MPP2(I,J)=MPP(I,1)*MPP(J,1)+MPP(I,2)*MPP(J,2)
        ENDDO
      ENDDO
C
      M2P=MPP(1,1)
      MUP=-MPP(2,2)
      MWP=SQRT((MPP(1,2)**2+MPP(2,1)**2)/2.)
      COSBEP=-MPP(1,2)/SR2/MWP
      SINBEP=-SIGN(1.,MPP(2,1))*SQRT(1.-COSBEP**2)
      COS2BP=1.-2*SINBEP**2
      SIN2BP=2*SINBEP*COSBEP
      ZETAS=(MUP**2-M2P**2)**2
     $+4*MWP**2*(MWP**2*COS2BP**2+MUP**2+M2P**2-2*MUP*M2P*SIN2BP)
      ZETA=SQRT(ZETAS)
      XM=(MUP**2-M2P**2+2*MWP**2*COS2BP-ZETA)
     $/(2*SR2*MWP*(-M2P*COSBEP+MUP*SINBEP))
      YM=(MUP**2-M2P**2-2*MWP**2*COS2BP-ZETA)
     $/(2*SR2*MWP*(-M2P*SINBEP+MUP*COSBEP))
      IF (XM.NE.0.) THEN
        GAMMAL=ATAN(1./XM)
      ELSE
        GAMMAL=PI/2.
      END IF
      IF (YM.NE.0.) THEN
        GAMMAR=ATAN(1./YM)
      ELSE
        GAMMAR=PI/2.
      END IF
      IF (GAMMAL.LT.0.) GAMMAL=GAMMAL+PI
      IF (GAMMAR.LT.0.) GAMMAR=GAMMAR+PI
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      AMW2SS=THX*THY*(COS(GAMMAR)*(M2P*COS(GAMMAL)+SR2*MWP*COSBEP*
     $SIN(GAMMAL))+SIN(GAMMAR)*(SR2*MWP*SINBEP*COS(GAMMAL)-
     $MUP*SIN(GAMMAL)))
      TMW1SS=SIGN(1.,AMW1SS)*SQRT(ABS(MIN((MPP2(1,1)+MPP2(2,2)
     $-SQRT((MPP2(1,1)-MPP2(2,2))**2+4.*MPP2(1,2)*MPP2(2,1)))/2.
     $,(MPP2(1,1)+MPP2(2,2)
     $+SQRT((MPP2(1,1)-MPP2(2,2))**2+4.*MPP2(1,2)*MPP2(2,1)))/2.)))
C
      INOSCL=AMW2SS**2
      DO I=1,2
        DO J=1,2
          IF(I.NE.J) THEN
            SSIGPL(I,J)=-SIGPL(INOSCL,J,I,G1,G2,CTHW)
            SSIGPR(I,J)=-SIGPR(INOSCL,J,I,G1,G2,CTHW)
            SSIGPS(I,J)=-SIGPS(INOSCL,J,I,G1,G2,CTHW)
          ELSE
            SSIGPL(I,J)=SIGPL(INOSCL,I,J,G1,G2,CTHW)
            SSIGPR(I,J)=SIGPR(INOSCL,I,J,G1,G2,CTHW)
            SSIGPS(I,J)=SIGPS(INOSCL,I,J,G1,G2,CTHW)
          ENDIF
          MPP(I,J)=0.
        ENDDO
      ENDDO
      MPPTRE(1,1)=M2
      MPPTRE(1,2)=-G2*VP
      MPPTRE(2,1)=-G2*V
      MPPTRE(2,2)=TWOM1
      DO I=1,2
        DO J=1,2
          MPP(I,J)=MPPTRE(I,J)
        ENDDO
      ENDDO
      DO I=1,2
        DO J=1,2
          DO K=1,2
            MPP(I,J)=MPP(I,J)-SSIGPR(I,K)*MPPTRE(K,J)
     $-MPPTRE(I,K)*SSIGPL(K,J)
          ENDDO
          MPP(I,J)=MPP(I,J)-SSIGPS(I,J)
        ENDDO
      ENDDO
      DO I=1,2
        DO J=1,2
          MPP2(I,J)=MPP(I,1)*MPP(J,1)+MPP(I,2)*MPP(J,2)
        ENDDO
      ENDDO
      TMW2SS=SIGN(1.,AMW2SS)*SQRT(ABS(MAX((MPP2(1,1)+MPP2(2,2)
     $-SQRT((MPP2(1,1)-MPP2(2,2))**2+4.*MPP2(1,2)*MPP2(2,1)))/2.
     $,(MPP2(1,1)+MPP2(2,2)
     $+SQRT((MPP2(1,1)-MPP2(2,2))**2+4.*MPP2(1,2)*MPP2(2,1)))/2.)))
C
C     Do third generation squarks and sleptons
C
C     Top squarks
      XLAM=DLOG(DBLE(HIGFRZ**2))
      AMTLSQ=SIGN(1.,AMTLSS)*AMTLSS**2
      AMTRSQ=SIGN(1.,AMTRSS)*AMTRSS**2
      XX=(AMGLSS/AMULSS)**2
      APD=AMTLSQ+AMTRSQ+2.*MTQ**2+AMZ**2*(COSB**2-SINB**2)/2.
     $-PITLTL(AMT1SS**2,G1,G2,G3,CTHW)-
     $PITRTR(AMT1SS**2,G1,G2,G3,CTHW)
      ADMBC=(AMTLSQ+MTQ**2+AMZ**2*(COSB**2-SINB**2)*(.5-2./3.*SN2THW)
     $-PITLTL(AMT1SS**2,G1,G2,G3,CTHW))*(AMTRSQ+MTQ**2+AMZ**2
     $*(COSB**2-SINB**2)*2./3.*SN2THW
     $-PITRTR(AMT1SS**2,G1,G2,G3,CTHW))-(MTQ*(-AAT-TWOM1*COSB/SINB)
     $-PITLTR(AMT1SS**2,G1,G2,G3,CTHW))**2
      AMT1SS=SQRT(ABS((APD-SQRT(ABS(APD**2-4.*ADMBC)))/2.))
      THETAT=ATAN((SQRT(ABS((APD-SQRT(ABS(APD**2-4.*ADMBC)))/2.))**2
     $-MTQ**2+AMZ**2*(COSB**2-SINB**2)
     $*(-.5+2*SN2THW/3.)-AMTLSQ+PITLTL(AMT1SS**2,G1,G2,G3,CTHW))
     $/(MTQ*(TWOM1*COSB/SINB+AAT)+PITLTR(AMT1SS**2,G1,G2,G3,CTHW)))
      APD=AMTLSQ+AMTRSQ+2.*MTQ**2+AMZ**2*(COSB**2-SINB**2)/2.
     $-PITLTL(AMT2SS**2,G1,G2,G3,CTHW)-
     $PITRTR(AMT2SS**2,G1,G2,G3,CTHW)
      ADMBC=(AMTLSQ+MTQ**2+AMZ**2*(COSB**2-SINB**2)*(.5-2./3.*SN2THW)
     $-PITLTL(AMT2SS**2,G1,G2,G3,CTHW))*(AMTRSQ+MTQ**2+AMZ**2
     $*(COSB**2-SINB**2)*2./3.*SN2THW
     $-PITRTR(AMT2SS**2,G1,G2,G3,CTHW))-(MTQ*(-AAT-TWOM1*COSB/SINB)
     $-PITLTR(AMT2SS**2,G1,G2,G3,CTHW))**2
      AMT2SS=SQRT(ABS((APD+SQRT(ABS(APD**2-4.*ADMBC)))/2.))
C
       APD=AMBLSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)*(-.5+SN2THW/3.)
     $+AMBRSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)*SN2THW/3.
     $-PIBLBL(AMB1SS**2,G1,G2,G3,CTHW)-
     $PIBRBR(AMB1SS**2,G1,G2,G3,CTHW)
      ADMBC=(AMBLSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)
     $*(-.5+SN2THW/3.)-PIBLBL(AMB1SS**2,G1,G2,G3,CTHW))*
     $(AMBRSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)*SN2THW/3.-
     $PIBRBR(AMB1SS**2,G1,G2,G3,CTHW))-(MBQ*(-AAB-TWOM1*SINB/COSB)-
     $PIBLBR(AMB1SS**2,G1,G2,G3,CTHW))**2
      AMB1SS=SQRT(ABS((APD-SQRT(ABS(APD**2-4.*ADMBC)))/2.))
      THETAB=ATAN((ABS((APD-SQRT(ABS(APD**2-4.*ADMBC)))/2.)-MBQ**2
     $+AMZ**2*(COSB**2-SINB**2)*(.5-SN2THW/3.)
     $-AMBLSS**2+PIBLBL(AMB1SS**2,G1,G2,G3,CTHW))
     $/(MBQ*(TWOM1*SINB/COSB+AAB)+PIBLBR(AMB1SS**2,G1,G2,G3,CTHW)))
       APD=AMBLSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)*(-.5+SN2THW/3.)
     $+AMBRSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)*SN2THW/3.
     $-PIBLBL(AMB2SS**2,G1,G2,G3,CTHW)-
     $PIBRBR(AMB2SS**2,G1,G2,G3,CTHW)
      ADMBC=(AMBLSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)
     $*(-.5+SN2THW/3.)-PIBLBL(AMB2SS**2,G1,G2,G3,CTHW))*
     $(AMBRSS**2+MBQ**2+AMZ**2*(COSB**2-SINB**2)*SN2THW/3.-
     $PIBRBR(AMB2SS**2,G1,G2,G3,CTHW))-(MBQ*(-AAB-TWOM1*SINB/COSB)-
     $PIBLBR(AMB2SS**2,G1,G2,G3,CTHW))**2
      AMB2SS=SQRT(ABS((APD+SQRT(ABS(APD**2-4.*ADMBC)))/2.))
C
      APD=AMLLSS**2+MLQ**2+AMZ**2*(COSB**2-SINB**2)*(-.5+SN2THW)
     $+AMLRSS**2+MLQ**2+AMZ**2*(COSB**2-SINB**2)*(-SN2THW)
     $-PILLLL(AML1SS**2,G1,G2,G3,CTHW)-PILRLR(AML1SS**2,G1,G2,G3,CTHW)
      ADMBC=(AMLLSS**2+MLQ**2+AMZ**2*(COSB**2-SINB**2)*(-.5+SN2THW)
     $-PILLLL(AML1SS**2,G1,G2,G3,CTHW))*(AMLRSS**2+MLQ**2
     $+AMZ**2*(COSB**2-SINB**2)*(-SN2THW)-
     $PILRLR(AML1SS**2,G1,G2,G3,CTHW))-(MLQ*(-AAL-TWOM1*SINB/COSB)
     $-PILLLR(AML1SS**2,G1,G2,G3,CTHW))**2
      AML1SS=SQRT(ABS((APD-SQRT(ABS(APD**2-4.*ADMBC)))/2.))
      THETAL=ATAN((ABS((APD-SQRT(ABS(APD**2-4.*ADMBC)))/2.)
     $-MLQ**2+AMZ**2*(COSB**2-SINB**2)*(.5-SN2THW)-
     $AMLLSS**2+PILLLL(AML1SS**2,G1,G2,G3,CTHW))
     $/(MLQ*(TWOM1*SINB/COSB+AAL)+PILLLR(AML1SS**2,G1,G2,G3,CTHW)))
      APD=AMLLSS**2+MLQ**2+AMZ**2*(COSB**2-SINB**2)*(-.5+SN2THW)
     $+AMLRSS**2+MLQ**2+AMZ**2*(COSB**2-SINB**2)*(-SN2THW)
     $-PILLLL(AML2SS**2,G1,G2,G3,CTHW)-PILRLR(AML2SS**2,G1,G2,G3,CTHW)
      ADMBC=(AMLLSS**2+MLQ**2+AMZ**2*(COSB**2-SINB**2)*(-.5+SN2THW)
     $-PILLLL(AML2SS**2,G1,G2,G3,CTHW))*(AMLRSS**2+MLQ**2
     $+AMZ**2*(COSB**2-SINB**2)*(-SN2THW)-
     $PILRLR(AML2SS**2,G1,G2,G3,CTHW))-(MLQ*(-AAL-TWOM1*SINB/COSB)
     $-PILLLR(AML2SS**2,G1,G2,G3,CTHW))**2
      AML2SS=SQRT(ABS((APD+SQRT(ABS(APD**2-4.*ADMBC)))/2.))
C
      XLAM=DLOG(DBLE(AMULSS**2))
      XX=(AMGLSS/AMULSS)**2
      AMULSS=SQRT(AMULSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMULSS**2,AMULSS,0.)+SSA0(AMGLSS)/AMULSS**2
     $-(1.-XX)*SSB0(AMULSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMURSS**2))
      XX=(AMGLSS/AMURSS)**2
      AMURSS=SQRT(AMURSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMURSS**2,AMURSS,0.)+SSA0(AMGLSS)/AMURSS**2
     $-(1.-XX)*SSB0(AMURSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMDLSS**2))
      XX=(AMGLSS/AMDLSS)**2
      AMDLSS=SQRT(AMDLSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMDLSS**2,AMDLSS,0.)+SSA0(AMGLSS)/AMDLSS**2
     $-(1.-XX)*SSB0(AMDLSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMDRSS**2))
      XX=(AMGLSS/AMDRSS)**2
      AMDRSS=SQRT(AMDRSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMDRSS**2,AMDRSS,0.)+SSA0(AMGLSS)/AMDRSS**2
     $-(1.-XX)*SSB0(AMDRSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMCLSS**2))
      XX=(AMGLSS/AMCLSS)**2
      AMCLSS=SQRT(AMCLSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMCLSS**2,AMCLSS,0.)+SSA0(AMGLSS)/AMCLSS**2
     $-(1.-XX)*SSB0(AMCLSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMCRSS**2))
      XX=(AMGLSS/AMCRSS)**2
      AMCRSS=SQRT(AMCRSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMCRSS**2,AMCRSS,0.)+SSA0(AMGLSS)/AMCRSS**2
     $-(1.-XX)*SSB0(AMCRSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMSLSS**2))
      XX=(AMGLSS/AMSLSS)**2
      AMSLSS=SQRT(AMSLSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMSLSS**2,AMSLSS,0.)+SSA0(AMGLSS)/AMSLSS**2
     $-(1.-XX)*SSB0(AMSLSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMSRSS**2))
      XX=(AMGLSS/AMSRSS)**2
      AMSRSS=SQRT(AMSRSS**2*(1.+G3**2/6./PI**2
     $*(2.*SSB1(AMSRSS**2,AMSRSS,0.)+SSA0(AMGLSS)/AMSRSS**2
     $-(1.-XX)*SSB0(AMSRSS**2,AMGLSS,0.))))
C
      XLAM=DLOG(DBLE(AMELSS**2))
      AMELSS=SQRT(AMELSS**2-PIELEL(AMELSS**2,G1,G2,G3,CTHW))     
      XLAM=DLOG(DBLE(AMERSS**2))
      AMERSS=SQRT(AMERSS**2-PIERER(AMERSS**2,G1,G2,G3,CTHW))
      XLAM=DLOG(DBLE(AMN1SS**2))
      AMN1SS=SQRT(AMN1SS**2-PINENE(AMN1SS**2,G1,G2,G3,CTHW))
      XLAM=DLOG(DBLE(AMMLSS**2))
      AMMLSS=SQRT(AMMLSS**2-PIELEL(AMMLSS**2,G1,G2,G3,CTHW))     
      XLAM=DLOG(DBLE(AMMRSS**2))
      AMMRSS=SQRT(AMMRSS**2-PIERER(AMMRSS**2,G1,G2,G3,CTHW))
      XLAM=DLOG(DBLE(AMN2SS**2))
      AMN2SS=SQRT(AMN2SS**2-PINENE(AMN2SS**2,G1,G2,G3,CTHW))
      XLAM=DLOG(DBLE(AMN3SS**2))
      AMN3SS=SQRT(AMN3SS**2-PINENE(AMN3SS**2,G1,G2,G3,CTHW))
      AMZ1SS=TMZ1SS
      AMZ2SS=TMZ2SS
      AMZ3SS=TMZ3SS
      AMZ4SS=TMZ4SS
      AMW1SS=TMW1SS
      AMW2SS=TMW2SS
C
      XLAM=DLOG(DBLE(HIGFRZ**2))
      RETURN
      END
+EOD
+DECK,SSMASS
      SUBROUTINE SSMASS(XMG,XM1,XM2,IALLOW,ILOOP,MHLNEG,MHCNEG,IMODEL)
C-----------------------------------------------------------------------
C
C          Diagonalize neutralino, chargino, and Higgs mass matrices
C          and save results in /SSPAR/.
C
C          If XM1, XM2 < 1E19, use them for the U(1) and SU(2) mass
C          terms. Otherwise calculate them from AMGLSS and unification.
C
C          Return IALLOW = 1 if Z1SS is not LSP
C                 IALLOW = 0 otherwise
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
+CDE,SSINF
+CDE,SUGMG
C
      REAL XM1,XM2,XMG
      INTEGER IALLOW,MHLNEG,MHCNEG,IMODEL
      REAL AR(4,4),WORK(4),WR(4)
      REAL ZETA,ZETAS,YM,XM,COS2A,SINA,AL,SIN2A,COSA,MU2,GP,G,
     $TEMP,VS,VP,V,MTAMTA,MTAMB,MTAMZ,ASMB,MBMB,
     $ASMT,MTMT,SUALFE,SUALFS
      REAL MW1,MW2,THX,THY,MU1
      REAL COSB,SINB,BE,COS2B,SIN2B,PI,SR2,HIGFRZ
      REAL TERM1,TERM2,TERM3,TANTHT,AMGLMZ,SSPOLE,TANTHB,TANTHL
      REAL CS2THW,DELCHI,AM2,AMTRSQ,AMTLSQ,DMTREE
      DOUBLE PRECISION SSMQCD
      COMPLEX*16 SSB0,SSB1,ZZZ
      REAL*8 REAL8
      INTEGER I,J,K,IERR,ILOOP
C
      REAL8(ZZZ)=DREAL(ZZZ)
      IALLOW=0
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4.*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      CS2THW=1.-SN2THW
C
      BE=ATAN(VUQ/VDQ)
      SINB=SIN(BE)
      COSB=COS(BE)
      SIN2B=SIN(2.*BE)
      COS2B=COS(2.*BE)
      HIGFRZ=SQRT(MAX(AMZ**2,AMTLSS*AMTRSS*SIGN(1.,AMTLSS*AMTRSS)))
C
C          Compute m(tau), m(b) at z scale using qcd, qed
C
C          Redo using MTQ, MBQ and MLQ
C      MTAMTA=AMTAU*(1.-SUALFE(AMTAU**2)/PI)
C      MTAMB=MTAMTA*(SUALFE(AMBT**2)/SUALFE(AMTAU**2))**(-27./76.)
C      MTAMZ=MTAMB*(SUALFE(AMZ**2)/SUALFE(AMBT**2))**(-27./80.)
C      MTAMZ=1.7463
C      ASMB=SUALFS(AMBT**2,.36,AMTP,3)
C      MBMB=AMBT*(1.-4*ASMB/3./PI)
C      MBQ=SSMQCD(DBLE(MBMB),DBLE(HIGFRZ))
C      ASMT=SUALFS(AMTP**2,.36,AMTP,3)
C      MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))*
C     $(ASMT/PI)**2)
C      MTQ=SSMQCD(DBLE(MTMT),DBLE(HIGFRZ))
C
C     Light/heavy stop states and mixing angle
C     Compute here only if RGE solution is not invoked;
C     otherwise, calculation is in SUGMAS
C
      AMTLSQ=SIGN(1.,AMTLSS)*AMTLSS**2
      AMTRSQ=SIGN(1.,AMTRSS)*AMTRSS**2
      TERM1=(AMTLSQ+AMTRSQ)/2.+AMZ**2*COS2B/4.+MTQ**2
      TERM2=((AMTLSQ-AMTRSQ)/2.+COS2B*(8.*AMW**2-5.*AMZ**2)
     $/12.)**2
      TERM3=SQRT(TERM2+MTQ**2*(TWOM1*COSB/SINB+AAT)**2)
      IF (TERM1.GT.TERM3) THEN
        AMT1SS=SQRT(TERM1-TERM3)
      ELSE
        AMT1SS=0.1
      END IF
      AMT2SS=SQRT(TERM1+TERM3)
      IF (AAT.NE.TWOM1*COSB/SINB) THEN
        TANTHT=(AMT1SS**2-MTQ**2+AMZ**2*COS2B*(-.5+2*SN2THW/3.)-
     $  AMTLSQ)/MTQ/(TWOM1*COSB/SINB+AAT)
        THETAT=ATAN(TANTHT)
      ELSE
        THETAT=PI/2.
      END IF
C
C     Light/heavy sbottom states and mixing angle
C
      TERM1=(AMBLSS**2+AMBRSS**2)/2.-AMZ**2*COS2B/4.+MBQ**2
      TERM2=((AMBLSS**2-AMBRSS**2)/2.-COS2B*(4.*AMW**2-AMZ**2)
     $/12.)**2
      TERM3=SQRT(TERM2+MBQ**2*(TWOM1*SINB/COSB+AAB)**2)
      IF (TERM1.GT.TERM3) THEN
        AMB1SS=SQRT(TERM1-TERM3)
      ELSE
        AMB1SS=0.1
      END IF
      AMB2SS=SQRT(TERM1+TERM3)
      TANTHB=(AMB1SS**2-MBQ**2+AMZ**2*COS2B*(.5-SN2THW/3.)-
     $AMBLSS**2)/MBQ/(TWOM1*SINB/COSB+AAB)
      THETAB=ATAN(TANTHB)
C
C     Light/heavy stau states and mixing angle
C
      TERM1=(AMLLSS**2+AMLRSS**2)/2.-AMZ**2*COS2B/4.+MLQ**2
      TERM2=((AMLLSS**2-AMLRSS**2)/2.-COS2B*(4.*AMW**2-3*AMZ**2)
     $/4.)**2
      TERM3=SQRT(TERM2+MLQ**2*(TWOM1*SINB/COSB+AAL)**2)
C     if stau mass^2<0, then set to tiny mass so point is excluded
      IF (TERM1.GT.TERM3) THEN
        AML1SS=SQRT(TERM1-TERM3)
      ELSE
        AML1SS=0.1
      END IF
      AML2SS=SQRT(TERM1+TERM3)
      TANTHL=(AML1SS**2-MLQ**2+AMZ**2*COS2B*(.5-SN2THW)-
     $AMLLSS**2)/MLQ/(TWOM1*SINB/COSB+AAL)
      THETAL=ATAN(TANTHL)
C
C     define msbar gluino mass at mz from physical gluino mass
      AMGLMZ=SSPOLE(SIGN(1.,XMG)*AMGLSS,AMGLSS**2,-ALFA3)
C      VS=2.*AMW**2/G**2/(1.+RV2V1**2)
      V=VUQ
      VP=VDQ
C
C          Use either explicit values or scaling to determine SU(2)
C          and U(1) mass terms. NOTE SIGN CONVENTION!
C
      IF(ABS(XM2).LT.1.E19.AND.ABS(XM1).LT.1.E19) THEN
         MU2=-XM2
         MU1=-XM1
      ELSE
         MU2=-ALFA2*AMGLMZ/ALFA3
         MU1=5*SN2THW/3./(1.-SN2THW)*MU2
      ENDIF
C
C          Neutralino mass matrix
C
      AR(1,1)=0.
      AR(1,2)=-TWOM1
      AR(1,3)=-G*V/SR2
      AR(1,4)=GP*V/SR2
      AR(2,1)=-TWOM1
      AR(2,2)=0.
      AR(2,3)=G*VP/SR2
      AR(2,4)=-GP*VP/SR2
      AR(3,1)=-G*V/SR2
      AR(3,2)=G*VP/SR2
      AR(3,3)=MU2
      AR(3,4)=0.
      AR(4,1)=GP*V/SR2
      AR(4,2)=-GP*VP/SR2
      AR(4,3)=0.
      AR(4,4)=MU1
C
      CALL EISRS1(4,4,AR,WR,ZMIXSS,IERR,WORK)
      IF (IERR.NE.0) THEN
        WRITE(LOUT,*) 'EISRS1 ERROR IN SSMASS, IERR=',IERR
        STOP99
      END IF
C
C       Sort eigenvectors and eigenvalues according to masses
C
      DO 10 I=1,3
        DO 11 J=I+1,4
          IF (ABS(WR(I)).GT.ABS(WR(J))) THEN
            TEMP=WR(J)
            WR(J)=WR(I)
            WR(I)=TEMP
            DO 12 K=1,4
              TEMP=ZMIXSS(K,J)
              ZMIXSS(K,J)=ZMIXSS(K,I)
              ZMIXSS(K,I)=TEMP
12          CONTINUE
          END IF
11      CONTINUE
10    CONTINUE
C
      AMZ1SS=WR(1)
      AMZ2SS=WR(2)
      AMZ3SS=WR(3)
      AMZ4SS=WR(4)
C
C          Chargino mass matrix
C
      AL=ATAN(RV2V1)
      SINA=SIN(AL)
      COSA=COS(AL)
      SIN2A=SIN(2.*AL)
      COS2A=COS(2.*AL)
      ZETAS=(TWOM1**2-MU2**2)**2
     $+4*AMW**2*(AMW**2*COS2A**2+TWOM1**2+MU2**2+2*TWOM1*MU2*SIN2A)
      ZETA=SQRT(ZETAS)
      XM=-(TWOM1**2-MU2**2-2*AMW**2*COS2A-ZETA)
     $/(2*SR2*AMW*(MU2*SINA+TWOM1*COSA))
      YM=-(TWOM1**2-MU2**2+2*AMW**2*COS2A-ZETA)
     $/(2*SR2*AMW*(MU2*COSA+TWOM1*SINA))
      IF (XM.NE.0.) THEN
        GAMMAL=ATAN(1./XM)
      ELSE
        GAMMAL=PI/2.
      END IF
      IF (YM.NE.0.) THEN
        GAMMAR=ATAN(1./YM)
      ELSE
        GAMMAR=PI/2.
      END IF
      IF (GAMMAL.LT.0.) GAMMAL=GAMMAL+PI
      IF (GAMMAR.LT.0.) GAMMAR=GAMMAR+PI
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      AMW2SS=THX*THY*(COS(GAMMAR)*(MU2*COS(GAMMAL)+G*VP*SIN(GAMMAL))
     $-SIN(GAMMAR)*(-G*V*COS(GAMMAL)-TWOM1*SIN(GAMMAL)))
      AMW1SS=SIN(GAMMAR)*(MU2*SIN(GAMMAL)-G*VP*COS(GAMMAL))
     $+COS(GAMMAR)*(-G*V*SIN(GAMMAL)+TWOM1*COS(GAMMAL))
      DMTREE=ABS(AMW1SS)-ABS(AMZ1SS)
C
C          Higgs mass matrix
C
c      IF (ILOOP.EQ.1) THEN
        CALL SSMHN(MHLNEG)
        CALL SSMHC(MHCNEG)
c      END IF
C
C          Compute 1loop radiative corrections to sparticle masses
C
      IF (ILOOP.EQ.1) THEN
        CALL SSM1LP(MU1,MU2,IALLOW)
      END IF
C     IMPLEMENT INO MASS SPLITTING FOR AMSB MODELS
      IF (IMODEL.EQ.7) THEN
      AM2=ABS(XM2)
      XLAM=LOG(MU2**2)
      MW1=ABS(AMW1SS)
      DELCHI=G**2*MW1/8./PI**2*(2*CS2THW*REAL8(SSB0(MW1**2,MW1,AMZ))+
     $2*SN2THW*REAL8(SSB0(MW1**2,MW1,0.))-2*REAL8(SSB0(MW1**2,MW1,AMW))
     $-CS2THW*REAL8(SSB1(MW1**2,MW1,AMZ))-SN2THW*
     $REAL8(SSB1(MW1**2,MW1,0.))+REAL8(SSB1(MW1**2,MW1,AMW)))
      AMW1SS=SIGN(1.,AMW1SS)*(ABS(AMZ1SS)+DMTREE+DELCHI)
      END IF
C          Check validity of parameters
C
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
      IF (IMODEL.EQ.0.OR.IMODEL.EQ.1.OR.IMODEL.EQ.7) THEN
        IF(MW1.LE.ABS(AMZ1SS)) IALLOW=1
        IF(AMT1SS.LE.ABS(AMZ1SS)) IALLOW=1
        IF(AMB1SS.LE.ABS(AMZ1SS)) IALLOW=1
        IF(AML1SS.LE.ABS(AMZ1SS)) IALLOW=1
      END IF
C      IF(IALLOW.NE.0) RETURN
C
      MSS(1)=AMGLSS
      MSS(2)=AMULSS
      MSS(3)=AMURSS
      MSS(4)=AMDLSS
      MSS(5)=AMDRSS
      MSS(6)=AMSLSS
      MSS(7)=AMSRSS
      MSS(8)=AMCLSS
      MSS(9)=AMCRSS
      MSS(10)=AMB1SS
      MSS(11)=AMB2SS
      MSS(12)=AMT1SS
      MSS(13)=AMT2SS
      MSS(14)=AMN1SS
      MSS(15)=AMN2SS
      MSS(16)=AMN3SS
      MSS(17)=AMELSS
      MSS(18)=AMERSS
      MSS(19)=AMMLSS
      MSS(20)=AMMRSS
      MSS(21)=AML1SS
      MSS(22)=AML2SS
      MSS(23)=AMZ1SS
      MSS(24)=AMZ2SS
      MSS(25)=AMZ3SS
      MSS(26)=AMZ4SS
      MSS(27)=AMW1SS
      MSS(28)=AMW2SS
      MSS(29)=AMHL
      MSS(30)=AMHH
      MSS(31)=AMHA
      MSS(32)=AMHC
      RETURN
      END
+EOD
+DECK,SSME3
      SUBROUTINE SSME3(KTYP,AM,ZI,ZF)
C
C          Give matrix element data for mode most recently saved by 
C          SSSAVE. Call this once for each pole in the matrix element,
C          giving the pole type, mass, and couplings. See /DKYSS3/
C          for more comments.
C
C          Assumes SUSY decay product is always FIRST.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,SSLUN
+CDE,SSMODE
+CDE,DKYSS3
C
      INTEGER KTYP,I
      REAL AM
      COMPLEX ZI(2),ZF(2)
C
C          If last SSSAVE failed, then skip the matrix element
C
      IF(.NOT.LSSMOD) RETURN
C
C          If MSSMOD(NSSMOD)=0, have not booked any poles yet for
C          last mode saved. Increment mode counter, and set initial and
C          final poles to next one.
C
      IF(MSSMOD(NSSMOD).EQ.0) THEN
        NMSS3=NMSS3+1
        IF(NMSS3.GT.MXMSS3) THEN
          WRITE(LOUT,*) 'ERROR IN SSME3...TOO MANY MODES=',NMSS3
          STOP99
        ENDIF
        MSSMOD(NSSMOD)=-NMSS3
        J1SS3(NMSS3)=NPSS3+1
        J2SS3(NMSS3)=NPSS3+1
        WTSS3(NMSS3)=0
      ENDIF
C
C          Add pole to list and set second counter to last pole
C
      NPSS3=NPSS3+1
      IF(NPSS3.GT.MXPSS3) THEN
        WRITE(LOUT,*) 'ERROR IN SSME3...TOO MANY POLES=',NPSS3
        STOP99
      ENDIF
      KSS3(NPSS3)=KTYP
      AMSS3(NPSS3)=AM
      DO 100 I=1,2
        ZISS3(I,NPSS3)=ZI(I)
        ZFSS3(I,NPSS3)=ZF(I)
100   CONTINUE
      J2SS3(NMSS3)=NPSS3
C
      RETURN
      END
+EOD
+DECK,SSMHC
      SUBROUTINE SSMHC(MHCNEG)
C-----------------------------------------------------------------------
C
C         Calculates charged Higgs mass 
C         (scalar Higgs mixing angle) using radiative
C         corrections calculated by M. Bisset
C         and save results in /SSPAR/.
C
C         Both top and bottom couplings are now 
C         included.  Non-degenerate mixed squark
C         masses and A-terms are also included.
C         The D-terms from the squark mass matrix
C         (terms prop. to g**2 * Yukawa coupling)
C         are included by default.
C
C         There is an arbitrary mass scale that must
C         chosen to avoid dimensionful logarithms.
C         The choice does not matter if D-terms are
C         not included, but it does matter if D-terms
C         are included. 
C     
C         Arbitrary mass scale set to
C              QQQ = HIGFRZ = SQRT(AMTLSS*AMTRSS)
C         Updated to include running masses as 2-loop effect
C
C         It is assumed that the A-terms are real.  
C         (Complex A-terms are taken into account 
C         much of the subroutine; but, not in all
C         cases.)
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
C
      INTEGER MHCNEG
      REAL PI,PI2,SR2,G2,GP2,GGP,GG1,GG2
      REAL GGPM,GG3,GG4
      REAL TANB,COTB,COSB,SINB,BE
      REAL SINB2,COSB2,COS2B,SIN2B
      REAL V2,VP2,V,VP,VVP,VPVM,VVPP,MT,MB
      REAL MT2,MB2,MT4,MB4,FT2,FB2,FT,FB
      REAL MW2,MZ2,ZAP,QQQ2,EP,EP2,RR,MHP2
      REAL ATI,ABI,ATR,ABR,AT2,AB2
      REAL MSTL2,MSTR2,MSBL2,MSBR2
      REAL TLRM,BLRM,TLRP,BLRP
      REAL MST1SQ,MST2SQ,MSB1SQ,MSB2SQ
      REAL TTT1,TTT2,TTT3,BBB1,BBB2,BBB3
      REAL TEMPT,TEMPB,ROOTT,ROOTB,TM1B
C
C      For non-degenerate squarks
C
      REAL TERMT,TERMB,DHRT1,DHRT2,DHRB1,DHRB2
      REAL DHRPT1,DHRPT2,DHRPB1,DHRPB2
      REAL DHPST1,DHPST2,DHPSB1,DHPSB2
      REAL DHMST1,DHMST2,DHMSB1,DHMSB2
      REAL ATA1,ATA2,BTA1,BTA2,ABA1,ABA2,BBA1,BBA2
      REAL ATA1SQ,ATA2SQ,BTA1SQ,BTA2SQ
      REAL ABA1SQ,ABA2SQ,BBA1SQ,BBA2SQ
      REAL NABT1,NABT2,NABB1,NABB2
      REAL FTG,FBG,BABA,PT1B1,PT1B2,PT2B1,PT2B2
      REAL PDPST1,PDPST2,PDPSB1,PDPSB2
      REAL PDMST1,PDMST2,PDMSB1,PDMSB2
      REAL PDPMT1,PDPMT2,PDPMB1,PDPMB2
      REAL LMST1,LMST2,LMSB1,LMSB2
      REAL EMI1,EMI2,EM3,TEMPF
      REAL DVRR,DVRPRP,DVRRP,TRACE,DETV 
      REAL TERMSQ,GOLD2,MHC2
      REAL HIGFRZ,ASMB,MBMB,MBQP,ASMT,MTMT,MTQP,SUALFS
      DOUBLE PRECISION SSMQCD
C
      MHCNEG=0
      PI=4.*ATAN(1.)
      PI2=PI**2
      SR2=SQRT(2.)
      G2=4.*PI*ALFAEM/SN2THW
      GP2=G2*SN2THW/(1.-SN2THW)
      HIGFRZ=SQRT(MAX(AMZ**2,AMTLSS*AMTRSS*SIGN(1.,AMTLSS*AMTRSS)))
c      ASMB=SUALFS(AMBT**2,.36,AMTP,3)
c      MBMB=AMBT*(1.-4*ASMB/3./PI)
c      MBQP=SSMQCD(DBLE(MBMB),DBLE(HIGFRZ))
c      ASMT=SUALFS(AMTP**2,.36,AMTP,3)
c      MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))*
c     $(ASMT/PI)**2)
c      MTQP=SSMQCD(DBLE(MTMT),DBLE(HIGFRZ))
      MT=MTQ
      MB=MBQ
      MT2=MT**2
      MB2=MB**2
      MT4=MT2**2
      MB4=MB2**2
      MW2=AMW**2
      MZ2=AMZ**2
      EP=TWOM1
      EP2=EP**2
      RR=RV2V1
      MHP2=AMHA**2
      TANB=1.0/RR
      COTB=RR
      BE=ATAN(1./RV2V1)
      SINB=SIN(BE)
      COSB=COS(BE)
      SINB2=SINB**2
      COSB2=COSB**2
      SIN2B=SIN(2.*BE)
      COS2B=COS(2.*BE)
      V2=2.0*MW2*SINB2/G2
      VP2=2.0*MW2*COSB2/G2
      V=SQRT(V2)
      VP=SQRT(VP2)
      VVP=SQRT(V2*VP2)
      VPVM=VP2-V2
      GGP=G2+GP2
      GGPM=G2-GP2
      GG1=G2-5.0*GP2/3.0
      GG2=G2-GP2/3.0
      GG3=G2+5.0*GP2/3.0
      GG4=G2+GP2/3.0
C
      VVPP=2.0*AMZ**2/GGP
      FT2=MT2/V2
      FB2=MB2/VP2
      FT=SQRT(FT2)
      FB=SQRT(FB2)
C
      MSTL2=AMTLSS**2*SIGN(1.,AMTLSS)
      MSTR2=AMTRSS**2*SIGN(1.,AMTRSS)
      MSBL2=AMBLSS**2
      MSBR2=AMBRSS**2
      TLRM=MSTL2-MSTR2
      BLRM=MSBL2-MSBR2 
      TLRP=MSTL2+MSTR2
      BLRP=MSBL2+MSBR2 
C
C          Charged Higgs mass calculation
C          (AAT and AAB are also assumed to be real)
C          
      ATR=AAT
      ABR=AAB
      ATI=0.0
      ABI=0.0
      AT2=ATR**2+ATI**2
      AB2=ABR**2+ABI**2
C
C      UNFORTUNATELY, I HAVE USED MY OLD CONVENTION
C      FOR THE STOP AND SBOTTOM EIGENVALUES HERE 
C      (T1 <==> T2 OF NOTATION IN X. TATA'S AND OTHER
C      PEOPLE'S NOTATION).  SO THE NEXT EIGHT LINES ARE
C      A FIX-UP UNTIL I GO THROUGH AND CHANGE THE
C      NOTATION THROUGHOUT THIS SUBROUTINE.
C
C
C     Calculate mt1,mt2,mb1,mb2 internally so masses consistent
C     with value of mbq and mtq used here
C
      MST2SQ=TLRP/2.+MZ2*COS2B/4.+MTQ**2-SQRT((TLRM/2.+COS2B/12.
     ,*(8*MW2-5*MZ2))**2+MTQ**2*(-AAT-EP*COTB)**2)
      MST1SQ=TLRP/2.+MZ2*COS2B/4.+MTQ**2+SQRT((TLRM/2.+COS2B/12.
     ,*(8*MW2-5*MZ2))**2+MTQ**2*(-AAT-EP*COTB)**2)
      MSB2SQ=BLRP/2.-MZ2*COS2B/4.+MBQ**2-SQRT((BLRM/2.-COS2B/12.
     ,*(4*MW2-MZ2))**2+MBQ**2*(-AAB-EP*TANB)**2)
      MSB1SQ=BLRP/2.-MZ2*COS2B/4.+MBQ**2+SQRT((BLRM/2.-COS2B/12.
     ,*(4*MW2-MZ2))**2+MBQ**2*(-AAB-EP*TANB)**2)
      IF (MST2SQ.LE.0..OR.MSB2SQ.LE.0.) THEN
        MHC2=-1.
        GO TO 50
      END IF
C
      QQQ2=HIGFRZ**2
      ZAP=1
C
C          Non-degenerate squarks and/or D-terms. Since D-terms are
C          always included, old dead code has been deleted. FEP
C
C          ROOTT recast as a sum of squares. Note that ROOTT=0 
C          could happen accidently and causes an error.
      TTT1=0.5*(MSTL2+MSTR2)+MT2+ZAP*VPVM*GGP/8.0
      TTT2=TLRM+ZAP*GG1*VPVM/4.0
      TTT3=4.0*FT2*(EP2*VP2+2.0*EP*VVP*ATR+AT2*V2)
      ROOTT=4*MT2*(COSB*EP + AAT*SINB)**2/SINB**2 +
     $(MSTL2-MSTR2 +
     $AMW**2*(-5*GP2/3 + G2)*(COSB**2 - SINB**2)/(2*G2))**2
      ROOTT=0.5*SQRT(ROOTT)
      IF(ROOTT.EQ.0.0) THEN
        WRITE(LOUT,*) 'SSMHC: ERROR: ROOTT = 0,',
     $  '  CANNOT CALCULATE H+ MASS FOR THIS CASE.'
        STOP99
      ENDIF
C
      BBB1=0.5*(MSBL2+MSBR2)+MB2-ZAP*VPVM*GGP/8.0
      BBB2=BLRM-ZAP*GG2*VPVM/4.0
      BBB3=4.0*FB2*(EP2*V2+2.0*EP*VVP*ABR+AB2*VP2)
C          ROOTB recast as a sum of squares.
      ROOTB=4*MB2*(AAB*COSB + EP*SINB)**2/COSB**2 + 
     $(AMBLSS**2 - AMBRSS**2 - 
     $AMW**2*(-GP2/3 + G2)*(COSB**2 - SINB**2)/(2*G2))**2
      ROOTB=0.5*SQRT(ROOTB)
      IF(ROOTB.EQ.0.0) THEN
        WRITE(LOUT,*) 'SSMHC: ERROR: ROOTB = 0,',
     $  '  CANNOT CALCULATE H+ MASS FOR THIS CASE.'
        STOP99
      ENDIF 
C
C      Calculate 2M1*B term
C
      TEMPT=EP*FT2*VVP*ATI**2/(ROOTT**2)
      TEMPB=EP*FB2*VVP*ABI**2/(ROOTB**2)
      TM1B=-FT2*(TEMPT+ATR)*TTT1*LOG(MST1SQ/MST2SQ)/ROOTT
      TM1B=TM1B-FT2*ATR*LOG(MST1SQ*MST2SQ/QQQ2/QQQ2)
      TM1B=TM1B+FT2*(2.0*TEMPT-ATR)
      TM1B=TM1B-FB2*(TEMPB+ABR)*BBB1*LOG(MSB1SQ/MSB2SQ)/ROOTB
      TM1B=TM1B-FB2*ABR*LOG(MSB1SQ*MSB2SQ/QQQ2/QQQ2)
      TM1B=TM1B+FB2*(2.0*TEMPB-ABR)
      TM1B=3.0*EP*TM1B/32.0/PI2
      TM1B=TM1B-VVP*MHP2/VVPP
C
C       Calculate derivatives w.r.t. H_R divided by v*sqrt(2)
C
      TEMPT=ZAP*GG1*(TLRM+VPVM*GG1/4.0)/8.0
      TERMT=-TEMPT+FT2*(EP*COTB*ATR+AT2)
      TERMT=TERMT/(2.0*ROOTT)
      DHRT1=FT2-ZAP*GGP/8.0 + TERMT
      DHRT2=FT2-ZAP*GGP/8.0 - TERMT
C     
      TEMPB=ZAP*GG2*(BLRM-VPVM*GG2/4.0)/8.0
      TERMB=TEMPB+FB2*EP*(EP+COTB*ABR)
      TERMB=TERMB/(2.0*ROOTB)
      DHRB1=ZAP*GGP/8.0 + TERMB
      DHRB2=ZAP*GGP/8.0 - TERMB
C
C       Calculate derivatives w.r.t. H_R' divided by v'*sqrt(2)
C
      TERMT=TEMPT+FT2*EP*(EP+TANB*ATR)
      TERMT=TERMT/(2.0*ROOTT)
      DHRPT1=ZAP*GGP/8.0 + TERMT
      DHRPT2=ZAP*GGP/8.0 - TERMT
C          
      TERMB=-TEMPB+FB2*(EP*TANB*ABR+AB2)
      TERMB=TERMB/(2.0*ROOTB)
      DHRPB1=FB2-ZAP*GGP/8.0 + TERMB
      DHRPB2=FB2-ZAP*GGP/8.0 - TERMB
C
C       Calculate second derivatives w.r.t. H_R^+
C
      TEMPT=(TLRM+ZAP*VPVM*GG1/4.0)/(4.0*ROOTT)
      TERMT=TEMPT*(-FT2+ZAP*GG3/4.0)
      DHPST1=FT2/2.0 + ZAP*GGPM/8.0 + TERMT
      DHPST2=FT2/2.0 + ZAP*GGPM/8.0 - TERMT
C
      TEMPB=(BLRM-ZAP*VPVM*GG2/4.0)/(4.0*ROOTB)
      TERMB=TEMPB*(FT2-ZAP*GG4/4.0)
      DHPSB1=FT2/2.0 - ZAP*GGPM/8.0 + TERMB
      DHPSB2=FT2/2.0 - ZAP*GGPM/8.0 - TERMB
C
C       Calculate second derivatives w.r.t. H_R'^-
C
      TERMT=TEMPT*(FB2-ZAP*GG3/4.0)
      DHMST1=FB2/2.0 - ZAP*GGPM/8.0 + TERMT
      DHMST2=FB2/2.0 - ZAP*GGPM/8.0 - TERMT
C
      TERMB=TEMPB*(-FB2+ZAP*GG4/4.0)
      DHMSB1=FB2/2.0 + ZAP*GGPM/8.0 + TERMB
      DHMSB2=FB2/2.0 + ZAP*GGPM/8.0 - TERMB
C
C       From perturbative terms
C       Here I assume A_t and A_b are real
C       and therefore the eigenvectors are real
C
C       Find stop eigenvector factors
C
      TEMPT=-TLRM/2.0 - ZAP*VPVM*GG1/8.0
      ATA1=TEMPT+ROOTT
      ATA2=TEMPT-ROOTT
      BTA1=-MT*(EP*COTB + ATR)
      BTA2=BTA1
      IF(ATA1.EQ.0.0 .AND. BTA1.EQ.0.0) THEN
        ATA1=-BTA1
        BTA1 = TEMPT - ROOTT
        IF(ATA1.EQ.0.0 .AND. BTA1.EQ.0.0) THEN
          WRITE(LOUT,*) 'SSMHC: ERROR: ZERO EIGENVECTOR FOR MST1SQ'
          STOP99
        ENDIF
      ENDIF
      IF(ATA2.EQ.0.0 .AND. BTA2.EQ.0.0) THEN
        ATA2=-BTA2
        BTA2=TEMPT+ROOTT
        IF(ATA2.EQ.0.0 .AND. BTA2.EQ.0.0) THEN
          WRITE(LOUT,*) 'SSMHC: ERROR:  ZERO EIGENVECTOR FOR MST2SQ'
          STOP99
        ENDIF
      ENDIF
      ATA1SQ=ATA1**2
      BTA1SQ=BTA1**2
      ATA2SQ=ATA2**2
      BTA2SQ=BTA2**2
      NABT1=1.0/(ATA1SQ+BTA1SQ)
      NABT2=1.0/(ATA2SQ+BTA2SQ)
C     
C       Find sbottom eigenvector factors
C
      TEMPB=-BLRM/2.0 + ZAP*VPVM*GG2/8.0
      ABA1=TEMPB+ROOTB
      ABA2=TEMPB-ROOTB
      BBA1=-MB*(EP*TANB + ABR)
      BBA2=BBA1
      IF(ABA1.EQ.0.0 .AND. BBA1.EQ.0.0) THEN
        ABA1=-BBA1
        BBA1=TEMPB-ROOTB
        IF(ABA1.EQ.0.0 .AND. BBA1.EQ.0.0) THEN
          WRITE(LOUT,*) 'SSMHC: ERROR: ZERO EIGENVECTOR FOR MSB1SQ'
          STOP99
        ENDIF
      ENDIF
      IF(ABA2.EQ.0.0 .AND. BBA2.EQ.0.0) THEN
        ABA2=-BBA2
        BBA2=TEMPB+ROOTB            
        IF(ABA2.EQ.0.0 .AND. BBA2.EQ.0.0) THEN
          WRITE(LOUT,*) 'SSMHC: ERROR ZERO EIGENVECTOR FOR MSB2SQ'
          STOP99
        ENDIF
      ENDIF
      ABA1SQ=ABA1**2
      BBA1SQ=BBA1**2
      ABA2SQ=ABA2**2
      BBA2SQ=BBA2**2
      NABB1=1.0/(ABA1SQ+BBA1SQ)
      NABB2=1.0/(ABA2SQ+BBA2SQ)
C
C       Calculate perturbative terms 
C        from H_R^+2 derivative terms
C         
      FTG=FT2-ZAP*G2/2.0
      BABA=FT*FB*(VVP*FTG-EP*ATR)
      PT1B1=V2*(FTG**2)*BTA1SQ*BBA1SQ 
      PT1B1=PT1B1+2.0*EP*FB*V*FTG*BTA1SQ*BBA1*ABA1 
      PT1B1=PT1B1-2.0*ATR*MT*FTG*BTA1*ATA1*BBA1SQ
      PT1B1=PT1B1+2.0*BABA*BTA1*ATA1*BBA1*ABA1
      PT1B1=PT1B1-2.0*ATR*FT2*MB*ATA1SQ*BBA1*ABA1
      PT1B1=PT1B1+2.0*EP*FT*FB*MB*BTA1*ATA1*ABA1SQ
      PT1B1=PT1B1+FT2*AT2*ATA1SQ*BBA1SQ
      PT1B1=PT1B1+FB2*EP2*BTA1SQ*ABA1SQ
      PT1B1=PT1B1+FT2*MB2*ATA1SQ*ABA1SQ
      PT1B1=PT1B1*NABT1*NABB1
C
      PT1B2=V2*(FTG**2)*BTA1SQ*BBA2SQ 
      PT1B2=PT1B2+2.0*EP*FB*V*FTG*BTA1SQ*BBA2*ABA2 
      PT1B2=PT1B2-2.0*ATR*MT*FTG*BTA1*ATA1*BBA2SQ
      PT1B2=PT1B2+2.0*BABA*BTA1*ATA1*BBA2*ABA2
      PT1B2=PT1B2-2.0*ATR*FT2*MB*ATA1SQ*BBA2*ABA2
      PT1B2=PT1B2+2.0*EP*FT*FB*MB*BTA1*ATA1*ABA2SQ
      PT1B2=PT1B2+FT2*AT2*ATA1SQ*BBA2SQ
      PT1B2=PT1B2+FB2*EP2*BTA1SQ*ABA2SQ
      PT1B2=PT1B2+FT2*MB2*ATA1SQ*ABA2SQ
      PT1B2=PT1B2*NABT1*NABB2
C
      PT2B1=V2*(FTG**2)*BTA2SQ*BBA1SQ 
      PT2B1=PT2B1+2.0*EP*FB*V*FTG*BTA2SQ*BBA1*ABA1 
      PT2B1=PT2B1-2.0*ATR*MT*FTG*BTA2*ATA2*BBA1SQ
      PT2B1=PT2B1+2.0*BABA*BTA2*ATA2*BBA1*ABA1
      PT2B1=PT2B1-2.0*ATR*FT2*MB*ATA2SQ*BBA1*ABA1
      PT2B1=PT2B1+2.0*EP*FT*FB*MB*BTA2*ATA2*ABA1SQ
      PT2B1=PT2B1+FT2*AT2*ATA2SQ*BBA1SQ
      PT2B1=PT2B1+FB2*EP2*BTA2SQ*ABA1SQ
      PT2B1=PT2B1+FT2*MB2*ATA2SQ*ABA1SQ
      PT2B1=PT2B1*NABT2*NABB1
C
      PT2B2=V2*(FTG**2)*BTA2SQ*BBA2SQ 
      PT2B2=PT2B2+2.0*EP*FB*V*FTG*BTA2SQ*BBA2*ABA2 
      PT2B2=PT2B2-2.0*ATR*MT*FTG*BTA2*ATA2*BBA2SQ
      PT2B2=PT2B2+2.0*BABA*BTA2*ATA2*BBA2*ABA2
      PT2B2=PT2B2-2.0*ATR*FT2*MB*ATA2SQ*BBA2*ABA2
      PT2B2=PT2B2+2.0*EP*FT*FB*MB*BTA2*ATA2*ABA2SQ
      PT2B2=PT2B2+FT2*AT2*ATA2SQ*BBA2SQ
      PT2B2=PT2B2+FB2*EP2*BTA2SQ*ABA2SQ
      PT2B2=PT2B2+FT2*MB2*ATA2SQ*ABA2SQ
      PT2B2=PT2B2*NABT2*NABB2
C          The following used to add 1e-8, but this may be less than
C          machine precision. Multiply by 1.001 instead.
      IF(MST1SQ.EQ.MSB1SQ) THEN
        WRITE(LOUT,*) 'SSMHC: WARNING: MST1 = MSB1',
     $  '  MST1 RAISED BY 0.0001' 
        MST1SQ = MST1SQ*1.0001
      ENDIF
      IF(MST1SQ.EQ.MSB2SQ) THEN
        WRITE(LOUT,*) 'SSMHC: WARNING: MST1 = MSB2',
     $  '  MST1 RAISED BY 0.0001' 
        MST1SQ = MST1SQ*1.0001
      ENDIF
      IF(MST2SQ.EQ.MSB1SQ) THEN
        WRITE(LOUT,*) 'SSMHC: WARNING: MST2 = MSB1',
     $  '  MST2 RAISED BY 0.0001' 
        MST2SQ = MST2SQ*1.0001
      ENDIF
      IF(MST2SQ.EQ.MSB2SQ) THEN
        WRITE(LOUT,*) 'SSMHC: WARNING: MST2 = MSB2',
     $  '  MST2 RAISED BY 0.0001'
        MST2SQ = MST2SQ*1.0001
      ENDIF
C
      PDPST1=PT1B1/(MST1SQ-MSB1SQ) +PT1B2/(MST1SQ-MSB2SQ)
      PDPST2=PT2B1/(MST2SQ-MSB1SQ) +PT2B2/(MST2SQ-MSB2SQ)
      PDPSB1=PT1B1/(MSB1SQ-MST1SQ) +PT2B1/(MSB1SQ-MST2SQ)
      PDPSB2=PT1B2/(MSB2SQ-MST1SQ) +PT2B2/(MSB2SQ-MST2SQ)
C     
C       Calculate perturbative terms 
C        from H_R'^-2 derivative terms
C
      FBG=FB2-ZAP*G2/2.0
      BABA=FT*FB*(VVP*FBG-EP*ABR)
      PT1B1=VP2*(FBG**2)*BTA1SQ*BBA1SQ 
      PT1B1=PT1B1-2.0*ABR*MB*FBG*BTA1SQ*BBA1*ABA1 
      PT1B1=PT1B1+2.0*EP*FT*VP*FBG*BTA1*ATA1*BBA1SQ
      PT1B1=PT1B1+2.0*BABA*BTA1*ATA1*BBA1*ABA1
      PT1B1=PT1B1+2.0*EP*FT*FB*MT*ATA1SQ*BBA1*ABA1
      PT1B1=PT1B1-2.0*ABR*FB2*MT*BTA1*ATA1*ABA1SQ
      PT1B1=PT1B1+FT2*EP2*ATA1SQ*BBA1SQ
      PT1B1=PT1B1+FB2*AB2*BTA1SQ*ABA1SQ
      PT1B1=PT1B1+FB2*MT2*ATA1SQ*ABA1SQ
      PT1B1=PT1B1*NABT1*NABB1
C
      PT1B2=VP2*(FBG**2)*BTA1SQ*BBA2SQ 
      PT1B2=PT1B2-2.0*ABR*MB*FBG*BTA1SQ*BBA2*ABA2 
      PT1B2=PT1B2+2.0*EP*FT*VP*FBG*BTA1*ATA1*BBA2SQ
      PT1B2=PT1B2+2.0*BABA*BTA1*ATA1*BBA2*ABA2
      PT1B2=PT1B2+2.0*EP*FT*FB*MT*ATA1SQ*BBA2*ABA2
      PT1B2=PT1B2-2.0*ABR*FB2*MT*BTA1*ATA1*ABA2SQ
      PT1B2=PT1B2+FT2*EP2*ATA1SQ*BBA2SQ
      PT1B2=PT1B2+FB2*AB2*BTA1SQ*ABA2SQ
      PT1B2=PT1B2+FB2*MT2*ATA1SQ*ABA2SQ
      PT1B2=PT1B2*NABT1*NABB2
C     
      PT2B1=VP2*(FBG**2)*BTA2SQ*BBA1SQ 
      PT2B1=PT2B1-2.0*ABR*MB*FBG*BTA2SQ*BBA1*ABA1 
      PT2B1=PT2B1+2.0*EP*FT*VP*FBG*BTA2*ATA2*BBA1SQ
      PT2B1=PT2B1+2.0*BABA*BTA2*ATA2*BBA1*ABA1
      PT2B1=PT2B1+2.0*EP*FT*FB*MT*ATA2SQ*BBA1*ABA1
      PT2B1=PT2B1-2.0*ABR*FB2*MT*BTA2*ATA2*ABA1SQ
      PT2B1=PT2B1+FT2*EP2*ATA2SQ*BBA1SQ
      PT2B1=PT2B1+FB2*AB2*BTA2SQ*ABA1SQ
      PT2B1=PT2B1+FB2*MT2*ATA2SQ*ABA1SQ
      PT2B1=PT2B1*NABT2*NABB1
C
      PT2B2=VP2*(FBG**2)*BTA2SQ*BBA2SQ 
      PT2B2=PT2B2-2.0*ABR*MB*FBG*BTA2SQ*BBA2*ABA2 
      PT2B2=PT2B2+2.0*EP*FT*VP*FBG*BTA2*ATA2*BBA2SQ
      PT2B2=PT2B2+2.0*BABA*BTA2*ATA2*BBA2*ABA2
      PT2B2=PT2B2+2.0*EP*FT*FB*MT*ATA2SQ*BBA2*ABA2
      PT2B2=PT2B2-2.0*ABR*FB2*MT*BTA2*ATA2*ABA2SQ
      PT2B2=PT2B2+FT2*EP2*ATA2SQ*BBA2SQ
      PT2B2=PT2B2+FB2*AB2*BTA2SQ*ABA2SQ
      PT2B2=PT2B2+FB2*MT2*ATA2SQ*ABA2SQ
      PT2B2=PT2B2*NABT2*NABB2
C
      PDMST1=PT1B1/(MST1SQ-MSB1SQ) +PT1B2/(MST1SQ-MSB2SQ)
      PDMST2=PT2B1/(MST2SQ-MSB1SQ) +PT2B2/(MST2SQ-MSB2SQ)
      PDMSB1=PT1B1/(MSB1SQ-MST1SQ) +PT2B1/(MSB1SQ-MST2SQ)
      PDMSB2=PT1B2/(MSB2SQ-MST1SQ) +PT2B2/(MSB2SQ-MST2SQ)
C     
C        Calculate perturbative terms 
C        from  H_R^+ H_R'^- derivative terms
C
      BABA=FT*FB*(V2*FTG+VP2*FBG+EP2+ATR*ABR)
      PT1B1=-VVP*FTG*FBG*BTA1SQ*BBA1SQ
      PT1B1=PT1B1+FB*(ABR*V*FTG-EP*VP*FBG)*BTA1SQ*BBA1*ABA1
      PT1B1=PT1B1-FT*(EP*V*FTG-ATR*VP*FBG)*BTA1*ATA1*BBA1SQ
      PT1B1=PT1B1-BABA*BTA1*ATA1*BBA1*ABA1
      PT1B1=PT1B1+FT2*FB*(ATR*V-EP*VP)*ATA1SQ*BBA1*ABA1
      PT1B1=PT1B1+FT*FB2*(ABR*VP-EP*V)*BTA1*ATA1*ABA1SQ
      PT1B1=PT1B1+FT2*EP*ATR*ATA1SQ*BBA1SQ
      PT1B1=PT1B1+FB2*EP*ABR*BTA1SQ*ABA1SQ
      PT1B1=PT1B1-FT*FB*MT*MB*ATA1SQ*ABA1SQ
      PT1B1=PT1B1*NABT1*NABB1
C
      PT1B2=-VVP*FTG*FBG*BTA1SQ*BBA2SQ
      PT1B2=PT1B2+FB*(ABR*V*FTG-EP*VP*FBG)*BTA1SQ*BBA2*ABA2
      PT1B2=PT1B2-FT*(EP*V*FTG-ATR*VP*FBG)*BTA1*ATA1*BBA2SQ
      PT1B2=PT1B2-BABA*BTA1*ATA1*BBA2*ABA2
      PT1B2=PT1B2+FT2*FB*(ATR*V-EP*VP)*ATA1SQ*BBA2*ABA2
      PT1B2=PT1B2+FT*FB2*(ABR*VP-EP*V)*BTA1*ATA1*ABA2SQ
      PT1B2=PT1B2+FT2*EP*ATR*ATA1SQ*BBA2SQ
      PT1B2=PT1B2+FB2*EP*ABR*BTA1SQ*ABA2SQ
      PT1B2=PT1B2-FT*FB*MT*MB*ATA1SQ*ABA2SQ
      PT1B2=PT1B2*NABT1*NABB2
C
      PT2B1= -VVP*FTG*FBG*BTA2SQ*BBA1SQ
      PT2B1= PT2B1 + FB*(ABR*V*FTG - EP*VP*FBG)*BTA2SQ*BBA1*ABA1
      PT2B1= PT2B1 - FT*(EP*V*FTG - ATR*VP*FBG)*BTA2*ATA2*BBA1SQ
      PT2B1= PT2B1 - BABA*BTA2*ATA2*BBA1*ABA1
      PT2B1= PT2B1 + FT2*FB*(ATR*V - EP*VP)*ATA2SQ*BBA1*ABA1
      PT2B1= PT2B1 + FT*FB2*(ABR*VP - EP*V)*BTA2*ATA2*ABA1SQ
      PT2B1= PT2B1 + FT2*EP*ATR*ATA2SQ*BBA1SQ
      PT2B1= PT2B1 + FB2*EP*ABR*BTA2SQ*ABA1SQ
      PT2B1= PT2B1 - FT*FB*MT*MB*ATA2SQ*ABA1SQ
      PT2B1= PT2B1*NABT2*NABB1
C
      PT2B2=-VVP*FTG*FBG*BTA2SQ*BBA2SQ
      PT2B2=PT2B2+FB*(ABR*V*FTG-EP*VP*FBG)*BTA2SQ*BBA2*ABA2
      PT2B2=PT2B2-FT*(EP*V*FTG-ATR*VP*FBG)*BTA2*ATA2*BBA2SQ
      PT2B2=PT2B2-BABA*BTA2*ATA2*BBA2*ABA2
      PT2B2=PT2B2+FT2*FB*(ATR*V-EP*VP)*ATA2SQ*BBA2*ABA2
      PT2B2=PT2B2+FT*FB2*(ABR*VP-EP*V)*BTA2*ATA2*ABA2SQ
      PT2B2=PT2B2+FT2*EP*ATR*ATA2SQ*BBA2SQ
      PT2B2=PT2B2+FB2*EP*ABR*BTA2SQ*ABA2SQ
      PT2B2=PT2B2-FT*FB*MT*MB*ATA2SQ*ABA2SQ
      PT2B2=PT2B2*NABT2*NABB2
C
      PDPMT1=PT1B1/(MST1SQ-MSB1SQ) +PT1B2/(MST1SQ-MSB2SQ)
      PDPMT2=PT2B1/(MST2SQ-MSB1SQ) +PT2B2/(MST2SQ-MSB2SQ)
      PDPMB1=PT1B1/(MSB1SQ-MST1SQ) +PT2B1/(MSB1SQ-MST2SQ)
      PDPMB2=PT1B2/(MSB2SQ-MST1SQ) +PT2B2/(MSB2SQ-MST2SQ)
C
      LMST1=MST1SQ*(2.0*LOG(MST1SQ/QQQ2)+1.0)            
      LMST2=MST2SQ*(2.0*LOG(MST2SQ/QQQ2)+1.0)             
      LMSB1=MSB1SQ*(2.0*LOG(MSB1SQ/QQQ2)+1.0) 
      LMSB2=MSB2SQ*(2.0*LOG(MSB2SQ/QQQ2)+1.0)            
C
      EMI1=LMST1*(PDPST1+DHPST1-DHRT1)
      EMI1=EMI1+LMST2*(PDPST2+DHPST2-DHRT2)
      EMI1=EMI1+LMSB1*(PDPSB1+DHPSB1-DHRB1)
      EMI1=EMI1+LMSB2*(PDPSB2+DHPSB2-DHRB2)
C     
      EMI2=LMST1*(PDMST1+DHMST1-DHRPT1)
      EMI2=EMI2+LMST2*(PDMST2+DHMST2-DHRPT2)
      EMI2=EMI2+LMSB1*(PDMSB1+DHMSB1-DHRPB1)
      EMI2=EMI2+LMSB2*(PDMSB2+DHMSB2-DHRPB2)
C
      EM3=LMST1*PDPMT1+LMST2*PDPMT2
      EM3=EM3+LMSB1*PDPMB1+LMSB2*PDPMB2
C
      TEMPF=MT2*LOG(MT2/QQQ2)-MB2*LOG(MB2/QQQ2)
      DVRR=4.0*FT2*MB2*TEMPF/(MT2-MB2)
      DVRR=3.0*(EMI1-DVRR-2.0*FT2*MB2)/32.0/PI2
      DVRR=-TM1B*COTB +VP2*G2/2.0 +DVRR
C
      DVRPRP=4.0*FB2*MT2*TEMPF/(MT2-MB2)
      DVRPRP=3.0*(EMI2-DVRPRP-2.0*FB2*MT2)/32.0/PI2
      DVRPRP=-TM1B*TANB +V2*G2/2.0 +DVRPRP
C
      DVRRP=1.0 +(MT2+MB2)*LOG(MT2/MB2)/(MT2-MB2)
      DVRRP=2.0*FT*FB*MT*MB*(DVRRP+LOG(MT2*MB2/(QQQ2**2)))
      DVRRP=3.0*(EM3+DVRRP)/32.0/PI2
      DVRRP=TM1B -G2*VVP/2.0 +DVRRP
C
      TRACE=DVRR+DVRPRP
      DETV=4.0*(DVRR*DVRPRP-DVRRP**2)
C          Rewrite TERMSQ=TRACE**2-DETV
      TERMSQ=(DVRR-DVRPRP)**2+4*DVRRP**2
      TERMSQ=SQRT(TERMSQ)/2.0
      GOLD2=TRACE/2.0 -TERMSQ
      MHC2=TRACE/2.0 +TERMSQ
C
50    IF(MHC2.LT.0.0) THEN
        MHCNEG=1
        AMHC=0.
        GO TO 1000
      ENDIF
      AMHC=SQRT(MHC2)
1000  RETURN
      END
+EOD
+DECK,SSMHN
      SUBROUTINE SSMHN(MHLNEG)
C-----------------------------------------------------------------------
C
C          Calculate HL, HH masses and ALFAH 
C          (scalar Higgs mixing angle) using radiative
C          corrections calculated by M. Bisset
C          and save results in /SSPAR/.
C
C          Both top and bottom couplings are now 
C          included.  Non-degenerate mixed squark
C          masses and A-terms are also included.
C          The D-terms from the squark mass matrix
C          (terms prop. to g**2 * Yukawa coupling)
C          are included as an option: 
C                 INRAD = 1 ==> D-TERMS ON
C                 INRAD = 2 ==> D-TERMS OFF    .
C
C         10/18/93 D-terms are now turned on.
C                     INRAD = 1 
C
C         There is an arbitrary mass scale that must
C         chosen to avoid dimensionful logarithms.
C         The choice does not matter if D-terms are
C         not included, but it does matter if D-terms
C         are included. 
C     
C         Arbitrary mass scale updated to 
C              QQQ = HIGFRZ = SQRT(AMTLSS*AMTRSS)
C         with running masses to include dominant 2-loop 
C         effects. 12/10/96 H. Baer
C
C         It is assumed that the A-terms are real.
C         Complex A-terms are allowed 
C         (unless RTT=0 or RBB=0 --see below) in 
C         this subroutine, but the imaginary parts
C         are now set to zero. 
C
C         It is crucial to use a value mbL, mbR, mb1 and mb2
C         consistent with the chosen value of mb(Q); ditto for
C         stop calculations.
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
C
      REAL PI,PI2,SR2,G2,GP2,GGP,GG1,GG2
      REAL TANB,COTB,COSB,SINB,BE
      REAL SINB2,COSB2,COS2B,SIN2B
      REAL V2,VP2,V,VP,VVP,VPVM,VVPP
      REAL MT2,MB2,FT2,FB2,MW2,MZ2,ZAP,QQQ2
      REAL EP,EP2,RR,MHP2
      REAL ATI,ABI,ATR,ABR,AT2,AB2
      REAL TLRM,BLRM,TLRP,BLRP
      REAL MST1SQ,MST2SQ,MSB1SQ,MSB2SQ,AMTRSQ,AMTLSQ

      REAL RTT,TTT1,TEMPT,TM1BT
      REAL TEMPS,T1RD,T2RD,T1RPD,T2RPD
      REAL CT1,A1,A2,T1RR,T2RR
      REAL CT5,A5,A6,T1RPRP,T2RPRP
      REAL A9,T1RRP,T2RRP
      REAL TEMPSQ,DT1,DT2,VRRT,VRPRPT,VRRPT
      REAL ALPHAT,LAT
C
      REAL RBB,BBB1,TEMPB,TM1BB
      REAL B1RD,B2RD,B1RPD,B2RPD
      REAL CB3,A3,A4,B1RR,B2RR
      REAL CB7,A7,A8,B1RPRP,B2RPRP
      REAL A10,B1RRP,B2RRP
      REAL DB1,DB2,VRRB,VRPRPB,VRRPB
      REAL ALPHAB,LAB
C
      REAL DVRR,DVRPRP,DVRRP,TEMPH
      REAL MHL2,MHH2,TRACEM,TPAL,TANAH
      REAL ASMB,MBMB,MBQP,ASMT,MTMT,MTQP,SUALFS,HIGFRZ
      DOUBLE PRECISION SSMQCD
      INTEGER INRAD,MHLNEG
C
      MHLNEG=0
      PI=4.*ATAN(1.)
      PI2 = PI**2
      SR2=SQRT(2.)
      G2=4.*PI*ALFAEM/SN2THW
      GP2=G2*SN2THW/(1.-SN2THW)
      HIGFRZ=SQRT(MAX(AMZ**2,AMTLSS*AMTRSS*SIGN(1.,AMTLSS*AMTRSS)))
c      ASMB=SUALFS(AMBT**2,.36,AMTP,3)
c      MBMB=AMBT*(1.-4*ASMB/3./PI)
c      MBQP=SSMQCD(DBLE(MBMB),DBLE(HIGFRZ))
c      ASMT=SUALFS(AMTP**2,.36,AMTP,3)
c      MTMT=AMTP/(1.+4*ASMT/3./PI+(16.11-1.04*(5.-6.63/AMTP))*
c     $(ASMT/PI)**2)
c      MTQP=SSMQCD(DBLE(MTMT),DBLE(HIGFRZ))
      MT2=MTQ**2
      MB2=MBQ**2
      MW2=AMW**2
      MZ2=AMZ**2
      EP=TWOM1
      EP2=EP**2
      RR=RV2V1
      MHP2=AMHA**2
      TANB=1.0/RR
      COTB=RR
      BE=ATAN(1./RV2V1)
      SINB=SIN(BE)
      COSB=COS(BE)
      SINB2=SINB**2
      COSB2=COSB**2
      SIN2B=SIN(2.*BE)
      COS2B=COS(2.*BE)
      V2=2.0*MW2*SINB2/G2
      VP2=2.0*MW2*COSB2/G2
      V=SQRT(V2)
      VP=SQRT(VP2)
      VVP=SQRT(V2*VP2)
      VPVM=VP2-V2
      GGP=G2+GP2
      GG1=G2-5.0*GP2/3.0
      GG2=G2-GP2/3.0
      VVPP=2.0*AMZ**2/GGP
      FT2=MT2/V2
      FB2=MB2/VP2
C
      AMTRSQ=SIGN(1.,AMTRSS)*AMTRSS**2
      AMTLSQ=SIGN(1.,AMTLSS)*AMTLSS**2
      TLRM=AMTLSQ-AMTRSQ
      BLRM=AMBLSS**2-AMBRSS**2 
      TLRP=AMTLSQ+AMTRSQ
      BLRP=AMBLSS**2+AMBRSS**2 
C
C          Higgs mass matrix
C
C     (AAT and AAB are also assumed to be real)
C          
      ATR=AAT
      ABR=AAB
      ATI=0.0
      ABI=0.0
      AT2=ATR**2+ATI**2
      AB2=ABR**2+ABI**2
C
C     Calculate mt1,mt2,mb1,mb2 internally so masses consistent
C     with value of mbq and mtq used here
C
      MST1SQ=TLRP/2.+MZ2*COS2B/4.+MTQ**2-SQRT((TLRM/2.+COS2B/12.
     ,*(8*MW2-5*MZ2))**2+MTQ**2*(-AAT-EP*COTB)**2)
      MST2SQ=TLRP/2.+MZ2*COS2B/4.+MTQ**2+SQRT((TLRM/2.+COS2B/12.
     ,*(8*MW2-5*MZ2))**2+MTQ**2*(-AAT-EP*COTB)**2)
      MSB1SQ=BLRP/2.-MZ2*COS2B/4.+MBQ**2-SQRT((BLRM/2.-COS2B/12.
     ,*(4*MW2-MZ2))**2+MBQ**2*(-AAB-EP*TANB)**2)
      MSB2SQ=BLRP/2.-MZ2*COS2B/4.+MBQ**2+SQRT((BLRM/2.-COS2B/12.
     ,*(4*MW2-MZ2))**2+MBQ**2*(-AAB-EP*TANB)**2)
      INRAD=1
      QQQ2=HIGFRZ**2
      IF (MST1SQ.LE.0..OR.MSB1SQ.LE.0.) THEN
        MHL2=-1.
        GO TO 50
      END IF
C
      ZAP = 1.0
C
C                  STOP TERMS
C          
      RTT=(TLRM+VPVM*ZAP*GG1/4.0)**2
     $      +4.0*MT2*(EP*COTB+ATR)**2+4.0*MT2*ATI**2
      RTT=SQRT(RTT)
C
C     calculate 2M1*B term
C
      TTT1=0.5*TLRP+MT2+VPVM*ZAP*GGP/8.0
      IF(RTT.NE.0.0) THEN
        TEMPT=4.0*EP*FT2*VVP*ATI**2/(RTT**2)
        TM1BT=-2.0*FT2*(TEMPT+ATR)*TTT1
     $               *LOG(MST2SQ/MST1SQ)/RTT
        TM1BT=TM1BT-FT2*ATR
     $               *LOG(MST1SQ*MST2SQ/QQQ2/QQQ2)
        TM1BT=TM1BT+FT2*(2.0*TEMPT-ATR)
        TM1BT=3.0*EP*TM1BT/32.0/PI2
C
C        calculate first derivatives w.r.t H_R
C           divided by sqrt(2) * v
C        
         TEMPS=-ZAP*GG1*(TLRM+ZAP*GG1*VPVM/4.0)/2.0 
         TEMPS=TEMPS+4.0*FT2*(AT2+EP*COTB*ATR)
         TEMPS=TEMPS/RTT/4.0 
         T1RD=FT2-ZAP*GGP/8.0-TEMPS
         T2RD=FT2-ZAP*GGP/8.0+TEMPS
C
C        calculate first derivatives w.r.t H_R'
C           divided by sqrt(2) * v'
C        
         TEMPS=ZAP*GG1*(TLRM+ZAP*GG1*VPVM/4.0)/2.0
         TEMPS=TEMPS+4.0*FT2*EP*(EP+TANB*ATR)
         TEMPS=TEMPS/RTT/4.0
         T1RPD=ZAP*GGP/8.0-TEMPS
         T2RPD=ZAP*GGP/8.0+TEMPS
C
C        calculate second derivatives w.r.t. H_R
C
         CT1=-V*ZAP*GG1*(TLRM+ZAP*GG1*VPVM/4.0)/SR2
         CT1=CT1+4.0*SR2*FT2*V*(EP*COTB*ATR+AT2)
         A1=-CT1**2/(RTT**3)/8.0
         A2=-ZAP*GG1*(TLRM+ZAP*GG1*VPVM/4.0)/2.0
         A2=A2+V2*ZAP*GG1**2/4.0+4.0*FT2*AT2
         A2=A2/RTT/4.0
         T1RR=FT2-ZAP*GGP/8.0-A1-A2
         T2RR=FT2-ZAP*GGP/8.0+A1+A2
C
C        calculate second derivatives w.r.t. H_R'
C
         CT5=VP*ZAP*GG1*(TLRM+ZAP*GG1*VPVM/4.0)/SR2
         CT5=CT5+4.0*SR2*FT2*VP*EP*(EP+TANB*ATR)
         A5=-CT5**2/(RTT**3)/8.0
         A6=ZAP*GG1*(TLRM+ZAP*GG1*VPVM/4.0)/2.0 
         A6=A6+VP2*ZAP*GG1**2/4.0+4.0*FT2*EP2
         A6=A6/RTT/4.0
         T1RPRP=ZAP*GGP/8.0-A5-A6
         T2RPRP=ZAP*GGP/8.0+A5+A6
C
C        calculate second derivatives w.r.t. H_R and H_R'
C
         A9=-VVP*ZAP*(GG1**2)/4.0+4.0*FT2*EP*ATR
         A9=A9/RTT/4.0
         T1RRP=CT1*CT5/(RTT**3)/8.0-A9
         T2RRP=-CT1*CT5/(RTT**3)/8.0+A9
C
C        calculate D^2 V / D^2 H_R
C
         TEMPSQ=MST1SQ*(T1RR-T1RD)
         DT1=2.0*(2.0*V2*T1RD**2+TEMPSQ)*LOG(MST1SQ/QQQ2)
         DT1=DT1+6.0*V2*T1RD**2+TEMPSQ
         TEMPSQ=MST2SQ*(T2RR-T2RD)
         DT2=2.0*(2.0*V2*T2RD**2+TEMPSQ)*LOG(MST2SQ/QQQ2)
         DT2=DT2+6.0*V2*T2RD**2+TEMPSQ
         VRRT=DT1+DT2-8.0*FT2*MT2*LOG(MT2/QQQ2)-12.0*FT2*MT2
         VRRT=-TM1BT*COTB+3.0*VRRT/32.0/PI2
C
C        calculate D^2 V / D^2 H'_R
C
         TEMPSQ=MST1SQ*(T1RPRP-T1RPD)
         DT1=2.0*(2.0*VP2*T1RPD**2+TEMPSQ)*LOG(MST1SQ/QQQ2)
         DT1=DT1+6.0*VP2*T1RPD**2+TEMPSQ
         TEMPSQ=MST2SQ*(T2RPRP-T2RPD)
         DT2=2.0*(2.0*VP2*T2RPD**2+TEMPSQ)*LOG(MST2SQ/QQQ2)
         DT2=DT2+6.0*VP2*T2RPD**2+TEMPSQ
         VRPRPT=-TM1BT*TANB+3.0*(DT1+DT2)/32.0/PI2
C
C        calculate D^2 V / D^H_R  D^H_R'
C
         DT1=2.0*VVP*T1RD*T1RPD+MST1SQ*T1RRP
         DT1=2.0*DT1*LOG(MST1SQ/QQQ2)
         DT1=DT1+6.0*VVP*T1RD*T1RPD+MST1SQ*T1RRP
         DT2=2.0*VVP*T2RD*T2RPD+MST2SQ*T2RRP
         DT2=2.0*DT2*LOG(MST2SQ/QQQ2)
         DT2=DT2+6.0*VVP*T2RD*T2RPD+MST2SQ*T2RRP
         VRRPT=TM1BT+3.0*(DT1+DT2)/32.0/PI2
C
      ELSE IF(RTT.EQ.0.0) THEN
C
         ALPHAT=TLRP/2.0+MT2+ZAP*GGP*VPVM/8.0
         LAT=2.0*LOG(ALPHAT/QQQ2)+3.0
C
C        calculate D^2 V / D^2 H_R
C
         VRRT=V2*(GGP**2+GG1**2)/16.0-MT2*GGP
         VRRT=ZAP*VRRT*LAT+8.0*FT2*MT2*LOG(ALPHAT/MT2)
         VRRT=3.0*VRRT/32.0/PI2
C
C        calculate D^2 V / D^2 H_R'
C
         VRPRPT=ZAP*VP2*(GGP**2+GG1**2)/16.0
         VRPRPT=3.0*(VRPRPT*LAT)/32.0/PI2
C
C        calculate D^2 V / D^H_R D^H_R'
C
         VRRPT=FT2*GGP-(GGP**2+GG1**2)/8.0
         VRRPT=ZAP*VVP*VRRPT*LAT/2.0
         VRRPT=3.0*VRRPT/32.0/PI2
C
C
      ENDIF
C
C     SBOTTOM TERMS
C
      RBB=(BLRM-VPVM*ZAP*GG2/4.0)**2
     $      +4.0*MB2*(EP*TANB+ABR)**2+4.0*MB2*ABI**2
      RBB=SQRT(RBB)
C      IF(RBB.EQ.0.0.AND.ABI.NE.0.0) THEN
C        WRITE(6,*) 'RBB=0, ABI NOT 0'
C        WRITE(6,*) 'ERROR: THIS CASE NOT COVERED YET'
C        GO TO 1000
C      ENDIF
C
      IF(RBB.NE.0.0) THEN
C
C     calculate 2M1*B term
C
        BBB1=0.5*BLRP+MB2-VPVM*ZAP*GGP/8.0
        TEMPB=4.0*EP*FB2*VVP*ABI**2/(RBB**2)       
        TM1BB=-2.0*FB2*(TEMPB+ABR)*BBB1
     $               *LOG(MSB2SQ/MSB1SQ)/RBB
        TM1BB=TM1BB-FB2*ABR
     $               *LOG(MSB1SQ*MSB2SQ/QQQ2/QQQ2)
        TM1BB=TM1BB+FB2*(2.0*TEMPB-ABR)
        TM1BB=3.0*EP*TM1BB/32.0/PI2
C
C        calculate first derivatives w.r.t H_R
C           divided by sqrt(2) * v
C        
        TEMPS=ZAP*GG2*(BLRM-ZAP*GG2*VPVM/4.0)/2.0
        TEMPS=TEMPS+4.0*FB2*EP*(EP+COTB*ABR)
        TEMPS=TEMPS/RBB/4.0
        B1RD=ZAP*GGP/8.0-TEMPS
        B2RD=ZAP*GGP/8.0+TEMPS

C        calculate first derivatives w.r.t H_R'
C           divided by sqrt(2) * v'
C
        TEMPS=-ZAP*GG2*(BLRM-ZAP*GG2*VPVM/4.0)/2.0
        TEMPS=TEMPS+4.0*FB2*(AB2+EP*TANB*ABR)
        TEMPS=TEMPS/RBB/4.0
        B1RPD=FB2-ZAP*GGP/8.0-TEMPS
        B2RPD=FB2-ZAP*GGP/8.0+TEMPS
C
C        calculate second derivatives w.r.t. H_R
C
        CB3=V*ZAP*GG2*(BLRM-ZAP*GG2*VPVM/4.0)/SR2
        CB3=CB3+4.0*SR2*FB2*V*EP*(EP+COTB*ABR)
        A3=-CB3**2/(RBB**3)/8.0
        A4=ZAP*GG2*(BLRM-ZAP*GG2*VPVM/4.0)/2.0
        A4=A4+V2*ZAP*GG2**2/4.0+4.0*FB2*EP2
        A4=A4/RBB/4.0
        B1RR=ZAP*GGP/8.0-A3-A4
        B2RR=ZAP*GGP/8.0+A3+A4
C
C       calculate second derivatives w.r.t. H_R'
C
        CB7=-VP*ZAP*GG2*(BLRM-ZAP*GG2*VPVM/4.0)/SR2
        CB7=CB7+4.0*SR2*FB2*VP*(AB2+EP*TANB*ABR)
        A7=-CB7**2/(RBB**3)/8.0
        A8=-ZAP*GG2*(BLRM-ZAP*GG2*VPVM/4.0)/2.0
        A8=A8+VP2*ZAP*GG2**2/4.0+4.0*FB2*AB2
        A8=A8/RBB/4.0
        B1RPRP=FB2-ZAP*GGP/8.0-A7-A8
        B2RPRP=FB2-ZAP*GGP/8.0+A7+A8
C
C       calculate second derivatives w.r.t. H_R and H_R'
C
        A10=-VVP*ZAP*(GG2**2)/4.0+4.0*FB2*EP*ABR
        A10=A10/RBB/4.0
        B1RRP=CB3*CB7/(RBB**3)/8.0-A10
        B2RRP=-CB3*CB7/(RBB**3)/8.0+A10
C
C       calculate  D^2 V / D^2 H_R
C
        TEMPSQ=MSB1SQ*(B1RR-B1RD)
        DB1=2.0*(2.0*V2*B1RD**2+TEMPSQ)*LOG(MSB1SQ/QQQ2)
        DB1=DB1+6.0*V2*B1RD**2+TEMPSQ
        TEMPSQ=MSB2SQ*(B2RR-B2RD)
        DB2=2.0*(2.0*V2*B2RD**2+TEMPSQ)*LOG(MSB2SQ/QQQ2)
        DB2=DB2+6.0*V2*B2RD**2+TEMPSQ
        VRRB=-TM1BB*COTB+3.0*(DB1+DB2)/32.0/PI2
C
C       calculate  D^2 V / D^2 H'_R
C
        TEMPSQ=MSB1SQ*(B1RPRP-B1RPD)
        DB1=2.0*(2.0*VP2*B1RPD**2+TEMPSQ)*LOG(MSB1SQ/QQQ2)
        DB1=DB1+6.0*VP2*B1RPD**2+TEMPSQ
        TEMPSQ=MSB2SQ*(B2RPRP-B2RPD)
        DB2=2.0*(2.0*VP2*B2RPD**2+TEMPSQ)*LOG(MSB2SQ/QQQ2)
        DB2=DB2+6.0*VP2*B2RPD**2+TEMPSQ
        VRPRPB=DB1+DB2
        VRPRPB=DB1+DB2-8.0*FB2*MB2*LOG(MB2/QQQ2)-12.0*FB2*MB2
        VRPRPB=-TM1BB*TANB+3.0*VRPRPB/32.0/PI2
C
C       calculate  D^2 V / D H_R  D H'_R
C
        DB1=2.0*VVP*B1RD*B1RPD+MSB1SQ*B1RRP
        DB1=2.0*DB1*LOG(MSB1SQ/QQQ2)
        DB1=DB1+6.0*VVP*B1RD*B1RPD+MSB1SQ*B1RRP
        DB2=2.0*VVP*B2RD*B2RPD+MSB2SQ*B2RRP
        DB2=2.0*DB2*LOG(MSB2SQ/QQQ2)
        DB2=DB2+6.0*VVP*B2RD*B2RPD+MSB2SQ*B2RRP
        VRRPB=TM1BB+3.0*(DB1+DB2)/32.0/PI2
 
      ELSE IF(RBB.EQ.0.0) THEN
C
        ALPHAB=BLRP/2.0+MB2-ZAP*GGP*VPVM/8.0
        LAB=2.0*LOG(ALPHAB/QQQ2)+3.0
C
C       calculate  D^2 V / D^2 H_R
C
        VRRB=ZAP*V2*(GGP**2 + GG2**2)/16.0
        VRRB=3.0*(VRRB*LAB)/32.0/PI2
C
C       calculate  D^2 V / D^2 H_R'
C
        VRPRPB=VP2*(GGP**2+GG2**2)/16.0-MB2*GGP         
        VRPRPB=ZAP*VRPRPB*LAB+8.0*FB2*MB2*LOG(ALPHAB/MB2)
        VRPRPB=3.0*VRPRPB/32.0/PI2
C
C       calculate  D^2 V / D^H_R D^H_R'
C
        VRRPB=FB2*GGP-(GGP**2+GG2**2)/8.0
        VRRPB=ZAP*VVP*VRRPB*LAB/2.0
        VRRPB=3.0*VRRPB/32.0/PI2
C
      ENDIF
C
      DVRR=VRRT+VRRB+VP2*MHP2/VVPP + V2*GGP/2.0
      DVRPRP=VRPRPT+VRPRPB+V2*MHP2/VVPP + VP2*GGP/2.0
      DVRRP=VRRPT+VRRPB-VVP*MHP2/VVPP - VVP*GGP/2.0
C          TEMPH is always non-negative:
      TEMPH=(DVRR-DVRPRP)**2+4*DVRRP**2
      TEMPH=0.5*SQRT(TEMPH)
      MHL2=0.5*(DVRR+DVRPRP)-TEMPH
      MHH2=0.5*(DVRR+DVRPRP)+TEMPH
50    IF(MHL2.LT.0.0) THEN
        MHLNEG=1
C        WRITE(LOUT,*) 'SSMHN: ERROR:  MHL**2 < 0.0 FOR PARAMETERS:'
C        WRITE(LOUT,*) 'MHP =', AMHA, 'TANB =', 1.0/RR
C        WRITE(LOUT,*) 'MSTL=', AMTLSS, 'MSBL=', AMBLSS 
C        WRITE(LOUT,*) 'MSTR=', AMTRSS, 'MSBR=', AMBRSS
C        WRITE(LOUT,*) 'AT=', AAT, 'AB=', AAB
C        WRITE(LOUT,*) 'MU=-2M1=', -EP
C        WRITE(LOUT,*) 'MT=', AMTP, 'MB=', AMBT
C        WRITE(LOUT,*) 'D-TERMS? 1=YES 2=NO :', INRAD
C        WRITE(LOUT,*) 'MASS SCALE (QQQ)=', SQRT(QQQ2)
        AMHH=SQRT(MHH2)
        AMHL=SQRT(ABS(MHL2))
        GO TO 1000
      ENDIF
      AMHL=SQRT(MHL2)
      AMHH=SQRT(MHH2)

C
C     Now calculate mixing angle ALFAH
C
      TRACEM=DVRR-DVRPRP
      TPAL=TRACEM**2 + 4.0*DVRRP**2
      TANAH=TRACEM+SQRT(TPAL)
      IF(DVRRP.EQ.0.0) THEN
        WRITE(LOUT,*) 'SSMHN: OFF-DIAGONAL TERM OF SCALAR HIGGS',
     $  ' MASS MATRIX IS ZERO '
        IF(TANAH.NE.0.0) THEN
          WRITE(LOUT,*) 'SSMHN: WARNING: TAN(ALFAH) FORMULA',
     $    ' YIELDS INFINITY'
        ELSE IF(TANAH.EQ.0.0) THEN
          WRITE(LOUT,*) 'SSMHN: WARNING: TAN(ALFAH) FORMULA',
     $    ' YIELDS 0/0 '
        ENDIF
        IF(DVRR.GT.DVRPRP) THEN
          WRITE(LOUT,*) 'SSMHN: DVRR > DVRPRP ==> SET ALFAH=PI/2'
          ALFAH = PI/2.0
        ELSE IF (DVRR .LT. DVRPRP) THEN
          WRITE(LOUT,*) 'SSMHN: DVRR < DVRPRP ==> SET ALFAH=0'
          ALFAH = 0.0
        ELSE IF (DVRR .EQ. DVRPRP) THEN
          WRITE(LOUT,*) 'SSMHN: DVRR = DVRPRP ==> ALFAH INDETERMINANT'
          WRITE(LOUT,*) 'SETTING SCALAR MIXING ANGLE ALPHA=PI/4'
          ALFAH=PI/4.0
        ENDIF
        GO TO 1000
      ENDIF
      TANAH = -0.5*TANAH/DVRRP
      ALFAH = ATAN(TANAH)
C
1000  RETURN
      END
+EOD
+DECK,SSMQCD
      DOUBLE PRECISION FUNCTION SSMQCD(DM,DQ)
C-----------------------------------------------------------------------
C     Calculate leading-log running mass for quark with mass DM at 
C     scale Q, using alpha_s which is continuous across thresholds.
C     See Drees and Hikasa, Phys. Lett. B240: 455-464, Eq. 4.5.
C
C     Note the threshold is at Q = 2 m, not at Q = m as in MSbar.
C
C     Bisset's QCDRAD, WDHFFC
C     I think there was an error in the sense that some thresholds
C     were mixed up between m and 2m. I am changing everything to m
C     Modified Nov. 22, 2005, by XT.

C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
C
      DOUBLE PRECISION DM,DQ,DLAM4,DLAM5,DLAM6,DNEFF,POW,RENORM
     $,DQBT,DQTP
C
C         Do nothing for light quarks
C
      IF(DM.LT.1.0) THEN
        SSMQCD=DM
        RETURN
      ENDIF
C
C          Calculate running mass
C
      DLAM4=DBLE(ALQCD4)
      DQBT=DBLE(AMBT)
      DQTP=DBLE(AMTP)
      SSMQCD=0
C          Q <  m(b)
      DNEFF=4
      POW=12.D0/(33.D0-2.*DNEFF)
      IF(DQ.LT.DQBT) THEN
        RENORM=(LOG(DM/DLAM4)/LOG(DQ/DLAM4))**POW
        SSMQCD=RENORM*DM
        RETURN
      ELSE
        RENORM=(LOG(DM/DLAM4)/LOG(DQBT/DLAM4))**POW
      ENDIF
C          m(b) < Q <  m(t)
      DNEFF=5
      POW=12.D0/(33.D0-2.*DNEFF)
      DLAM5=DEXP((25.D0*LOG(DLAM4)-LOG(DQBT**2))/23.D0)
      IF(DQ.GE.DQBT.AND.DQ.LT.DQTP) THEN
        RENORM=RENORM
     $  *(LOG(DQBT/DLAM5)/LOG(DQ/DLAM5))**POW
        SSMQCD=RENORM*DM
        RETURN
      ELSE
        RENORM=RENORM
     $  *(LOG(DQBT/DLAM5)/LOG(DQTP/DLAM5))**POW
      ENDIF
C           m(t) < Q
      DNEFF=6
      POW=12.D0/(33.D0-2.*DNEFF)
      DLAM6=DEXP((25.D0*LOG(DLAM4)-LOG(DQBT**2)
     $-LOG(4*AMTP**2))/21.D0) 
      RENORM=RENORM
     $*(LOG(DQTP/DLAM6)/LOG(DQ/DLAM6))**POW
      SSMQCD=RENORM*DM
      RETURN
      END
+EOD
+DECK,SSMSSM
      SUBROUTINE SSMSSM(XMG,XMU,XMHA,XTANB,XMQ1,XMDR,XMUR,
     $XML1,XMER,XMQ2,XMSR,XMCR,XML2,XMMR,XMQ3,XMBR,XMTR,
     $XML3,XMLR,XAT,XAB,XAL,XM1,XM2,XMT,IALLOW,IMODEL)
C-----------------------------------------------------------------------
C
C     Calculate MSSM masses and decays using parameters:
C       XM1    = U(1) mass
C              > 1e19: use scaling from XMG
C       XM2    = SU(2) mass
C              > 1e19: use scaling from XMG
C       XMG    = signed gluino mass
C       XMQ1,...  = 1st gen. su(2) soft squark mass,...
C       XMTL   = m(stop-left)
C       XMTR   = m(stop-right)
C       XMBR   = m(sbot-right)
C       XML1   = left selectron mass
C       XMER   = right selectron mass
C       XMN1   = 1st ge. sneutrino mass
C       XTANB  = v/v' = ratio of vev's
C       XMU    = -2*m_1 = SUSY Higgs mass
C       XMHA   = m(pseudo-scalar-Higgs)
C       XMT    = m(top)
C       XAT    = stop trilinear coupling
C       XAB    = sbottom trilinear coupling
C       XAL    = stau trilinear coupling
C       IALLOW = 0 for valid point, 1 otherwise
C       IMODEL = 1 for SUGRA or MSSM, 2 for GMSB
C
C     Program outline:
C     SSMSSM:  Initialize standard model parameters in /SSSM/ and 
C              SUSY parameters in /SSPAR/.
C     SSMASS:  Calculate dependent SUSY masses and mixings.
C     SSTPBF:  Calculate top decays; save in /SSMODE/.
C     SSSTBF:  Calculate stop decays; save in /SSMODE/.
C     SSGLBF:  Calcualte gluino decays; save in /SSMODE/.
C     SSQKBF:  Calculate squark decays; save in /SSMODE/.
C     SSWZBF:  Calculate gaugino decays; save in /SSMODE/.
C     SSHIBF:  Calculate Higgs decays; save in /SSMODE/.
C
C     Notes: 
C  1) All particle ID codes are defined with symbolic names in 
C     /SSTYPE/, making it easy to change them.
C
C  2) /SSMODE/ contains the parent, the daughters, the width, and
C     the branching ratio for each mode. Decay modes for a given parent
C     need not be adjacent, so they must be sorted at the end.
C
C  3) Some of Baer's original routines used single precision and others
C     double precision. To accomodate this, the variable names used in
C     /SSSM/ and /SSPAR/ have all been changed to longer, more 
C     descriptive ones.
C
C  4) All routines have been strongly typed.
C
C     Source: H. Baer, et al.
C     Modified: F. Paige, Aug. 1992
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,DKYSS3
C
      REAL XR21,PI,SR2
      REAL XMG,XMU,XMHA,XTANB,XMQ1,XMDR,XMUR,XML1,XMER,XMQ2,XMSR,
     $XMCR,XML2,XMMR,XMQ3,XMBR,XMTR,XML3,XMLR,XAT,XAB,XAL,XM1,XM2,
     $XMT,MU1,MU2,BETA,COS2B
      INTEGER IALLOW,MHLNEG,MHCNEG,IMODEL,ILOOP
C
      NSSMOD=0
C
C          Standard model and SUSY parameters
C
      IALLOW=0
      XR21=1./XTANB
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      AMDN=0.0099
      AMUP=0.0056
      AMST=0.199
      AMCH=1.35
      AMBT=5.0
      AMTP=XMT
      AME=0.511E-3
      AMMU=0.105
      AMTAU=1.777
      AMW=80.423
      AMZ=91.17
      GAMW=2.12
      GAMZ=2.487
      ALFAEM=1./128.
      SN2THW=0.232
      ALFA2=ALFAEM/SN2THW
      BETA=ATAN(XTANB)
      COS2B=COS(2*BETA)
C
C          SU(2) and U(1) gaugino masses are reset in SSMASS if
C          they are > 1e19.
C
      MU2=XM2
      MU1=XM1
C          Set 2nd gen soft terms equal to 1st gen. soft terms 
c          unless previously set by user.
      IF (XMQ2.GE.1.E19) THEN
        XMQ2=XMQ1
        XMSR=XMDR
        XMCR=XMUR
        XML2=XML1
        XMMR=XMER
      END IF
C
C          The results can be quite sensitive to the choice of the
C          4-flavor QCD scale ALQCD4 and the expression for the QCD
C          coupling ALFA3. Select among the following lines:
C
      ALQCD4=0.177
      ALFA3=0.12
C
C          Keep track of sign of M3; user input of Mgl>0 means M3<0
      SGNM3=-SIGN(1.,XMG)
C          Calculate simple masses; other masses via SSMASS
      AMGLSS=ABS(XMG)
      AMULSS=SQRT(XMQ1**2+AMUP**2+(.5-2.*SN2THW/3.)*AMZ**2*COS2B)
      AMURSS=SQRT(XMUR**2+AMUP**2+2./3.*SN2THW*AMZ**2*COS2B)
      AMDLSS=SQRT(XMQ1**2+AMDN**2+(-.5+SN2THW/3.)*AMZ**2*COS2B)
      AMDRSS=SQRT(XMDR**2+AMDN**2-1./3.*SN2THW*AMZ**2*COS2B)
      AMCLSS=SQRT(XMQ2**2+AMCH**2+(.5-2.*SN2THW/3.)*AMZ**2*COS2B)
      AMCRSS=SQRT(XMCR**2+AMCH**2+2./3.*SN2THW*AMZ**2*COS2B)
      AMSLSS=SQRT(XMQ2**2+AMST**2+(-.5+SN2THW/3.)*AMZ**2*COS2B)
      AMSRSS=SQRT(XMSR**2+AMST**2-1./3.*SN2THW*AMZ**2*COS2B)
      AMELSS=SQRT(XML1**2+AME**2-(.5-SN2THW)*AMZ**2*COS2B)
      AMERSS=SQRT(XMER**2+AME**2-SN2THW*AMZ**2*COS2B)
      AMMLSS=SQRT(XML2**2+AMMU**2-(.5-SN2THW)*AMZ**2*COS2B)
      AMMRSS=SQRT(XMMR**2+AMMU**2-SN2THW*AMZ**2*COS2B)
      AMN1SS=SQRT(XML1**2+.5*AMZ**2*COS2B)
      AMN2SS=SQRT(XML2**2+.5*AMZ**2*COS2B)
      AMN3SS=SQRT(XML3**2+.5*AMZ**2*COS2B)
      AMTLSS=XMQ3
      AMTRSS=XMTR
      AMBLSS=XMQ3
      AMBRSS=XMBR
      AMLLSS=XML3
      AMLRSS=XMLR
      AMHA=XMHA
      AAT=XAT
      AAB=XAB
      AAL=XAL
      TWOM1=-XMU
      RV2V1=XR21
C
C          Calculate mass eigenstates and check Z1SS = LSP
C
      IF (IMODEL.EQ.0) THEN
        ILOOP=0
      ELSE
        ILOOP=1
      END IF
      CALL SSMASS(XMG,MU1,MU2,IALLOW,ILOOP,MHLNEG,MHCNEG,IMODEL)
      IF (MHLNEG.EQ.1.OR.MHCNEG.EQ.1) IALLOW=10
C     IF(IALLOW.NE.0) RETURN
C
C          Initialize counters for matrix elements
C          Calculate decay widths and branching rations
C
      NMSS3=0
      NPSS3=0
      CALL SSTPBF
      CALL SSGLBF
      CALL SSQKBF
      CALL SSSTBF
      CALL SSLPBF
      CALL SSWZBF
      CALL SSHIBF(IMODEL)
C
      RETURN
      END
+EOD
+DECK,SSN1ST
        REAL FUNCTION SSN1ST(SS)
C-----------------------------------------------------------------------
C          SSN1ST: l_1 -> stau_1+nu_l+nutaubar: TATA G FUNCTION
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL SS
        DOUBLE PRECISION S,M1,M2,MST1,MN1,WID
        S=SS
        M1=TMP(1)
        M2=TMP(2)
        MST1=TMP(3)
        MN1=TMP(4)
        WID=(S-MST1**2)**2/(S-M1**2)/(S-M2**2)*(S-MN1**2)**2
     $       /S**2/MN1**2
        SSN1ST=WID
        RETURN
        END
+EOD
+DECK,SSNORM
      SUBROUTINE SSNORM(ID)
C-----------------------------------------------------------------------
C          Normalize branching ratios for ID
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
C
      INTEGER ID,I
      REAL GAMSUM
C
      GAMSUM=0
      DO 100 I=1,NSSMOD
        IF(ISSMOD(I).EQ.ID) GAMSUM=GAMSUM+GSSMOD(I)
100   CONTINUE
      IF(GAMSUM.EQ.0) RETURN
      DO 200 I=1,NSSMOD
        IF(ISSMOD(I).EQ.ID) BSSMOD(I)=GSSMOD(I)/GAMSUM
200   CONTINUE
      RETURN
      END 
+EOD
+DECK,SSPOLE
      REAL FUNCTION SSPOLE(MGMS,MUSQ,AS)
C*********************************************************************
C* Computes the on-shell (pole) gluino mass for given running (MSbar)*
C* gluino mass, defined at scale MUSQ, and given alpha_s (AS). The   *
C* squark masses are stored in the SQUARK COMMON block.              *
C* This function needs the complex functions B0 and B1.              *
C* Contributed by M. Drees; modified by H. Baer                      *
C  B0 contributions from Pierce et al.                               *
C  included on 9/23/05 by J.Ferrandis and H. Baer                    *
C                                                                    *
C  Version 7.30: Cast COMPLEX*16 to REAL*8 in standard way. :-(      *
C*********************************************************************
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
+CDE,SSINF
      REAL MGMS,MUSQ,AS,MGSQ,FAC
      DOUBLE PRECISION DMUSQ,DFAC
      COMPLEX*16 SSB1,SSB0
      DMUSQ=MUSQ
      XLAM = LOG(DMUSQ)
      MGSQ = MGMS*MGMS
C
C          Cast COMPLEX*16 to REAL*8:
C
      DFAC = -SSB1(MGSQ,0.,AMULSS) -SSB1(MGSQ,0.,AMURSS)
     $-SSB1(MGSQ,0.,AMDLSS) -SSB1(MGSQ,0.,AMDRSS)
     $-SSB1(MGSQ,0.,AMSLSS) -SSB1(MGSQ,0.,AMSRSS)
     $-SSB1(MGSQ,0.,AMCLSS) -SSB1(MGSQ,0.,AMCRSS)-
     $ ( SSB1(MGSQ,AMTP,AMT1SS)+ SSB1(MGSQ,AMTP,AMT2SS)+
     $  SSB1(MGSQ,4.0,AMB1SS) + SSB1(MGSQ,4.0,AMB2SS) )
     $ - AMTP*SIN(2.*THETAT)*(SSB0(MGSQ,AMTP,AMT1SS)-
     $   SSB0(MGSQ,AMTP,AMT2SS))/MGMS
     $ - 4.0*SIN(2.*THETAB)*(SSB0(MGSQ,4.0,AMB1SS)-
     $   SSB0(MGSQ,4.0,AMB2SS))/MGMS
      DFAC = DFAC + 15.D0 + 9.D0*LOG(DMUSQ/MGSQ)
      FAC=DFAC
      SSPOLE = MGMS*(1.0 + .0796*AS*FAC )
      RETURN
      END
+EOD
+DECK,SSQKBF
        SUBROUTINE SSQKBF
C-----------------------------------------------------------------------
C
C        This program gives squark branching fractions to gauginos
C        according to Baer,Barger,Karatas,Tata (Phys.Rev.D36,96(1987)
C        Updated for b_1,b_2 and non-degenerate sq masses 8/13/96
C        Baer's SQUBF
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
C
      COMPLEX ZI,ZONE,ZA,ZB,ZAUIZ,ZADIZ,ZBUIZ,ZBDIZ
      DOUBLE PRECISION SSALFS
      REAL SSXLAM,WID,AUIZS,ADIZS,BUIZS,BDIZS
      REAL PI,SR2,G,GP,COSA,SINA,SNZI,THIZ
     $,TANB,COTB,XM,YM,THX,THY,FT,FB
      REAL MZIZ,CS2THW,TN2THW,BETA,BH,A,AS
      INTEGER IZ
      REAL MW1,MW2,SNW1,SNW2,COST,SINT,COSB,SINB
      REAL AWD(2),AWU(2),BW(2),BWP(2)
      INTEGER ISZIZ(4)
      DATA ZI/(0.,1.)/,ZONE/(1.,0.)/
C
C          Partly duplicated from SSMASS
C
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      CS2THW=1.-SN2THW
      TN2THW=SN2THW/CS2THW
      TANB=1./RV2V1
      COTB=RV2V1
      BETA=ATAN(TANB)
C          Reconstruct masses from SSMASS
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSA=COS(ALFAH)
      SINA=SIN(ALFAH)
      SNW1=SIGN(1.,AMW1SS)
      SNW2=SIGN(1.,AMW2SS)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      FB=G*MBQ/SR2/AMW/COS(BETA)
      FT=G*MTQ/SR2/AMW/SIN(BETA)
      AWD(1)=-G*SNW1*SIN(GAMMAR)
      AWD(2)=-G*SNW2*THY*COS(GAMMAR)
      AWU(1)=-G*SIN(GAMMAL)
      AWU(2)=-G*THX*COS(GAMMAL)
      BW(1)=-FT*SNW1*COS(GAMMAR)
      BW(2)=FT*SNW2*THY*SIN(GAMMAR)
      BWP(1)=-FB*COS(GAMMAL)
      BWP(2)=FB*THX*SIN(GAMMAL)
C
C          Compute squark branching fractions to zi
C
      ISZIZ(1)=ISZ1
      ISZIZ(2)=ISZ2
      ISZIZ(3)=ISZ3
      ISZIZ(4)=ISZ4
      DO 100 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        SNZI=SIGN(1.,AMZISS(IZ))
        IF (SNZI.EQ.1.) THEN
           THIZ=0.
        ELSE
           THIZ=1.
        END IF
        ZAUIZ=ZI**(THIZ-1.)*(-1)*SNZI
     $  *(G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ))
        ZBUIZ=ZI**(THIZ-1.)*4*GP*ZMIXSS(4,IZ)/3./SR2
        ZADIZ=ZI**(THIZ-1.)*(-1)*SNZI
     $  *(-G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ))
        ZBDIZ=ZI**(THIZ-1.)*(-2)*GP*ZMIXSS(4,IZ)/3./SR2
        AUIZS=ZAUIZ*CONJG(ZAUIZ)
        ADIZS=ZADIZ*CONJG(ZADIZ)
        BUIZS=ZBUIZ*CONJG(ZBUIZ)
        BDIZS=ZBDIZ*CONJG(ZBDIZ)
C          squark --> q + qb + zi, q = u, d, s
        IF (AMULSS.GT.MZIZ) THEN
          WID=AUIZS*AMULSS*(1.-MZIZ**2/AMULSS**2)**2/16./PI
          CALL SSSAVE(ISUPL,WID,ISZIZ(IZ),IDUP,0,0,0)
        END IF
        IF (AMDLSS.GT.MZIZ) THEN
          WID=ADIZS*AMDLSS*(1.-MZIZ**2/AMDLSS**2)**2/16./PI
          CALL SSSAVE(ISDNL,WID,ISZIZ(IZ),IDDN,0,0,0)
        END IF
        IF (AMSLSS.GT.MZIZ) THEN
          WID=ADIZS*AMSLSS*(1.-MZIZ**2/AMSLSS**2)**2/16./PI
          CALL SSSAVE(ISSTL,WID,ISZIZ(IZ),IDST,0,0,0)
        END IF
        IF (AMURSS.GT.MZIZ) THEN
          WID=BUIZS*AMURSS*(1.-MZIZ**2/AMURSS**2)**2/16./PI
          CALL SSSAVE(ISUPR,WID,ISZIZ(IZ),IDUP,0,0,0)
        END IF
        IF (AMDRSS.GT.MZIZ) THEN
          WID=BDIZS*AMDRSS*(1.-MZIZ**2/AMDRSS**2)**2/16./PI
          CALL SSSAVE(ISDNR,WID,ISZIZ(IZ),IDDN,0,0,0)
        END IF
        IF (AMSRSS.GT.MZIZ) THEN
          WID=BDIZS*AMSRSS*(1.-MZIZ**2/AMSRSS**2)**2/16./PI
          CALL SSSAVE(ISSTR,WID,ISZIZ(IZ),IDST,0,0,0)
        END IF
C          squark --> q + zi, q = c
        IF (AMCLSS.GT.(MZIZ+AMCH)) THEN
          WID=AUIZS*AMCLSS*(1.-MZIZ**2/AMCLSS**2-AMCH**2/AMCLSS**2)
     $    *SQRT(SSXLAM(1.,MZIZ**2/AMCLSS**2,AMCH**2/AMCLSS**2))/16./PI
          CALL SSSAVE(ISCHL,WID,ISZIZ(IZ),IDCH,0,0,0)
        END IF
        IF (AMCRSS.GT.(MZIZ+AMCH)) THEN
          WID=BUIZS*AMCRSS*(1.-MZIZ**2/AMCRSS**2-AMCH**2/AMCRSS**2)
     $    *SQRT(SSXLAM(1.,MZIZ**2/AMCRSS**2,AMCH**2/AMCRSS**2))/16./PI
          CALL SSSAVE(ISCHR,WID,ISZIZ(IZ),IDCH,0,0,0)
        END IF
C          sbottom_1 --> b + zi
        IF (AMB1SS.GT.(MZIZ+AMBT)) THEN
          ZA=(ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB/2.-
     $       (ZI*ZBDIZ-FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB/2.
          ZB=(-ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB/2.-
     $       (ZI*ZBDIZ+FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB/2.
          WID=(ZA*CONJG(ZA)*(AMB1SS**2-(AMBT+MZIZ)**2)+
     $     ZB*CONJG(ZB)*(AMB1SS**2-(MZIZ-AMBT)**2))/8./PI/AMB1SS
     $    *SQRT(SSXLAM(1.,MZIZ**2/AMB1SS**2,AMBT**2/AMB1SS**2))
          CALL SSSAVE(ISBT1,WID,ISZIZ(IZ),IDBT,0,0,0)
        END IF
C          sbottom_2 --> b + zi
        IF (AMB2SS.GT.(MZIZ+AMBT)) THEN
          ZA=(ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB/2.+
     $       (ZI*ZBDIZ-FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB/2.
          ZB=(-ZI*ZADIZ-FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB/2.+
     $       (ZI*ZBDIZ+FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB/2.
          WID=(ZA*CONJG(ZA)*(AMB2SS**2-(AMBT+MZIZ)**2)+
     $     ZB*CONJG(ZB)*(AMB2SS**2-(MZIZ-AMBT)**2))/8./PI/AMB2SS
     $    *SQRT(SSXLAM(1.,MZIZ**2/AMB2SS**2,AMBT**2/AMB2SS**2))
          CALL SSSAVE(ISBT2,WID,ISZIZ(IZ),IDBT,0,0,0)
        END IF
100   CONTINUE
C
C          Compute squark branching fractions to gluinos
C
      IF (AMULSS.GT.AMGLSS) THEN
        WID=2*SSALFS(DBLE(AMULSS**2))*AMULSS*
     $  (1.-AMGLSS**2/AMULSS**2)**2/3.
        CALL SSSAVE(ISUPL,WID,ISGL,IDUP,0,0,0)
      END IF
      IF (AMDLSS.GT.AMGLSS) THEN
        WID=2*SSALFS(DBLE(AMDLSS**2))*AMDLSS*
     $  (1.-AMGLSS**2/AMDLSS**2)**2/3.
        CALL SSSAVE(ISDNL,WID,ISGL,IDDN,0,0,0)
      END IF
      IF (AMSLSS.GT.AMGLSS) THEN
        WID=2*SSALFS(DBLE(AMSLSS**2))*AMSLSS*
     $  (1.-AMGLSS**2/AMSLSS**2)**2/3.
        CALL SSSAVE(ISSTL,WID,ISGL,IDST,0,0,0)
      END IF
      IF (AMURSS.GT.AMGLSS) THEN
        WID=2*SSALFS(DBLE(AMURSS**2))*AMURSS*
     $  (1.-AMGLSS**2/AMURSS**2)**2/3.
        CALL SSSAVE(ISUPR,WID,ISGL,IDUP,0,0,0)
      END IF
      IF (AMDRSS.GT.AMGLSS) THEN
        WID=2*SSALFS(DBLE(AMDRSS**2))*AMDRSS*
     $  (1.-AMGLSS**2/AMDRSS**2)**2/3.
        CALL SSSAVE(ISDNR,WID,ISGL,IDDN,0,0,0)
      END IF
      IF (AMSRSS.GT.AMGLSS) THEN
        WID=2*SSALFS(DBLE(AMSRSS**2))*AMSRSS*
     $  (1.-AMGLSS**2/AMSRSS**2)**2/3.
        CALL SSSAVE(ISSTR,WID,ISGL,IDST,0,0,0)
      END IF
C
      IF (AMCLSS.GT.(AMGLSS+AMCH)) THEN
        WID=2*SSALFS(DBLE(AMCLSS**2))*AMCLSS*(1.-AMGLSS**2/AMCLSS**2-
     $  AMCH**2/AMCLSS**2)*SQRT(SSXLAM(1.,AMGLSS**2/AMCLSS**2,
     $  AMCH**2/AMCLSS**2))/3.
        CALL SSSAVE(ISCHL,WID,ISGL,IDCH,0,0,0)
      END IF
      IF (AMCRSS.GT.(AMGLSS+AMCH)) THEN
        WID=2*SSALFS(DBLE(AMCRSS**2))*AMCRSS*(1.-AMGLSS**2/AMCRSS**2-
     $  AMCH**2/AMCRSS**2)*SQRT(SSXLAM(1.,AMGLSS**2/AMCRSS**2,
     $  AMCH**2/AMCRSS**2))/3.
        CALL SSSAVE(ISCHR,WID,ISGL,IDCH,0,0,0)
      END IF
C
      IF (AMB1SS.GT.(AMGLSS+AMBT)) THEN
        WID=2*SSALFS(DBLE(AMB1SS**2))*AMB1SS*(1.-AMGLSS**2/AMB1SS**2-
     $  AMBT**2/AMB1SS**2-2*SGNM3*SIN(2*THETAB)*AMBT*AMGLSS/AMB1SS**2)
     $  *SQRT(SSXLAM(1.,AMGLSS**2/AMB1SS**2,AMBT**2/AMB1SS**2))/3.
        CALL SSSAVE(ISBT1,WID,ISGL,IDBT,0,0,0)
      END IF
C
      IF (AMB2SS.GT.(AMGLSS+AMBT)) THEN
        WID=2*SSALFS(DBLE(AMB2SS**2))*AMB2SS*(1.-AMGLSS**2/AMB2SS**2-
     $  AMBT**2/AMB2SS**2+2*SGNM3*SIN(2*THETAB)*AMBT*AMGLSS/AMB2SS**2)
     $  *SQRT(SSXLAM(1.,AMGLSS**2/AMB2SS**2,AMBT**2/AMB2SS**2))/3.
        CALL SSSAVE(ISBT2,WID,ISGL,IDBT,0,0,0)
      END IF
C
C           Compute branching fractions to wi --- theta-C = 0
C
      IF (AMULSS.GT.MW1) THEN
        WID=G**2*SIN(GAMMAR)**2*AMULSS*(1.-MW1**2/AMULSS**2)**2/16./PI
        CALL SSSAVE(ISUPL,WID,ISW1,IDDN,0,0,0)
      END IF
      IF (AMCLSS.GT.MW1) THEN
        WID=G**2*SIN(GAMMAR)**2*AMCLSS*(1.-MW1**2/AMCLSS**2)**2/16./PI
        CALL SSSAVE(ISCHL,WID,ISW1,IDST,0,0,0)
      END IF
      IF (AMDLSS.GT.MW1) THEN
        WID=G**2*SIN(GAMMAL)**2*AMDLSS*(1.-MW1**2/AMDLSS**2)**2/16./PI
        CALL SSSAVE(ISDNL,WID,-ISW1,IDUP,0,0,0)
      END IF
C
      IF (AMSLSS.GT.(MW1+AMCH)) THEN
        WID=G**2*SIN(GAMMAL)**2*AMSLSS*(1.-MW1**2/AMSLSS**2
     $  -AMCH**2/AMSLSS**2)
     $  *SQRT(SSXLAM(1.,MW1**2/AMSLSS**2,AMCH**2/AMSLSS**2))/16./PI
        CALL SSSAVE(ISSTL,WID,-ISW1,IDCH,0,0,0)
      ENDIF
C
       IF (AMB1SS.GT.(MW1+AMTP)) THEN
         A=AWU(1)*COSB-BWP(1)*SINB
         AS=A*A
         WID=AMB1SS*((AS+BW(1)**2*COSB**2)*(1.-MW1**2/AMB1SS**2
     $  -AMTP**2/AMB1SS**2)-4*AMTP*MW1*BW(1)*A*COSB/AMB1SS**2)
     $   *SQRT(SSXLAM(1.,MW1**2/AMB1SS**2,AMTP**2/AMB1SS**2))/16./PI
        CALL SSSAVE(ISBT1,WID,-ISW1,IDTP,0,0,0)
      ENDIF
C
       IF (AMB2SS.GT.(MW1+AMTP)) THEN
         A=AWU(1)*SINB+BWP(1)*COSB
         AS=A*A
         WID=AMB2SS*((AS+BW(1)**2*SINB**2)*(1.-MW1**2/AMB2SS**2
     $  -AMTP**2/AMB2SS**2)-4*AMTP*MW1*BW(1)*A*SINB/AMB2SS**2)
     $   *SQRT(SSXLAM(1.,MW1**2/AMB2SS**2,AMTP**2/AMB2SS**2))/16./PI
        CALL SSSAVE(ISBT2,WID,-ISW1,IDTP,0,0,0)
      ENDIF
C
      IF (AMULSS.GT.MW2) THEN
        WID=G**2*COS(GAMMAR)**2*AMULSS*(1.-MW2**2/AMULSS**2)**2/16./PI 
        CALL SSSAVE(ISUPL,WID,ISW2,IDDN,0,0,0)
      END IF
      IF (AMCLSS.GT.MW2) THEN
        WID=G**2*COS(GAMMAR)**2*AMCLSS*(1.-MW2**2/AMCLSS**2)**2/16./PI 
        CALL SSSAVE(ISCHL,WID,ISW2,IDST,0,0,0)
      END IF
      IF (AMDLSS.GT.MW2) THEN
        WID=G**2*COS(GAMMAL)**2*AMDLSS*(1.-MW2**2/AMDLSS**2)**2/16./PI
        CALL SSSAVE(ISDNL,WID,-ISW2,IDUP,0,0,0)
      END IF
C
      IF (AMSLSS.GT.(MW2+AMCH)) THEN
        WID=G**2*COS(GAMMAL)**2*AMSLSS*(1.-MW2**2/AMSLSS**2
     $  -AMCH**2/AMSLSS**2)
     $  *SQRT(SSXLAM(1.,MW2**2/AMSLSS**2,AMCH**2/AMSLSS**2))/16./PI
        CALL SSSAVE(ISSTL,WID,-ISW2,IDCH,0,0,0)
      ENDIF
C
      IF (AMB1SS.GT.(MW2+AMTP)) THEN
         A=AWU(2)*COSB-BWP(2)*SINB
         AS=A*A
         WID=AMB1SS*((AS+BW(2)**2*COSB**2)*(1.-MW2**2/AMB1SS**2
     $  -AMTP**2/AMB1SS**2)-4*AMTP*MW2*BW(2)*A*COSB/AMB1SS**2)
     $   *SQRT(SSXLAM(1.,MW2**2/AMB1SS**2,AMTP**2/AMB1SS**2))/16./PI
        CALL SSSAVE(ISBT1,WID,-ISW2,IDTP,0,0,0)
      ENDIF 
C
      IF (AMB2SS.GT.(MW2+AMTP)) THEN
         A=AWU(2)*SINB+BWP(2)*COSB
         AS=A*A
         WID=AMB2SS*((AS+BW(2)**2*SINB**2)*(1.-MW2**2/AMB2SS**2
     $  -AMTP**2/AMB2SS**2)-4*AMTP*MW2*BW(2)*A*SINB/AMB2SS**2)
     $   *SQRT(SSXLAM(1.,MW2**2/AMB2SS**2,AMTP**2/AMB2SS**2))/16./PI
        CALL SSSAVE(ISBT2,WID,-ISW2,IDTP,0,0,0)
      ENDIF 
C
      IF (AMB1SS.GT.(AMW+AMT1SS)) THEN
        WID=G**2*COST**2*COSB**2*(SSXLAM(AMB1SS**2,AMW**2,
     $   AMT1SS**2))**1.5/32./PI/AMB1SS**3/AMW**2
        CALL SSSAVE(ISBT1,WID,-IDW,ISTP1,0,0,0)
      ENDIF 
C
      IF (AMB1SS.GT.(AMW+AMT2SS)) THEN
        WID=G**2*SINT**2*COSB**2*(SSXLAM(AMB1SS**2,AMW**2,
     $   AMT2SS**2))**1.5/32./PI/AMB1SS**3/AMW**2
        CALL SSSAVE(ISBT1,WID,-IDW,ISTP2,0,0,0)
      ENDIF 
C
      IF (AMB2SS.GT.(AMW+AMT1SS)) THEN
        WID=G**2*COST**2*SINB**2*(SSXLAM(AMB2SS**2,AMW**2,
     $   AMT1SS**2))**1.5/32./PI/AMB2SS**3/AMW**2
        CALL SSSAVE(ISBT2,WID,-IDW,ISTP1,0,0,0)
      ENDIF 
C
      IF (AMB2SS.GT.(AMW+AMT2SS)) THEN
        WID=G**2*SINT**2*SINB**2*(SSXLAM(AMB2SS**2,AMW**2,
     $   AMT2SS**2))**1.5/32./PI/AMB2SS**3/AMW**2
        CALL SSSAVE(ISBT2,WID,-IDW,ISTP2,0,0,0)
      ENDIF 
C 
      IF (AMB2SS.GT.(AMZ+AMB1SS)) THEN
        WID=G**2*COSB**2*SINB**2*(SSXLAM(AMB2SS**2,AMZ**2,
     $   AMB1SS**2))**1.5/64./PI/AMB2SS**3/AMZ**2/CS2THW
        CALL SSSAVE(ISBT2,WID,IDZ,ISBT1,0,0,0)
      ENDIF 
C 
      IF (AMB2SS.GT.(AMHL+AMB1SS)) THEN
        BH=G*AMW*SIN(BETA-ALFAH)*(-1.+TN2THW/3.)*SINB*COSB/2.+G*
     $  AMBT*(TWOM1*COSA+AAB*SINA)*COS(2*THETAB)/2./AMW/COS(BETA)
        WID=BH**2*SQRT(SSXLAM(AMB2SS**2,AMHL**2,AMB1SS**2))/
     $      16./PI/AMB2SS**3
        CALL SSSAVE(ISBT2,WID,ISHL,ISBT1,0,0,0)
      ENDIF 
C 
      IF (AMB2SS.GT.(AMHA+AMB1SS)) THEN
        BH=G*AMBT*(TWOM1-AAB*TANB)/2./AMW
        WID=BH**2*SQRT(SSXLAM(AMB2SS**2,AMHA**2,AMB1SS**2))/
     $      16./PI/AMB2SS**3
        CALL SSSAVE(ISBT2,WID,ISHA,ISBT1,0,0,0)
      ENDIF 
C 
      IF (AMB2SS.GT.(AMHH+AMB1SS)) THEN
        BH=-G*AMW*COS(BETA-ALFAH)*(-1.+TN2THW/3.)*SINB*COSB/2.+G*
     $  AMBT*(-TWOM1*SINA+AAB*COSA)*COS(2*THETAB)/2./AMW/COS(BETA)
        WID=BH**2*SQRT(SSXLAM(AMB2SS**2,AMHH**2,AMB1SS**2))/
     $      16./PI/AMB2SS**3
        CALL SSSAVE(ISBT2,WID,ISHH,ISBT1,0,0,0)
      ENDIF 
C 
C     b_i -> H^- t_i 
C
      IF (AMB1SS.GT.(AMT1SS+AMHC)) THEN
        A=G/SR2/AMW*(AMTP*AMBT*(COTB+TANB)*SINT*SINB+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $COST*COSB-AMTP*(TWOM1-AAT*COTB)*SINT*COSB-AMBT*
     $(TWOM1-AAB*TANB)*SINB*COST)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMB1SS**2,AMT1SS**2,AMHC**2))/
     $      16./PI/AMB1SS**3
        CALL SSSAVE(ISBT1,WID,-ISHC,ISTP1,0,0,0)
      END IF
C 
      IF (AMB1SS.GT.(AMT2SS+AMHC)) THEN
        A=G/SR2/AMW*(-AMTP*AMBT*(COTB+TANB)*COST*SINT+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $SINT*COSB+AMTP*(TWOM1-AAT*COTB)*COST*COSB-AMBT*
     $(TWOM1-AAB*TANB)*SINT*SINB)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMB1SS**2,AMT2SS**2,AMHC**2))/
     $      16./PI/AMB1SS**3
        CALL SSSAVE(ISBT1,WID,-ISHC,ISTP2,0,0,0)
      END IF
C 
      IF (AMB2SS.GT.(AMT1SS+AMHC)) THEN
        A=G/SR2/AMW*(-AMTP*AMBT*(COTB+TANB)*SINT*COSB+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $COST*SINB-AMTP*(TWOM1-AAT*COTB)*SINT*SINB+AMBT*
     $(TWOM1-AAB*TANB)*COST*COSB)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMB2SS**2,AMT1SS**2,AMHC**2))/
     $      16./PI/AMB2SS**3
        CALL SSSAVE(ISBT2,WID,-ISHC,ISTP1,0,0,0)
      END IF
C 
      IF (AMB2SS.GT.(AMT2SS+AMHC)) THEN
        A=G/SR2/AMW*(AMTP*AMBT*(COTB+TANB)*COST*COSB+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $SINT*SINB+AMTP*(TWOM1-AAT*COTB)*SINB*COST+AMBT*
     $(TWOM1-AAB*TANB)*COSB*SINT)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMB2SS**2,AMT2SS**2,AMHC**2))/
     $      16./PI/AMB2SS**3
        CALL SSSAVE(ISBT2,WID,-ISHC,ISTP2,0,0,0)
      END IF
C 
C          Normalize branching ratios 
C
      CALL SSNORM(ISUPL)
      CALL SSNORM(ISDNL)
      CALL SSNORM(ISSTL)
      CALL SSNORM(ISCHL)
      CALL SSNORM(ISBT1)
      CALL SSNORM(ISUPR)
      CALL SSNORM(ISDNR)
      CALL SSNORM(ISSTR)
      CALL SSNORM(ISCHR)
      CALL SSNORM(ISBT2)
C
       RETURN
       END
+EOD
+DECK,SSRSGB
C--------------------------------------------------------------------
      FUNCTION SSRSGB(QS)
C--------------------------------------------------------------------
C
C     Calculate b quark self energy
C     according to Pierce et al. formulae adapted to Isajet
C
C     Modified by Javier 9/2005 / Log threholds already implemented 
C     through RGE decoupling have been substracted by 
C     a redefinition of B1 function
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSPAR
+CDE,SSSM
+CDE,SUGMG
+CDE,SUGPAS
      COMPLEX ZAZB1(4),ZAZB2(4),ZBZB1(4),ZBZB2(4),ZI
      COMPLEX ZAWD(2)
      COMPLEX ZAWT1(2),ZAWT2(2),ZBWT1(2),ZBWT2(2)
      COMPLEX*16 SSB0,SSB1F,ZZZ,SIGWI,SIGZI
      REAL SR2,PI,E,G,TANB,BETA,SINB,COSB,COSA,SINA,COST,SINT,
     $MG,MT1,MT2,MB1,MB2,GLB,GRB,XM,YM,THX,THY,
     $FB1(4),FB2(4),GB1(4),GB2(4),MZI(4),FT,FB,
     $RSIGB,QS,SSRSGB,ZBW(2),BWP(2),FWT1(2),GWT1(2),FWT2(2),
     $GWT2(2),MWI(2),MW,MZ,MB,MT,SUALFS,COS2W,FAC,
     $COSBE,SINBE,XM3
      REAL*8 LP(11),LPTOT
      REAL*8 REAL8,RSIGWI,RSIGZI

      INTEGER THZ(4),THW(2),I
C
      DATA ZI/(0.,1.)/
C     Recompute weak scale Yukawa couplings including SUSY loops
C     Follow formulae of Pierce et al. NPB491, 3 (1997)
C
      REAL8(ZZZ)=DREAL(ZZZ)
      SR2=SQRT(2.)
      PI=4*ATAN(1.)
      E=SQRT(4*PI*ALFAEM)
      COS2W=1.-SN2THW
      G=G2
      MW=AMW
      MZ=AMZ
      MB=MBQ
C      ASMZ=SUALFS(AMZ**2,.36,AMTP,3)
      FAC=16*PI**2
      TANB=VUQ/VDQ
      BETA=ATAN(TANB)
      SINBE=SIN(BETA)
      COSBE=COS(BETA)
      COSA=COS(ALFAH)
      SINA=SIN(ALFAH)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      MG=ABS(GSS(9))
      XM3=M3Q
      MT=AMTP
      MT1=MSS(12)
      MT2=MSS(13)
      MB1=MSS(10)
      MB2=MSS(11)
      GLB=-.5+XW/3.
      GRB=-XW/3.
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      THW(1)=0
      IF(AMW1SS.LT.0.) THW(1)=1
      THW(2)=0
      IF(AMW2SS.LT.0.) THW(2)=1
 
C     Neutralino-fermion-sfermion couplings
C     a(Pierce)=-beta^* ; b(Pierce)=-alpha^*
C
      SIGZI=(0.,0.)
      DO I=1,4
        THZ(I)=0
        IF (AMZISS(I).LT.0.) THZ(I)=1
        MZI(I)=ABS(AMZISS(I))
        ZAZB1(I)=ZI*(-ZI)**(THZ(I)-1)*(-G*ZMIXSS(3,I)+GP*
     $  ZMIXSS(4,I)/3.)/SR2*COSB+(-ZI)**(THZ(I))*FB*ZMIXSS(2,I)*SINB
        ZAZB2(I)=ZI*(-ZI)**(THZ(I)-1)*(-G*ZMIXSS(3,I)+GP*
     $  ZMIXSS(4,I)/3.)/SR2*SINB-(-ZI)**(THZ(I))*FB*ZMIXSS(2,I)*COSB
        ZBZB1(I)=-ZI*(ZI)**(THZ(I)-1)*(-2)*GP/3./SR2*ZMIXSS(4,I)*SINB
     $  -(ZI)**(THZ(I))*FB*ZMIXSS(2,I)*COSB
        ZBZB2(I)=ZI*(ZI)**(THZ(I)-1)*(-2)*GP/3./SR2*ZMIXSS(4,I)*COSB
     $  -(ZI)**(THZ(I))*FB*ZMIXSS(2,I)*SINB
        FB1(I)=ZAZB1(I)*CONJG(ZAZB1(I))+ZBZB1(I)*CONJG(ZBZB1(I))
        GB1(I)=2*REAL(ZAZB1(I)*CONJG(ZBZB1(I)))
        FB2(I)=ZAZB2(I)*CONJG(ZAZB2(I))+ZBZB2(I)*CONJG(ZBZB2(I))
        GB2(I)=2*REAL(ZAZB2(I)*CONJG(ZBZB2(I)))
        SIGZI=SIGZI+FB1(I)*SSB1F(QS,MZI(I),MB1)+GB1(I)*MZI(I)/MBQ*
     $  SSB0(QS,MZI(I),MB1)+FB2(I)*SSB1F(QS,MZI(I),MB2)
     $  +GB2(I)*MZI(I)/MBQ*SSB0(QS,MZI(I),MB2)
      END DO
      RSIGZI=REAL8(SIGZI)
C
C     Chargino-fermion-sfermion couplings; I labels chargino
C
      ZAWD(1)=ZI*(-1)**THW(1)*G*SIN(GAMMAR)
      ZAWD(2)=ZI*(-1)**THW(2)*THY*G*COS(GAMMAR)
      ZBW(1)=-(-1)**THW(1)*FT*COS(GAMMAR)
      ZBW(2)=(-1)**THW(2)*THY*FT*SIN(GAMMAR)
      BWP(1)=-FB*COS(GAMMAL)
      BWP(2)=FB*THX*SIN(GAMMAL)
      SIGWI=(0.,0.)
      MWI(1)=ABS(AMW1SS)
      MWI(2)=ABS(AMW2SS)
      DO I=1,2
        ZAWT1(I)=-ZI*ZAWD(I)*COST+ZBW(I)*SINT
        ZAWT2(I)=-ZI*ZAWD(I)*SINT-ZBW(I)*COST
        ZBWT1(I)=-BWP(I)*COST
        ZBWT2(I)=-BWP(I)*SINT
        FWT1(I)=ZAWT1(I)*CONJG(ZAWT1(I))+ZBWT1(I)*CONJG(ZBWT1(I))
        GWT1(I)=2*REAL(CONJG(ZBWT1(I))*ZAWT1(I))
        FWT2(I)=ZAWT2(I)*CONJG(ZAWT2(I))+ZBWT2(I)*CONJG(ZBWT2(I))
        GWT2(I)=2*REAL(CONJG(ZBWT2(I))*ZAWT2(I))
        SIGWI=SIGWI+FWT1(I)*SSB1F(QS,MWI(I),MT1)+
     $MWI(I)/MBQ*GWT1(I)*SSB0(QS,MWI(I),MT1)+
     $FWT2(I)*SSB1F(QS,MWI(I),MT2)+
     $MWI(I)/MBQ*GWT2(I)*SSB0(QS,MWI(I),MT2)
      END DO
      RSIGWI=REAL8(SIGWI)
      LP(1)=ASMSS/3./PI*(REAL8(SSB1F(QS,MG,MB1))+
     $  REAL8(SSB1F(QS,MG,MB2))-SIN(2*THETAB)*XM3/MBQ*
     $  (REAL8(SSB0(QS,MG,MB1))-REAL8(SSB0(QS,MG,MB2))))
      LP(2)=.5*FB**2*COSA**2*(REAL8(SSB1F(QS,MB,AMHH))+
     $REAL8(SSB0(QS,MB,AMHH)))/FAC
      LP(3)=.5*FB**2*SINA**2*(REAL8(SSB1F(QS,MB,AMHL))+
     $REAL8(SSB0(QS,MB,AMHL)))/FAC
      LP(4)=.5*FB**2*SINBE**2*(REAL8(SSB1F(QS,MB,AMHA))-
     $REAL8(SSB0(QS,MB,AMHA)))/FAC
      LP(5)=.5*FB**2*COSBE**2*(REAL8(SSB1F(QS,MB,MZ))-
     $REAL8(SSB0(QS,MB,MZ)))/FAC
      LP(6)=.5*((FT**2*COSBE**2+FB**2*SINBE**2)*
     $REAL8(SSB1F(QS,MT,AMHC))+(G2**2+FT**2*SINBE**2+FB**2*COSBE**2)
     $*REAL8(SSB1F(QS,MT,MW)))/FAC
      LP(7)=FT**2*SINBE**2*(REAL8(SSB0(QS,MT,AMHC))-
     $REAL8(SSB0(QS,MT,MW)))/FAC
      LP(8)=0.
      LP(9)=+G2**2/COS2W*((GLB**2+GRB**2)*REAL8(SSB1F(QS,MB,MZ))
     $+4*GLB*GRB*REAL8(SSB0(QS,MB,MZ)))/FAC
      LP(10)=.5*RSIGZI/FAC
      LP(11)=.5*RSIGWI/FAC
      LPTOT=0.D0
      DO I=1,11
        LPTOT=LPTOT+LP(I)
C        WRITE(6,*) 'LP(',I,')=',LP(I)
      END DO
      SSRSGB=LPTOT
100   RETURN
      END
+EOD
+DECK,SSRSGL
C--------------------------------------------------------------------
      FUNCTION SSRSGL(QS)
C--------------------------------------------------------------------
C
C     Calculate tau lepton self energy
C     according to Pierce et al. formulae adapted to Isajet
C
C     Modified by Javier 9/2005 /Log threholds already 
C     implemented through RGE decoupling have been substracted 
C     by a redefinition of B1 function
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSPAR
+CDE,SSSM
+CDE,SUGMG
+CDE,SUGPAS
      COMPLEX ZAZL1(4),ZAZL2(4),ZBZL1(4),ZBZL2(4),ZI
      COMPLEX ZAWL(2)
      COMPLEX ZAWSN(2),ZBWSN(2)
      COMPLEX*16 SSB0,SSB1F,ZZZ,SIGWI,SIGZI
      REAL SR2,PI,E,G,TANB,BETA,SINB,COSB,COSA,SINA,COSL,SINL,
     $MG,ML1,ML2,MSN,GLL,GRL,XM,YM,THX,THY,
     $FL1(4),FL2(4),GL1(4),GL2(4),MZI(4),FL,ML,
     $RSIGL,QS,SSRSGL,BWPP(2),FWSN(2),GWSN(2),
     $MWI(2),MW,MZ,COS2W,FAC,
     $COSBE,SINBE
      REAL*8 LP(11),LPTOT
      REAL*8 REAL8,RSIGWI,RSIGZI

      INTEGER THZ(4),THW(2),I
C
      DATA ZI/(0.,1.)/
C     Recompute weak scale Yukawa couplings including SUSY loops
C     Follow formulae of Pierce et al. NPB491, 3 (1997)
C
      REAL8(ZZZ)=DREAL(ZZZ)
      SR2=SQRT(2.)
      PI=4*ATAN(1.)
      E=SQRT(4*PI*ALFAEM)
      COS2W=1.-SN2THW
      G=G2
      MW=AMW
      MZ=AMZ
      ML=MLQ
      FAC=16*PI**2
      TANB=VUQ/VDQ
      BETA=ATAN(TANB)
      SINBE=SIN(BETA)
      COSBE=COS(BETA)
      COSA=COS(ALFAH)
      SINA=SIN(ALFAH)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
      MSN=AMN3SS
      ML1=AML1SS
      ML2=AML2SS
      GLL=-.5+XW
      GRL=-XW
      FL=MLQ/VDQ
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      THW(1)=0
      IF(AMW1SS.LT.0.) THW(1)=1
      THW(2)=0
      IF(AMW2SS.LT.0.) THW(2)=1
 
C     Neutralino-fermion-sfermion couplings
C     a(Pierce)=-beta^* ; b(Pierce)=-alpha^*
C
      SIGZI=(0.,0.)
      DO I=1,4
        THZ(I)=0
        IF (AMZISS(I).LT.0.) THZ(I)=1
        MZI(I)=ABS(AMZISS(I))
        ZAZL1(I)=ZI*(-1)*(-ZI)**(THZ(I)-1)*(G*ZMIXSS(3,I)+GP*
     $  ZMIXSS(4,I))/SR2*COSL+(-ZI)**(THZ(I))*FL*ZMIXSS(2,I)*SINL
        ZAZL2(I)=ZI*(-1)*(-ZI)**(THZ(I)-1)*(G*ZMIXSS(3,I)+GP*
     $  ZMIXSS(4,I))/SR2*SINL-(-ZI)**(THZ(I))*FL*ZMIXSS(2,I)*COSL
        ZBZL1(I)=-ZI*(-1)*(ZI)**(THZ(I)-1)*SR2*GP*ZMIXSS(4,I)*SINL
     $  -(ZI)**(THZ(I))*FL*ZMIXSS(2,I)*COSL
        ZBZL2(I)=ZI*(-1)*(ZI)**(THZ(I)-1)*SR2*GP*ZMIXSS(4,I)*COSL
     $  -(ZI)**(THZ(I))*FL*ZMIXSS(2,I)*SINL
        FL1(I)=ZAZL1(I)*CONJG(ZAZL1(I))+ZBZL1(I)*CONJG(ZBZL1(I))
        GL1(I)=2*REAL(ZAZL1(I)*CONJG(ZBZL1(I)))
        FL2(I)=ZAZL2(I)*CONJG(ZAZL2(I))+ZBZL2(I)*CONJG(ZBZL2(I))
        GL2(I)=2*REAL(ZAZL2(I)*CONJG(ZBZL2(I)))
        SIGZI=SIGZI+FL1(I)*SSB1F(QS,MZI(I),ML1)+GL1(I)*MZI(I)/ML*
     $  SSB0(QS,MZI(I),ML1)+FL2(I)*SSB1F(QS,MZI(I),ML2)
     $  +GL2(I)*MZI(I)/ML*SSB0(QS,MZI(I),ML2)
      END DO
      RSIGZI=REAL8(SIGZI)
C
C     Chargino-fermion-sfermion couplings; I labels chargino
C
      ZAWL(1)=ZI*(-1)**THW(1)*G*SIN(GAMMAR)
      ZAWL(2)=ZI*(-1)**THW(2)*THY*G*COS(GAMMAR)
      BWPP(1)=-FL*COS(GAMMAL)
      BWPP(2)=FL*THX*SIN(GAMMAL)
      SIGWI=(0.,0.)
      MWI(1)=ABS(AMW1SS)
      MWI(2)=ABS(AMW2SS)
      DO I=1,2
        ZAWSN(I)=-ZI*ZAWL(I)
        ZBWSN(I)=-BWPP(I)
        FWSN(I)=ZAWSN(I)*CONJG(ZAWSN(I))+ZBWSN(I)*CONJG(ZBWSN(I))
        GWSN(I)=2*REAL(CONJG(ZBWSN(I))*ZAWSN(I))
        SIGWI=SIGWI+FWSN(I)*SSB1F(QS,MWI(I),MSN)+
     $  MWI(I)/MLQ*GWSN(I)*SSB0(QS,MWI(I),MSN)
      END DO
      RSIGWI=REAL8(SIGWI)
      LP(1)=0.
      LP(2)=.5*FL**2*COSA**2*(REAL8(SSB1F(QS,ML,AMHH))+
     $REAL8(SSB0(QS,ML,AMHH)))/FAC
      LP(3)=.5*FL**2*SINA**2*(REAL8(SSB1F(QS,ML,AMHL))+
     $REAL8(SSB0(QS,ML,AMHL)))/FAC
      LP(4)=.5*FL**2*SINBE**2*(REAL8(SSB1F(QS,ML,AMHA))-
     $REAL8(SSB0(QS,ML,AMHA)))/FAC
      LP(5)=.5*FL**2*COSBE**2*(REAL8(SSB1F(QS,ML,MZ))-
     $REAL8(SSB0(QS,ML,MZ)))/FAC
      LP(6)=.5*(FL**2*SINBE**2*REAL8(SSB1F(QS,0.,AMHC))+
     $(G2**2+FL**2*COSBE**2)*REAL8(SSB1F(QS,0.,MW)))/FAC
      LP(7)=0.
      LP(8)=0.
      LP(9)=+G2**2/COS2W*((GLL**2+GRL**2)*REAL8(SSB1F(QS,ML,MZ))
     $+4*GLL*GRL*REAL8(SSB0(QS,ML,MZ)))/FAC
      LP(10)=.5*RSIGZI/FAC
      LP(11)=.5*RSIGWI/FAC
      LPTOT=0.D0
      DO I=1,11
        LPTOT=LPTOT+LP(I)
C        WRITE(6,*) 'LP(',I,')=',LP(I)
      END DO
      SSRSGL=LPTOT
100   RETURN
      END
+EOD
+DECK,SSRSGT
C--------------------------------------------------------------------
      FUNCTION SSRSGT(QS)
C--------------------------------------------------------------------
C
C     Calculate top quark self energy
C     according to Pierce et al. formulae adapted to Isajet
C
C     Modified by Javier 9/2005 /Log threholds already implemented 
C     through RGE decoupling have been substracted 
C     by a redefinition of B1 function
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSPAR
+CDE,SSSM
+CDE,SUGMG
+CDE,SUGPAS
      COMPLEX ZAZT1(4),ZAZT2(4),ZBZT1(4),ZBZT2(4),ZI
      COMPLEX ZAWU(2)
      COMPLEX ZAWB1(2),ZAWB2(2),ZBWB1(2),ZBWB2(2)
      COMPLEX*16 SSB0,SSB1F,SSB1,ZZZ,SIGWI,SIGZI
      REAL SR2,PI,E,G,TANB,BETA,SINB,COSB,COSA,SINA,COST,SINT,
     $MG,MT1,MT2,MB1,MB2,GLT,GRT,XM,YM,THX,THY,
     $FT1(4),FT2(4),GT1(4),GT2(4),MZI(4),FT,FB,
     $RSIGT,QS,SSRSGT,ZBW(2),BWP(2),FWB1(2),GWB1(2),FWB2(2),
     $GWB2(2),MWI(2),MW,MZ,MB,MT,SUALFS,COS2W,FAC,
     $COSBE,SINBE,XM3,ST2LP,AT,CF,CA
      REAL*8 LP(11),LPTOT
      REAL*8 REAL8,RSIGWI,RSIGZI

      INTEGER THZ(4),THW(2),I
C
      DATA ZI/(0.,1.)/
C     Recompute weak scale Yukawa couplings including SUSY loops
C     Follow formulae of Pierce et al. NPB491, 3 (1997)
C
      REAL8(ZZZ)=DREAL(ZZZ)
      CA=3.
      CF=4./3.
      SR2=SQRT(2.)
      PI=4*ATAN(1.)
      E=SQRT(4*PI*ALFAEM)
      COS2W=1.-SN2THW
      G=G2
      MW=AMW
      MZ=AMZ
      MB=AMBT
      FAC=16*PI**2
      TANB=VUQ/VDQ
      BETA=ATAN(TANB)
      SINBE=SIN(BETA)
      COSBE=COS(BETA)
      COSA=COS(ALFAH)
      SINA=SIN(ALFAH)
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      MG=ABS(GSS(9))
      XM3=M3Q
      MT=AMTP
      MT1=MSS(12)
      MT2=MSS(13)
      MB1=MSS(10)
      MB2=MSS(11)
      GLT=.5-2*XW/3.
      GRT=2*XW/3.
      FT=MTQ/VUQ
      FB=MBQ/VDQ
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      THW(1)=0
      IF(AMW1SS.LT.0.) THW(1)=1
      THW(2)=0
      IF(AMW2SS.LT.0.) THW(2)=1
 
C     Neutralino-fermion-sfermion couplings
C     a(Pierce)=-beta^* ; b(Pierce)=-alpha^*
C
      SIGZI=(0.,0.)
      DO I=1,4
        THZ(I)=0
        IF (AMZISS(I).LT.0.) THZ(I)=1
        MZI(I)=ABS(AMZISS(I))
        ZAZT1(I)=ZI*(-ZI)**(THZ(I)-1)*(G*ZMIXSS(3,I)+GP*
     $ZMIXSS(4,I)/3.)/SR2*COST+(-ZI)**(THZ(I))*FT*ZMIXSS(1,I)*SINT
        ZAZT2(I)=ZI*(-ZI)**(THZ(I)-1)*(G*ZMIXSS(3,I)+GP*
     $ZMIXSS(4,I)/3.)/SR2*SINT-(-ZI)**(THZ(I))*FT*ZMIXSS(1,I)*COST
        ZBZT1(I)=-ZI*(ZI)**(THZ(I)-1)*4*GP/3./SR2*ZMIXSS(4,I)*SINT
     $-(ZI)**(THZ(I))*FT*ZMIXSS(1,I)*COST
        ZBZT2(I)=ZI*(ZI)**(THZ(I)-1)*4*GP/3./SR2*ZMIXSS(4,I)*COST
     $-(ZI)**(THZ(I))*FT*ZMIXSS(1,I)*SINT
        FT1(I)=ZAZT1(I)*CONJG(ZAZT1(I))+ZBZT1(I)*CONJG(ZBZT1(I))
        GT1(I)=2*REAL(ZAZT1(I)*CONJG(ZBZT1(I)))
        FT2(I)=ZAZT2(I)*CONJG(ZAZT2(I))+ZBZT2(I)*CONJG(ZBZT2(I))
        GT2(I)=2*REAL(ZAZT2(I)*CONJG(ZBZT2(I)))
        SIGZI=SIGZI+FT1(I)*SSB1F(QS,MZI(I),MT1)+GT1(I)*MZI(I)/MTQ*
     $SSB0(QS,MZI(I),MT1)+FT2(I)*SSB1F(QS,MZI(I),MT2)
     $+GT2(I)*MZI(I)/MTQ*SSB0(QS,MZI(I),MT2)
      END DO
      RSIGZI=REAL8(SIGZI)
C
C     Chargino-fermion-sfermion couplings; I labels chargino
C
      ZAWU(1)=ZI*G*SIN(GAMMAL)
      ZAWU(2)=ZI*THX*G*COS(GAMMAL)
      ZBW(1)=-(-1)**THW(1)*FT*COS(GAMMAR)
      ZBW(2)=(-1)**THW(2)*THY*FT*SIN(GAMMAR)
      BWP(1)=-FB*COS(GAMMAL)
      BWP(2)=FB*THX*SIN(GAMMAL)
      SIGWI=(0.,0.)
      MWI(1)=ABS(AMW1SS)
      MWI(2)=ABS(AMW2SS)
      DO I=1,2
        ZAWB1(I)=-ZI*ZAWU(I)*COSB+BWP(I)*SINB
        ZAWB2(I)=-ZI*ZAWU(I)*SINB-BWP(I)*COSB
        ZBWB1(I)=-ZBW(I)*COSB
        ZBWB2(I)=-ZBW(I)*SINB
        FWB1(I)=ZAWB1(I)*CONJG(ZAWB1(I))+ZBWB1(I)*CONJG(ZBWB1(I))
        GWB1(I)=2*REAL(CONJG(ZBWB1(I))*ZAWB1(I))
        FWB2(I)=ZAWB2(I)*CONJG(ZAWB2(I))+ZBWB2(I)*CONJG(ZBWB2(I))
        GWB2(I)=2*REAL(CONJG(ZBWB2(I))*ZAWB2(I))
        SIGWI=SIGWI+FWB1(I)*SSB1F(QS,MWI(I),MB1)+
     $GWB1(I)*MWI(I)/MTQ*SSB0(QS,MWI(I),MB1)+
     $FWB2(I)*SSB1F(QS,MWI(I),MB2)+
     $MWI(I)/MTQ*GWB2(I)*SSB0(QS,MWI(I),MB2)
      END DO
      RSIGWI=REAL8(SIGWI)
      LP(1)=ASMSS/3./PI*(REAL8(SSB1F(QS,MG,MT1))+
     $  REAL8(SSB1F(QS,MG,MT2))-SIN(2*THETAT)*XM3/MTQ*
     $  (REAL8(SSB0(QS,MG,MT1))-REAL8(SSB0(QS,MG,MT2))))
      LP(2)=.5*FT**2*SINA**2*(REAL8(SSB1F(QS,MT,AMHH))+
     $REAL8(SSB0(QS,MT,AMHH)))/FAC
      LP(3)=.5*FT**2*COSA**2*(REAL8(SSB1(QS,MT,AMHL))+
     $REAL8(SSB0(QS,MT,AMHL)))/FAC
      LP(4)=.5*FT**2*COSBE**2*(REAL8(SSB1F(QS,MT,AMHA))-
     $REAL8(SSB0(QS,MT,AMHA)))/FAC
      LP(5)=.5*FT**2*SINBE**2*(REAL8(SSB1(QS,MT,MZ))-
     $REAL8(SSB0(QS,MT,MZ)))/FAC
      LP(6)=.5*((FB**2*SINBE**2+FT**2*COSBE**2)*
     $REAL8(SSB1F(QS,MB,AMHC))+(G2**2+FB**2*COSBE**2+FT**2*SINBE**2)
     $*REAL8(SSB1(QS,MB,MW)))/FAC
      LP(7)=FB**2*COSBE**2*(REAL8(SSB0(QS,MB,AMHC))-
     $REAL8(SSB0(QS,MB,MW)))/FAC
      LP(8)=-(2*E/3.)**2*(5.+3*LOG(QS/MT**2))/FAC
      LP(9)=+G2**2/COS2W*((GLT**2+GRT**2)*REAL8(SSB1(QS,MT,MZ))
     $+4*GLT*GRT*REAL8(SSB0(QS,MT,MZ)))/FAC
      LP(10)=.5*RSIGZI/FAC
      LP(11)=.5*RSIGWI/FAC
      LPTOT=0.D0
      DO I=1,11
        LPTOT=LPTOT+LP(I)
C        WRITE(*,*) 'LP(',I,')=',LP(I)
      END DO
      AT=AAT-MU/TANB
      ST2LP=CF*(ASMSS/4./PI)**2*(47./3.+CF*23./24.+CA*175./72.
     $-4*AT/MSUSY+CF*AT/MSUSY*(7./3.+6*LOG(MT/MSUSY))
     $-8*CA*AT/3./MSUSY)
      SSRSGT=LPTOT
      SSRSGT=SSRSGT-ST2LP
100   RETURN
      END
+EOD
+DECK,SSSAVE
      SUBROUTINE SSSAVE(IIN,GAM,IOUT1,IOUT2,IOUT3,IOUT4,IOUT5)
C-----------------------------------------------------------------------
C     Store a SUSY decay mode in /SSMODE/
C     Ver 7.14: Increment NSSMOD only after test
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,SSLUN
+CDE,SSMODE
C
      INTEGER IIN,IOUT1,IOUT2,IOUT3,IOUT4,IOUT5,I
      REAL GAM
C
      IF (GAM.LE.0.) THEN
        IF(GAM.LT.0.) THEN
          WRITE(LOUT,1000) IIN,IOUT1,IOUT2,IOUT3,IOUT4,IOUT5,GAM
1000      FORMAT(' WARNING: SSSAVE: ',I5,' --> ',5I5,E14.5)
        ENDIF
        LSSMOD=.FALSE.
        GO TO 999
      ENDIF
      NSSMOD=NSSMOD+1
      LSSMOD=.TRUE.
      IF(NSSMOD.GT.MXSS) THEN
        WRITE(LOUT,*) 'SSSAVE: TOO MANY MODES, IIN = ',IIN
        STOP99
      ENDIF
      ISSMOD(NSSMOD)=IIN
      JSSMOD(1,NSSMOD)=IOUT1
      JSSMOD(2,NSSMOD)=IOUT2
      JSSMOD(3,NSSMOD)=IOUT3
      JSSMOD(4,NSSMOD)=IOUT4
      JSSMOD(5,NSSMOD)=IOUT5
      GSSMOD(NSSMOD)=GAM
      BSSMOD(NSSMOD)=0.
      MSSMOD(NSSMOD)=0
C          Check that quarks and gluons appear at end of list.
      DO 100 I=1,4
        IF(IABS(JSSMOD(I,NSSMOD)).LE.9.AND.
     $  IABS(JSSMOD(I+1,NSSMOD)).GT.9) THEN
          WRITE(LOUT,1100) IIN,IOUT1,IOUT2,IOUT3,IOUT4,IOUT5
1100      FORMAT(' WARNING: SSSAVE: BAD ORDER: ',I5,' --> ',5I5)
          STOP99
        ENDIF
100   CONTINUE
C
999   RETURN
      END
+EOD
+DECK,SSSNWS
        REAL FUNCTION SSSNWS(EE)
C-----------------------------------------------------------------------
C          SSSNWS: sneutrino->stau_1+f+fb' via W*
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL EE
        DOUBLE PRECISION E,M1,M2,MSN,ML1,WID
        E=EE
        M1=TMP(1)
        M2=TMP(2)
        ML1=TMP(3)
        MSN=TMP(4)
        WID=MSN**2*(E*E-ML1*ML1)**1.5/
     $      (MSN**2+ML1**2-2*MSN*E-M1**2)**2
        SSSNWS=WID
        RETURN
        END
+EOD
+DECK,SSSTBF
        SUBROUTINE SSSTBF
C-----------------------------------------------------------------------
C
C        This program gives stop squark branching fractions to gauginos
C        according to Baer and Tata.
C        If no other modes are allowed, stop -> c z_i through loops is
C        used as the default.
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
C
      COMPLEX ZI,ZONE,ZA,ZB,ZPP,ZPM,ZAUIZ,ZBUIZ
      DOUBLE PRECISION SSALFS
      REAL SSXLAM
      REAL WID,AWD(2),BW(2),FB,FT,XM,YM,THX,THY,AU1,MZ1,WIDC1
      REAL PI,SR2,G,GP,TANB,COTB,MPL,MMI,AH
      REAL AUIZ,MZIZ,SINT,COST,AS,BS,SNZI,THIZ
      INTEGER IZ,ISTOP,IDSTOP
      REAL AMSTOP,BWP(2),A
      REAL MW1,MW2,SNW1,SNW2,CS2THW,BETA,TN2THW,SINB,COSB
      INTEGER ISZIZ(4)
      DATA ZONE/(1.,0.)/,ZI/(0.,1.)/
C
C          Partly duplicated from SSMASS
C
      CS2THW=1.-SN2THW
      TN2THW=SN2THW/CS2THW
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      TANB=1./RV2V1
      COTB=RV2V1
      BETA=ATAN(TANB)
C          Reconstruct masses from SSMASS
      FB=G*MBQ/SR2/AMW/COS(BETA)
      FT=G*MTQ/SR2/AMW/SIN(BETA)
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
      SNW1=SIGN(1.,AMW1SS)
      SNW2=SIGN(1.,AMW2SS)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
C
      AWD(1)=-G*SNW1*SIN(GAMMAR)
      AWD(2)=-G*SNW2*THY*COS(GAMMAR)
      BW(1)=-FT*SNW1*COS(GAMMAR)
      BW(2)=FT*SNW2*THY*SIN(GAMMAR)
      BWP(1)=-FB*COS(GAMMAL)
      BWP(2)=FB*THX*SIN(GAMMAL)
      MMI=AMW1SS
      MPL=AMW2SS
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
C
C          Compute stop_i branching fractions to charm + zi if no other
C          modes are allowed. WIDC1 is taken from Hikasa-Kobayashi
C          and subsequent decays to charm are scaled in terms of this.
C
      ISZIZ(1)=ISZ1
      ISZIZ(2)=ISZ2
      ISZIZ(3)=ISZ3
      ISZIZ(4)=ISZ4
      AU1=-G/SR2*ZMIXSS(3,1)-GP/3./SR2*ZMIXSS(4,1)
      MZ1=ABS(AMZISS(1))
      DO 100 ISTOP=1,2
        IF(ISTOP.EQ.1) THEN
          AMSTOP=AMT1SS
          IDSTOP=ISTP1
        ELSE
          AMSTOP=AMT2SS
          IDSTOP=ISTP2
        ENDIF
        IF(AMSTOP.LT.(MW1+AMBT).AND.AMSTOP.GT.(AMCH+MZ1)) THEN
          WIDC1=3.E-10*AMT1SS*(1.-MZ1**2/AMT1SS**2)**2
          DO 110 IZ=1,4
            MZIZ=ABS(AMZISS(IZ))
            AUIZ=-G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ)
            IF (AMT1SS.GT.(AMCH+MZIZ)) THEN
              WID=AUIZ**2*(AMSTOP**2-MZIZ**2)/AU1**2
     $        /(AMSTOP**2-MZ1**2)*WIDC1
              CALL SSSAVE(IDSTOP,WID,ISZIZ(IZ),IDCH,0,0,0)
            END IF
110       CONTINUE
        ELSEIF(AMSTOP.LT.(MW1+AMBT).AND.AMSTOP.LE.(AMCH+MZ1)) THEN
          WRITE(LOUT,1000) ISTOP
1000      FORMAT(' ERROR IN SSSTBF: NO ALLOWED MODE FOR STOP',I2)
        END IF
100   CONTINUE
C
C          stop_i -> gluino + top
C
      IF (AMT1SS.GT.(AMGLSS+AMTP)) THEN
        WID=2*SSALFS(DBLE(AMT1SS**2))*AMT1SS*((1.-AMGLSS**2/AMT1SS**2-
     $  AMTP**2/AMT1SS**2)-SGNM3*2*SIN(2*THETAT)*AMTP*AMGLSS/AMT1SS**2)
     $  *SQRT(SSXLAM(1.,AMGLSS**2/AMT1SS**2,AMTP**2/AMT1SS**2))/3.
        CALL SSSAVE(ISTP1,WID,ISGL,IDTP,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMGLSS+AMTP)) THEN
        WID=2*SSALFS(DBLE(AMT2SS**2))*AMT2SS*((1.-AMGLSS**2/AMT2SS**2-
     $  AMTP**2/AMT2SS**2)+SGNM3*2*SIN(2*THETAT)*AMTP*AMGLSS/AMT2SS**2)
     $  *SQRT(SSXLAM(1.,AMGLSS**2/AMT2SS**2,AMTP**2/AMT2SS**2))/3.
        CALL SSSAVE(ISTP2,WID,ISGL,IDTP,0,0,0)
      END IF
C
C          stop_1 -> top + zino_i
C
      DO 200 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        SNZI=SIGN(1.,AMZISS(IZ))
        IF (SNZI.EQ.1.) THEN
           THIZ=0.
        ELSE
           THIZ=1.
        END IF
        ZAUIZ=ZI**(THIZ-1.)*SNZI
     $  *(-G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBUIZ=ZI**(THIZ-1.)*4*GP*ZMIXSS(4,IZ)/3./SR2
        ZPP=ZI**THIZ
        ZPM=(-ZI)**THIZ
        ZA=((ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*COST
     $  -(ZI*ZBUIZ-ZPM*FT*ZMIXSS(1,IZ))*SINT)/2.
        ZB=((-ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*COST
     $  -(ZI*ZBUIZ+ZPM*FT*ZMIXSS(1,IZ))*SINT)/2.
        AS=ZA*CONJG(ZA)
        BS=ZB*CONJG(ZB)
        IF (AMT1SS.GT.(AMTP+MZIZ)) THEN
          WID=(AS*(AMT1SS**2-(AMTP+MZIZ)**2)+BS
     $    *(AMT1SS**2-(AMTP-MZIZ)**2))/8./PI/AMT1SS
     $    *SQRT(SSXLAM(1.,AMTP**2/AMT1SS**2,MZIZ**2/AMT1SS**2))
          CALL SSSAVE(ISTP1,WID,ISZIZ(IZ),IDTP,0,0,0)
        END IF
200   CONTINUE
C
C          Wino decays
C
      IF (AMT1SS.GT.(AMBT+MW1)) THEN
        A=AWD(1)*COST-BW(1)*SINT
        AS=A*A
        WID=AMT1SS*((AS+BWP(1)**2*COST**2)*(1.-MW1**2/AMT1SS**2-
     $   AMBT**2/AMT1SS**2)-4*MW1*AMBT*BWP(1)*COST*A/AMT1SS**2)
     $   *SQRT(SSXLAM(1.,MW1**2/AMT1SS**2,AMBT**2/AMT1SS**2))/16./PI
        CALL SSSAVE(ISTP1,WID,ISW1,IDBT,0,0,0)
      END IF
      IF (AMT1SS.GT.(AMBT+MW2)) THEN
        A=AWD(2)*COST-BW(2)*SINT
        AS=A*A
        WID=AMT1SS*((AS+BWP(2)**2*COST**2)*(1.-MW2**2/AMT1SS**2-
     $   AMBT**2/AMT1SS**2)-4*MW2*AMBT*BWP(2)*COST*A/AMT1SS**2)
     $   *SQRT(SSXLAM(1.,MW2**2/AMT1SS**2,AMBT**2/AMT1SS**2))/16./PI
        CALL SSSAVE(ISTP1,WID,ISW2,IDBT,0,0,0)
      END IF
C 
      IF (AMT2SS.GT.(AMBT+MW1)) THEN
        A=AWD(1)*SINT+BW(1)*COST
        AS=A*A
        WID=AMT2SS*((AS+BWP(1)**2*SINT**2)*(1.-MW1**2/AMT2SS**2-
     $   AMBT**2/AMT2SS**2)-4*MW1*AMBT*BWP(1)*SINT*A/AMT2SS**2)
     $   *SQRT(SSXLAM(1.,MW1**2/AMT2SS**2,AMBT**2/AMT2SS**2))/16./PI
        CALL SSSAVE(ISTP2,WID,ISW1,IDBT,0,0,0)
      END IF
      IF (AMT2SS.GT.(AMBT+MW2)) THEN
        A=AWD(2)*SINT+BW(2)*COST
        AS=A*A
        WID=AMT2SS*((AS+BWP(2)**2*SINT**2)*(1.-MW2**2/AMT2SS**2-
     $   AMBT**2/AMT2SS**2)-4*MW2*AMBT*BWP(2)*SINT*A/AMT2SS**2)
     $  *SQRT(SSXLAM(1.,MW2**2/AMT2SS**2,AMBT**2/AMT2SS**2))/16./PI
        CALL SSSAVE(ISTP2,WID,ISW2,IDBT,0,0,0)
      END IF
C
C          stop_2 -> stop_1 + X modes
C
      IF (AMT2SS.GT.(AMT1SS+AMZ)) THEN
        WID=G**2*COST**2*SINT**2
     $  *(SQRT(SSXLAM(AMT2SS**2,AMZ**2,AMT1SS**2)))**3
     $  /64./PI/CS2THW/AMT2SS**3/AMZ**2
        CALL SSSAVE(ISTP2,WID,IDZ,ISTP1,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMT1SS+AMHL)) THEN
        AH=G*AMW*SIN(BETA-ALFAH)*(1.-5.*TN2THW/3.)*SINT*COST/2.
     $  +G*AMTP*COS(2.*THETAT)*(TWOM1*SIN(ALFAH)+AAT*COS(ALFAH))/2.
     $  /AMW/SIN(BETA)
        WID=AH**2/16./PI/AMT2SS**3
     $  *SQRT(SSXLAM(AMT2SS**2,AMHL**2,AMT1SS**2))
        CALL SSSAVE(ISTP2,WID,ISHL,ISTP1,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMT1SS+AMHH)) THEN
        AH=-G*AMW*COS(BETA-ALFAH)*(1.-5.*TN2THW/3.)*SINT*COST/2.
     $  +G*AMTP*COS(2.*THETAT)*(TWOM1*COS(ALFAH)-AAT*SIN(ALFAH))/2.
     $  /AMW/SIN(BETA)
        WID=AH**2/16./PI/AMT2SS**3
     $  *SQRT(SSXLAM(AMT2SS**2,AMHH**2,AMT1SS**2))
        CALL SSSAVE(ISTP2,WID,ISHH,ISTP1,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMT1SS+AMHA)) THEN
        AH=G*AMTP*(TWOM1-AAT/TANB)/2./AMW
        WID=AH**2/16./PI/AMT2SS**3
     $  *SQRT(SSXLAM(AMT2SS**2,AMHA**2,AMT1SS**2))
        CALL SSSAVE(ISTP2,WID,ISHA,ISTP1,0,0,0)
      END IF
C
C          t_i --> b_i + W decays
C
      IF (AMT1SS.GT.(AMB1SS+AMW)) THEN
        WID=G**2*COST**2*COSB**2*(SSXLAM(AMT1SS**2,AMB1SS**2,
     $AMW**2))**1.5/32./PI/AMT1SS**3/AMW**2
        CALL SSSAVE(ISTP1,WID,IDW,ISBT1,0,0,0)
      END IF
C
      IF (AMT1SS.GT.(AMB2SS+AMW)) THEN
        WID=G**2*COST**2*SINB**2*(SSXLAM(AMT1SS**2,AMB2SS**2,
     $AMW**2))**1.5/32./PI/AMT1SS**3/AMW**2
        CALL SSSAVE(ISTP1,WID,IDW,ISBT2,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMB1SS+AMW)) THEN
        WID=G**2*SINT**2*COSB**2*(SSXLAM(AMT2SS**2,AMB1SS**2,
     $AMW**2))**1.5/32./PI/AMT2SS**3/AMW**2
        CALL SSSAVE(ISTP2,WID,IDW,ISBT1,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMB2SS+AMW)) THEN
        WID=G**2*SINT**2*SINB**2*(SSXLAM(AMT2SS**2,AMB2SS**2,
     $AMW**2))**1.5/32./PI/AMT2SS**3/AMW**2
        CALL SSSAVE(ISTP2,WID,IDW,ISBT2,0,0,0)
      END IF
C
C          t_i --> b_i + H+ decays
C
      IF (AMT1SS.GT.(AMB1SS+AMHC)) THEN
        A=G/SR2/AMW*(AMTP*AMBT*(COTB+TANB)*SINT*SINB+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $COST*COSB-AMTP*(TWOM1-AAT*COTB)*SINT*COSB-AMBT*
     $(TWOM1-AAB*TANB)*SINB*COST)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMT1SS**2,AMB1SS**2,AMHC**2))/
     $      16./PI/AMT1SS**3
        CALL SSSAVE(ISTP1,WID,ISHC,ISBT1,0,0,0)
      END IF
C
      IF (AMT1SS.GT.(AMB2SS+AMHC)) THEN
        A=G/SR2/AMW*(-AMTP*AMBT*(COTB+TANB)*SINT*COSB+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $COST*SINB-AMTP*(TWOM1-AAT*COTB)*SINT*SINB+AMBT*
     $(TWOM1-AAB*TANB)*COST*COSB)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMT1SS**2,AMB2SS**2,AMHC**2))/
     $      16./PI/AMT1SS**3
        CALL SSSAVE(ISTP1,WID,ISHC,ISBT2,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMB1SS+AMHC)) THEN
        A=G/SR2/AMW*(-AMTP*AMBT*(COTB+TANB)*COST*SINT+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $SINT*COSB+AMTP*(TWOM1-AAT*COTB)*COST*COSB-AMBT*
     $(TWOM1-AAB*TANB)*SINT*SINB)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMT2SS**2,AMB1SS**2,AMHC**2))/
     $      16./PI/AMT2SS**3
        CALL SSSAVE(ISTP2,WID,ISHC,ISBT1,0,0,0)
      END IF
C
      IF (AMT2SS.GT.(AMB2SS+AMHC)) THEN
        A=G/SR2/AMW*(AMTP*AMBT*(COTB+TANB)*COST*COSB+
     $(AMBT**2*TANB+AMTP**2*COTB-AMW**2*SIN(2*BETA))*
     $SINT*SINB+AMTP*(TWOM1-AAT*COTB)*SINB*COST+AMBT*
     $(TWOM1-AAB*TANB)*COSB*SINT)
        AS=A*A
        WID=AS*SQRT(SSXLAM(AMT2SS**2,AMB2SS**2,AMHC**2))/
     $      16./PI/AMT2SS**3
        CALL SSSAVE(ISTP2,WID,ISHC,ISBT2,0,0,0)
      END IF
C
C
C          stop_2 -> top + zino_i
C
      DO 500 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        SNZI=SIGN(1.,AMZISS(IZ))
        IF (SNZI.EQ.1.) THEN
           THIZ=0.
        ELSE
           THIZ=1.
        END IF
        ZAUIZ=ZI**(THIZ-1.)*SNZI
     $  *(-G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBUIZ=ZI**(THIZ-1.)*4*GP*ZMIXSS(4,IZ)/3./SR2
        ZPP=ZI**THIZ
        ZPM=(-ZI)**THIZ
        ZA=((ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*SINT
     $  +(ZI*ZBUIZ-ZPM*FT*ZMIXSS(1,IZ))*COST)/2.
        ZB=((-ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*SINT
     $  +(ZI*ZBUIZ+ZPM*FT*ZMIXSS(1,IZ))*COST)/2.
        AS=ZA*CONJG(ZA)
        BS=ZB*CONJG(ZB)
        IF (AMT2SS.GT.(AMTP+MZIZ)) THEN
          WID=(AS*(AMT2SS**2-(AMTP+MZIZ)**2)+BS
     $    *(AMT2SS**2-(AMTP-MZIZ)**2))/8./PI/AMT2SS
     $    *SQRT(SSXLAM(1.,AMTP**2/AMT2SS**2,MZIZ**2/AMT2SS**2))
          CALL SSSAVE(ISTP2,WID,ISZIZ(IZ),IDTP,0,0,0)
        END IF
500   CONTINUE
C 
C          Normalize branching ratios 
C
       CALL SSNORM(ISTP1)
       CALL SSNORM(ISTP2)
C
       RETURN
       END
+EOD
+DECK,SSSVME
      SUBROUTINE SSSVME(ME)
C
C          Set MSSMOD flag for last mode in /SSMODE/
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSMODE
C
      INTEGER ME
      MSSMOD(NSSMOD)=ME
      RETURN
      END
+EOD
+DECK,SSTEST
      SUBROUTINE SSTEST(IALLOW)
C
C          Test MSSM parameters against existing bounds on SUSY from
C          LEP and SLC:
C          IALLOW = 1    Z1 is not LSP
C          IALLOW = 2    Gamma(Z -> Z1SS Z1SS) < GAMINV
C          IALLOW = 4    Z -> charginos allowed
C          IALLOW = 8    BF(Z -> Z1SS Z2SS)>10^5
C          IALLOW = 16   Z -> squarks, sleptons
C          IALLOW = 32   BR(Z -> Z* HL0) < B(Z -> Z* H(M=MHSM))
C          IALLOW = 64   BR(Z -> HL0 HA0) > 0
C          IALLOW = 128  M(H+) > M(Z)/2
C          where GAMINV is the present bound on the invisible width,
C          and MHSM is the lower bound on the standard Higgs mass.
C
C          Bounds on the other modes are only approximate, but the
C          error in the allowed region of masses must be tiny. 
C          Updated by H. Baer on 5/25/95
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
+CDE,SSTYPE
+CDE,SUGMG
+CDE,XMSSM
C
      INTEGER IALLOW
      EXTERNAL SSZHX
      REAL MHSM,GAMINV,PI,SR2,G,GP,MZ,MZ1,MZ2,MZ3,MZ4,MW1,MW2,
     $TANB,BETA,COS2B,SIN2B,VS,V,VP,FT,MHL,ALPHA,SUSYCC,
     $GAMSS,W11,GZ1Z1,GAMSM,SSXINT,SSXLAM,COS2W,
     $W12,GZ1Z2,DGAMZ,BFZ,BFZ1Z2
C
C          Current bounds
      DATA MHSM/64./,GAMINV/.0043/,DGAMZ/.0115/,BFZ/1.E-5/
C
C          Initialize
C
      IALLOW=0
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      COS2W=SQRT(1.-SN2THW)
      MZ=AMZ
      MZ1=ABS(AMZ1SS)
      MZ2=ABS(AMZ2SS)
      MZ3=ABS(AMZ3SS)
      MZ4=ABS(AMZ4SS)
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
C
C          Check that Z1SS is LSP
C
      IF(MZ1.GT.MW1.OR.MZ1.GT.AMGLSS.OR.MZ1.GT.AMULSS
     $.OR.MZ1.GT.AMERSS.OR.MZ1.GT.AMELSS.OR.MZ1.GT.AMN1SS
     $.OR.MZ1.GT.AMB1SS.OR.MZ1.GT.AMT1SS.OR.MZ1.GT.AML1SS) THEN
        IALLOW=IALLOW+1
      ENDIF
C
C          Z -> Z1SS + Z1SS
C
      IF (AMZ.GT.2*MZ1) THEN
        W11=SQRT(G*G+GP*GP)
     $  *(ZMIXSS(1,1)*ZMIXSS(1,1)-ZMIXSS(2,1)*ZMIXSS(2,1))/4.
        GZ1Z1=SQRT(SSXLAM(MZ**2,MZ1**2,MZ1**2))/12./PI/MZ**3*W11**2
     $  *(2*MZ**2-MZ1**2-MZ1**2-(MZ1**2-MZ1**2)**2/MZ**2
     $  -6*MZ1*MZ1*SIGN(1.,AMZ1SS*AMZ1SS))
        IF(GZ1Z1.GT.GAMINV) THEN
          IALLOW=IALLOW+2
        ENDIF
      ENDIF
C
C          Check for other allowed visible modes modes
C
      IF(AMZ.GT.2*MW1) THEN
        IALLOW=IALLOW+4
      ENDIF
C
C          Check funny Z branching fractions
C
      BFZ1Z2=0.
      IF (AMZ.GT.MZ1+MZ2) THEN
        W12=SQRT(G*G+GP*GP)
     $  *(ZMIXSS(1,1)*ZMIXSS(1,2)-ZMIXSS(2,1)*ZMIXSS(2,2))/4.
        GZ1Z2=SQRT(SSXLAM(MZ**2,MZ1**2,MZ2**2))/6./PI/MZ**3*W12**2
     $  *(2*MZ**2-MZ1**2-MZ2**2-(MZ1**2-MZ2**2)**2/MZ**2
     $  -6*MZ1*MZ2*SIGN(1.,AMZ1SS*AMZ2SS))
        BFZ1Z2=GZ1Z2/GAMZ
      END IF
      IF(BFZ1Z2.GT.BFZ) THEN
        IALLOW=IALLOW+8
      ENDIF
C
      IF(AMZ.GT.2*AMULSS.OR.AMZ.GT.2*AMELSS.OR.AMZ.GT.2*AMERSS
     $.OR.AMZ.GT.2*AMN1SS.OR.AMZ.GT.2*AMB1SS.OR.AMZ.GT.2*AMT1SS)THEN
        IALLOW=IALLOW+16
      ENDIF
C
C          Z -> Higgs modes
C
      TMP(1)=MHSM
      GAMSM=SSXINT(2*MHSM/MZ,SSZHX,(1.+MHSM**2/MZ**2))  
C          Z -> hl0 x
      IF(AMZ.GT.AMHL) THEN
        TANB=1./RV2V1
        BETA=ATAN(TANB)
        COS2B=COS(2*BETA)
        SIN2B=SIN(2*BETA)
        VS=2*AMW**2/G**2/(1.+RV2V1**2)
        V=SQRT(VS)
        VP=RV2V1*V
        FT=G*AMTP/SR2/AMW/V*SQRT(V**2+VP**2)
        MHL=AMHL
        ALPHA=ALFAH
        SUSYCC=SIN(ALPHA+BETA)
        TMP(1)=MHL
        GAMSS=SSXINT(2*MHL/AMZ,SSZHX,(1.+MHL**2/AMZ**2))*SUSYCC**2
        IF(GAMSS.GE.GAMSM) IALLOW=IALLOW+32
      ENDIF
C          Z -> hl0 ha0
      IF (AMZ.GT.(AMHL+AMHA)) THEN
        IALLOW=IALLOW+64
      ENDIF
C          Z -> H+ H-
      IF(AMZ.GT.2*AMHC) THEN
        IALLOW=IALLOW+128
      ENDIF
C
      RETURN
      END
+EOD
+DECK,SSTPBF
        SUBROUTINE SSTPBF
C-----------------------------------------------------------------------
C
C     Calculate the top branching ratios.
C     Source: H. Baer (modified by F. Paige)
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
C
      COMPLEX ZI,ZONE,ZA,ZB,ZPP,ZPM,ZAUIZ,ZBUIZ
      REAL SSXLAM,G,AL2,BE2,TANB,COTB,GTBW,GTBH,BWLL,GF,BWQQ,PI,SR2
      REAL WID,AS,BS,MZIZ,CS2THW,GP,FT,FB,SNZI,THIZ
      REAL SINT,COST,SINB,COSB,AWI,BWI,AMW1,AMW2,SNWI
      REAL THX,THY,XM,YM,BETA
      INTEGER IZ,ISZIZ(4)
      DATA ZONE/(1.,0.)/,ZI/(0.,1.)/
C
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      TANB=1./RV2V1
      COTB=1./TANB
      BETA=ATAN(TANB)
      CS2THW=1.-SN2THW
      FB=G*MBQ/SR2/AMW/COS(BETA)
      FT=G*MTQ/SR2/AMW/SIN(BETA)
      SINT=SIN(THETAT)
      COST=COS(THETAT)
      SINB=SIN(THETAB)
      COSB=COS(THETAB)
      ISZIZ(1)=ISZ1
      ISZIZ(2)=ISZ2
      ISZIZ(3)=ISZ3
      ISZIZ(4)=ISZ4
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
C
C          W decays
C
      GF=1.16E-5
      GTBW=GF*AMTP**3*SSXLAM(1.,AMW**2/AMTP**2,AMBT**2/AMTP**2)*
     $((1.-AMBT**2/AMTP**2)**2+AMW**2/AMTP**2*(1.+AMBT**2/AMTP**2)
     $-2*AMW**4/AMTP**4)/(8.*PI*SR2)
      BWQQ=3./9.
      BWLL=1./9.
      CALL SSSAVE(IDTP,BWQQ*GTBW,IDUP,-IDDN,IDBT,0,0)
      CALL SSSAVE(IDTP,BWQQ*GTBW,IDCH,-IDST,IDBT,0,0)
      CALL SSSAVE(IDTP,BWLL*GTBW,-IDE,IDNE,IDBT,0,0)
      CALL SSSAVE(IDTP,BWLL*GTBW,-IDMU,IDNM,IDBT,0,0)
      CALL SSSAVE(IDTP,BWLL*GTBW,-IDTAU,IDNT,IDBT,0,0)
C
C          H+ decays
C
      AL2=(G/2/SR2/AMW*(AMBT*TANB+AMTP*COTB))**2
      BE2=(G/2/SR2/AMW*(AMBT*TANB-AMTP*COTB))**2
      IF (AMTP.GT.(AMBT+AMHC)) THEN
        GTBH=AMTP/16./PI*((AL2+BE2)
     $  *(1.+AMBT**2/AMTP**2-AMHC**2/AMTP**2) 
     $  +2*(AL2-BE2)*AMBT/AMTP)
     $  *SQRT(SSXLAM(1.,AMHC**2/AMTP**2,AMBT**2/AMTP**2))
        CALL SSSAVE(IDTP,GTBH,ISHC,IDBT,0,0,0) 
      END IF
C
C          t->t_1 + z_i decays
      DO 100 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        SNZI=SIGN(1.,AMZISS(IZ))
        IF (SNZI.EQ.1.) THEN
           THIZ=0.
        ELSE
           THIZ=1.
        END IF
        ZAUIZ=ZI**(THIZ-1.)*SNZI*
     $(-G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBUIZ=ZI**(THIZ-1.)*4*GP*ZMIXSS(4,IZ)/3./SR2
        ZPP=ZI**THIZ
        ZPM=(-ZI)**THIZ
        ZA=((ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*COST-
     $(ZI*ZBUIZ-ZPM*FT*ZMIXSS(1,IZ))*SINT)/2.
        ZB=((-ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*COST-
     $(ZI*ZBUIZ+ZPM*FT*ZMIXSS(1,IZ))*SINT)/2.
        AS=ZA*CONJG(ZA)
        BS=ZB*CONJG(ZB)
        IF (AMTP.GT.(AMT1SS+MZIZ)) THEN
          WID=(AS*((AMTP+MZIZ)**2-AMT1SS**2)+BS*
     $((AMTP-MZIZ)**2-AMT1SS**2))/16./PI/AMTP*
     $SQRT(SSXLAM(1.,AMT1SS**2/AMTP**2,MZIZ**2/AMTP**2))
          CALL SSSAVE(IDTP,WID,ISZIZ(IZ),ISTP1,0,0,0)
        END IF
100   CONTINUE
C
C       t -> sb_1 + sW_i
C
        AMW1=ABS(AMW1SS)
        AMW2=ABS(AMW2SS)
        IF (AMTP.GT.(AMB1SS+AMW1)) THEN
          SNWI=SIGN(1.,AMW1SS)
          AWI=-G*SIN(GAMMAL)*COSB+FB*COS(GAMMAL)*SINB
          BWI=-FT*(-SNWI)*COS(GAMMAR)
          WID=AMTP*((AWI**2+BWI**2*COSB**2)*(1.+AMW1**2/AMTP**2
     $-AMB1SS**2/AMTP**2)+4*AMW1/AMTP*AWI*BWI*COST)/32./PI*
     $SQRT(SSXLAM(1.,AMW1**2/AMTP**2,AMB1SS**2/AMTP**2))
          CALL SSSAVE(IDTP,WID,ISW1,ISBT1,0,0,0)
        END IF
c
        IF (AMTP.GT.(AMB1SS+AMW2)) THEN
          SNWI=SIGN(1.,AMW2SS)
          AWI=-G*THX*COS(GAMMAL)*COSB-FB*THX*SIN(GAMMAL)*SINB
          BWI=FT*(-SNWI)*THY*SIN(GAMMAR)
          WID=AMTP*((AWI**2+BWI**2*COSB**2)*(1.+AMW2**2/AMTP**2
     $-AMB1SS**2/AMTP**2)+4*AMW2/AMTP*AWI*BWI*COST)/32./PI*
     $SQRT(SSXLAM(1.,AMW2**2/AMTP**2,AMB1SS**2/AMTP**2))
          CALL SSSAVE(IDTP,WID,ISW2,ISBT1,0,0,0)
        END IF
C
C       t -> sb_2 + sW_i
C
        IF (AMTP.GT.(AMB2SS+AMW1)) THEN
          SNWI=SIGN(1.,AMW1SS)
          AWI=-G*SIN(GAMMAL)*SINB-FB*COS(GAMMAL)*COSB
          BWI=-FT*(-SNWI)*COS(GAMMAR)
          WID=AMTP*((AWI**2+BWI**2*SINB**2)*(1.+AMW1**2/AMTP**2
     $-AMB2SS**2/AMTP**2)+4*AMW1/AMTP*AWI*BWI*COST)/32./PI*
     $SQRT(SSXLAM(1.,AMW1**2/AMTP**2,AMB2SS**2/AMTP**2))
          CALL SSSAVE(IDTP,WID,ISW1,ISBT2,0,0,0)
        END IF
c
        IF (AMTP.GT.(AMB2SS+AMW2)) THEN
          SNWI=SIGN(1.,AMW2SS)
          AWI=-G*THX*COS(GAMMAL)*SINB+FB*THX*SIN(GAMMAL)*COSB
          BWI=FT*(-SNWI)*THY*SIN(GAMMAR)
          WID=AMTP*((AWI**2+BWI**2*SINB**2)*(1.+AMW2**2/AMTP**2
     $-AMB2SS**2/AMTP**2)+4*AMW2/AMTP*AWI*BWI*COST)/32./PI*
     $SQRT(SSXLAM(1.,AMW2**2/AMTP**2,AMB2SS**2/AMTP**2))
          CALL SSSAVE(IDTP,WID,ISW2,ISBT2,0,0,0)
        END IF
C
C
C          Normalize branching ratios
C
      CALL SSNORM(IDTP)
C
      RETURN
      END
+EOD
+DECK,SSWIBF
        SUBROUTINE SSWIBF
C-----------------------------------------------------------------------
C       This subroutine calculates the chargino (wi) subset of
C       SSWZBF, which was too long.
C       Valid for all scalar masses (functions in double precision)
C       Includes Higgs sector radiative corrections (Aug. 31)
C
C       Auxiliary functions are called SSWxyi, SSZxyi, where normally
C       x indicates the SUSY particle, y the SM particle(s), and i is
C       a counter.
C
C       Require a mass gap PSGAP = 1.0 GeV for 3-body decays.
C
C       Part of Baer's GAUGBF
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SSTMP
+CDE,SSPOLS
C
      EXTERNAL SSZWF1,SSZZF1,SSZZF2,SSZZF3,SSWZF1,SSWZF2,SSWZF3
     $,SSWZF4,SSWZF5,SSWZF6,SSWZF7,SSWWF1,SSZZF4,SSZZF5,SSGX1
     $,SSGX2,SSGX8,SSWZ2P,SSWZ3P
C
      REAL AUI(4),BUI(4),ADI(4),BDI(4),ALI(4),BLI(4),ANI(4),BNI(4)
     $,WIJ(4,4),AUWI(4),ADWI(4),ANWI(4),ALWI(4),XIM(4),YIM(4)
     $,XIP(4),YIP(4),SNIJ(4,4),XLIJ(4,4),HIJ(4,4)
     $,V1I(4),V2I(4),V3I(4),V4I(4),XHIJ(4,4),XPIJ(4,4),AMWISS(2)
C
      INTEGER ISZ(4),THJZ
C
      REAL MWIW,SL,PP,SP,PL,PH,SH,COSB,SINB,COSA,SINA
     $,FACTOR,MZJZ,ULIM,XINTGL,COSBE,SINBE
     $,UPPER,CONST
      REAL W21ZU,W21ZN,W21ZL,W21ZD,W21U,W21D,W21S,W21C,W21N1
     $,W21N2,W21N3,W21E,W21M,W21L,STHW,CTHW
      REAL T3,XI2,CC,PSIINT,T2,T1,PHIINT,XI1,EF,A,Z,B
     $,TANB,FB,FT,SR2,G,PI,GP,FL
     $,MW2,SNW1,MW1,YM,BE,SNW2,XM,THX,THY
     $,BTN,APD,APL,APU,BTD,BTL,APN,BTU,Y,MZ1,FPI
      REAL TANW,COTW,XWINO,YWINO,SNIW,SNJZ
      REAL SSXINT,SSXLAM,OL,OR,DEL
      REAL WID,TERM1,TERM2,TERM3,TERM4,E,TERMH
      REAL FACT,ALJZ1,ALJZ2,BEJZ1,BEJZ2
      REAL ALIW1,ALIW2,AHCJZ,BHCJZ,TERMW,TERMN,TERM12,TERMN1,
     $TERMN2,TERMWN,TERMW1,TERMW2,TERMH1,TERMH2,TERMHN
      REAL XIPM,YIPM,COSL,SINL,BPWI(2),BPLWI(2)
      REAL BWI(2),AW,COST,SINT
      REAL POLNL,POLNR,POL1L,POL1R,POL2L,POL2R,POL12L,POL12R,
     $POLN1L,POLN1R,POLN2L,POLN2R
      REAL SUALFE,MTAMTA,MTAMB,MTAMZ,AMPL,AMPI
      REAL FUDGE,PSGAP
      COMPLEX ZI,ZONE,Z1(2),Z2(2)
      INTEGER IW,JZ,IZ,ISZJZ,ISWIW
      DATA FUDGE/1.0/,AMPI/.140/
      DATA ZONE/(1.,0.)/,ZI/(0.,1.)/,FPI/.1315/
      DATA PSGAP/1.0/
C
C          Constants from neutralino mass matrix
C
      AMPL=2.4E18
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      E=SQRT(4*PI/128.)
C
      TANW=SQRT(SN2THW/(1.-SN2THW))
      COTW=1./TANW
      STHW=SQRT(SN2THW)
      CTHW=SQRT(1.-SN2THW)
      APL=.25*(3*TANW-COTW)
      BTL=.25*(COTW+TANW)
      APN=.25*(TANW+COTW)
      BTN=-.25*(COTW+TANW)
      APU=-5*TANW/12.+COTW/4.
      BTU=-.25*(COTW+TANW)
      APD=-COTW/4.+TANW/12.
      BTD=.25*(COTW+TANW)
C
      TANB=1./RV2V1
      BE=ATAN(1./RV2V1)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      FB=G*MBQ/SR2/AMW/COS(BE)
      FT=G*MTQ/SR2/AMW/SIN(BE)
C      MTAMTA=AMTAU*(1.-SUALFE(AMTAU**2)/PI)
C      MTAMB=MTAMTA*(SUALFE(AMBT**2)/SUALFE(AMTAU**2))**(-27./76.)
C      MTAMZ=MTAMB*(SUALFE(AMZ**2)/SUALFE(AMBT**2))**(-27./80.)
      mtamz=MLQ
      FL=G*MTAMZ/SR2/AMW/COS(BE)
      SNW1=SIGN(1.,AMW1SS)
      SNW2=SIGN(1.,AMW2SS)
      AMWISS(1)=AMW1SS
      AMWISS(2)=AMW2SS
      BWI(1)=-FT*SNW1*COS(GAMMAR)
      BWI(2)=FT*SNW2*THY*SIN(GAMMAR)
      BPWI(1)=-FB*COS(GAMMAL)
      BPWI(2)=FB*THX*SIN(GAMMAL)
      BPLWI(1)=-FL*COS(GAMMAL)
      BPLWI(2)=FL*THX*SIN(GAMMAL)
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
      MZ1=ABS(AMZ1SS)
      XWINO=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)
     $-THY*SIN(GAMMAR)*COS(GAMMAR))
      YWINO=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)
     $+THY*SIN(GAMMAR)*COS(GAMMAR))
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
C
C          Constants from Higgs mass matrix
C
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
C
C          Gaugino couplings
C
      DO 100 IZ=1,4
        AUI(IZ)=G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ)
        BUI(IZ)=4.*GP/3./SR2*ZMIXSS(4,IZ)
        ADI(IZ)=-G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ)
        BDI(IZ)=-2.*GP/3./SR2*ZMIXSS(4,IZ)
        ALI(IZ)=G/SR2*ZMIXSS(3,IZ)+GP/SR2*ZMIXSS(4,IZ)
        BLI(IZ)=-SR2*GP*ZMIXSS(4,IZ)
        ANI(IZ)=G/SR2*ZMIXSS(3,IZ)-GP/SR2*ZMIXSS(4,IZ)
        BNI(IZ)=0.0
100   CONTINUE
C
      DO 110 IZ=1,4
      DO 110 JZ=1,4
        IF(IZ.LT.JZ) THEN
          WIJ(IZ,JZ)=SQRT(G**2+GP**2)
     $    *(ZMIXSS(1,IZ)*ZMIXSS(1,JZ)-ZMIXSS(2,IZ)*ZMIXSS(2,JZ))/4.
        ELSEIF(IZ.GT.JZ) THEN
          WIJ(IZ,JZ)=-SQRT(G**2+GP**2)
     $    *(ZMIXSS(1,IZ)*ZMIXSS(1,JZ)-ZMIXSS(2,IZ)*ZMIXSS(2,JZ))/4.
        ENDIF
110   CONTINUE
C
      AUWI(2)=G*THX*COS(GAMMAL)
      ADWI(2)=SNW2*G*THY*COS(GAMMAR)
      ALWI(2)=ADWI(2)
      ANWI(2)=AUWI(2)
      AUWI(1)=G*SIN(GAMMAL)
      ADWI(1)=SNW1*G*SIN(GAMMAR)
      ALWI(1)=ADWI(1)
      ANWI(1)=AUWI(1)
C
      DO 120 IZ=1,4
        XIM(IZ)=.5*(SNW1*SIGN(1.,AMZISS(IZ))*(COS(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ))-COS(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ))
        YIM(IZ)=.5*(-SNW1*SIGN(1.,AMZISS(IZ))*(COS(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ))-COS(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ))
        XIP(IZ)=.5*(SNW2*SIGN(1.,AMZISS(IZ))*THY*(-SIN(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ))+THX*(SIN(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ)))
        YIP(IZ)=.5*(-SNW2*SIGN(1.,AMZISS(IZ))*THY*(-SIN(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ))+THX*(SIN(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ)))
120   CONTINUE
C
      DO 130 IZ=1,4
      DO 130 JZ=1,4
        IF(IZ.NE.JZ) THEN
          SNIJ(IZ,JZ)=-1.*SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
          XLIJ(IZ,JZ)=-SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*SINA-ZMIXSS(1,IZ)*COSA)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
          XHIJ(IZ,JZ)=-SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*COSA+ZMIXSS(1,IZ)*SINA)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
          XPIJ(IZ,JZ)=SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*SINBE-ZMIXSS(1,IZ)*COSBE)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
          HIJ(IZ,JZ)=-SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*COSA+ZMIXSS(1,IZ)*SINA)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
        ENDIF
130   CONTINUE
C
      SP=-.5*(-THY*SNW2*COSBE*SIN(GAMMAL)*SIN(GAMMAR)+
     $THY*SNW2*SINBE*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*COSBE*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*SINBE*SIN(GAMMAL)*SIN(GAMMAR))
      PP=-.5*(-THY*SNW2*COSBE*SIN(GAMMAL)*SIN(GAMMAR)+
     $THY*SNW2*SINBE*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*COSBE*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*SINBE*SIN(GAMMAL)*SIN(GAMMAR))
C
      SL=.5*(THY*SNW2*SINA*COS(GAMMAL)*COS(GAMMAR)-
     $THY*SNW2*COSA*SIN(GAMMAL)*SIN(GAMMAR)+
     $THX*SNW1*COSA*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*SINA*SIN(GAMMAL)*SIN(GAMMAR))
      PL=.5*(THY*SNW2*SINA*COS(GAMMAL)*COS(GAMMAR)-
     $THY*SNW2*COSA*SIN(GAMMAL)*SIN(GAMMAR)-
     $THX*SNW1*COSA*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*SINA*SIN(GAMMAL)*SIN(GAMMAR))
C
      SH=.5*(THY*SNW2*COSA*COS(GAMMAL)*COS(GAMMAR)+
     $THY*SNW2*SINA*SIN(GAMMAL)*SIN(GAMMAR)-
     $THX*SNW1*SINA*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*COSA*SIN(GAMMAL)*SIN(GAMMAR))
      PH=.5*(THY*SNW2*COSA*COS(GAMMAL)*COS(GAMMAR)+
     $THY*SNW2*SINA*SIN(GAMMAL)*SIN(GAMMAR)+
     $THX*SNW1*SINA*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*COSA*SIN(GAMMAL)*SIN(GAMMAR))
C
      DO 140 IZ=1,4
        V1I(IZ)=-SIN(GAMMAR)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  -G*COS(GAMMAR)*ZMIXSS(1,IZ)
        V2I(IZ)=COS(GAMMAR)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  -G*SIN(GAMMAR)*ZMIXSS(1,IZ)
        V3I(IZ)=-SIN(GAMMAL)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  +G*COS(GAMMAL)*ZMIXSS(2,IZ)
        V4I(IZ)=COS(GAMMAL)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  +G*SIN(GAMMAL)*ZMIXSS(2,IZ)
140   CONTINUE
C
C-----------------------------------------------------------------------
C          Generate Chargino Branching Fractions
C-----------------------------------------------------------------------
      ISZ(1)=ISZ1
      ISZ(2)=ISZ2
      ISZ(3)=ISZ3
      ISZ(4)=ISZ4
C     FIRST TRY EXCLUSIVE DECAY TO SINGLE PION
      IF (MW1.GT.(MZ1+AMPI).AND.MW1.LT.(MZ1+1.5)) THEN
        WID=G**4*FPI**2*SQRT(SSXLAM(MW1**2,MZ1**2,AMPI**2))/
     $      128./MW1**3/PI/AMW**4*((XIM(1)**2+YIM(1)**2)*
     $      (MW1-MZ1)**2*(MW1+MZ1)**2-AMPI**2*(XIM(1)**2*(MW1-MZ1)**2+
     $      YIM(1)**2*(MW1+MZ1)**2))
        CALL SSSAVE(ISW1,WID,ISZ(1),120,0,0,0)
      END IF
      IF (MW1.GT.(MZ1+2*AMPI).AND.MW1.LT.(MZ1+1.5)) THEN
        OL=XIM(1)+YIM(1)
        OR=XIM(1)-YIM(1)
        TMP(1)=MW1
        TMP(2)=MZ1
        TMP(3)=OL
        TMP(4)=OR
        DEL=MW1-MZ1
        WID=2*G**4/64./AMW**4/192./PI**3/MW1**3*
     $      SSXINT(4*AMPI**2,SSWZ2P,DEL**2)
        CALL SSSAVE(ISW1,WID,ISZ(1),120,110,0,0)
      END IF
      IF (MW1.GT.(MZ1+3*AMPI).AND.MW1.LT.(MZ1+1.5)) THEN
        OL=XIM(1)+YIM(1)
        OR=XIM(1)-YIM(1)
        TMP(1)=MW1
        TMP(2)=MZ1
        TMP(3)=OL
        TMP(4)=OR
        DEL=MW1-MZ1
        WID=2*G**4/64./AMW**4/6912./PI**5/MW1**3/FPI**2*
     $      SSXINT(9*AMPI**2,SSWZ3P,DEL**2)
        CALL SSSAVE(ISW1,WID,ISZ(1),120,110,110,0)
        CALL SSSAVE(ISW1,WID,ISZ(1),120,-120,120,0)
      END IF
      DO 300 IW=1,2
C          Loop over w1, w2
        IF(IW.EQ.1) THEN
            MWIW=MW1
            SNIW=SNW1
            ISWIW=ISW1
        ELSE
            MWIW=MW2
            SNIW=SNW2
            ISWIW=ISW2
        ENDIF
C
C          Decays to zj
C
        DO 310 JZ=1,4
          MZJZ=ABS(AMZISS(JZ))
          ISZJZ=ISZ(JZ)
          SNJZ=SIGN(1.,AMZISS(JZ))
          THJZ=0.
          IF (AMZISS(JZ).LT.0.) THJZ=1.
          IF(MWIW.LE.FUDGE*MZJZ) GOTO 310
C          Couplings
          IF(IW.EQ.1) THEN
            XIPM=XIM(JZ)
            YIPM=YIM(JZ)
          ELSE
            XIPM=XIP(JZ)
            YIPM=YIP(JZ)
          ENDIF
C
C          wi --> f + fbar + zj
C
          IF (MWIW.GT.(MZJZ+AMUP+AMDN+PSGAP)) THEN
            IF (IW.EQ.1.AND.JZ.EQ.1.AND.(MW1.LT.(MZ1+1.5))) THEN
C          Exit hadronic mode if exclusive pion decay active
              GO TO 200
            END IF
            IF (MWIW.LT.(AMW+MZJZ)) THEN
            TMP(1)=XIPM**2+YIPM**2
            TMP(2)=XIPM**2-YIPM**2
            TMP(3)=MWIW
            TMP(4)=MZJZ
            TERM1=SSXINT(MZJZ,SSWZF1,(MWIW**2+MZJZ**2)/2./MWIW)/
     $            2./MWIW/(2*PI)**5*2*G**4*PI**2/3.
            ELSE
            TERM1=0.
            END IF
            ULIM=MWIW/2.*(1.-MZJZ**2/MWIW**2)
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.AMULSS) THEN
            TMP(2)=AMULSS
            PSIINT=SSXINT(0.,SSWZF2,ULIM)
            T1=AUI(JZ)**2*ADWI(IW)**2*PSIINT
            ELSE
            T1=0.
            END IF
            IF (MWIW.LT.AMDLSS) THEN
            TMP(2)=AMDLSS
            PSIINT=SSXINT(0.,SSWZF2,ULIM)
            T2=ADI(JZ)**2*AUWI(IW)**2*PSIINT
            ELSE
            T2=0.
            END IF
            IF (MWIW.LT.AMDLSS.AND.MWIW.LT.AMULSS) THEN
            TMP(2)=0.
            TMP(4)=AMDLSS
            TMP(5)=AMULSS
            PHIINT=SSXINT(0.,SSGX2,ULIM)
            CC=2*SIGN(1.,AMZISS(JZ))*AUWI(IW)*ADWI(IW)*AUI(JZ)*ADI(JZ)
            T3=CC*PHIINT
            ELSE
            T3=0.
            END IF
            TERM2=(T1+T2+T3)/2./MWIW/(2*PI)**5
            FACTOR=1./2./MWIW/(2*PI)**5*2*SR2*G**2
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMULSS) THEN
            TMP(2)=AMULSS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM3=FACTOR*ADWI(IW)*AUI(JZ)*((XIPM-YIPM)*XI1
     $      -(XIPM+YIPM)*XI2)*SIGN(1.,AMZISS(JZ))
            ELSE
            TERM3=0.
            END IF
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMDLSS) THEN
            TMP(2)=AMDLSS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM4=-FACTOR*AUWI(IW)*ADI(JZ)*((XIPM+YIPM)*XI1
     $      -(XIPM-YIPM)*XI2)
            ELSE
            TERM4=0.
            END IF
            WID=3*(TERM1+TERM2+TERM3+TERM4)
            CALL SSSAVE(ISWIW,WID,ISZJZ,IDUP,-IDDN,0,0)
C         Enter information for decay matrix element
            Z1(1)=ZI**THJZ*G*XIPM
            Z1(2)=ZI**THJZ*G*YIPM
            Z2(1)=G/2./SR2
            Z2(2)=-G/2./SR2
            CALL SSME3(1,AMW,Z1,Z2)
            Z1(1)=ZI*AUWI(IW)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ADI(JZ))/2.
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMDLSS,Z1,Z2)
            Z1(1)=CONJG(ZI*ADWI(IW))/2.
            Z1(2)=-Z1(1)
            Z2(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*AUI(JZ)/2.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMULSS,Z1,Z2)
          END IF
C          wi --> c + sbar + zj
200       IF (MWIW.GT.(MZJZ+AMCH+AMST+PSGAP)) THEN
            IF (MWIW.LT.(AMW+MZJZ)) THEN
            TMP(1)=XIPM**2+YIPM**2
            TMP(2)=XIPM**2-YIPM**2
            TMP(3)=MWIW
            TMP(4)=MZJZ
            TERM1=SSXINT(MZJZ,SSWZF1,(MWIW**2+MZJZ**2)/2./MWIW)/
     $            2./MWIW/(2*PI)**5*2*G**4*PI**2/3.
            ELSE
            TERM1=0.
            END IF
            ULIM=MWIW/2.*(1.-MZJZ**2/MWIW**2)
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.AMCLSS) THEN
            TMP(2)=AMCLSS
            PSIINT=SSXINT(0.,SSWZF2,ULIM)
            T1=AUI(JZ)**2*ADWI(IW)**2*PSIINT
            ELSE
            T1=0.
            END IF
            IF (MWIW.LT.AMSLSS) THEN
            TMP(2)=AMSLSS
            PSIINT=SSXINT(0.,SSWZF2,ULIM)
            T2=ADI(JZ)**2*AUWI(IW)**2*PSIINT
            ELSE
            T2=0.
            END IF
            IF (MWIW.LT.AMSLSS.AND.MWIW.LT.AMCLSS) THEN
            TMP(2)=0.
            TMP(4)=AMSLSS
            TMP(5)=AMCLSS
            PHIINT=SSXINT(0.,SSGX2,ULIM)
            CC=2*SIGN(1.,AMZISS(JZ))*AUWI(IW)*ADWI(IW)*AUI(JZ)*ADI(JZ)
            T3=CC*PHIINT
            ELSE
            T3=0.
            END IF
            TERM2=(T1+T2+T3)/2./MWIW/(2*PI)**5
            FACTOR=1./2./MWIW/(2*PI)**5*2*SR2*G**2
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMCLSS) THEN
            TMP(2)=AMCLSS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM3=FACTOR*ADWI(IW)*AUI(JZ)*((XIPM-YIPM)*XI1
     $      -(XIPM+YIPM)*XI2)*SIGN(1.,AMZISS(JZ))
            ELSE
            TERM3=0.
            END IF
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMSLSS) THEN
            TMP(2)=AMSLSS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM4=-FACTOR*AUWI(IW)*ADI(JZ)*((XIPM+YIPM)*XI1
     $      -(XIPM-YIPM)*XI2)
            ELSE
            TERM4=0.
            END IF
            WID=3*(TERM1+TERM2+TERM3+TERM4)
            CALL SSSAVE(ISWIW,WID,ISZJZ,IDCH,-IDST,0,0)
C         Enter information for decay matrix element
            Z1(1)=ZI**THJZ*G*XIPM
            Z1(2)=ZI**THJZ*G*YIPM
            Z2(1)=G/2./SR2
            Z2(2)=-G/2./SR2
            CALL SSME3(1,AMW,Z1,Z2)
            Z1(1)=ZI*AUWI(IW)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ADI(JZ))/2.
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMSLSS,Z1,Z2)
            Z1(1)=CONJG(ZI*ADWI(IW))/2.
            Z1(2)=-Z1(1)
            Z2(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*AUI(JZ)/2.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMCLSS,Z1,Z2)
          END IF
C          wi -> t + bbar + zj neglected since 2-body modes should dominate
C
C          wi --> nu_e + e + zj
C          We do not require PSGAP for leptonic modes since no 
C          hadronization needed.
C
          IF (MWIW.GT.(MZJZ+AME)) THEN
            IF (MWIW.LT.(AMW+MZJZ)) THEN
            TMP(1)=XIPM**2+YIPM**2
            TMP(2)=XIPM**2-YIPM**2
            TMP(3)=MWIW
            TMP(4)=MZJZ
            TERM1=SSXINT(MZJZ,SSWZF1,(MWIW**2+MZJZ**2)/2./MWIW)/
     $            2./MWIW/(2*PI)**5*2*G**4*PI**2/3.
            ELSE
            TERM1=0.
            END IF
            ULIM=MWIW/2.*(1.-MZJZ**2/MWIW**2)
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.AMN1SS) THEN
            TMP(2)=AMN1SS
            T1=ANI(JZ)**2*ALWI(IW)**2*SSXINT(0.,SSWZF2,ULIM)
            ELSE
            T1=0.
            END IF
            IF (MWIW.LT.AMELSS) THEN
            TMP(2)=AMELSS
            T2=ALI(JZ)**2*ANWI(IW)**2*SSXINT(0.,SSWZF2,ULIM)
            ELSE
            T2=0.
            END IF
            IF (MWIW.LT.AMELSS.AND.MWIW.LT.AMN1SS) THEN
            TMP(2)=0.
            TMP(4)=AMELSS
            TMP(5)=AMN1SS
            T3=-2*SIGN(1.,AMZISS(JZ))*ANWI(IW)*ALWI(IW)*ANI(JZ)*
     $         ALI(JZ)*SSXINT(0.,SSGX2,ULIM)
            ELSE
            T3=0.
            END IF
            TERM2=(T1+T2+T3)/2./MWIW/(2*PI)**5
            FACTOR=1./2./MWIW/(2*PI)**5*2*SR2*G**2
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMN1SS) THEN
            TMP(2)=AMN1SS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM3=FACTOR*ALWI(IW)*ANI(JZ)*((XIPM-YIPM)*XI1
     $      -(XIPM+YIPM)*XI2)*SIGN(1.,AMZISS(JZ))
            ELSE
            TERM3=0.
            END IF
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMELSS) THEN
            TMP(2)=AMELSS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM4=FACTOR*ANWI(IW)*ALI(JZ)*((XIPM+YIPM)*XI1
     $      -(XIPM-YIPM)*XI2)
            ELSE
            TERM4=0.
            END IF
            WID=TERM1+TERM2+TERM3+TERM4
            CALL SSSAVE(ISWIW,WID,ISZJZ,-IDE,IDNE,0,0)
C         Enter information for decay matrix element
            Z1(1)=ZI**THJZ*G*XIPM
            Z1(2)=ZI**THJZ*G*YIPM
            Z2(1)=G/2./SR2
            Z2(2)=-G/2./SR2
            CALL SSME3(1,AMW,Z1,Z2)
            Z1(1)=ZI*ANWI(IW)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ALI(JZ))/2.
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMELSS,Z1,Z2)
            Z1(1)=CONJG(ZI*ALWI(IW))/2.
            Z1(2)=-Z1(1)
            Z2(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMN1SS,Z1,Z2)
          END IF
C          wi --> nu_mu + mu + zj
          IF (MWIW.GT.(MZJZ+AMMU)) THEN
            IF (MWIW.LT.(AMW+MZJZ)) THEN
            TMP(1)=XIPM**2+YIPM**2
            TMP(2)=XIPM**2-YIPM**2
            TMP(3)=MWIW
            TMP(4)=MZJZ
            TERM1=SSXINT(MZJZ,SSWZF1,(MWIW**2+MZJZ**2)/2./MWIW)/
     $            2./MWIW/(2*PI)**5*2*G**4*PI**2/3.
            ELSE
            TERM1=0.
            END IF
            ULIM=MWIW/2.*(1.-MZJZ**2/MWIW**2)
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.AMN2SS) THEN
            TMP(2)=AMN2SS
            T1=ANI(JZ)**2*ALWI(IW)**2*SSXINT(0.,SSWZF2,ULIM)
            ELSE
            T1=0.
            END IF
            IF (MWIW.LT.AMMLSS) THEN
            TMP(2)=AMMLSS
            T2=ALI(JZ)**2*ANWI(IW)**2*SSXINT(0.,SSWZF2,ULIM)
            ELSE
            T2=0.
            END IF
            IF (MWIW.LT.AMMLSS.AND.MWIW.LT.AMN2SS) THEN
            TMP(2)=0.
            TMP(4)=AMMLSS
            TMP(5)=AMN2SS
            T3=-2*SIGN(1.,AMZISS(JZ))*ANWI(IW)*ALWI(IW)*ANI(JZ)*
     $         ALI(JZ)*SSXINT(0.,SSGX2,ULIM)
            ELSE
            T3=0.
            END IF
            TERM2=(T1+T2+T3)/2./MWIW/(2*PI)**5
            FACTOR=1./2./MWIW/(2*PI)**5*2*SR2*G**2
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMN2SS) THEN
            TMP(2)=AMN2SS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM3=FACTOR*ALWI(IW)*ANI(JZ)*((XIPM-YIPM)*XI1
     $      -(XIPM+YIPM)*XI2)*SIGN(1.,AMZISS(JZ))
            ELSE
            TERM3=0.
            END IF
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMMLSS) THEN
            TMP(2)=AMMLSS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERM4=FACTOR*ANWI(IW)*ALI(JZ)*((XIPM+YIPM)*XI1
     $      -(XIPM-YIPM)*XI2)
            ELSE
            TERM4=0.
            END IF
            WID=TERM1+TERM2+TERM3+TERM4
            CALL SSSAVE(ISWIW,WID,ISZJZ,-IDMU,IDNM,0,0)
C         Enter information for decay matrix element
            Z1(1)=ZI**THJZ*G*XIPM
            Z1(2)=ZI**THJZ*G*YIPM
            Z2(1)=G/2./SR2
            Z2(2)=-G/2./SR2
            CALL SSME3(1,AMW,Z1,Z2)
            Z1(1)=ZI*ANWI(IW)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ALI(JZ))/2.
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMMLSS,Z1,Z2)
            Z1(1)=CONJG(ZI*ALWI(IW))/2.
            Z1(2)=-Z1(1)
            Z2(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.
            Z2(2)=Z2(1)
            CALL SSME3(3,AMN2SS,Z1,Z2)
          END IF
C          wi --> nu_tau + tau + zj ; includes mixing and Yukawas
          FACT=1./2./MWIW/(2*PI)**5
          ALJZ1=-ALI(JZ)*COSL-FL*ZMIXSS(2,JZ)*SINL
          ALJZ2=-ALI(JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
          BEJZ1=BLI(JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
          BEJZ2=-BLI(JZ)*COSL+FL*ZMIXSS(2,JZ)*SINL
          SNJZ=SIGN(1.,AMZISS(JZ))
C         Change ALWI def'ns in accord with Drees note
          ALWI(1)=-G*SIN(GAMMAR)
          ALWI(2)=-G*THY*COS(GAMMAR)
C          Polarization for stau_1 -> z1ss+tau.
C          See above for other cases.
          IF(IW.EQ.1.AND.JZ.EQ.1) THEN
            PTAU1(JZ)=(BEJZ1**2-ALJZ1**2)/(BEJZ1**2+ALJZ1**2)
            PTAU2(JZ)=(BEJZ2**2-ALJZ2**2)/(BEJZ2**2+ALJZ2**2)
          ENDIF
          IF (IW.EQ.1) THEN
            ALIW1=-G*SIN(GAMMAL)*COSL+FL*COS(GAMMAL)*SINL
            ALIW2=-G*SIN(GAMMAL)*SINL-FL*COS(GAMMAL)*COSL
            AHCJZ=COSBE*V2I(JZ)
            BHCJZ=-SINBE*V4I(JZ)
          ELSE IF (IW.EQ.2) THEN
            ALIW1=(-G*COS(GAMMAL)*COSL-FL*SIN(GAMMAL)*SINL)*THX
            ALIW2=(-G*COS(GAMMAL)*SINL+FL*SIN(GAMMAL)*COSL)*THX
            AHCJZ=COSBE*V1I(JZ)*THY
            BHCJZ=-SINBE*V3I(JZ)*THX
          END IF
          IF (MWIW.GT.(MZJZ+AMTAU)) THEN
            IF (MWIW.LT.(AMW+MZJZ)) THEN
            TMP(1)=XIPM**2+YIPM**2
            TMP(2)=XIPM**2-YIPM**2
            TMP(3)=MWIW
            TMP(4)=MZJZ
            TERMW=SSXINT(MZJZ,SSWZF1,(MWIW**2+MZJZ**2)/2./MWIW)*
     $            FACT*2*G**4*PI**2/3.
            ELSE
            TERMW=0.
            END IF
            ULIM=(MWIW**2-MZJZ**2)/2./MWIW
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.AMN3SS) THEN
            TMP(2)=AMN3SS
            POLNL=FACT*ANI(JZ)**2*ALWI(IW)**2*
     $            SSXINT(0.,SSWZF2,ULIM)
            POLNR=POLNL*BPLWI(IW)**2/ALWI(IW)**2
            TERMN=POLNL+POLNR
            ELSE
            POLNL=0.
            POLNR=0.
            TERMN=0.
            END IF
            IF (MWIW.LT.AML1SS) THEN
            TMP(2)=AML1SS
            POL1L=FACT*ALJZ1**2*ALIW1**2*SSXINT(0.,SSWZF2,ULIM)
            POL1R=POL1L*BEJZ1**2/ALJZ1**2
            TERM1=POL1L+POL1R
            ELSE
            POL1L=0.
            POL1R=0.
            TERM1=0.
            END IF
            IF (MWIW.LT.AML2SS) THEN
            TMP(2)=AML2SS
            POL2L=FACT*ALJZ2**2*ALIW2**2*SSXINT(0.,SSWZF2,ULIM)
            POL2R=POL2L*BEJZ2**2/ALJZ2**2
            TERM2=POL2L+POL2R
            ELSE
            POL2L=0.
            POL2R=0.
            TERM2=0.
            END IF
            IF (MWIW.LT.AML1SS) THEN
            TMP(2)=0.
            TMP(3)=MZJZ
            TMP(4)=AML1SS
            TMP(5)=AML2SS
            POL12L=FACT*2*ALIW1*ALIW2*ALJZ1*ALJZ2*
     $             SSXINT(0.,SSGX1,ULIM)
            POL12R=POL12L*BEJZ1*BEJZ2/ALJZ1/ALJZ2
            TERM12=POL12L+POL12R
            ELSE
            POL12L=0.
            POL12R=0.
            TERM12=0.
            END IF
            IF (MWIW.LT.(AMHC+MZJZ)) THEN
            TMP(2)=AMHC
            TMP(3)=MZJZ
            TMP(4)=AHCJZ
            TMP(5)=BHCJZ
            TMP(6)=SIGN(1.,AMZISS(JZ))*SIGN(1.,AMWISS(IW))
            TERMH=FACT*PI**2*MWIW*(G*MTAMZ*TANB/AMW)**2/2.*
     $         SSXINT(MZJZ,SSWZF6,(MWIW**2+MZJZ**2)/2./MWIW)
            ELSE
            TERMH=0.
            END IF
            IF (MWIW.LT.AML1SS.AND.MWIW.LT.AMN3SS) THEN
            TMP(2)=0.
            TMP(3)=MZJZ
            TMP(4)=AMN3SS
            TMP(5)=AML1SS
            POLN1L=+2*FACT*ANI(JZ)*ALIW1*SNJZ*SNIW*ALWI(IW)*
     $             ALJZ1*SSXINT(0.,SSGX2,ULIM)
            POLN1R=-2*FACT*ANI(JZ)*ALIW1*BPLWI(IW)*BEJZ1*
     $             SSXINT(0.,SSGX8,ULIM)
            TERMN1=POLN1L+POLN1R
            ELSE
            POLN1L=0.
            POLN1R=0.
            TERMN1=0.
            END IF
            IF (MWIW.LT.AML2SS.AND.MWIW.LT.AMN3SS) THEN
            TMP(2)=0.
            TMP(3)=MZJZ
            TMP(4)=AMN3SS
            TMP(5)=AML2SS
            POLN2L=+2*FACT*ANI(JZ)*ALIW2*SNJZ*SNIW*ALWI(IW)*ALJZ2*
     $             SSXINT(0.,SSGX2,ULIM)
            POLN2R=-2*FACT*ANI(JZ)*ALIW2*BPLWI(IW)*BEJZ2*
     $             SSXINT(0.,SSGX8,ULIM)
            TERMN2=POLN2L+POLN2R
            ELSE
            POLN2L=0.
            POLN2R=0.
            TERMN2=0.
            END IF
            TMP(1)=MWIW
            TMP(3)=MZJZ
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AMN3SS) THEN
            TMP(2)=AMN3SS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERMWN=2*SR2*G**2*FACT*ALWI(IW)*ANI(JZ)*((XIPM-
     $         YIPM)*XI1-(XIPM+YIPM)*XI2)*SIGN(1.,AMZISS(JZ))
            ELSE
            TERMWN=0.
            END IF
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AML1SS) THEN
            TMP(2)=AML1SS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERMW1=2*SR2*G**2*FACT*ALIW1*ALJZ1*
     $             ((XIPM+YIPM)*XI1-(XIPM-YIPM)*XI2)
            ELSE
            TERMW1=0.
            END IF
            IF (MWIW.LT.(MZJZ+AMW).AND.MWIW.LT.AML2SS) THEN
            TMP(2)=AML2SS
            XI1=SSXINT(0.,SSWZF4,(MWIW-MZJZ)**2)
            XI2=SSXINT(0.,SSWZF5,(MWIW-MZJZ)**2)
            TERMW2=2*SR2*G**2*FACT*ALIW2*ALJZ2*
     $             ((XIPM+YIPM)*XI1-(XIPM-YIPM)*XI2)
            ELSE
            TERMW2=0.
            END IF
            TMP(2)=MZJZ
            TMP(3)=AMHC
            TMP(5)=AHCJZ
            TMP(6)=BHCJZ
            TMP(7)=SNJZ*SNIW
            IF (MWIW.LT.(AMHC+MZJZ).AND.MWIW.LT.AML1SS) THEN
            TMP(4)=AML1SS
            TERMH1=PI**2/2./MWIW*FACT*SR2*ALIW1*BEJZ1*G*MTAMZ*
     $             TANB/AMW*SSXINT(0.,SSWZF7,(MWIW-MZJZ)**2)
            ELSE
            TERMH1=0.
            END IF
            IF (MWIW.LT.(AMHC+MZJZ).AND.MWIW.LT.AML2SS) THEN
            TMP(4)=AML2SS
            TERMH2=PI**2/2./MWIW*FACT*SR2*ALIW2*BEJZ2*G*MTAMZ*
     $             TANB/AMW*SSXINT(0.,SSWZF7,(MWIW-MZJZ)**2)
            ELSE
            TERMH2=0.
            END IF
            IF (MWIW.LT.(AMHC+MZJZ).AND.MWIW.LT.AMN3SS) THEN
            TMP(4)=AMN3SS
            TERMHN=PI**2/2./MWIW*FACT*SR2*ANI(JZ)*BPLWI(IW)*G*
     $         MTAMZ*TANB/AMW*SSXINT(0.,SSWZF7,(MWIW-MZJZ)**2)
            ELSE
            TERMHN=0.
            END IF
            WID=TERMW+TERMN+TERM1+TERM2+TERMH+TERMWN+TERMW1+
     $          TERMW2+TERM12+TERMN1+TERMN2+TERMH1+TERMH2+
     $          TERMHN
C          tau polarization for 3-body w1 -> z1 tau nu
            IF (IW.EQ.1.AND.JZ.EQ.1.AND.WID.GT.0.) THEN
              PTAUWZ=(POLNR+POL1R+POL2R+POL12R+TERMH+POLN1R+
     $               POLN2R+TERMHN+TERMH1+TERMH2-(TERMW+POLNL+
     $               POL1L+POL2L+POL12L+POLN1L+POLN2L+TERMWN+
     $               TERMW1+TERMW2))/WID
            END IF
            CALL SSSAVE(ISWIW,WID,ISZJZ,-IDTAU,IDNT,0,0)
            Z1(1)=ZI**THJZ*G*XIPM
            Z1(2)=ZI**THJZ*G*YIPM
            Z2(1)=-G/2./SR2
            Z2(2)=-Z2(1)
            CALL SSME3(1,AMW,Z1,Z2)
            Z1(1)=-(ZI)**THJZ*ALIW1/2.
            Z1(2)=-Z1(1)
            Z2(1)=(ALJZ1+(-1.)**THJZ*BEJZ1)/2.
            Z2(2)=(ALJZ1-(-1.)**THJZ*BEJZ1)/2.
            CALL SSME3(2,AML1SS,Z1,Z2)
            Z1(1)=-(ZI)**THJZ*ALIW2/2.
            Z1(2)=-Z1(1)
            Z2(1)=(ALJZ2+(-1.)**THJZ*BEJZ2)/2.
            Z2(2)=(ALJZ2-(-1.)**THJZ*BEJZ2)/2.
            CALL SSME3(2,AML2SS,Z1,Z2)
            Z1(1)=(-1.)**THJZ*ANI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=(SNIW*ALWI(IW)+BPLWI(IW))/2.
            Z2(2)=(SNIW*ALWI(IW)-BPLWI(IW))/2.
            CALL SSME3(3,AMN3SS,Z1,Z2)
            Z1(1)=ZI**THJZ*G*MTAMZ*TANB/SR2/AMW/2.
            Z1(2)=-Z1(1)
            Z2(1)=(SNIW*AHCJZ-SNJZ*BHCJZ)/2.
            Z2(2)=(SNIW*AHCJZ+SNJZ*BHCJZ)/2.
            CALL SSME3(4,AMHC,Z1,Z2)
          END IF
C
C          wi --> w + zj
C
          IF (MWIW.GT.(MZJZ+AMW)) THEN
            EF=MWIW**2+MZJZ**2-AMW**2+((MWIW**2-MZJZ**2)**2
     $         -AMW**4)/AMW/AMW
            WID=G*G*SQRT(SSXLAM(MWIW**2,MZJZ**2,AMW**2))/32./PI/
     $          MWIW**3*(2.*EF*(XIPM**2+YIPM**2)-12*MWIW*MZJZ*
     $          (XIPM**2-YIPM**2))
            CALL SSSAVE(ISWIW,WID,ISZJZ,IDW,0,0,0)
          END IF
C
C          wi --> h+ + zj
C
          IF (MWIW.GT.(MZJZ+AMHC)) THEN
            IF(IW.EQ.1) THEN
              A=(SNW1*COSBE*V2I(JZ)
     $        -SIGN(1.,AMZISS(JZ))*SINBE*V4I(JZ))/2.
              B=(SNW1*COSBE*V2I(JZ)
     $        +SIGN(1.,AMZISS(JZ))*SINBE*V4I(JZ))/2.
            ELSE
              A=(THY*SNW2*COSBE*V1I(JZ)
     $        -THX*SIGN(1.,AMZISS(JZ))*SINBE*V3I(JZ))/2.
              B=(THY*SNW2*COSBE*V1I(JZ)
     $        +THX*SIGN(1.,AMZISS(JZ))*SINBE*V3I(JZ))/2.
            ENDIF
            WID=SQRT(MWIW**4+MZJZ**4+AMHC**4-2.*(MWIW*MZJZ)**2-
     $      2.*(MWIW*AMHC)**2-2.*(MZJZ*AMHC)**2)/8./PI/MWIW**3*
     $      ((A*A+B*B)*(MWIW*MWIW+MZJZ*MZJZ-AMHC*AMHC)/2.
     $      +(A*A-B*B)*MWIW*MZJZ) 
            CALL SSSAVE(ISWIW,WID,ISZJZ,ISHC,0,0,0)
          ENDIF
310     CONTINUE
C
C          wi --> quark + squark
C
        IF(MWIW.GT.(AMULSS+AMDN)) THEN
          WID=3.*ADWI(IW)**2/32./PI/MWIW*(1.+AMDN**2/MWIW**2-
     $     AMULSS**2/MWIW**2)*SQRT(SSXLAM(MWIW**2,AMDN**2,AMULSS**2))
          CALL SSSAVE(ISWIW,WID,+ISUPL,-IDDN,0,0,0)
        END IF
        IF(MWIW.GT.(AMDLSS+AMUP)) THEN
          WID=3.*AUWI(IW)**2/32./PI/MWIW*(1.+AMUP**2/MWIW**2-
     $     AMDLSS**2/MWIW**2)*SQRT(SSXLAM(MWIW**2,AMUP**2,AMDLSS**2))
          CALL SSSAVE(ISWIW,WID,-ISDNL,+IDUP,0,0,0)
        END IF
        IF(MWIW.GT.(AMCLSS+AMST)) THEN
          WID=3.*ADWI(IW)**2/32./PI/MWIW*(1.+AMST**2/MWIW**2-
     $     AMCLSS**2/MWIW**2)*SQRT(SSXLAM(MWIW**2,AMST**2,AMCLSS**2))
          CALL SSSAVE(ISWIW,WID,+ISCHL,-IDST,0,0,0)
        END IF
        IF(MWIW.GT.(AMSLSS+AMCH)) THEN
          WID=3.*AUWI(IW)**2/32./PI/MWIW*(1.+AMCH**2/MWIW**2-
     $     AMCLSS**2/MWIW**2)*SQRT(SSXLAM(MWIW**2,AMCH**2,AMCLSS**2))
          CALL SSSAVE(ISWIW,WID,-ISSTL,+IDCH,0,0,0)
        ENDIF
        IF(MWIW.GT.(AMT1SS+AMBT)) THEN
          AW=-ADWI(IW)*COST-BWI(IW)*SINT
          WID=3*((AW**2+BPWI(IW)**2*COST**2)*(MWIW**2+AMBT**2-AMT1SS**2)
     $        +4*AW*BPWI(IW)*COST*AMBT*MWIW)/32./PI/MWIW**3*
     $      SQRT(SSXLAM(MWIW**2,AMBT**2,AMT1SS**2))
          CALL SSSAVE(ISWIW,WID,ISTP1,-IDBT,0,0,0)
        ENDIF
        IF(MWIW.GT.(AMT2SS+AMBT)) THEN
          AW=-ADWI(IW)*SINT+BWI(IW)*COST
          WID=3*((AW**2+BPWI(IW)**2*SINT**2)*(MWIW**2+AMBT**2-AMT2SS**2)
     $        +4*AW*BPWI(IW)*SINT*AMBT*MWIW)/32./PI/MWIW**3*
     $      SQRT(SSXLAM(MWIW**2,AMBT**2,AMT2SS**2))
          CALL SSSAVE(ISWIW,WID,ISTP2,-IDBT,0,0,0)
        ENDIF
        IF(MWIW.GT.(AMB1SS+AMTP)) THEN
          AW=-AUWI(IW)*COSB-BPWI(IW)*SINB
          WID=3*((AW**2+BWI(IW)**2*COSB**2)*(MWIW**2+AMTP**2-AMB1SS**2)
     $        +4*AW*BWI(IW)*COSB*AMTP*MWIW)/32./PI/MWIW**3*
     $      SQRT(SSXLAM(MWIW**2,AMTP**2,AMB1SS**2))
          CALL SSSAVE(ISWIW,WID,-ISBT1,IDTP,0,0,0)
        ENDIF
        IF(MWIW.GT.(AMB2SS+AMTP)) THEN
          AW=-AUWI(IW)*SINB+BPWI(IW)*COSB
          WID=3*((AW**2+BWI(IW)**2*SINB**2)*(MWIW**2+AMTP**2-AMB2SS**2)
     $        +4*AW*BWI(IW)*SINB*AMTP*MWIW)/32./PI/MWIW**3*
     $      SQRT(SSXLAM(MWIW**2,AMTP**2,AMB2SS**2))
          CALL SSSAVE(ISWIW,WID,-ISBT2,IDTP,0,0,0)
        ENDIF
C
C          wi --> lepton + slepton
C
        IF(MWIW.GT.(AMN1SS+AME)) THEN
          AW=-ALWI(IW)
          WID=AW**2*(MWIW**2+AME**2-AMN1SS**2)/32./PI/MWIW**3*
     $        SQRT(SSXLAM(MWIW**2,AME**2,AMN1SS**2))
          CALL SSSAVE(ISWIW,WID,ISNEL,-IDE,0,0,0)
        END IF
        IF(MWIW.GT.(AMN2SS+AMMU)) THEN
          AW=-ALWI(IW)
          WID=AW**2*(MWIW**2+AMMU**2-AMN2SS**2)/32./PI/MWIW**3*
     $        SQRT(SSXLAM(MWIW**2,AMMU**2,AMN2SS**2))
          CALL SSSAVE(ISWIW,WID,ISNML,-IDMU,0,0,0)
        END IF
        IF(MWIW.GT.(AMN3SS+AMTAU)) THEN
          AW=-ALWI(IW)
          WID=((AW**2+BPLWI(IW)**2)*(MWIW**2+AMTAU**2-AMN3SS**2)+
     $        4*AW*BPLWI(IW)*AMTAU*MWIW)/32./PI/MWIW**3*
     $        SQRT(SSXLAM(MWIW**2,AMTAU**2,AMN3SS**2))
          CALL SSSAVE(ISWIW,WID,ISNTL,-IDTAU,0,0,0)
        ENDIF
        IF(MWIW.GT.AMELSS) THEN
          WID=ANWI(IW)**2*(MWIW**2-AMELSS**2)**2/32./PI/MWIW**3
          CALL SSSAVE(ISWIW,WID,-ISEL,IDNE,0,0,0)
        ENDIF
        IF(MWIW.GT.AMMLSS) THEN
          WID=ANWI(IW)**2*(MWIW**2-AMMLSS**2)**2/32./PI/MWIW**3
          CALL SSSAVE(ISWIW,WID,-ISMUL,IDNM,0,0,0)
        END IF
        IF(MWIW.GT.AML1SS) THEN
          AW=-ANWI(IW)*COSL-BPLWI(IW)*SINL
          WID=AW**2*(MWIW**2-AML1SS**2)**2/32./PI/MWIW**3
          CALL SSSAVE(ISWIW,WID,-ISTAU1,IDNT,0,0,0)
        END IF
        IF(MWIW.GT.AML2SS) THEN
          AW=-ANWI(IW)*SINL+BPLWI(IW)*COSL
          WID=AW**2*(MWIW**2-AML2SS**2)**2/32./PI/MWIW**3
          CALL SSSAVE(ISWIW,WID,-ISTAU2,IDNT,0,0,0)
        END IF
300   CONTINUE
C
C          w2 --> w1 + z
C          w2 --> w1 + f + fbar
C
      IF (MW2.GT.(MW1+AMZ)) THEN
        EF=MW2**2+MW1**2-AMZ**2+((MW2**2-MW1**2)**2-
     $     AMZ**4)/AMZ/AMZ
        Y=(THX*SIN(GAMMAL)*COS(GAMMAL)-THY*SIN(GAMMAR)*COS(GAMMAR))/2.
        Z=(THX*SIN(GAMMAL)*COS(GAMMAL)+THY*SIN(GAMMAR)*COS(GAMMAR))/2.
        WID=E*E*(COTW+TANW)**2*SQRT(SSXLAM(MW2**2,MW1**2,AMZ**2))/
     $      128./PI/MW2**3*(2*EF*(Y*Y+Z*Z)+
     $      12*MW2*MW1*(Y*Y-Z*Z)*SNW2*SNW1)
        CALL SSSAVE(ISW2,WID,ISW1,IDZ,0,0,0)
        W21ZL=0.
        W21ZN=0.
        W21ZU=0.
        W21ZD=0.
C          ...w1 + f + fbar
      ELSE
        CONST=E**4*(COTW+TANW)**2/96./PI**3/MW2
        UPPER=(MW2**2+MW1**2)/2./MW2
        TMP(1)=MW2
        TMP(2)=MW1
        TMP(3)=AMZ
        TMP(4)=SNW1*SNW2
        TMP(5)=XWINO
        TMP(6)=YWINO
        XINTGL=SSXINT(MW1,SSWWF1,UPPER)
        W21ZL=(APL**2+BTL**2)*CONST*XINTGL
        W21ZN=(APN**2+BTN**2)*CONST*XINTGL
        W21ZU=3*(APU**2+BTU**2)*CONST*XINTGL
        W21ZD=3*(APD**2+BTD**2)*CONST*XINTGL
      END IF
C     do w2 ->w1+q+qbar via sq'
      TMP(1)=MW2
      TMP(3)=MW1
      UPPER=(MW2**2-MW1**2)/2./MW2
      IF (MW2.LT.AMULSS) THEN
        TMP(2)=AMULSS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21D=3*(ADWI(2)*ADWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21D=0.
      END IF
      IF (MW2.LT.AMDLSS) THEN
        TMP(2)=AMDLSS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21U=3*(AUWI(2)*AUWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21U=0.
      END IF
      IF (MW2.LT.AMCLSS) THEN
        TMP(2)=AMCLSS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21S=3*(ADWI(2)*ADWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21S=0.
      END IF
      IF (MW2.LT.AMSLSS) THEN
        TMP(2)=AMSLSS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21C=3*(AUWI(2)*AUWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21C=0.
      END IF
      IF (MW2.LT.AMN1SS) THEN
        TMP(2)=AMN1SS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21E=(ALWI(2)*ALWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21E=0.
      END IF
      IF (MW2.LT.AMN2SS) THEN
        TMP(2)=AMN2SS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21M=(ALWI(2)*ALWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21M=0.
      END IF
      IF (MW2.LT.AMN3SS) THEN
        TMP(2)=AMN3SS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21L=(ALWI(2)*ALWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21L=0.
      END IF
      IF (MW2.LT.AMELSS) THEN
        TMP(2)=AMELSS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21N1=(ANWI(2)*ANWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21N1=0.
      END IF
      IF (MW2.LT.AMMLSS) THEN
        TMP(2)=AMMLSS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21N2=(ANWI(2)*ANWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21N2=0.
      END IF
C     !!! W2->W1+NU_TAU+NU_TAUBAR NEEDS UPDATING FOR STAU MIXING
      IF (MW2.LT.AML1SS) THEN
        TMP(2)=AML1SS
        XINTGL=SSXINT(0.,SSWZF2,UPPER)
        W21N3=(ANWI(2)*ANWI(1))**2*XINTGL/2./MW2/(2*PI)**5
      ELSE
        W21N3=0.
      END IF
C-----WINO-2 ->WINO-1 +BBBAR NEEDS UPDATE -------------------
C-----WINO-2 ->WINO-1 +TTBAR NEEDS UPDATE -------------------
C-----THESE ALL LACK INTERFERENCE TERMS AS WELL
      W21D=W21D+W21ZD
      W21U=W21U+W21ZU
      W21S=W21S+W21ZD
      W21C=W21C+W21ZU
      W21N1=W21N1+W21ZN
      W21N2=W21N2+W21ZN
      W21N3=W21N3+W21ZN
      W21E=W21E+W21ZL
      W21M=W21M+W21ZL
      W21L=W21L+W21ZL
      IF(W21D.GT.0.) THEN
        CALL SSSAVE(ISW2,W21D,ISW1,IDDN,-IDDN,0,0)
      END IF
      IF(MW2.GT.(MW1+2*AMST+1.)) THEN
        CALL SSSAVE(ISW2,W21S,ISW1,IDST,-IDST,0,0)
      END IF
C      IF (MW2.GT.(MW1+2*AMBT+2.)) THEN
C        CALL SSSAVE(ISW2,W21D,ISW1,IDBT,-IDBT,0,0)
C      END IF
      IF(W21U.GT.0.) THEN
        CALL SSSAVE(ISW2,W21U,ISW1,IDUP,-IDUP,0,0)
      END IF
      IF (MW2.GT.(MW1+2*AMCH+1.)) THEN
        CALL SSSAVE(ISW2,W21C,ISW1,IDCH,-IDCH,0,0)
      ENDIF
C        IF (MW2.GT.(MW1+2*AMTP+2.)) THEN
C          CALL SSSAVE(ISW2,W21U,ISW1,IDTP,-IDTP,0,0)
C        END IF
      IF(W21N1.GT.0.) THEN
        CALL SSSAVE(ISW2,W21N1,ISW1,IDNE,-IDNE,0,0)
      ENDIF
      IF(W21N2.GT.0.) THEN
        CALL SSSAVE(ISW2,W21N2,ISW1,IDNM,-IDNM,0,0)
      ENDIF
      IF(W21N3.GT.0.) THEN
        CALL SSSAVE(ISW2,W21N3,ISW1,IDNT,-IDNT,0,0)
      ENDIF
      IF(W21E.GT.0.) THEN
        CALL SSSAVE(ISW2,W21E,ISW1,IDE,-IDE,0,0)
      ENDIF
      IF(MW2.GT.(MW1+2*AMMU+1.)) THEN
        CALL SSSAVE(ISW2,W21M,ISW1,IDMU,-IDMU,0,0)
      ENDIF
      IF(MW2.GT.(MW1+2*AMTAU+1.)) THEN
        CALL SSSAVE(ISW2,W21L,ISW1,IDTAU,-IDTAU,0,0)
      ENDIF
C
C          w2 --> w1 + higgs
C
C          w2 --> w1 + hl
      IF(MW2.GT.(MW1+AMHL)) THEN
        WID=G*G/16./PI/MW2**3*SQRT(SSXLAM(MW2**2,MW1**2,AMHL**2))*
     $  ((SL*SL+PL*PL)*(MW2*MW2+MW1*MW1-AMHL*AMHL)/2.+
     $  (SL*SL-PL*PL)*MW2*MW1)
        CALL SSSAVE(ISW2,WID,ISW1,ISHL,0,0,0)
      ENDIF
C          w2 --> w1 + hh
      IF(MW2.GT.(MW1+AMHH)) THEN
        WID=G*G/16./PI/MW2**3*SQRT(SSXLAM(MW2**2,MW1**2,AMHH**2))*
     $  ((SH*SH+PH*PH)*(MW2*MW2+MW1*MW1-AMHH*AMHH)/2.+
     $  (SH*SH-PH*PH)*MW2*MW1)
        CALL SSSAVE(ISW2,WID,ISW1,ISHH,0,0,0)
      ENDIF
C          w2 --> w1 + ha
      IF(MW2.GT.(MW1+AMHA)) THEN
        WID=G*G/16./PI/MW2**3*SQRT(SSXLAM(MW2**2,MW1**2,AMHA**2))*
     $  ((SP*SP+PP*PP)*(MW2*MW2+MW1*MW1-AMHA*AMHA)/2.+
     $  (SP*SP-PP*PP)*MW2*MW1)
        CALL SSSAVE(ISW2,WID,ISW1,ISHA,0,0,0)
      END IF
C
C          Normalize wi branching ratios
C
      CALL SSNORM(ISW1)
      CALL SSNORM(ISW2)
C
      RETURN
      END
+EOD
+DECK,SSWWF1
        REAL FUNCTION SSWWF1(EE)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Baer's WIWFUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      DOUBLE PRECISION E,MW2,MW1,MZ,SN,XX,YY,T1,T2,T3,T4
      REAL EE
C
      E=EE
      MW2=TMP(1)
      MW1=TMP(2)
      MZ=TMP(3)
      SN=TMP(4)
      XX=TMP(5)
      YY=TMP(6)
C
      T1=DSQRT(E**2-MW1**2)/(MW2**2+MW1**2-MZ**2-2*MW2*E)**2
      T2=3*E*MW2*(MW2**2+MW1**2)-2*MW2**2*MW1**2-4*MW2**2*E*E
      T3=2*E*MW2-MW2**2-MW1**2
      T4=T1*((XX**2+YY**2)*T2-3*SN*(XX**2-YY**2)*MW2*MW1*T3)
      SSWWF1=T4
      RETURN
      END
+EOD
+DECK,SSWZ2P
        REAL FUNCTION SSWZ2P(Q2)
C-----------------------------------------------------------------------
C          SSWIBF: w1ss -> z1ss pi+ pi0
C          Taken from Chen, Drees, Gunion hep-ph/9902309 Eq. A2b
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSTMP
C
      REAL Q2
      DOUBLE PRECISION MW1,MZ1,OL,OR,MR,GR,MRP,GRP,QS,
     $RQS,FQSS,MPI,WID,SSDLAM,B
      COMPLEX FQS,ZI
      DATA ZI/(0.,1.)/,MR/.773D0/,GR/.145D0/,MRP/1.37D0/,GRP/.510D0/
      DATA MPI/.140D0/,B/-.145D0/
C
      QS=Q2
      RQS=SQRT(QS)
      MW1=TMP(1)
      MZ1=TMP(2)
      OL=TMP(3)
      OR=TMP(4)
      FQS=(MR**2/(MR**2-QS-ZI*RQS*GR)+B*
     ,(MRP**2/(MRP**2-QS-ZI*RQS*GRP)))/(1.D0+B)
      FQSS=FQS*CONJG(FQS)
      WID=FQSS*(1.D0-4*MPI**2/QS)**1.5D0*SQRT(SSDLAM(MW1**2,MZ1**2,QS))
     ,*((OL**2+OR**2)*(QS*(MW1**2+MZ1**2-2*QS)+(MW1**2-MZ1**2)**2)
     ,-12*OL*OR*QS*MW1*MZ1)
      SSWZ2P=WID
      RETURN
      END
+EOD
+DECK,SSWZ3P
        REAL FUNCTION SSWZ3P(Q2)
C-----------------------------------------------------------------------
C          SSWIBF: w1ss -> z1ss pi+ pi0 pi0 or z1ss pi+ pi- pi+
C          Taken from Chen, Drees, Gunion hep-ph/9902309 Eq. A2c
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSTMP
C
      REAL Q2
      DOUBLE PRECISION MW1,MZ1,OL,OR,MA2,GA2,QS,
     $RQS,FQSS,MPI,WID,SSDLAM,MR,GQS
      COMPLEX FQS,ZI
      DATA ZI/(0.,1.)/,MA2/1.318D0/,GA2/.107D0/
      DATA MPI/.140D0/,MR/.773D0/
C
      QS=Q2
      RQS=SQRT(QS)
      MW1=TMP(1)
      MZ1=TMP(2)
      OL=TMP(3)
      OR=TMP(4)
      FQS=MA2**2/(MA2**2-QS-ZI*RQS*GA2)
      FQSS=FQS*CONJG(FQS)
      IF (QS.LT.(MR+MPI)) THEN
        GQS=4.1*(QS-9*MPI**2)**3*(1.D0-3.3*(QS-9*MPI**2)+
     ,      5.8*(QS-9*MPI**2)**2)
      ELSE
        GQS=QS*(1.623D0+10.38/QS-9.32/QS/QS+.65/QS**3)
      END IF
      WID=FQSS*SQRT(SSDLAM(MW1**2,MZ1**2,QS))*GQS
     ,*((OL**2+OR**2)*(MW1**2+MZ1**2-2*QS+(MW1**2-MZ1**2)**2/QS)
     ,-12*OL*OR*MW1*MZ1)
      SSWZ3P=1.35*WID
      RETURN
      END
+EOD
+DECK,SSWZBF
        SUBROUTINE SSWZBF
C-----------------------------------------------------------------------
C       This subroutine gives chargino (wi) and neutralino (zi)
C       decays according to Baer, et al.
C       Valid for all scalar masses (functions in double precision)
C       Includes Higgs sector radiative corrections (Aug. 31)
C
C       Auxiliary functions are called SSWxyi, SSZxyi, where normally
C       x indicates the SUSY particle, y the SM particle(s), and i is
C       a counter.
C
C       Ver. 7.07: For w_i -> z_j or z_i -> w_j decays, require that
C                  decay be allowed by a factor FUDGE = 1.0
C       Ver. 7.28: Calculate full large tan(beta) decays.
C                  Calculate tau polarizations.
C       Ver. 7.33: Add GMSB modes.
C       Ver. 7.41: Add decay matrix elements.
C                  Split real work into sszibf and sswfbf.
C
C       Baer's GAUGBF
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SSTMP
+CDE,SSPOLS
C
      INTEGER IZ
C
C          Initialize polarizations to zero
C
      DO 150 IZ=1,4
        PTAU1(IZ)=0
        PTAU2(IZ)=0
150   CONTINUE
      PTAUZZ=0
      PTAUWZ=0
C-----------------------------------------------------------------------
C          Generate Neutralino zi Branching Fractions
C-----------------------------------------------------------------------
      CALL SSZIBF
C-----------------------------------------------------------------------
C          Generate Chargino Branching Fractions
C-----------------------------------------------------------------------
      CALL SSWIBF
C
C          Set more neutralino polarizations
C
      IF (ABS(AMZISS(2)).GT.(AMTAU+AML1SS)) PTAUZ2(1)=PTAU1(2)
      IF (ABS(AMZISS(2)).GT.(AMTAU+AML2SS)) PTAUZ2(2)=PTAU2(2)
      IF (ABS(AMZISS(3)).GT.(AMTAU+AML1SS)) PTAUZ3(1)=PTAU1(3)
      IF (ABS(AMZISS(3)).GT.(AMTAU+AML2SS)) PTAUZ3(2)=PTAU2(3)
      IF (ABS(AMZISS(4)).GT.(AMTAU+AML1SS)) PTAUZ4(1)=PTAU1(4)
      IF (ABS(AMZISS(4)).GT.(AMTAU+AML2SS)) PTAUZ4(2)=PTAU2(4)
C
      RETURN
      END
+EOD
+DECK,SSWZF1
        REAL FUNCTION SSWZF1(EE)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Baer's WIWFUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL EE
      DOUBLE PRECISION C1,C2,MWI,MZI,MW,PROP,T1,T2,E
C
      E=EE
      C1=TMP(1)
      C2=TMP(2)
      MWI=TMP(3)
      MZI=TMP(4)
      MW=AMW
C
      PROP=(MWI**2+MZI**2-2*MWI*E-MW**2)**2
      T1=C1*(3*(MWI**2+MZI**2)*MWI*E-4*MWI**2*E*E-2*MWI**2*MZI**2)
      T2=-3*C2*MWI*MZI*(MWI**2+MZI**2-2*MWI*E)
      SSWZF1=SQRT(MAX(0.D0,E*E-MZI**2))/PROP*(T1+T2)
      RETURN
      END
+EOD
+DECK,SSWZF2
        REAL FUNCTION SSWZF2(QQ)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Baer's PSIFUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL QQ
      DOUBLE PRECISION M1,M2,M3,PI,Q
      DATA PI/3.14159265D0/
C
      Q=QQ
      M1=TMP(1)
      M2=TMP(2)
      M3=TMP(3)
C
      SSWZF2=PI**2*M1*Q*Q*(M1**2-2*M1*Q-M3**2)**2/
     $(M1**2-2*M1*Q-M2**2)**2/(M1**2-2*M1*Q)
      RETURN
      END
+EOD
+DECK,SSWZF3
        REAL FUNCTION SSWZF3(QQ)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Baer's PHIFUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL QQ
      DOUBLE PRECISION M1,M2,M3,T,B,XLOG,SQBKT,Q,PI
      DATA PI/3.14159265D0/
C
      Q=QQ
      M1=TMP(1)
      M2=TMP(2)
      M3=TMP(3)
C
      T=M2**2*(M1-2*Q)-M1*M3**2
      B=(M1-2*Q)*(M2**2-2*M1*Q-M3**2)
      XLOG=DLOG(T/B)
      SQBKT=-Q*(M1**2-M3**2-2*M1*Q)/M1/(M1-2*Q)-
     $(2*M1*Q-M2**2+M3**2)*XLOG/2./M1
      SSWZF3=.5*PI**2*M1*M3*SQBKT/(M1**2-M2**2-2*M1*Q)
      RETURN
      END
+EOD
+DECK,SSWZF4
        REAL FUNCTION SSWZF4(SS)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Baer's XI1FUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C-----------------------------------------------------------------------
      REAL SS,PI
      DOUBLE PRECISION M1,M2,M3,EQ,Q,XMUS,XLOG,TERM,S,MW
      DATA PI/3.14159265/
C
      S=SS
      M1=TMP(1)
      M2=TMP(2)
      M3=TMP(3)
      MW=AMW
C
      EQ=(S+M1**2-M3**2)/2./M1
      IF (EQ**2.GE.S) THEN
        Q=DSQRT(EQ**2-S)
      ELSE
        Q=0.D0
      END IF
      XMUS=M2**2+S-M3**2
      XLOG=DLOG((M1*(EQ+Q)-XMUS)/(M1*(EQ-Q)-XMUS))
      TERM=-.5*M1*EQ*Q-.5*(M2**2-M1**2-S)*Q-
     $.25/M1*(M2**2-M3**2)*(M2**2-M1**2)*XLOG
C          SS can stay single precision below
      SSWZF4=PI**2/2./M1/(SS-MW**2)*TERM
      RETURN
      END
+EOD
+DECK,SSWZF5
        REAL FUNCTION SSWZF5(SS)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Baer's XI2FUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL MW,PI,SS
      DOUBLE PRECISION M1,M2,M3,EQ,Q,XMUS,D,XLOG,S
      DATA PI/3.14159265/,MW/80./
C
      S=SS
      M1=TMP(1)
      M2=TMP(2)
      M3=TMP(3)
      MW=AMW
C
      EQ=(S+M1**2-M3**2)/2./M1
      Q=DSQRT(MAX(0.D0,EQ**2-S))
      XMUS=M2**2+S-M3**2
      D=(M1*(EQ+Q)-XMUS)/(M1*(EQ-Q)-XMUS)
      XLOG=DLOG(D)
      SSWZF5=PI**2/2./M1*M3*S/4./(SS-MW**2)*XLOG
      RETURN
      END
+EOD
+DECK,SSWZF6
        REAL FUNCTION SSWZF6(EE)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Drees' function for charged Higgs exchange
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL EE
      DOUBLE PRECISION E,MW,MZ,MH,AL,BE,SN,RES
C
      E=EE
      MW=TMP(1)
      MH=TMP(2)
      MZ=TMP(3)
      AL=TMP(4)
      BE=TMP(5)
      SN=TMP(6)
C
      RES=SQRT(E**2-MZ**2)*(MW**2+MZ**2-2*MW*E)*
     ,(E*(AL**2+BE**2)+2*SN*MZ*AL*BE)/
     ,(MW**2+MZ**2-2*MW*E-MH**2)**2
      SSWZF6=RES
      RETURN
      END
+EOD
+DECK,SSWZF7
        REAL FUNCTION SSWZF7(SS)
C-----------------------------------------------------------------------
C          SSWZBF: wiss -> zjss f fbar
C          Drees' function for charged Higgs/sfermion interference
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL SS
      DOUBLE PRECISION S,MS,MW,MZ,MH,AL,BE,SN,RES,
     $EQ,Q,MUS,XL,TERM
C
      S=SS
      MW=TMP(1)
      MZ=TMP(2)
      MH=TMP(3)
      MS=TMP(4)
      AL=TMP(5)
      BE=TMP(6)
      SN=TMP(7)
C
      EQ=(S+MW**2-MZ**2)/2.D0/MW
      Q=SQRT(MAX(0.D0,EQ**2-S))
      MUS=S+MS**2-MZ**2
      XL=LOG((MW*(EQ+Q)-MUS)/(MW*(EQ-Q)-MUS))
      TERM=BE*S*MS**2+SN*AL*MW*MZ*S
      RES=(S*Q*BE/2.D0+TERM*XL/4.D0/MW)/(S-MH**2)
      SSWZF7=RES
      RETURN
      END
+EOD
+DECK,SSXINT
        REAL FUNCTION SSXINT(XL,F,XR)
C-----------------------------------------------------------------------
C          Integrate F over (XL,XR) using adaptive Gaussian quadrature.
C          TOLABS = 1e-35: absolute error for convergence.
C          TOLREL = 5e-5:  relative error for convergence.
C          TOLBIN = 1e-3:  relative bin size limit. Set contribution to
C                          zero if bin falls below this.
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
        EXTERNAL F
        INTEGER NMAX
        REAL TOLABS,TOLREL,TOLBIN,XMIN,XLIMS(100)
        REAL R(93),W(93)
        INTEGER PTR(4),NORD(4)
        INTEGER ICOUNT,IBAD
        REAL XL,XR,F
        REAL AA,BB,TVAL,VAL,TOL
        INTEGER NLIMS,I,J
C
        DATA PTR,NORD/4,10,22,46,  6,12,24,48/
        DATA R/.2386191860,.6612093865,.9324695142,
     1 .1252334085,.3678314990,.5873179543,.7699026742,.9041172563,
     1 .9815606342,.0640568929,.1911188675,.3150426797,.4337935076,
     1 .5454214714,.6480936519,.7401241916,.8200019860,.8864155270,
     1 .9382745520,.9747285560,.9951872200,.0323801710,.0970046992,
     1 .1612223561,.2247637903,.2873624873,.3487558863,.4086864820,
     1 .4669029048,.5231609747,.5772247261,.6288673968,.6778723796,
     1 .7240341309,.7671590325,.8070662040,.8435882616,.8765720203,
     1 .9058791367,.9313866907,.9529877032,.9705915925,.9841245837,
     1 .9935301723,.9987710073,.0162767488,.0488129851,.0812974955,
     1 .1136958501,.1459737146,.1780968824,.2100313105,.2417431561,
     1 .2731988126,.3043649444,.3352085229,.3656968614,.3957976498,
     1 .4254789884,.4547094222,.4834579739,.5116941772,.5393881083,
     1 .5665104186,.5930323648,.6189258401,.6441634037,.6687183100,
     1 .6925645366,.7156768123,.7380306437,.7596023411,.7803690438,
     1 .8003087441,.8194003107,.8376235112,.8549590334,.8713885059,
     1 .8868945174,.9014606353,.9150714231,.9277124567,.9393703398,
     1 .9500327178,.9596882914,.9683268285,.9759391746,.9825172636,
     1 .9880541263,.9925439003,.9959818430,.9983643759,.9996895039/
        DATA W/.4679139346,.3607615730,.1713244924,
     1 .2491470458,.2334925365,.2031674267,.1600783285,.1069393260,
     1 .0471753364,.1279381953,.1258374563,.1216704729,.1155056681,
     1 .1074442701,.0976186521,.0861901615,.0733464814,.0592985849,
     1 .0442774388,.0285313886,.0123412298,.0647376968,.0644661644,
     1 .0639242386,.0631141923,.0620394232,.0607044392,.0591148397,
     1 .0572772921,.0551995037,.0528901894,.0503590356,.0476166585,
     1 .0446745609,.0415450829,.0382413511,.0347772226,.0311672278,
     1 .0274265097,.0235707608,.0196161605,.0155793157,.0114772346,
     1 .0073275539,.0031533461,.0325506145,.0325161187,.0324471637,
     1 .0323438226,.0322062048,.0320344562,.0318287589,.0315893308,
     1 .0313164256,.0310103326,.0306713761,.0302999154,.0298963441,
     1 .0294610900,.0289946142,.0284974111,.0279700076,.0274129627,
     1 .0268268667,.0262123407,.0255700360,.0249006332,.0242048418,
     1 .0234833991,.0227370697,.0219666444,.0211729399,.0203567972,
     1 .0195190811,.0186606796,.0177825023,.0168854799,.0159705629,
     1 .0150387210,.0140909418,.0131282296,.0121516047,.0111621020,
     1 .0101607705,.0091486712,.0081268769,.0070964708,.0060585455,
     1 .0050142027,.0039645543,.0029107318,.0018539608,.0007967921/
C
      DATA TOLABS,TOLREL,TOLBIN,NMAX/1.E-35,5.E-5,1E-3,100/
C
      SSXINT=0
      NLIMS=2
      XLIMS(1)=XL
      XLIMS(2)=XR
      ICOUNT = 0
      IBAD=0
      XMIN=TOLBIN*ABS(XR-XL)
C
10    AA=(XLIMS(NLIMS)-XLIMS(NLIMS-1))/2
      BB=(XLIMS(NLIMS)+XLIMS(NLIMS-1))/2
      TVAL=0
      DO 15 I=1,3
15    TVAL=TVAL+W(I)*(F(BB+AA*R(I))+F(BB-AA*R(I)))
      TVAL=TVAL*AA
      DO 25 J=1,4
        VAL=0
        DO 20 I=PTR(J),PTR(J)-1+NORD(J)
          ICOUNT = ICOUNT + 1
          IF (ICOUNT .GT. 1E5) THEN
            WRITE(LOUT,*) 'ERROR IN SSXINT: SET SSXINT = 0'
            SSXINT=0
            RETURN
          ENDIF
20      VAL=VAL+W(I)*(F(BB+AA*R(I))+F(BB-AA*R(I)))
        VAL=VAL*AA
        TOL=MAX(TOLABS,TOLREL*ABS(VAL))
        IF (ABS(TVAL-VAL).LT.TOL) THEN
          SSXINT=SSXINT+VAL
          NLIMS=NLIMS-2
          IF (NLIMS.NE.0) GO TO 10
          GO TO 999
        ELSEIF(ABS(AA).LT.XMIN.AND.J.EQ.4) THEN
C           Bin is too small -- set VAL = 0. -- FEP
          IBAD=IBAD+1
          NLIMS=NLIMS-2
          IF (NLIMS.NE.0) GO TO 10
          GO TO 999
        ENDIF
25    TVAL=VAL
      IF (NMAX.EQ.2) THEN
        SSXINT=VAL
        GO TO 999
      END IF
      IF (NLIMS.GT.(NMAX-2)) THEN
        WRITE(LOUT,50) SSXINT,NMAX,BB-AA,BB+AA
50      FORMAT (' ERROR IN SSXINT, SSXINT,NMAX,XL,XR=',G15.7,I5,2G15.7)
        RETURN
      END IF
      XLIMS(NLIMS+1)=BB
      XLIMS(NLIMS+2)=BB+AA
      XLIMS(NLIMS)=BB
      NLIMS=NLIMS+2
      GO TO 10
C
999   IF(IBAD.GT.0) THEN
        WRITE(LOUT,*) 'WARNING IN SSXINT: BAD CONVERGENCE FOR ',IBAD,
     $  ' INTERVALS.'
      ENDIF
      RETURN
      END
+EOD
+DECK,SSXLAM
      REAL FUNCTION SSXLAM(A,B,C)
C-----------------------------------------------------------------------
C          Kinematic function
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL A,B,C
C          Rewrite SSXLAM=A**2+B**2+C**2-2*A*B-2*A*C-2*B*C
      IF(A.GE.B.AND.A.GE.C) THEN
        SSXLAM=(A-B-C)**2-4*B*C
      ELSEIF(B.GE.A.AND.B.GE.C) THEN
        SSXLAM=(B-A-C)**2-4*A*C
      ELSE
        SSXLAM=(C-A-B)**2-4*A*B
      ENDIF
      RETURN
      END
+EOD
+DECK,SSZHX
      FUNCTION SSZHX(X)
C----------------------------------------------------------------
C          Auxiliary function for Z -> HL Z*. Called by SSTEST.
C----------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
+CDE,SSTYPE
C
      REAL X,SSZHX
      REAL MHL,MZ,GZ,R,DEN,TERM
C
      MHL=TMP(1)
      MZ=AMZ
      GZ=GAMZ
      R=MHL/MZ
      TERM=(1.-X+X**2/12.+2*R**2/3.)*SQRT(X**2-4*R**2)
      DEN=(X-R**2)**2+(GZ/MZ)**2
      SSZHX=TERM/DEN
      RETURN
      END
+EOD
+DECK,SSZIBF
        SUBROUTINE SSZIBF
C-----------------------------------------------------------------------
C       This subroutine calculates the neutralino (zi) subset of
C       SSWZBF, which was too long.
C       Valid for all scalar masses (functions in double precision)
C       Includes Higgs sector radiative corrections (Aug. 31)
C
C       Auxiliary functions are called SSWxyi, SSZxyi, where normally
C       x indicates the SUSY particle, y the SM particle(s), and i is
C       a counter.
C
C       Require a mass gap PSGAP = 1.0 GeV for 3-body decays.
C
C       Part of Baer's GAUGBF
C
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSMODE
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTYPE
+CDE,SSTMP
+CDE,SSPOLS
C
      EXTERNAL SSZWF1,SSZZF1,SSZZF2,SSZZF3,SSWZF1,SSWZF2,SSWZF3
     $,SSWZF4,SSWZF5,SSWZF6,SSWZF7,SSWWF1,SSZZF4,SSZZF5,SSGX1
     $,SSGX2,SSGX8
C
C     Tadas added
C
      EXTERNAL SSZZG1,SSZZG2,SSZZG3,SSZZG4
      REAL ZAUIP(4), ZBUIP(4), ZADIP(4), ZBDIP(4), ZALIP(4),
     $ZBLIP(4), ZDI1(4), ZDI2(4), ZEI1(4), ZEI2(4), ZAI1(4),
     $ZAI2(4), ZAI3(4), ZAI4(4), ALPH1(4), ALPH2(4),
     $BET1(4), BET2(4)
      REAL SNIZF, MZIZF, IHW, JHW, KHW, I2HW
      INTEGER TIZ, IIZ, ISZIZF, THIW1, THIW2, THIZF
      COMPLEX GEFF, CI, CJ, C00, IMAG
      PARAMETER (IMAG=(0,1))
C
C     End of Tadas
C
      REAL AUI(4),BUI(4),ADI(4),BDI(4),ALI(4),BLI(4),ANI(4),BNI(4)
     $,WIJ(4,4),AUWI(4),ADWI(4),ANWI(4),ALWI(4),XIM(4),YIM(4)
     $,XIP(4),YIP(4),SNIJ(4,4),XLIJ(4,4),HIJ(4,4)
     $,V1I(4),V2I(4),V3I(4),V4I(4),XHIJ(4,4),XPIJ(4,4),AMWISS(2)
C
      INTEGER ISZ(4),THIZ,THJZ
C
      REAL MWIW,SL,PP,SP,PL,MZIZ,PH,SH,COSB,SINB,COSA,SINA
     $,MZJZ,FAC,COSBE,SINBE
      REAL STHW,CTHW
      REAL EF,A,B,TANB,FB,FT,SR2,G,PI,GP,FL
     $,MW2,SNW1,MW1,YM,BE,SNW2,XM,THX,THY
     $,BTN,APD,APL,APU,BTD,BTL,APN,BTU
      REAL TANW,COTW,XWINO,YWINO,SN,SNIW,SNJZ
      REAL SSXINT,SSXLAM
      REAL WID,WIDEE,E,
     $TERMLL,TERMRR,TERMZZ,TERMLZ,TERMRZ,TERMLH
      REAL FACT,ALIZ1,ALJZ1,ALIZ2,ALJZ2,BEIZ1,BEJZ1,BEIZ2,BEJZ2,
     $SGNIJ,XUPPER,GLLF1,GRRF1,GLRF1,GF1,GLLF2,GRRF2,GLRF2,GF2,
     $GLGL,GRGR,GLGR,GRGL,GF12,GF,TERMHL,TERMHH,TERMHA,
     $TERM1Z,TERM2Z,TERM1L,TERM2L,TERM1H,TERM2H,TERM1A,TERM2A
      REAL COSL,SINL,BPWI(2),BPLWI(2)
      REAL BWI(2),AS,BS,COST,SINT,SNIZ
      REAL GLLF1L,GRRF1R,GLGLL,GRGRR,GLLF2L,GRRF2R,TMZZRL,TMZZLR,
     $TM1ZRL,TM1ZLR,TM2ZRL,TM2ZLR
      REAL SUALFE,MTAMTA,MTAMB,MTAMZ,AMPL
      REAL FUDGE,PSGAP
      COMPLEX ZI,ZONE,ZA,ZB,ZPP,ZPM,ZAUIZ,ZBUIZ,ZADIZ,ZBDIZ,
     $ZALIZ,ZBLIZ,Z1(2),Z2(2)
      INTEGER IW,JZ,IZ,ISZIZ,ISWIW
      DATA FUDGE/1.0/
      DATA ZONE/(1.,0.)/,ZI/(0.,1.)/
      DATA PSGAP/1.0/
C
C          Constants from neutralino mass matrix
C
      AMPL=2.4E18
      PI=4.*ATAN(1.)
      SR2=SQRT(2.)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*SQRT(SN2THW/(1.-SN2THW))
      E=SQRT(4*PI/128.)
C
      TANW=SQRT(SN2THW/(1.-SN2THW))
      COTW=1./TANW
      STHW=SQRT(SN2THW)
      CTHW=SQRT(1.-SN2THW)
      APL=.25*(3*TANW-COTW)
      BTL=.25*(COTW+TANW)
      APN=.25*(TANW+COTW)
      BTN=-.25*(COTW+TANW)
      APU=-5*TANW/12.+COTW/4.
      BTU=-.25*(COTW+TANW)
      APD=-COTW/4.+TANW/12.
      BTD=.25*(COTW+TANW)
C
      TANB=1./RV2V1
      BE=ATAN(1./RV2V1)
      SINBE=SIN(BE)
      COSBE=COS(BE)
      XM=1./TAN(GAMMAL)
      YM=1./TAN(GAMMAR)
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)
      FB=G*MBQ/SR2/AMW/COS(BE)
      FT=G*MTQ/SR2/AMW/SIN(BE)
C      MTAMTA=AMTAU*(1.-SUALFE(AMTAU**2)/PI)
C      MTAMB=MTAMTA*(SUALFE(AMBT**2)/SUALFE(AMTAU**2))**(-27./76.)
C      MTAMZ=MTAMB*(SUALFE(AMZ**2)/SUALFE(AMBT**2))**(-27./80.)
      MTAMZ=MLQ
      FL=G*MTAMZ/SR2/AMW/COS(BE)
      SNW1=SIGN(1.,AMW1SS)
      SNW2=SIGN(1.,AMW2SS)
      AMWISS(1)=AMW1SS
      AMWISS(2)=AMW2SS
      BWI(1)=-FT*SNW1*COS(GAMMAR)
      BWI(2)=FT*SNW2*THY*SIN(GAMMAR)
      BPWI(1)=-FB*COS(GAMMAL)
      BPWI(2)=FB*THX*SIN(GAMMAL)
      BPLWI(1)=-FL*COS(GAMMAL)
      BPLWI(2)=FL*THX*SIN(GAMMAL)
      MW1=ABS(AMW1SS)
      MW2=ABS(AMW2SS)
      XWINO=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)
     $-THY*SIN(GAMMAR)*COS(GAMMAR))
      YWINO=.5*(THX*SIN(GAMMAL)*COS(GAMMAL)
     $+THY*SIN(GAMMAR)*COS(GAMMAR))
      COST=COS(THETAT)
      SINT=SIN(THETAT)
      COSB=COS(THETAB)
      SINB=SIN(THETAB)
      COSL=COS(THETAL)
      SINL=SIN(THETAL)
C
C          Constants from Higgs mass matrix
C
      SINA=SIN(ALFAH)
      COSA=COS(ALFAH)
C
C          Gaugino couplings
C
      DO 100 IZ=1,4
        AUI(IZ)=G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ)
        BUI(IZ)=4.*GP/3./SR2*ZMIXSS(4,IZ)
        ADI(IZ)=-G/SR2*ZMIXSS(3,IZ)+GP/3./SR2*ZMIXSS(4,IZ)
        BDI(IZ)=-2.*GP/3./SR2*ZMIXSS(4,IZ)
        ALI(IZ)=G/SR2*ZMIXSS(3,IZ)+GP/SR2*ZMIXSS(4,IZ)
        BLI(IZ)=-SR2*GP*ZMIXSS(4,IZ)
        ANI(IZ)=G/SR2*ZMIXSS(3,IZ)-GP/SR2*ZMIXSS(4,IZ)
        BNI(IZ)=0.0
100   CONTINUE
C
      DO 110 IZ=1,4
      DO 110 JZ=1,4
        IF(IZ.LT.JZ) THEN
          WIJ(IZ,JZ)=SQRT(G**2+GP**2)
     $    *(ZMIXSS(1,IZ)*ZMIXSS(1,JZ)-ZMIXSS(2,IZ)*ZMIXSS(2,JZ))/4.
        ELSEIF(IZ.GT.JZ) THEN
          WIJ(IZ,JZ)=-SQRT(G**2+GP**2)
     $    *(ZMIXSS(1,IZ)*ZMIXSS(1,JZ)-ZMIXSS(2,IZ)*ZMIXSS(2,JZ))/4.
        ENDIF
110   CONTINUE
C
      AUWI(2)=G*THX*COS(GAMMAL)
      ADWI(2)=SNW2*G*THY*COS(GAMMAR)
      ALWI(2)=ADWI(2)
      ANWI(2)=AUWI(2)
      AUWI(1)=G*SIN(GAMMAL)
      ADWI(1)=SNW1*G*SIN(GAMMAR)
      ALWI(1)=ADWI(1)
      ANWI(1)=AUWI(1)
C
      DO 120 IZ=1,4
        XIM(IZ)=.5*(SNW1*SIGN(1.,AMZISS(IZ))*(COS(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ))-COS(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ))
        YIM(IZ)=.5*(-SNW1*SIGN(1.,AMZISS(IZ))*(COS(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,IZ))-COS(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,IZ))
        XIP(IZ)=.5*(SNW2*SIGN(1.,AMZISS(IZ))*THY*(-SIN(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ))+THX*(SIN(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ)))
        YIP(IZ)=.5*(-SNW2*SIGN(1.,AMZISS(IZ))*THY*(-SIN(GAMMAR)
     $  *ZMIXSS(1,IZ)/SR2+COS(GAMMAR)*ZMIXSS(3,IZ))+THX*(SIN(GAMMAL)
     $  *ZMIXSS(2,IZ)/SR2+COS(GAMMAL)*ZMIXSS(3,IZ)))
120   CONTINUE
C
      DO 130 IZ=1,4
      DO 130 JZ=1,4
        IF(IZ.NE.JZ) THEN
          SNIJ(IZ,JZ)=-1.*SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
          XLIJ(IZ,JZ)=-SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*SINA-ZMIXSS(1,IZ)*COSA)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
          XHIJ(IZ,JZ)=-SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*COSA+ZMIXSS(1,IZ)*SINA)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
          XPIJ(IZ,JZ)=SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*SINBE-ZMIXSS(1,IZ)*COSBE)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
          HIJ(IZ,JZ)=-SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
     $    *(ZMIXSS(2,IZ)*COSA+ZMIXSS(1,IZ)*SINA)
     $    *(G*ZMIXSS(3,JZ)-GP*ZMIXSS(4,JZ))/2.
        ENDIF
130   CONTINUE
C
      SP=-.5*(-THY*SNW2*COSBE*SIN(GAMMAL)*SIN(GAMMAR)+
     $THY*SNW2*SINBE*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*COSBE*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*SINBE*SIN(GAMMAL)*SIN(GAMMAR))
      PP=-.5*(-THY*SNW2*COSBE*SIN(GAMMAL)*SIN(GAMMAR)+
     $THY*SNW2*SINBE*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*COSBE*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*SINBE*SIN(GAMMAL)*SIN(GAMMAR))
C
      SL=.5*(THY*SNW2*SINA*COS(GAMMAL)*COS(GAMMAR)-
     $THY*SNW2*COSA*SIN(GAMMAL)*SIN(GAMMAR)+
     $THX*SNW1*COSA*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*SINA*SIN(GAMMAL)*SIN(GAMMAR))
      PL=.5*(THY*SNW2*SINA*COS(GAMMAL)*COS(GAMMAR)-
     $THY*SNW2*COSA*SIN(GAMMAL)*SIN(GAMMAR)-
     $THX*SNW1*COSA*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*SINA*SIN(GAMMAL)*SIN(GAMMAR))
C
      SH=.5*(THY*SNW2*COSA*COS(GAMMAL)*COS(GAMMAR)+
     $THY*SNW2*SINA*SIN(GAMMAL)*SIN(GAMMAR)-
     $THX*SNW1*SINA*COS(GAMMAL)*COS(GAMMAR)-
     $THX*SNW1*COSA*SIN(GAMMAL)*SIN(GAMMAR))
      PH=.5*(THY*SNW2*COSA*COS(GAMMAL)*COS(GAMMAR)+
     $THY*SNW2*SINA*SIN(GAMMAL)*SIN(GAMMAR)+
     $THX*SNW1*SINA*COS(GAMMAL)*COS(GAMMAR)+
     $THX*SNW1*COSA*SIN(GAMMAL)*SIN(GAMMAR))
C
      DO 140 IZ=1,4
        V1I(IZ)=-SIN(GAMMAR)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  -G*COS(GAMMAR)*ZMIXSS(1,IZ)
        V2I(IZ)=COS(GAMMAR)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  -G*SIN(GAMMAR)*ZMIXSS(1,IZ)
        V3I(IZ)=-SIN(GAMMAL)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  +G*COS(GAMMAL)*ZMIXSS(2,IZ)
        V4I(IZ)=COS(GAMMAL)/SR2*(G*ZMIXSS(3,IZ)+GP*ZMIXSS(4,IZ))
     $  +G*SIN(GAMMAL)*ZMIXSS(2,IZ)
140   CONTINUE
C-----------------------------------------------------------------------
C          Generate Neutralino zi Branching Fractions
C-----------------------------------------------------------------------
      ISZ(1)=ISZ1
      ISZ(2)=ISZ2
      ISZ(3)=ISZ3
      ISZ(4)=ISZ4
C
      DO 200 IZ=2,4
        MZIZ=ABS(AMZISS(IZ))
        SNIZ=SIGN(1.,AMZISS(IZ))
        IF (SNIZ.EQ.1.) THEN
           THIZ=0
        ELSE
           THIZ=1
        END IF
        ISZIZ=ISZ(IZ)
C          z2 --> z1 + photon
C          !!! NEEDS UPDATING
C       Tadas commented
C        IF (IZ.EQ.2.AND.(ABS(ZMIXSS(3,1)).LE.1.E-4).AND.
C     $  (ABS(ZMIXSS(4,1)).LE.1.E-4)) THEN
C          CALL SSSAVE(ISZ2,1.,ISZ1,IDGM,0,0,0)
C          GOTO 200
C        END IF
C       Tadas comment ends
C
C       Tadas begins
C
        IF (SNW1.EQ.1.) THEN
           THIW1=0
        ELSE
           THIW1=1
        END IF
        IF (SNW2.EQ.1.) THEN
           THIW2=0
        ELSE
           THIW2=1
        END IF
C       Coefficient definitions
      DO TIZ=1,4
C       For M_abcd
        ZAUIP(TIZ)=G/SR2*ZMIXSS(3,TIZ)+GP/3./SR2*ZMIXSS(4,TIZ)
        ZBUIP(TIZ)=-4.*GP/3./SR2*ZMIXSS(4,TIZ)
        ZADIP(TIZ)=-G/SR2*ZMIXSS(3,TIZ)+GP/3./SR2*ZMIXSS(4,TIZ)
        ZBDIP(TIZ)=2.*GP/3./SR2*ZMIXSS(4,TIZ)
        ZALIP(TIZ)=-G/SR2*ZMIXSS(3,TIZ)-GP/SR2*ZMIXSS(4,TIZ)
        ZBLIP(TIZ)=SR2*GP*ZMIXSS(4,TIZ)
C       For M_efgh
        ZDI1(TIZ)=G*(-1)**THIW1*(COS(GAMMAR)
     $*ZMIXSS(1,TIZ)/SR2+SIN(GAMMAR)*ZMIXSS(3,TIZ))
        ZDI2(TIZ)=G*THY*(-1)**THIW2*(-SIN(GAMMAR)
     $*ZMIXSS(1,TIZ)/SR2+COS(GAMMAR)*ZMIXSS(3,TIZ))
        ZEI1(TIZ)=G*(-COS(GAMMAL)
     $*ZMIXSS(2,TIZ)/SR2+SIN(GAMMAL)*ZMIXSS(3,TIZ))
        ZEI2(TIZ)=G*THX*(SIN(GAMMAL)
     $*ZMIXSS(2,TIZ)/SR2+COS(GAMMAL)*ZMIXSS(3,TIZ))
C       For M_ijkl
        ZAI1(TIZ)=-(G*ZMIXSS(3,TIZ)+GP*ZMIXSS(4,TIZ))*SIN(GAMMAR)
     $/SR2-G*ZMIXSS(1,TIZ)*COS(GAMMAR)
        ZAI2(TIZ)=(G*ZMIXSS(3,TIZ)+GP*ZMIXSS(4,TIZ))*COS(GAMMAR)
     $/SR2-G*ZMIXSS(1,TIZ)*SIN(GAMMAR)
        ZAI3(TIZ)=-(G*ZMIXSS(3,TIZ)+GP*ZMIXSS(4,TIZ))*SIN(GAMMAL)
     $/SR2+G*ZMIXSS(2,TIZ)*COS(GAMMAL)
        ZAI4(TIZ)=(G*ZMIXSS(3,TIZ)+GP*ZMIXSS(4,TIZ))*COS(GAMMAL)
     $/SR2+G*ZMIXSS(2,TIZ)*SIN(GAMMAL)
      ENDDO
C       Coefficient definitions end
      DO 22213 IIZ=1,IZ-1
        ISZIZF=ISZ(IIZ)
        MZIZF=ABS(AMZISS(IIZ))
        SNIZF=SIGN(1.,AMZISS(IIZ))
        IF (SNIZF.EQ.1.) THEN
           THIZF=0
        ELSE
           THIZF=1
        END IF
        TMP(3)=MZIZ
        TMP(4)=MZIZF
C
C       Calculating M_abcd
C
C       Top quark terms
      TIZ=IZ
        ALPH1(TIZ)=ZAUIP(TIZ)*COST-FT*ZMIXSS(1,TIZ)*SINT
        ALPH2(TIZ)=ZAUIP(TIZ)*SINT+FT*ZMIXSS(1,TIZ)*COST
        BET1(TIZ)=-ZBUIP(TIZ)*SINT+FT*ZMIXSS(1,TIZ)*COST
        BET2(TIZ)=ZBUIP(TIZ)*COST+FT*ZMIXSS(1,TIZ)*SINT
      TIZ=IIZ
        ALPH1(TIZ)=ZAUIP(TIZ)*COST-FT*ZMIXSS(1,TIZ)*SINT
        ALPH2(TIZ)=ZAUIP(TIZ)*SINT+FT*ZMIXSS(1,TIZ)*COST
        BET1(TIZ)=-ZBUIP(TIZ)*SINT+FT*ZMIXSS(1,TIZ)*COST
        BET2(TIZ)=ZBUIP(TIZ)*COST+FT*ZMIXSS(1,TIZ)*SINT
      TMP(1)=AMTP
      TMP(2)=AMT1SS
      IF (MZIZ.LT.(AMTP+AMT1SS)) THEN
        IHW=SSXINT(0.,SSZZG1,1.)
        KHW=SSXINT(0.,SSZZG3,1.)
        I2HW=SSXINT(0.,SSZZG2,1.)
        CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
        CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
        C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
        GEFF=3.*2.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMTP*C00*IHW)
      ELSE
        GEFF=0.
      ENDIF
      TMP(2)=AMT2SS
      IF (MZIZ.LT.(AMTP+AMT2SS)) THEN
        IHW=SSXINT(0.,SSZZG1,1.)
        KHW=SSXINT(0.,SSZZG3,1.)
        I2HW=SSXINT(0.,SSZZG2,1.)
        CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH2(IIZ)*ALPH2(IZ)
     $-BET2(IIZ)*BET2(IZ))
        CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH2(IIZ)*ALPH2(IZ)
     $-BET2(IIZ)*BET2(IZ))
        C00=IMAG**(THIZ+THIZF)*(BET2(IIZ)*ALPH2(IZ)
     $-BET2(IZ)*ALPH2(IIZ))
        GEFF=GEFF+3.*2.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMTP*C00*IHW)
      ENDIF
C       Bottom quark terms
      TIZ=IZ
        ALPH1(TIZ)=ZADIP(TIZ)*COSB-FB*ZMIXSS(2,TIZ)*SINB
        ALPH2(TIZ)=ZADIP(TIZ)*SINB+FB*ZMIXSS(2,TIZ)*COSB
        BET1(TIZ)=-ZBDIP(TIZ)*SINB+FB*ZMIXSS(2,TIZ)*COSB
        BET2(TIZ)=ZBDIP(TIZ)*COSB+FB*ZMIXSS(2,TIZ)*SINB
      TIZ=IIZ
        ALPH1(TIZ)=ZADIP(TIZ)*COSB-FB*ZMIXSS(2,TIZ)*SINB
        ALPH2(TIZ)=ZADIP(TIZ)*SINB+FB*ZMIXSS(2,TIZ)*COSB
        BET1(TIZ)=-ZBDIP(TIZ)*SINB+FB*ZMIXSS(2,TIZ)*COSB
        BET2(TIZ)=ZBDIP(TIZ)*COSB+FB*ZMIXSS(2,TIZ)*SINB
      TMP(1)=AMBT
      TMP(2)=AMB1SS
      IF (MZIZ.LT.(AMBT+AMB1SS)) THEN
        IHW=SSXINT(0.,SSZZG1,1.)
        KHW=SSXINT(0.,SSZZG3,1.)
        I2HW=SSXINT(0.,SSZZG2,1.)
        CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
        CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
        C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
        GEFF=GEFF-3.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMBT*C00*IHW)
      ENDIF
      TMP(2)=AMB2SS
      IF (MZIZ.LT.(AMBT+AMB2SS)) THEN
        IHW=SSXINT(0.,SSZZG1,1.)
        KHW=SSXINT(0.,SSZZG3,1.)
        I2HW=SSXINT(0.,SSZZG2,1.)
        CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH2(IIZ)*ALPH2(IZ)
     $-BET2(IIZ)*BET2(IZ))
        CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH2(IIZ)*ALPH2(IZ)
     $-BET2(IIZ)*BET2(IZ))
        C00=IMAG**(THIZ+THIZF)*(BET2(IIZ)*ALPH2(IZ)
     $-BET2(IZ)*ALPH2(IIZ))
        GEFF=GEFF-3.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMBT*C00*IHW)
      ENDIF
C       Tau lepton term
      TIZ=IZ
        ALPH1(TIZ)=ZALIP(TIZ)*COSL-FL*ZMIXSS(2,TIZ)*SINL
        ALPH2(TIZ)=ZALIP(TIZ)*SINL+FL*ZMIXSS(2,TIZ)*COSL
        BET1(TIZ)=-ZBLIP(TIZ)*SINL+FL*ZMIXSS(2,TIZ)*COSL
        BET2(TIZ)=ZBLIP(TIZ)*COSL+FL*ZMIXSS(2,TIZ)*SINL
      TIZ=IIZ
        ALPH1(TIZ)=ZALIP(TIZ)*COSL-FL*ZMIXSS(2,TIZ)*SINL
        ALPH2(TIZ)=ZALIP(TIZ)*SINL+FL*ZMIXSS(2,TIZ)*COSL
        BET1(TIZ)=-ZBLIP(TIZ)*SINL+FL*ZMIXSS(2,TIZ)*COSL
        BET2(TIZ)=ZBLIP(TIZ)*COSL+FL*ZMIXSS(2,TIZ)*SINL
      TMP(1)=AMTAU
      TMP(2)=AML1SS
      IF (MZIZ.LT.(AMTAU+AML1SS)) THEN
      IHW=SSXINT(0.,SSZZG1,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMTAU*C00*IHW)
      ENDIF
      TMP(2)=AML2SS
      IF (MZIZ.LT.(AMTAU+AML2SS)) THEN
      IHW=SSXINT(0.,SSZZG1,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMTAU*C00*IHW)
      ENDIF
C       Other leptons and quarks; Mixing angle is 0
C       Electron
      TIZ=IZ
        ALPH1(TIZ)=ZALIP(TIZ)
        ALPH2(TIZ)=0.
        BET1(TIZ)=0.
        BET2(TIZ)=ZBLIP(TIZ)
      TIZ=IIZ
        ALPH1(TIZ)=ZALIP(TIZ)
        ALPH2(TIZ)=0.
        BET1(TIZ)=0.
        BET2(TIZ)=ZBLIP(TIZ)
      TMP(1)=AME
      TMP(2)=AMELSS
      IF (MZIZ.LT.(AME+AMELSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AME*C00*IHW)
      ENDIF
      TMP(2)=AMERSS
      IF (MZIZ.LT.(AME+AMERSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AME*C00*IHW)
      ENDIF
C       Muon
      TIZ=IZ
        ALPH1(TIZ)=ZALIP(TIZ)
        ALPH2(TIZ)=0.
        BET1(TIZ)=0.
        BET2(TIZ)=ZBLIP(TIZ)
      TIZ=IIZ
        ALPH1(TIZ)=ZALIP(TIZ)
        ALPH2(TIZ)=0.
        BET1(TIZ)=0.
        BET2(TIZ)=ZBLIP(TIZ)
      TMP(1)=AMMU
      TMP(2)=AMMLSS
      IF (MZIZ.LT.(AMMU+AMMLSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMMU*C00*IHW)
      ENDIF
      TMP(2)=AMMRSS
      IF (MZIZ.LT.(AMMU+AMMRSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMMU*C00*IHW)
      ENDIF
C       Down quark
      TIZ=IZ
        ALPH1(TIZ)=ZADIP(TIZ)
c        ALPH2(TIZ)=0.
c        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMDN*ZMIXSS(2,TIZ)/SR2/AMW/COSBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBDIP(TIZ)
      TIZ=IIZ
        ALPH1(TIZ)=ZADIP(TIZ)
c        ALPH2(TIZ)=0.
c        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMDN*ZMIXSS(2,TIZ)/SR2/AMW/COSBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBDIP(TIZ)
      TMP(1)=AMDN
      TMP(2)=AMDLSS
      IF (MZIZ.LT.(AMDN+AMDLSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-3.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMDN*C00*IHW)
      ENDIF
      TMP(2)=AMDRSS
      IF (MZIZ.LT.(AMDN+AMDRSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-3.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMDN*C00*IHW)
      ENDIF
C       Strange quark
      TIZ=IZ
        ALPH1(TIZ)=ZADIP(TIZ)
C        ALPH2(TIZ)=0.
C        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMST*ZMIXSS(2,TIZ)/SR2/AMW/COSBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBDIP(TIZ)
      TIZ=IIZ
        ALPH1(TIZ)=ZADIP(TIZ)
C        ALPH2(TIZ)=0.
C        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMST*ZMIXSS(2,TIZ)/SR2/AMW/COSBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBDIP(TIZ)
      TMP(1)=AMST
      TMP(2)=AMSLSS
      IF (MZIZ.LT.(AMST+AMSLSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-3.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMST*C00*IHW)
      ENDIF
      TMP(2)=AMSRSS
      IF (MZIZ.LT.(AMST+AMSRSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF-3.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMST*C00*IHW)
      ENDIF
C       Up quark
      TIZ=IZ
        ALPH1(TIZ)=ZAUIP(TIZ)
C        ALPH2(TIZ)=0.
C        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMUP*ZMIXSS(1,TIZ)/SR2/AMW/SINBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBUIP(TIZ)
      TIZ=IIZ
        ALPH1(TIZ)=ZAUIP(TIZ)
C        ALPH2(TIZ)=0.
C        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMUP*ZMIXSS(1,TIZ)/SR2/AMW/SINBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBUIP(TIZ)
      TMP(1)=AMUP
      TMP(2)=AMULSS
      IF (MZIZ.LT.(AMUP+AMULSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF+3.*2.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMUP*C00*IHW)
      ENDIF
      TMP(2)=AMURSS
      IF (MZIZ.LT.(AMUP+AMURSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF+3.*2.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMUP*C00*IHW)
      ENDIF
C       Charm quark
      TIZ=IZ
        ALPH1(TIZ)=ZAUIP(TIZ)
C        ALPH2(TIZ)=0.
C        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMCH*ZMIXSS(1,TIZ)/SR2/AMW/SINBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBUIP(TIZ)
      TIZ=IIZ
        ALPH1(TIZ)=ZAUIP(TIZ)
C        ALPH2(TIZ)=0.
C        BET1(TIZ)=0.
        ALPH2(TIZ)=G*AMCH*ZMIXSS(1,TIZ)/SR2/AMW/SINBE
        BET1(TIZ)=ALPH2(TIZ)
        BET2(TIZ)=ZBUIP(TIZ)
      TMP(1)=AMCH
      TMP(2)=AMCLSS
      IF (MZIZ.LT.(AMCH+AMCLSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF+3.*2.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMCH*C00*IHW)
      ENDIF 
      TMP(2)=AMCRSS
      IF (MZIZ.LT.(AMCH+AMCRSS)) THEN
C          Divergent for mf=0 but multiplied by mf
C     IHW=SSXINT(0.,SSZZG1,1.)
      IHW=0
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ALPH1(IIZ)*ALPH1(IZ)
     $-BET1(IIZ)*BET1(IZ))
      C00=IMAG**(THIZ+THIZF)*(BET1(IIZ)*ALPH1(IZ)
     $-BET1(IZ)*ALPH1(IIZ))
      GEFF=GEFF+3.*2.*E/3./16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+AMCH*C00*IHW)
      ENDIF
C
C       Calculating M_efgh
C
      TMP(2)=AMW
      TMP(1)=MW1
      IF (MZIZ.LT.(AMW+MW1)) THEN
      JHW=SSXINT(0.,SSZZG4,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ZDI1(IIZ)*ZDI1(IZ)
     $-ZEI1(IIZ)*ZEI1(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ZDI1(IIZ)*ZDI1(IZ)
     $-ZEI1(IIZ)*ZEI1(IZ))
      C00=IMAG**(THIZ+THIZF)*(ZEI1(IIZ)*ZDI1(IZ)
     $-ZEI1(IZ)*ZDI1(IIZ))
      GEFF=GEFF-E/8./PI**2*(-MZIZF*CI*(JHW-KHW)+MZIZ*
     $CJ*(I2HW-JHW-KHW)+2*MW1*C00*JHW)
      ENDIF
      TMP(1)=MW2
      IF (MZIZ.LT.(AMW+MW2)) THEN
      JHW=SSXINT(0.,SSZZG4,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(ZDI2(IIZ)*ZDI2(IZ)
     $-ZEI2(IIZ)*ZEI2(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(ZDI2(IIZ)*ZDI2(IZ)
     $-ZEI2(IIZ)*ZEI2(IZ))
      C00=IMAG**(THIZ+THIZF)*(ZEI2(IIZ)*ZDI2(IZ)
     $-ZEI2(IZ)*ZDI2(IIZ))
      GEFF=GEFF-E/8./PI**2*(-MZIZF*CI*(JHW-KHW)+MZIZ*
     $CJ*(I2HW-JHW-KHW)+2*MW2*C00*JHW)
      ENDIF
C
C       Calculating M_ijkl
C
      TMP(2)=AMHC
      TMP(1)=MW1
      IF (MZIZ.LT.(AMHC+MW1)) THEN
      IHW=SSXINT(0.,SSZZG1,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(SINBE**2*ZAI4(IIZ)
     $*ZAI4(IZ)-COSBE**2*ZAI2(IIZ)*ZAI2(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(SINBE**2*ZAI4(IIZ)
     $*ZAI4(IZ)-COSBE**2*ZAI2(IIZ)*ZAI2(IZ))
      C00=-IMAG**(THIZ+THIZF)*(-1)**THIW1*SINBE*COSBE*
     $(ZAI2(IIZ)*ZAI4(IZ)-ZAI2(IZ)*ZAI4(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+MW1*C00*IHW)
      ENDIF
      TMP(1)=MW2
      IF (MZIZ.LT.(AMHC+MW2)) THEN
      IHW=SSXINT(0.,SSZZG1,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(SINBE**2*THX*ZAI3(IIZ)
     $*THX*ZAI3(IZ)-COSBE**2*ZAI1(IIZ)*ZAI1(IZ)*THY**2)
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(SINBE**2*THX*ZAI3(IIZ)
     $*THX*ZAI3(IZ)-COSBE**2*ZAI1(IIZ)*ZAI1(IZ)*THY**2)
      C00=-IMAG**(THIZ+THIZF)*(-1)**THIW2*SINBE*COSBE*
     $THX*THY*(ZAI1(IIZ)*ZAI3(IZ)-ZAI1(IZ)*ZAI3(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+MW2*C00*IHW)
      ENDIF
C
C       Calculating M_mnop
C
      TMP(2)=AMW
      TMP(1)=MW1
      IF (MZIZ.LT.(AMW+MW1)) THEN
      IHW=SSXINT(0.,SSZZG1,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(COSBE**2*ZAI4(IIZ)
     $*ZAI4(IZ)-SINBE**2*ZAI2(IIZ)*ZAI2(IZ))
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(COSBE**2*ZAI4(IIZ)
     $*ZAI4(IZ)-SINBE**2*ZAI2(IIZ)*ZAI2(IZ))
      C00=IMAG**(THIZ+THIZF)*(-1)**THIW1*SINBE*COSBE*
     $(ZAI2(IIZ)*ZAI4(IZ)-ZAI2(IZ)*ZAI4(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+MW1*C00*IHW)
      ENDIF
      TMP(1)=MW2
      IF (MZIZ.LT.(AMW+MW2)) THEN
      IHW=SSXINT(0.,SSZZG1,1.)
      KHW=SSXINT(0.,SSZZG3,1.)
      I2HW=SSXINT(0.,SSZZG2,1.)
      CI=(-IMAG)**THIZF*IMAG**THIZ*(COSBE**2*THX*ZAI3(IIZ)
     $*THX*ZAI3(IZ)-SINBE**2*ZAI1(IIZ)*ZAI1(IZ)*THY**2)
      CJ=-IMAG**THIZF*(-IMAG)**THIZ*(COSBE**2*THX*ZAI3(IIZ)
     $*THX*ZAI3(IZ)-SINBE**2*ZAI1(IIZ)*ZAI1(IZ)*THY**2)
      C00=IMAG**(THIZ+THIZF)*(-1)**THIW2*SINBE*COSBE*
     $THX*THY*(ZAI1(IIZ)*ZAI3(IZ)-ZAI1(IZ)*ZAI3(IIZ))
      GEFF=GEFF-E/16./PI**2*(MZIZF*CI*KHW+MZIZ*
     $CJ*(I2HW-KHW)+MW2*C00*IHW)
      ENDIF
C       Width
      WID=ABS(GEFF)**2*((MZIZ**2-MZIZF**2)/MZIZ)**3/8./PI
      CALL SSSAVE(ISZIZ,WID,ISZIZF,IDGM,0,0,0)
22213   CONTINUE
C
C       Tadas ends
C
C
C          zi --> wi + x partial widths
C
        DO 205 IW=1,2
C          Loop over w1, w2
          IF(IW.EQ.1) THEN
            MWIW=MW1
            SNIW=SNW1
            ISWIW=ISW1
          ELSE
            MWIW=MW2
            SNIW=SNW2
            ISWIW=ISW2
          ENDIF
C
C          zi -> wj + w
C
          IF(MZIZ.GT.MWIW+AMW) THEN
            EF=MZIZ**2+MWIW**2-AMW**2+((MZIZ**2-MWIW**2)**2
     $         -AMW**4)/AMW/AMW
            WID=G*G*SQRT(SSXLAM(MZIZ**2,AMW**2,MWIW**2))/32./PI/
     $          MZIZ**3*(2.*EF*(XIM(IZ)**2+YIM(IZ)**2)-12.*
     $          MZIZ*MWIW*(XIM(IZ)**2-YIM(IZ)**2))
            CALL SSSAVE(ISZIZ,WID,+ISWIW,-IDW,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISWIW,+IDW,0,0,0)
C
C          zi -> wj + f + fbar (w forbidden) ONLY W CONTRIBUTION INCLUDED!
C
          ELSEIF(MZIZ.GT.FUDGE*MWIW+PSGAP) THEN
            TMP(1)=MWIW
            TMP(2)=MZIZ
            IF(IW.EQ.1) THEN
              TMP(3)=XIM(IZ)
              TMP(4)=YIM(IZ)
            ELSE
              TMP(3)=XIP(IZ)
              TMP(4)=YIP(IZ)
            ENDIF
            WID=G**4/96./PI**3/MZIZ
     $      *SSXINT(MWIW,SSZWF1,(MWIW**2+MZIZ**2)/2./MZIZ)
            CALL SSSAVE(ISZIZ,3.*WID,-ISWIW,IDUP,-IDDN,0,0)
            Z1(1)=(-ZI)**THIZ*G*TMP(3)
            Z1(2)=(-ZI)**THIZ*G*TMP(4)
            Z2(1)=G/2./SR2
            Z2(2)=-Z2(1)
            CALL SSME3(1,AMW,Z1,Z2)
            CALL SSSAVE(ISZIZ,WID,-ISWIW,IDNE,-IDE,0,0)
            CALL SSME3(1,AMW,Z1,Z2)
            CALL SSSAVE(ISZIZ,WID,-ISWIW,IDNM,-IDMU,0,0)
            CALL SSME3(1,AMW,Z1,Z2)
            CALL SSSAVE(ISZIZ,3.*WID,ISWIW,IDDN,-IDUP,0,0)
            CALL SSME3(1,AMW,Z1,Z2)
            CALL SSSAVE(ISZIZ,WID,ISWIW,IDE,-IDNE,0,0)
            CALL SSME3(1,AMW,Z1,Z2)
            CALL SSSAVE(ISZIZ,WID,ISWIW,IDMU,-IDNM,0,0)
            CALL SSME3(1,AMW,Z1,Z2)
            IF (MZIZ.GT.(MWIW+AMCH+AMST+PSGAP)) THEN
              CALL SSSAVE(ISZIZ,3.*WID,-ISWIW,IDCH,-IDST,0,0)
              CALL SSME3(1,AMW,Z1,Z2)
              CALL SSSAVE(ISZIZ,WID,-ISWIW,IDNT,-IDTAU,0,0)
              CALL SSME3(1,AMW,Z1,Z2)
              CALL SSSAVE(ISZIZ,3.*WID,ISWIW,IDST,-IDCH,0,0)
              CALL SSME3(1,AMW,Z1,Z2)
              CALL SSSAVE(ISZIZ,WID,ISWIW,IDTAU,-IDNT,0,0)
              CALL SSME3(1,AMW,Z1,Z2)
            ENDIF
          ENDIF
C
C          zi --> wj + hc
C
          IF (MZIZ.GT.(MWIW+AMHC)) THEN
          IF (IW.EQ.1) THEN 
            A=(SNW1*COSBE*V2I(IZ)-SIGN(1.,AMZISS(IZ))
     $      *SINBE*V4I(IZ))/2.
            B=(SNW1*COSBE*V2I(IZ)+SIGN(1.,AMZISS(IZ))
     $      *SINBE*V4I(IZ))/2.
          ELSE
            A=(THY*SNW2*COSBE*V1I(IZ)-SIGN(1.,AMZISS(IZ))
     $      *THX*SINBE*V3I(IZ))/2.
            B=(THY*SNW2*COSBE*V1I(IZ)+SIGN(1.,AMZISS(IZ))
     $      *THX*SINBE*V3I(IZ))/2.
          END IF
            WID=SQRT(MWIW**4+MZIZ**4+AMHC**4-2.*(MWIW*MZIZ)**2
     $      -2*(MWIW*AMHC)**2-2*(MZIZ*AMHC)**2)/8./PI/MZIZ**3
     $      *((A*A+B*B)*(MWIW*MWIW+MZIZ*MZIZ-AMHC*AMHC)/2.
     $      +(A*A-B*B)*MWIW*MZIZ)
            CALL SSSAVE(ISZIZ,WID,+ISWIW,-ISHC,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISWIW,+ISHC,0,0,0)
          ENDIF
205     CONTINUE
C
C          zi --> zj + z
C
C          Note that if m(zi) > m(zj) + m(z), then the z terms are
C          omitted from the zi -> zj + f + fbar calculation, so there
C          is no double counting with zi -> zj + z.
C
        DO 210 JZ=1,IZ-1
          MZJZ=ABS(AMZISS(JZ))
          IF(MZIZ.GT.(MZJZ+AMZ)) THEN
            SN=-1.*SIGN(1.,AMZISS(IZ))*SIGN(1.,AMZISS(JZ))
            WID=WIJ(JZ,IZ)**2/(2.*PI)/(MZIZ)**3*SQRT(MZIZ**4+MZJZ**4
     $      +AMZ**4-2.*(MZIZ*MZJZ)**2-2.*(MZIZ*AMZ)**2-2.*(MZJZ*AMZ)**2)
     $      *((MZIZ**2+MZJZ**2-AMZ**2)/2.+((MZIZ**2-MZJZ**2)**2-AMZ**4)/
     $      2./AMZ**2-3.*SN*MZIZ*MZJZ)
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDZ,0,0,0)
          END IF
210     CONTINUE
C
C          zi --> zj + f + fbar
C
        DO 220 JZ=1,IZ-1
          MZJZ=ABS(AMZISS(JZ))
          SNJZ=SIGN(1.,AMZISS(JZ))
          IF (SNJZ.EQ.1.) THEN
           THJZ=0
          ELSE
           THJZ=1
          END IF
          IF(MZIZ.LT.FUDGE*MZJZ) GO TO 220
          FAC=1./2./MZIZ/(2.*PI)**5*PI**2*MZIZ**2
C          Leptons -- Z decay allowed, so omit Z
            TMP(1)=MZIZ
            TMP(2)=MZJZ
            TMP(4)=-SNIJ(JZ,IZ)
            TMP(6)=0.
C          zi -> zj + u + ubar
          IF (MZIZ.GT.(MZJZ+2*AMUP+PSGAP)) THEN
            IF (MZIZ.LT.AMULSS) THEN
            TMP(3)=AMULSS
            TERMLL=3*2*AUI(JZ)**2*AUI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.AMURSS) THEN
            TMP(3)=AMURSS
            TERMRR=3*2*BUI(JZ)**2*BUI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMRR=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=3*(APU**2+BTU**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMULSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMULSS
            TERMLZ=3*8*E*(APU-BTU)*WIJ(JZ,IZ)*AUI(JZ)*AUI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            IF (MZIZ.LT.AMURSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMURSS
            TERMRZ=-3*8*E*(APU+BTU)*WIJ(JZ,IZ)*BUI(JZ)*BUI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMRZ=0.
            END IF
            WID=TERMLL+TERMRR+TERMZZ+TERMLZ+TERMRZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDUP,-IDUP,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APU
            Z2(2)=BTU
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*AUI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*AUI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMULSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BUI(IZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*BUI(JZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMURSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*AUI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*AUI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMULSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*BUI(JZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BUI(IZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMURSS,Z1,Z2)
          END IF
C          zi -> zj + d + dbar
          TMP(4)=-SNIJ(JZ,IZ)
          IF (MZIZ.GT.(MZJZ+2*AMDN+PSGAP)) THEN
            IF (MZIZ.LT.AMDLSS) THEN
            TMP(3)=AMDLSS
            TERMLL=3*2*ADI(JZ)**2*ADI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.AMDRSS) THEN
            TMP(3)=AMDRSS
            TERMRR=3*2*BDI(JZ)**2*BDI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMRR=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=3*(APD**2+BTD**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMDLSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMDLSS
            TERMLZ=3*8*E*(APD-BTD)*WIJ(JZ,IZ)*ADI(JZ)*ADI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            IF (MZIZ.LT.AMDRSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMDRSS
            TERMRZ=-3*8*E*(APD+BTD)*WIJ(JZ,IZ)*BDI(JZ)*BDI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMRZ=0.
            END IF
            WID=TERMLL+TERMRR+TERMZZ+TERMLZ+TERMRZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDDN,-IDDN,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APD
            Z2(2)=BTD
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ADI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ADI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMDLSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BDI(IZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*BDI(JZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMDRSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ADI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ADI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMDLSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*BDI(JZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BDI(IZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMDRSS,Z1,Z2)
          END IF
C          zi -> zj + s + sbar
          TMP(4)=-SNIJ(JZ,IZ)
          IF (MZIZ.GT.(MZJZ+2*AMST+PSGAP)) THEN
            IF (MZIZ.LT.AMSLSS) THEN
            TMP(3)=AMSLSS
            TERMLL=3*2*ADI(JZ)**2*ADI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.AMSRSS) THEN
            TMP(3)=AMSRSS
            TERMRR=3*2*BDI(JZ)**2*BDI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMRR=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=3*(APD**2+BTD**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMSLSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMSLSS
            TERMLZ=3*8*E*(APD-BTD)*WIJ(JZ,IZ)*ADI(JZ)*ADI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            IF (MZIZ.LT.AMSRSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMSRSS
            TERMRZ=-3*8*E*(APD+BTD)*WIJ(JZ,IZ)*BDI(JZ)*BDI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMRZ=0.
            END IF
            WID=TERMLL+TERMRR+TERMZZ+TERMLZ+TERMRZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDST,-IDST,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APD
            Z2(2)=BTD
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ADI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ADI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMSLSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BDI(IZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*BDI(JZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMSRSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ADI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ADI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMSLSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*BDI(JZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BDI(IZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMSRSS,Z1,Z2)
          END IF
C          zi -> zj + c + cbar
          TMP(4)=-SNIJ(JZ,IZ)
          IF (MZIZ.GT.(MZJZ+2*AMCH+PSGAP)) THEN
            IF (MZIZ.LT.AMCLSS) THEN
            TMP(3)=AMCLSS
            TERMLL=3*2*AUI(JZ)**2*AUI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.AMCRSS) THEN
            TMP(3)=AMCRSS
            TERMRR=3*2*BUI(JZ)**2*BUI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMRR=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=3*(APU**2+BTU**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMCLSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMCLSS
            TERMLZ=3*8*E*(APU-BTU)*WIJ(JZ,IZ)*AUI(JZ)*AUI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            IF (MZIZ.LT.AMCRSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMCRSS
            TERMRZ=-3*8*E*(APU+BTU)*WIJ(JZ,IZ)*BUI(JZ)*BUI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMRZ=0.
            END IF
            WID=TERMLL+TERMRR+TERMZZ+TERMLZ+TERMRZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDCH,-IDCH,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APU
            Z2(2)=BTU
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*AUI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*AUI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMCLSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BUI(IZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*BUI(JZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMCRSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*AUI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*AUI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMCLSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*BUI(JZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BUI(IZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMCRSS,Z1,Z2)
          END IF
C          zi -> zj + b+ bbar ; mixing/yukawa effects now included!
C                              thanks to M. Drees
          FACT=1./2./(2*PI)**5/2./MZIZ
          ALIZ1=ADI(IZ)*COSB-FB*ZMIXSS(2,IZ)*SINB
          ALJZ1=ADI(JZ)*COSB-FB*ZMIXSS(2,JZ)*SINB
          ALIZ2=ADI(IZ)*SINB+FB*ZMIXSS(2,IZ)*COSB
          ALJZ2=ADI(JZ)*SINB+FB*ZMIXSS(2,JZ)*COSB
          BEIZ1=BDI(IZ)*SINB+FB*ZMIXSS(2,IZ)*COSB
          BEJZ1=BDI(JZ)*SINB+FB*ZMIXSS(2,JZ)*COSB
          BEIZ2=-BDI(IZ)*COSB+FB*ZMIXSS(2,IZ)*SINB
          BEJZ2=-BDI(JZ)*COSB+FB*ZMIXSS(2,JZ)*SINB
          SGNIJ=-SNIJ(JZ,IZ)
          XUPPER=(MZIZ**2+AMBT**2-(AMBT+MZJZ)**2)/2./MZIZ
          IF (MZIZ.GT.(MZJZ+2*AMBT+PSGAP)) THEN
            TMP(1)=MZIZ
            TMP(2)=AMBT
            TMP(3)=MZJZ
            TMP(4)=AMB1SS
            TMP(5)=AMB1SS
            TMP(6)=AMBT
            IF (MZIZ.LT.AMB1SS) THEN
              GLLF1=4*ALIZ1**2*((ALJZ1**2+BEJZ1**2)*
     ,             SSXINT(AMBT,SSGX1,XUPPER)+SGNIJ*ALJZ1**2*
     ,             SSXINT(AMBT,SSGX2,XUPPER))
              GRRF1=4*BEIZ1**2*((ALJZ1**2+BEJZ1**2)*
     ,             SSXINT(AMBT,SSGX1,XUPPER)+SGNIJ*BEJZ1**2*
     ,             SSXINT(AMBT,SSGX2,XUPPER))
              GLRF1=-8*ALIZ1*BEIZ1*ALJZ1*BEJZ1*
     ,               SSXINT(AMBT,SSGX8,XUPPER)
              GF1=GLLF1+GRRF1+GLRF1
            ELSE
              GF1=0.
            END IF
            IF (MZIZ.LT.AMB1SS) THEN
            TMP(4)=AMB1SS
            TMP(5)=AMB2SS
              GLGL=8*ALIZ1*ALIZ2*(ALJZ1*ALJZ2+BEJZ1*BEJZ2)*
     ,             SSXINT(AMBT,SSGX1,XUPPER)+SGNIJ*8*ALIZ1*ALIZ2*
     ,             ALJZ1*ALJZ2*SSXINT(AMBT,SSGX2,XUPPER)
              GRGR=8*BEIZ1*BEIZ2*(ALJZ1*ALJZ2+BEJZ1*BEJZ2)*
     ,             SSXINT(AMBT,SSGX1,XUPPER)+SGNIJ*8*BEIZ1*BEIZ2*
     ,             BEJZ1*BEJZ2*SSXINT(AMBT,SSGX2,XUPPER)
              GLGR=-8*ALIZ1*BEIZ2*ALJZ2*BEJZ1*
     ,              SSXINT(AMBT,SSGX8,XUPPER)
              GRGL=-8*ALIZ2*BEIZ1*ALJZ1*BEJZ2*
     ,              SSXINT(AMBT,SSGX8,XUPPER)
              GF12=GLGL+GRGR+GLGR+GRGL
            ELSE
              GF12=0.
            END IF
            IF (MZIZ.LT.AMB2SS) THEN
            TMP(4)=AMB2SS
            TMP(5)=AMB2SS
              GLLF2=4*ALIZ2**2*((ALJZ2**2+BEJZ2**2)*
     ,              SSXINT(AMBT,SSGX1,XUPPER)+SGNIJ*ALJZ2**2*
     ,              SSXINT(AMBT,SSGX2,XUPPER))
              GRRF2=4*BEIZ2**2*((ALJZ2**2+BEJZ2**2)*
     ,              SSXINT(AMBT,SSGX1,XUPPER)+SGNIJ*BEJZ2**2*
     ,              SSXINT(AMBT,SSGX2,XUPPER))
              GLRF2=-8*ALIZ2*BEIZ2*ALJZ2*BEJZ2*
     ,              SSXINT(AMBT,SSGX8,XUPPER)
              GF2=GLLF2+GRRF2+GLRF2
            ELSE
              GF2=0.
            END IF
            GF=FACT*(GF1+GF2+GF12)
            TMP(2)=MZJZ
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APD**2+BTD**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $       *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2-4*AMBT**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHL)) THEN
            TMP(3)=AMHL
            TMP(5)=AMHL
            TMP(4)=-SNIJ(JZ,IZ)
            TERMHL=G**2/64./PI**3/MZIZ*(MBQ*SINA*(XLIJ(JZ,IZ)+
     $        XLIJ(IZ,JZ))/AMW/COSBE)**2*
     $        SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMBT**2)/2./MZIZ)
            ELSE
            TERMHL=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHH)) THEN
            TMP(3)=AMHH
            TMP(5)=AMHH
            TMP(4)=-SNIJ(JZ,IZ)
            TERMHH=G**2/64./PI**3/MZIZ*(MBQ*COSA*(XHIJ(JZ,IZ)+
     $       XHIJ(IZ,JZ))/AMW/COSBE)**2*
     $       SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMBT**2)/2./MZIZ)
            ELSE
            TERMHH=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHH).AND.MZIZ.LE.(MZJZ+AMHL)) THEN
            TMP(3)=AMHL
            TMP(5)=AMHH
            TMP(4)=-SNIJ(JZ,IZ)
            TERMLH=2*G**2/64./PI**3/MZIZ*(MBQ/AMW/COSBE)**2*
     $            (COSA*(XHIJ(JZ,IZ)+XHIJ(IZ,JZ))*SINA*
     $       (XLIJ(JZ,IZ)+XLIJ(IZ,JZ)))*
     $       SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMBT**2)/2./MZIZ)
            ELSE
            TERMLH=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHA)) THEN
            TMP(3)=AMHA
            TMP(5)=AMHA
            TMP(4)=SNIJ(JZ,IZ)
            TERMHA=G**2*TANB**2/64./PI**3/MZIZ*(MBQ*(XPIJ(JZ,IZ)+
     $            XPIJ(IZ,JZ))/AMW)**2*
     $       SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMBT**2)/2./MZIZ)
            ELSE
            TERMHA=0.
            END IF
            IF (MZIZ.LT.AMB1SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=-SGNIJ
            TMP(3)=AMB1SS
            TERM1Z=8*E*WIJ(JZ,IZ)*(ALJZ1*ALIZ1*(APD-BTD)-
     $       BEJZ1*BEIZ1*(APD+BTD))/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMBT**2,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERM1Z=0.
            END IF
            IF (MZIZ.LT.AMB2SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=-SGNIJ
            TMP(3)=AMB2SS
            TERM2Z=8*E*WIJ(JZ,IZ)*(ALJZ2*ALIZ2*(APD-BTD)-
     $       BEJZ2*BEIZ2*(APD+BTD))/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMBT**2,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERM2Z=0.
            END IF
            IF (MZIZ.LT.AMB1SS.AND.MZIZ.LT.(MZJZ+AMHL)) THEN
            TMP(3)=AMB1SS
            TMP(4)=SGNIJ
            TMP(5)=AMHL
            TERM1L=2*PI*PI*G*MBQ*SINA*SGNIJ*(XLIJ(IZ,JZ)+
     $        XLIJ(JZ,IZ))*(ALIZ1*BEJZ1+ALJZ1*BEIZ1)
     $       /MZIZ/AMW/COSBE*SSXINT(4*AMBT**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM1L=FACT*TERM1L
            ELSE
            TERM1L=0.
            END IF
            IF (MZIZ.LT.AMB2SS.AND.MZIZ.LT.(MZJZ+AMHL)) THEN
            TMP(3)=AMB2SS
            TMP(4)=SGNIJ
            TMP(5)=AMHL
            TERM2L=2*PI*PI*G*MBQ*SINA*SGNIJ*(XLIJ(IZ,JZ)+
     $        XLIJ(JZ,IZ))*(ALIZ2*BEJZ2+ALJZ2*BEIZ2)
     $       /MZIZ/AMW/COSBE*SSXINT(4*AMBT**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM2L=FACT*TERM2L
            ELSE
            TERM2L=0.
            END IF
            IF (MZIZ.LT.AMB1SS.AND.MZIZ.LT.(MZJZ+AMHH)) THEN
            TMP(3)=AMB1SS
            TMP(4)=SGNIJ
            TMP(5)=AMHH
            TERM1H=2*PI*PI*G*MBQ*COSA*SGNIJ*(XHIJ(IZ,JZ)+
     $        XHIJ(JZ,IZ))*(ALIZ1*BEJZ1+ALJZ1*BEIZ1)
     $       /MZIZ/AMW/COSBE*SSXINT(4*AMBT**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM1H=FACT*TERM1H
            ELSE
            TERM1H=0.
            END IF
            IF (MZIZ.LT.AMB2SS.AND.MZIZ.LT.(MZJZ+AMHH)) THEN
            TMP(3)=AMB2SS
            TMP(4)=SGNIJ
            TMP(5)=AMHH
            TERM2H=2*PI*PI*G*MBQ*COSA*SGNIJ*(XHIJ(IZ,JZ)+
     $        XHIJ(JZ,IZ))*(ALIZ2*BEJZ2+ALJZ2*BEIZ2)
     $       /MZIZ/AMW/COSBE*SSXINT(4*AMBT**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM2H=FACT*TERM2H
            ELSE
            TERM2H=0.
            END IF
            IF (MZIZ.LT.AMB1SS.AND.MZIZ.LT.(MZJZ+AMHA)) THEN
            TMP(3)=AMB1SS
            TMP(4)=-SGNIJ
            TMP(5)=AMHA
            TERM1A=-2*PI*PI*G*MBQ*TANB*SGNIJ*(XPIJ(IZ,JZ)+
     $        XPIJ(JZ,IZ))*(ALIZ1*BEJZ1+ALJZ1*BEIZ1)
     $        /MZIZ/AMW*SSXINT(4*AMBT**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM1A=FACT*TERM1A
            ELSE
            TERM1A=0.
            END IF
            IF (MZIZ.LT.AMB2SS.AND.MZIZ.LT.(MZJZ+AMHA)) THEN
            TMP(3)=AMB2SS
            TMP(4)=-SGNIJ
            TMP(5)=AMHA
            TERM2A=-2*PI*PI*G*MBQ*TANB*SGNIJ*(XPIJ(IZ,JZ)+
     $        XPIJ(JZ,IZ))*(ALIZ2*BEJZ2+ALJZ2*BEIZ2)
     $        /MZIZ/AMW*SSXINT(4*AMBT**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM2A=FACT*TERM2A
            ELSE
            TERM2A=0.
            END IF
            WID=3*(GF+TERMZZ+TERMHL+TERMHH+TERMLH+TERMHA+TERM1Z+
     $        TERM2Z+TERM1L+TERM2L+TERM1H+TERM2H+TERM1A+TERM2A)
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDBT,-IDBT,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APD
            Z2(2)=BTD
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=((ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-(ZI**THIZ*BDI(IZ)-
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.
            Z1(2)=((-ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-(ZI**THIZ*BDI(IZ)+
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.
            Z2(1)=CONJG(((ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*COSB-(ZI**THJZ*BDI(JZ)-
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINB)/2.)
            Z2(2)=-CONJG(((-ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*COSB-(ZI**THJZ*BDI(JZ)+
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINB)/2.)
            CALL SSME3(2,AMB1SS,Z1,Z2)
            Z1(1)=((ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+(ZI**THIZ*BDI(IZ)-
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.
            Z1(2)=((-ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+(ZI**THIZ*BDI(IZ)+
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.
            Z2(1)=CONJG(((ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*SINB+(ZI**THJZ*BDI(JZ)-
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSB)/2.)
            Z2(2)=-CONJG(((-ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*SINB+(ZI**THJZ*BDI(JZ)+
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSB)/2.)
            CALL SSME3(2,AMB2SS,Z1,Z2)
            Z1(1)=((ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*COSB-(ZI**THJZ*BDI(JZ)-
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINB)/2.
            Z1(2)=((-ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*COSB-(ZI**THJZ*BDI(JZ)+
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINB)/2.
            Z2(1)=-CONJG(((ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-(ZI**THIZ*BDI(IZ)-
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.)
            Z2(2)=CONJG(((-ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*COSB-(ZI**THIZ*BDI(IZ)+
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINB)/2.)
            CALL SSME3(3,AMB1SS,Z1,Z2)
            Z1(1)=((ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*SINB+(ZI**THJZ*BDI(JZ)-
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSB)/2.
            Z1(2)=((-ZI**(THJZ)*(-1.)**(THJZ+1)*ADI(JZ)-
     $            FB*ZMIXSS(2,JZ)*ZI**THJZ)*SINB+(ZI**THJZ*BDI(JZ)+
     $            FB*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSB)/2.
            Z2(1)=-CONJG(((ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+(ZI**THIZ*BDI(IZ)-
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.)
            Z2(2)=CONJG(((-ZI**(THIZ)*(-1.)**(THIZ+1)*ADI(IZ)-
     $            FB*ZMIXSS(2,IZ)*ZI**THIZ)*SINB+(ZI**THIZ*BDI(IZ)+
     $            FB*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSB)/2.)
            CALL SSME3(3,AMB2SS,Z1,Z2)
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=(-ZI)**(THIZ+THJZ)*(XLIJ(IZ,JZ)+XLIJ(JZ,IZ))
             Z1(2)=0.
            ELSE
             Z1(1)=0.
             Z1(2)=(-ZI)**(THIZ+THJZ)*(XLIJ(IZ,JZ)+XLIJ(JZ,IZ))
            END IF
            Z2(1)=-G*MBQ*SINA/2./AMW/COSBE
            Z2(2)=0.
            CALL SSME3(4,AMHL,Z1,Z2)
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=(-ZI)**(THIZ+THJZ)*(XHIJ(IZ,JZ)+XHIJ(JZ,IZ))
             Z1(2)=0.
            ELSE
             Z1(1)=0.
             Z1(2)=(-ZI)**(THIZ+THJZ)*(XHIJ(IZ,JZ)+XHIJ(JZ,IZ))
            END IF
            Z2(1)=-G*MBQ*COSA/2./AMW/COSBE
            Z2(2)=0.
            CALL SSME3(4,AMHH,Z1,Z2)
            IF (-SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=(-ZI)**(THIZ+THJZ+1)*(XPIJ(IZ,JZ)+XPIJ(JZ,IZ))
            ELSE
             Z1(1)=(-ZI)**(THIZ+THJZ+1)*(XPIJ(IZ,JZ)+XPIJ(JZ,IZ))
             Z1(2)=0.
            END IF
            Z2(1)=0.
            Z2(2)=ZI*G*MBQ*TANB/2./AMW
            CALL SSME3(4,AMHA,Z1,Z2)
          END IF
C          zi -> zj + e + ebar
          TMP(2)=MZJZ
          TMP(4)=-SNIJ(JZ,IZ)
          TMP(6)=0.
          IF (MZIZ.GT.(MZJZ+2*AME+PSGAP)) THEN
            IF (MZIZ.LT.AMELSS) THEN
            TMP(3)=AMELSS
            TERMLL=2*ALI(JZ)**2*ALI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.AMERSS) THEN
            TMP(3)=AMERSS
            TERMRR=2*BLI(JZ)**2*BLI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMRR=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APL**2+BTL**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMELSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMELSS
            TERMLZ=8*E*(APL-BTL)*WIJ(JZ,IZ)*ALI(JZ)*ALI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            IF (MZIZ.LT.AMERSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMERSS
            TERMRZ=-8*E*(APL+BTL)*WIJ(JZ,IZ)*BLI(JZ)*BLI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMRZ=0.
            END IF
            WID=TERMLL+TERMRR+TERMZZ+TERMLZ+TERMRZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDE,-IDE,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APL
            Z2(2)=BTL
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ALI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ALI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMELSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BLI(IZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*BLI(JZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMERSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ALI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ALI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMELSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*BLI(JZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BLI(IZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMERSS,Z1,Z2)
          END IF
C          zi -> zj + mu + mubar
          TMP(4)=-SNIJ(JZ,IZ)
          IF (MZIZ.GT.(MZJZ+2*AMMU+PSGAP)) THEN
            IF (MZIZ.LT.AMMLSS) THEN
            TMP(3)=AMMLSS
            TERMLL=2*ALI(JZ)**2*ALI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.AMMRSS) THEN
            TMP(3)=AMMRSS
            TERMRR=2*BLI(JZ)**2*BLI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMRR=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APL**2+BTL**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMMLSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMMLSS
            TERMLZ=8*E*(APL-BTL)*WIJ(JZ,IZ)*ALI(JZ)*ALI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            IF (MZIZ.LT.AMMRSS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMMRSS
            TERMRZ=-8*E*(APL+BTL)*WIJ(JZ,IZ)*BLI(JZ)*BLI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMRZ=0.
            END IF
            WID=TERMLL+TERMRR+TERMZZ+TERMLZ+TERMRZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDMU,-IDMU,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APL
            Z2(2)=BTL
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ALI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ALI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMMLSS,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*BLI(IZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*BLI(JZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(2,AMMRSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ALI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ALI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMMLSS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*BLI(JZ)/2.
            Z1(2)=Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*BLI(IZ)/2.)
            Z2(2)=-Z2(1)
            CALL SSME3(3,AMMRSS,Z1,Z2)
          END IF
C          zi -> zj + tau + taubar.
C          Mixing/yukawa effects now included thanks to M. Drees
          ALIZ1=-ALI(IZ)*COSL-FL*ZMIXSS(2,IZ)*SINL
          ALJZ1=-ALI(JZ)*COSL-FL*ZMIXSS(2,JZ)*SINL
          ALIZ2=-ALI(IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
          ALJZ2=-ALI(JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
          BEIZ1=BLI(IZ)*SINL+FL*ZMIXSS(2,IZ)*COSL
          BEJZ1=BLI(JZ)*SINL+FL*ZMIXSS(2,JZ)*COSL
          BEIZ2=-BLI(IZ)*COSL+FL*ZMIXSS(2,IZ)*SINL
          BEJZ2=-BLI(JZ)*COSL+FL*ZMIXSS(2,JZ)*SINL
          SGNIJ=-SNIJ(JZ,IZ)
          XUPPER=(MZIZ**2+AMTAU**2-(AMTAU+MZJZ)**2)/2./MZIZ
C          Polarization for stau_i -> z2ss+tau, z3ss+tau, z4ss+tau.
C          See below for z1ss+tau.
          IF(JZ.EQ.1) THEN
            PTAU1(IZ)=(BEIZ1**2-ALIZ1**2)/(BEIZ1**2+ALIZ1**2)
            PTAU2(IZ)=(BEIZ2**2-ALIZ2**2)/(BEIZ2**2+ALIZ2**2)
          ENDIF
          IF (MZIZ.GT.(MZJZ+2*AMTAU+PSGAP)) THEN
            TMP(1)=MZIZ
            TMP(2)=AMTAU
            TMP(3)=MZJZ
            TMP(4)=AML1SS
            TMP(5)=AML1SS
            TMP(6)=AMTAU
            IF (MZIZ.LT.AML1SS) THEN
              GLLF1=4*ALIZ1**2*((ALJZ1**2+BEJZ1**2)*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*ALJZ1**2*
     ,             SSXINT(AMTAU,SSGX2,XUPPER))
              GLLF1L=FACT*4*ALIZ1**2*(ALJZ1**2*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*ALJZ1**2*
     ,             SSXINT(AMTAU,SSGX2,XUPPER))
              GRRF1=4*BEIZ1**2*((ALJZ1**2+BEJZ1**2)*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*BEJZ1**2*
     ,             SSXINT(AMTAU,SSGX2,XUPPER))
              GRRF1R=FACT*4*BEIZ1**2*(BEJZ1**2*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*BEJZ1**2*
     ,             SSXINT(AMTAU,SSGX2,XUPPER))
              GLRF1=-8*ALIZ1*BEIZ1*ALJZ1*BEJZ1*
     ,               SSXINT(AMTAU,SSGX8,XUPPER)
              GF1=GLLF1+GRRF1+GLRF1
            ELSE
              GLLF1L=0.
              GRRF1R=0.
              GF1=0.
            END IF
            IF (MZIZ.LT.AML1SS) THEN
            TMP(4)=AML1SS
            TMP(5)=AML2SS
              GLGL=8*ALIZ1*ALIZ2*(ALJZ1*ALJZ2+BEJZ1*BEJZ2)*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*8*ALIZ1*ALIZ2*
     ,             ALJZ1*ALJZ2*SSXINT(AMTAU,SSGX2,XUPPER)
              GLGLL=FACT*(8*ALIZ1*ALIZ2*ALJZ1*ALJZ2*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*8*ALIZ1*ALIZ2*
     ,             ALJZ1*ALJZ2*SSXINT(AMTAU,SSGX2,XUPPER))
              GRGR=8*BEIZ1*BEIZ2*(ALJZ1*ALJZ2+BEJZ1*BEJZ2)*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*8*BEIZ1*BEIZ2*
     ,             BEJZ1*BEJZ2*SSXINT(AMTAU,SSGX2,XUPPER)
              GRGRR=FACT*(8*BEIZ1*BEIZ2*BEJZ1*BEJZ2*
     ,             SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*8*BEIZ1*BEIZ2*
     ,             BEJZ1*BEJZ2*SSXINT(AMTAU,SSGX2,XUPPER))
              GLGR=-8*ALIZ1*BEIZ2*ALJZ2*BEJZ1*
     ,              SSXINT(AMTAU,SSGX8,XUPPER)
              GRGL=-8*ALIZ2*BEIZ1*ALJZ1*BEJZ2*
     ,              SSXINT(AMTAU,SSGX8,XUPPER)
              GF12=GLGL+GRGR+GLGR+GRGL
            ELSE
              GLGLL=0.
              GRGRR=0.
              GF12=0.
            END IF
            IF (MZIZ.LT.AML2SS) THEN
            TMP(4)=AML2SS
            TMP(5)=AML2SS
              GLLF2=4*ALIZ2**2*((ALJZ2**2+BEJZ2**2)*
     ,              SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*ALJZ2**2*
     ,              SSXINT(AMTAU,SSGX2,XUPPER))
              GLLF2L=FACT*4*ALIZ2**2*(ALJZ2**2*
     ,              SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*ALJZ2**2*
     ,              SSXINT(AMTAU,SSGX2,XUPPER))
              GRRF2=4*BEIZ2**2*((ALJZ2**2+BEJZ2**2)*
     ,              SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*BEJZ2**2*
     ,              SSXINT(AMTAU,SSGX2,XUPPER))
              GRRF2R=FACT*4*BEIZ2**2*(BEJZ2**2*
     ,              SSXINT(AMTAU,SSGX1,XUPPER)+SGNIJ*BEJZ2**2*
     ,              SSXINT(AMTAU,SSGX2,XUPPER))
              GLRF2=-8*ALIZ2*BEIZ2*ALJZ2*BEJZ2*
     ,              SSXINT(AMTAU,SSGX8,XUPPER)
              GF2=GLLF2+GRRF2+GLRF2
            ELSE
              GLLF2L=0.
              GRRF2R=0.
              GF2=0.
            END IF
            GF=FACT*(GF1+GF2+GF12)
            TMP(2)=MZJZ
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APL**2+BTL**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $      *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2-4*AMTAU**2)/2./MZIZ)
            TMZZRL=TERMZZ*(APL+BTL)**2/2./(APL**2+BTL**2)
            TMZZLR=TERMZZ*(APL-BTL)**2/2./(APL**2+BTL**2)
            ELSE
            TERMZZ=0.
            TMZZRL=0.
            TMZZLR=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHL)) THEN
            TMP(3)=AMHL
            TMP(5)=AMHL
            TMP(4)=-SNIJ(JZ,IZ)
            TERMHL=G**2/64./PI**3/MZIZ*(MTAMZ*SINA*(XLIJ(JZ,IZ)+
     $         XLIJ(IZ,JZ))/AMW/COSBE)**2*
     $      SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMTAU**2)/2./MZIZ)
            ELSE
            TERMHL=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHH)) THEN
            TMP(3)=AMHH
            TMP(5)=AMHH
            TMP(4)=-SNIJ(JZ,IZ)
            TERMHH=G**2/64./PI**3/MZIZ*(MTAMZ*COSA*(XHIJ(JZ,IZ)+
     $            XHIJ(IZ,JZ))/AMW/COSBE)**2*
     $      SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMTAU**2)/2./MZIZ)
            ELSE
            TERMHH=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHH).AND.MZIZ.LE.(MZJZ+AMHL)) THEN
            TMP(3)=AMHL
            TMP(5)=AMHH
            TMP(4)=-SNIJ(JZ,IZ)
            TERMLH=2*G**2/64./PI**3/MZIZ*(MTAMZ/AMW/COSBE)**2*
     $            (COSA*(XHIJ(JZ,IZ)+XHIJ(IZ,JZ))*SINA*
     $             (XLIJ(JZ,IZ)+XLIJ(IZ,JZ)))*
     $      SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMTAU**2)/2./MZIZ)
            ELSE
            TERMLH=0.
            END IF
            IF (MZIZ.LE.(MZJZ+AMHA)) THEN
            TMP(3)=AMHA
            TMP(5)=AMHA
            TMP(4)=SNIJ(JZ,IZ)
            TERMHA=G**2*TANB**2/64./PI**3/MZIZ*(MTAMZ*(XPIJ(JZ,IZ)+
     $            XPIJ(IZ,JZ))/AMW)**2*
     $      SSXINT(MZJZ,SSZZF4,(MZIZ**2+MZJZ**2-4*AMTAU**2)/2./MZIZ)
            ELSE
            TERMHA=0.
            END IF
            IF (MZIZ.LT.AML1SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=-SGNIJ
            TMP(3)=AML1SS
            TERM1Z=8*E*WIJ(JZ,IZ)*(ALJZ1*ALIZ1*(APL-BTL)-
     $       BEJZ1*BEIZ1*(APL+BTL))/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMTAU**2,SSZZF3,(MZIZ-MZJZ)**2)
            TM1ZRL=-8*E*WIJ(JZ,IZ)*BEJZ1*BEIZ1*(APL+BTL)/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMTAU**2,SSZZF3,(MZIZ-MZJZ)**2)
            TM1ZLR=8*E*WIJ(JZ,IZ)*ALJZ1*ALIZ1*(APL-BTL)/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMTAU**2,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERM1Z=0.
            TM1ZRL=0.
            TM1ZLR=0.
            END IF
            IF (MZIZ.LT.AML2SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=-SGNIJ
            TMP(3)=AML2SS
            TERM2Z=8*E*WIJ(JZ,IZ)*(ALJZ2*ALIZ2*(APL-BTL)-
     $       BEJZ2*BEIZ2*(APL+BTL))/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMTAU**2,SSZZF3,(MZIZ-MZJZ)**2)
            TM2ZRL=-8*E*WIJ(JZ,IZ)*BEJZ2*BEIZ2*(APL+BTL)/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMTAU**2,SSZZF3,(MZIZ-MZJZ)**2)
            TM2ZLR=8*E*WIJ(JZ,IZ)*ALJZ2*ALIZ2*(APL-BTL)/MZIZ
     $      /(2*PI)**5*SSXINT(4*AMTAU**2,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERM2Z=0.
            TM2ZRL=0.
            TM2ZLR=0.
            END IF
            IF (MZIZ.LT.AML1SS.AND.MZIZ.LT.(MZJZ+AMHL)) THEN
            TMP(3)=AML1SS
            TMP(4)=SGNIJ
            TMP(5)=AMHL
            TERM1L=2*PI*PI*G*MTAMZ*SINA*SGNIJ*(XLIJ(IZ,JZ)+
     $        XLIJ(JZ,IZ))*(ALIZ1*BEJZ1+ALJZ1*BEIZ1)
     $      /MZIZ/AMW/COSBE*SSXINT(4*AMTAU**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM1L=FACT*TERM1L
            ELSE
            TERM1L=0.
            END IF
            IF (MZIZ.LT.AML2SS.AND.MZIZ.LT.(MZJZ+AMHL)) THEN
            TMP(3)=AML2SS
            TMP(4)=SGNIJ
            TMP(5)=AMHL
            TERM2L=2*PI*PI*G*MTAMZ*SINA*SGNIJ*(XLIJ(IZ,JZ)+
     $        XLIJ(JZ,IZ))*(ALIZ2*BEJZ2+ALJZ2*BEIZ2)
     $      /MZIZ/AMW/COSBE*SSXINT(4*AMTAU**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM2L=FACT*TERM2L
            ELSE
            TERM2L=0.
            END IF
            IF (MZIZ.LT.AML1SS.AND.MZIZ.LT.(MZJZ+AMHH)) THEN
            TMP(3)=AML1SS
            TMP(4)=SGNIJ
            TMP(5)=AMHH
            TERM1H=2*PI*PI*G*MTAMZ*COSA*SGNIJ*(XHIJ(IZ,JZ)+
     $        XHIJ(JZ,IZ))*(ALIZ1*BEJZ1+ALJZ1*BEIZ1)
     $      /MZIZ/AMW/COSBE*SSXINT(4*AMTAU**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM1H=FACT*TERM1H
            ELSE
            TERM1H=0.
            END IF
            IF (MZIZ.LT.AML2SS.AND.MZIZ.LT.(MZJZ+AMHH)) THEN
            TMP(3)=AML2SS
            TMP(4)=SGNIJ
            TMP(5)=AMHH
            TERM2H=2*PI*PI*G*MTAMZ*COSA*SGNIJ*(XHIJ(IZ,JZ)+
     $        XHIJ(JZ,IZ))*(ALIZ2*BEJZ2+ALJZ2*BEIZ2)
     $    /MZIZ/AMW/COSBE*SSXINT(4*AMTAU**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM2H=FACT*TERM2H
            ELSE
            TERM2H=0.
            END IF
            IF (MZIZ.LT.AML1SS.AND.MZIZ.LT.(MZJZ+AMHA)) THEN
            TMP(3)=AML1SS
            TMP(4)=-SGNIJ
            TMP(5)=AMHA
            TERM1A=-2*PI*PI*G*MTAMZ*TANB*SGNIJ*(XPIJ(IZ,JZ)+
     $        XPIJ(JZ,IZ))*(ALIZ1*BEJZ1+ALJZ1*BEIZ1)
     $       /MZIZ/AMW*SSXINT(4*AMTAU**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM1A=FACT*TERM1A
            ELSE
            TERM1A=0.
            END IF
            IF (MZIZ.LT.AML2SS.AND.MZIZ.LT.(MZJZ+AMHA)) THEN
            TMP(3)=AML2SS
            TMP(4)=-SGNIJ
            TMP(5)=AMHA
            TERM2A=-2*PI*PI*G*MTAMZ*TANB*SGNIJ*(XPIJ(IZ,JZ)+
     $        XPIJ(JZ,IZ))*(ALIZ2*BEJZ2+ALJZ2*BEIZ2)
     $       /MZIZ/AMW*SSXINT(4*AMTAU**2,SSZZF5,(MZIZ-MZJZ)**2)
            TERM2A=FACT*TERM2A
            ELSE
            TERM2A=0.
            END IF
            WID=GF+TERMZZ+TERMHL+TERMHH+TERMLH+TERMHA+TERM1Z+
     $        TERM2Z+TERM1L+TERM2L+TERM1H+TERM2H+TERM1A+TERM2A
C              tau polarization for 3-body z2 -> z1 tau tau
            IF (IZ.EQ.2.AND.JZ.EQ.1.AND.WID.GT.0.) THEN
              PTAUZZ=(GRRF1R+GRGRR+GRRF2R+TMZZRL+TM1ZRL+TM2ZRL-
     $               (GLLF1L+GLGLL+GLLF2L+TMZZLR+TM1ZLR+TM2ZLR))
     $               /WID
            END IF
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDTAU,-IDTAU,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APL
            Z2(2)=BTL
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=((ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*COSL-(ZI**THIZ*BLI(IZ)-
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINL)/2.
            Z1(2)=((-ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*COSL-(ZI**THIZ*BLI(IZ)+
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINL)/2.
            Z2(1)=CONJG(((ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*COSL-(ZI**THJZ*BLI(JZ)-
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINL)/2.)
            Z2(2)=-CONJG(((-ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*COSL-(ZI**THJZ*BLI(JZ)+
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINL)/2.)
            CALL SSME3(2,AML1SS,Z1,Z2)
            Z1(1)=((ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*SINL+(ZI**THIZ*BLI(IZ)-
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSL)/2.
            Z1(2)=((-ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*SINL+(ZI**THIZ*BLI(IZ)+
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSL)/2.
            Z2(1)=CONJG(((ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*SINL+(ZI**THJZ*BLI(JZ)-
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSL)/2.)
            Z2(2)=-CONJG(((-ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*SINL+(ZI**THJZ*BLI(JZ)+
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSL)/2.)
            CALL SSME3(2,AML2SS,Z1,Z2)
            Z1(1)=((ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*COSL-(ZI**THJZ*BLI(JZ)-
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINL)/2.
            Z1(2)=((-ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*COSL-(ZI**THJZ*BLI(JZ)+
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*SINL)/2.
            Z2(1)=-CONJG(((ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*COSL-(ZI**THIZ*BLI(IZ)-
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINL)/2.)
            Z2(2)=CONJG(((-ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*COSL-(ZI**THIZ*BLI(IZ)+
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*SINL)/2.)
            CALL SSME3(3,AML1SS,Z1,Z2)
            Z1(1)=((ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*SINL+(ZI**THJZ*BLI(JZ)-
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSL)/2.
            Z1(2)=((-ZI**(THJZ)*(-1.)**(THJZ+1)*ALI(JZ)-
     $            FL*ZMIXSS(2,JZ)*ZI**THJZ)*SINL+(ZI**THJZ*BLI(JZ)+
     $            FL*ZMIXSS(2,JZ)*(-ZI)**THJZ)*COSL)/2.
            Z2(1)=-CONJG(((ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*SINL+(ZI**THIZ*BLI(IZ)-
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSL)/2.)
            Z2(2)=CONJG(((-ZI**(THIZ)*(-1.)**(THIZ+1)*ALI(IZ)-
     $            FL*ZMIXSS(2,IZ)*ZI**THIZ)*SINL+(ZI**THIZ*BLI(IZ)+
     $            FL*ZMIXSS(2,IZ)*(-ZI)**THIZ)*COSL)/2.)
            CALL SSME3(3,AML2SS,Z1,Z2)
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=(-ZI)**(THIZ+THJZ)*(XLIJ(IZ,JZ)+XLIJ(JZ,IZ))
             Z1(2)=0.
            ELSE
             Z1(1)=0.
             Z1(2)=(-ZI)**(THIZ+THJZ)*(XLIJ(IZ,JZ)+XLIJ(JZ,IZ))
            END IF
            Z2(1)=-G*MTAMZ*SINA/2./AMW/COSBE
            Z2(2)=0.
            CALL SSME3(4,AMHL,Z1,Z2)
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=(-ZI)**(THIZ+THJZ)*(XHIJ(IZ,JZ)+XHIJ(JZ,IZ))
             Z1(2)=0.
            ELSE
             Z1(1)=0.
             Z1(2)=(-ZI)**(THIZ+THJZ)*(XHIJ(IZ,JZ)+XHIJ(JZ,IZ))
            END IF
            Z2(1)=-G*MTAMZ*COSA/2./AMW/COSBE
            Z2(2)=0.
            CALL SSME3(4,AMHH,Z1,Z2)
            IF (-SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=(-ZI)**(THIZ+THJZ+1)*(XPIJ(IZ,JZ)+XPIJ(JZ,IZ))
            ELSE
             Z1(1)=(-ZI)**(THIZ+THJZ+1)*(XPIJ(IZ,JZ)+XPIJ(JZ,IZ))
             Z1(2)=0.
            END IF
            Z2(1)=0.
            Z2(2)=ZI*G*MTAMZ*TANB/2./AMW
            CALL SSME3(4,AMHA,Z1,Z2)
          END IF
C          zi -> zj + nu_e + nu_e bar
          TMP(6)=0.
          IF (MZIZ.GT.MZJZ+PSGAP) THEN
            IF (MZIZ.LT.AMN1SS) THEN
            TMP(4)=-SNIJ(JZ,IZ)
            TMP(3)=AMN1SS
            TERMLL=2*ANI(JZ)**2*ANI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APN**2+BTN**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMN1SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMN1SS
            TERMLZ=8*E*(APN-BTN)*WIJ(JZ,IZ)*ANI(JZ)*ANI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            WID=TERMLL+TERMZZ+TERMLZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDNE,-IDNE,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APN
            Z2(2)=BTN
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ANI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMN1SS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ANI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMN1SS,Z1,Z2)
          END IF
C          zi -> zj + nu_mu + nu_mu bar
          IF (MZIZ.GT.MZJZ+PSGAP) THEN
            IF (MZIZ.LT.AMN2SS) THEN
            TMP(4)=-SNIJ(JZ,IZ)
            TMP(3)=AMN2SS
            TERMLL=2*ANI(JZ)**2*ANI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APN**2+BTN**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMN2SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMN2SS
            TERMLZ=8*E*(APN-BTN)*WIJ(JZ,IZ)*ANI(JZ)*ANI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            WID=TERMLL+TERMZZ+TERMLZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDNM,-IDNM,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APN
            Z2(2)=BTN
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ANI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMN2SS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ANI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMN2SS,Z1,Z2)
          END IF
C          zi -> zj + nu_tau + nu_tau bar
          IF (MZIZ.GT.MZJZ+PSGAP) THEN
            IF (MZIZ.LT.AMN3SS) THEN
            TMP(4)=-SNIJ(JZ,IZ)
            TMP(3)=AMN3SS
            TERMLL=2*ANI(JZ)**2*ANI(IZ)**2*FAC*SSXINT(0.,SSZZF1,1.)
            ELSE
            TERMLL=0.
            END IF
            IF (MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TERMZZ=(APN**2+BTN**2)*E**2*WIJ(JZ,IZ)**2/MZIZ
     $             *SSXINT(MZJZ,SSZZF2,(MZIZ**2+MZJZ**2)/2./MZIZ)
            ELSE
            TERMZZ=0.
            END IF
            IF (MZIZ.LT.AMN3SS.AND.MZIZ.LT.(MZJZ+AMZ)) THEN
            TMP(4)=+SNIJ(JZ,IZ)
            TMP(3)=AMN3SS
            TERMLZ=8*E*(APN-BTN)*WIJ(JZ,IZ)*ANI(JZ)*ANI(IZ)/MZIZ
     $      /(2*PI)**5*SSXINT(0.,SSZZF3,(MZIZ-MZJZ)**2)
            ELSE
            TERMLZ=0.
            END IF
            WID=TERMLL+TERMZZ+TERMLZ
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),IDNT,-IDNT,0,0)
C     Enter information for decay matrix element
            IF (-1.*SNIJ(JZ,IZ).GT.0.) THEN
             Z1(1)=0.
             Z1(2)=2*E*WIJ(JZ,IZ)
            ELSE
             Z1(1)=2*E*WIJ(JZ,IZ)
             Z1(2)=0.
            END IF
            Z2(1)=APN
            Z2(2)=BTN
            CALL SSME3(1,AMZ,Z1,Z2)
            Z1(1)=ZI**(THIZ-1)*(-1.)**(THIZ+1)*ANI(IZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=CONJG(ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(2,AMN3SS,Z1,Z2)
            Z1(1)=ZI**(THJZ-1)*(-1.)**(THJZ+1)*ANI(JZ)/2.
            Z1(2)=-Z1(1)
            Z2(1)=-CONJG(ZI**(THIZ-1)*(-1.)**(THIZ+1)*ANI(IZ)/2.)
            Z2(2)=Z2(1)
            CALL SSME3(3,AMN3SS,Z1,Z2)
          END IF
220     CONTINUE
C
C          zi --> zj + higgs
C
        DO 230 JZ=1,IZ-1
C          zi --> zj + hl
          MZJZ=ABS(AMZISS(JZ))
          IF (MZIZ.GT.(MZJZ+AMHL)) THEN
            SN=SIGN(1.,AMZISS(JZ))*SIGN(1.,AMZISS(IZ))
            WID=(XLIJ(JZ,IZ)+XLIJ(IZ,JZ))**2/8./PI/(MZIZ)**3
     $      *SQRT(MZIZ**4+MZJZ**4+AMHL**4-2.*(MZIZ*MZJZ)**2
     $      -2.*(MZIZ*AMHL)**2-2.*(MZJZ*AMHL)**2)*((MZIZ**2+MZJZ**2
     $      -AMHL**2)/2.+SN*MZIZ*MZJZ)
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),ISHL,0,0,0)
          END IF
C          zi --> zj + hh
          IF (MZIZ.GT.(MZJZ+AMHH)) THEN
            SN=SIGN(1.,AMZISS(JZ))*SIGN(1.,AMZISS(IZ))
            WID=(HIJ(JZ,IZ)+HIJ(IZ,JZ))**2/8./PI/(MZIZ)**3
     $      *SQRT(MZIZ**4+MZJZ**4+AMHH**4-2.*(MZIZ*MZJZ)**2
     $      -2.*(MZIZ*AMHH)**2-2.*(MZJZ*AMHH)**2)
     $      *((MZIZ**2+MZJZ**2-AMHH**2)/2.+SN*MZIZ*MZJZ)
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),ISHH,0,0,0)
          END IF
C          zi --> zj + ha
          IF (MZIZ.GT.(MZJZ+AMHA)) THEN
            SN=-SIGN(1.,AMZISS(JZ))*SIGN(1.,AMZISS(IZ))
            WID=(XPIJ(IZ,JZ)+XPIJ(JZ,IZ))**2/8./PI/(MZIZ)**3
     $      *SQRT(MZIZ**4+MZJZ**4+AMHA**4-2.*(MZIZ*MZJZ)**2
     $      -2.*(MZIZ*AMHA)**2-2.*(MZJZ*AMHA)**2)*((MZIZ**2+MZJZ**2
     $      -AMHA**2)/2.+SN*MZIZ*MZJZ)
            CALL SSSAVE(ISZIZ,WID,ISZ(JZ),ISHA,0,0,0)
          END IF
230     CONTINUE
200   CONTINUE
C
C          zi --> squark + qbar; enlarge to include Z1 decays
C                 in case of models with light gravitino
C
      DO 245 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        SNIZ=SIGN(1.,AMZISS(IZ))
        IF (SNIZ.EQ.1.) THEN
           THIZ=0
        ELSE
           THIZ=1
        END IF
        ISZIZ=ISZ(IZ)
C          left squarks
        IF (MZIZ.GT.(AMULSS+AMUP)) THEN
          WID=3*AUI(IZ)**2*(MZIZ**2+AMUP**2-AMULSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMUP**2,AMULSS**2))
          CALL SSSAVE(ISZIZ,WID,ISUPL,-IDUP,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISUPL,IDUP,0,0,0)
        ENDIF
        IF (MZIZ.GT.(AMDLSS+AMDN)) THEN
          WID=3*ADI(IZ)**2*(MZIZ**2+AMDN**2-AMDLSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMDN**2,AMDLSS**2))
          CALL SSSAVE(ISZIZ,WID,ISDNL,-IDDN,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISDNL,IDDN,0,0,0)
        END IF
        IF (MZIZ.GT.(AMSLSS+AMST)) THEN
          WID=3*ADI(IZ)**2*(MZIZ**2+AMST**2-AMSLSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMST**2,AMSLSS**2))
          CALL SSSAVE(ISZIZ,WID,ISSTL,-IDST,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISSTL,IDST,0,0,0)
        END IF
        IF (MZIZ.GT.(AMCLSS+AMCH)) THEN
          WID=3*AUI(IZ)**2*(MZIZ**2+AMCH**2-AMCLSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMCH**2,AMCLSS**2))
          CALL SSSAVE(ISZIZ,WID,ISCHL,-IDCH,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISCHL,IDCH,0,0,0)
        ENDIF
C          right squarks
        IF (MZIZ.GT.(AMURSS+AMUP)) THEN
          WID=3*BUI(IZ)**2*(MZIZ**2+AMUP**2-AMURSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMUP**2,AMURSS**2))
          CALL SSSAVE(ISZIZ,WID,ISUPR,-IDUP,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISUPR,IDUP,0,0,0)
        END IF
        IF (MZIZ.GT.(AMDRSS+AMDN)) THEN
          WID=3*BDI(IZ)**2*(MZIZ**2+AMDN**2-AMDRSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMDN**2,AMDRSS**2))
          CALL SSSAVE(ISZIZ,WID,ISDNR,-IDDN,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISDNR,IDDN,0,0,0)
        END IF
        IF (MZIZ.GT.(AMSRSS+AMST)) THEN
          WID=3*BDI(IZ)**2*(MZIZ**2+AMST**2-AMSRSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMST**2,AMSRSS**2))
          CALL SSSAVE(ISZIZ,WID,ISSTR,-IDST,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISSTR,IDST,0,0,0)
        END IF
        IF(MZIZ.GT.(AMCRSS+AMCH)) THEN
          WID=3*BUI(IZ)**2*(MZIZ**2+AMCH**2-AMCRSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMCH**2,AMCRSS**2))
            CALL SSSAVE(ISZIZ,WID,ISCHR,-IDCH,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISCHR,IDCH,0,0,0)
        ENDIF
C          z_i --> sbottom + bottom
C
        ZAUIZ=ZI**(THIZ-1)*SNIZ
     $  *(-G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBUIZ=ZI**(THIZ-1)*4*GP*ZMIXSS(4,IZ)/3./SR2
        ZADIZ=ZI**(THIZ-1)*SNIZ
     $  *(G/SR2*ZMIXSS(3,IZ)-GP/3./SR2*ZMIXSS(4,IZ))
        ZBDIZ=-2*ZI**(THIZ-1)*GP*ZMIXSS(4,IZ)/3./SR2
        ZALIZ=ZI**(THIZ-1)*SNIZ
     $  *(G/SR2*ZMIXSS(3,IZ)+GP/SR2*ZMIXSS(4,IZ))
        ZBLIZ=-1*ZI**(THIZ-1)*SR2*GP*ZMIXSS(4,IZ)
        ZPP=ZI**THIZ
        ZPM=(-ZI)**THIZ
        IF(MZIZ.GT.(AMB1SS+AMBT)) THEN
          ZA=((ZI*ZADIZ-ZPP*FB*ZMIXSS(2,IZ))*COSB
     $     -(ZI*ZBDIZ-ZPM*FB*ZMIXSS(2,IZ))*SINB)/2.
          ZB=((-ZI*ZADIZ-ZPP*FB*ZMIXSS(2,IZ))*COSB
     $     -(ZI*ZBDIZ+ZPM*FB*ZMIXSS(2,IZ))*SINB)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=3*(AS*((AMBT+MZIZ)**2-AMB1SS**2)+BS*((MZIZ-AMBT)**2-
     $     AMB1SS**2))/16./PI/MZIZ**3*
     $     SQRT(SSXLAM(MZIZ**2,AMB1SS**2,AMBT**2))
            CALL SSSAVE(ISZIZ,WID,ISBT1,-IDBT,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISBT1,IDBT,0,0,0)
        ENDIF
        IF(MZIZ.GT.(AMB2SS+AMBT)) THEN
          ZA=((ZI*ZADIZ-ZPP*FB*ZMIXSS(2,IZ))*SINB
     $     +(ZI*ZBDIZ-ZPM*FB*ZMIXSS(2,IZ))*COSB)/2.
          ZB=((-ZI*ZADIZ-ZPP*FB*ZMIXSS(2,IZ))*SINB
     $     +(ZI*ZBDIZ+ZPM*FB*ZMIXSS(2,IZ))*COSB)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=3*(AS*((AMBT+MZIZ)**2-AMB2SS**2)+BS*((MZIZ-AMBT)**2-
     $     AMB2SS**2))/16./PI/MZIZ**3*
     $     SQRT(SSXLAM(MZIZ**2,AMB2SS**2,AMBT**2))
            CALL SSSAVE(ISZIZ,WID,ISBT2,-IDBT,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISBT2,IDBT,0,0,0)
        ENDIF
C          z_i --> stop + top
C
        IF(MZIZ.GT.AMT1SS+AMTP) THEN
          ZA=((ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*COST
     $     -(ZI*ZBUIZ-ZPM*FT*ZMIXSS(1,IZ))*SINT)/2.
          ZB=((-ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*COST
     $     -(ZI*ZBUIZ+ZPM*FT*ZMIXSS(1,IZ))*SINT)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=3*(AS*((AMTP+MZIZ)**2-AMT1SS**2)+BS*((MZIZ-AMTP)**2-
     $     AMT1SS**2))/16./PI/MZIZ**3*
     $     SQRT(SSXLAM(MZIZ**2,AMT1SS**2,AMTP**2))
          CALL SSSAVE(ISZIZ,WID,ISTP1,-IDTP,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISTP1,IDTP,0,0,0)
        ENDIF
        IF(MZIZ.GT.AMT2SS+AMTP) THEN
          ZA=((ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*SINT
     $     +(ZI*ZBUIZ-ZPM*FT*ZMIXSS(1,IZ))*COST)/2.
          ZB=((-ZI*ZAUIZ-ZPP*FT*ZMIXSS(1,IZ))*SINT
     $     +(ZI*ZBUIZ+ZPM*FT*ZMIXSS(1,IZ))*COST)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=3*(AS*((AMTP+MZIZ)**2-AMT2SS**2)+BS*((MZIZ-AMTP)**2-
     $     AMT2SS**2))/16./PI/MZIZ**3*
     $     SQRT(SSXLAM(MZIZ**2,AMT2SS**2,AMTP**2))
          CALL SSSAVE(ISZIZ,WID,ISTP2,-IDTP,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISTP2,IDTP,0,0,0)
        ENDIF
C
C          zi --> slepton + lepton
C
        IF(MZIZ.GT.(AMELSS+AME)) THEN
          WID=ALI(IZ)**2*(MZIZ**2+AME**2-AMELSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AME**2,AMELSS**2))
          CALL SSSAVE(ISZIZ,WID,ISEL,-IDE,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISEL,IDE,0,0,0)
        END IF
        IF(MZIZ.GT.(AMMLSS+AMMU)) THEN
          WID=ALI(IZ)**2*(MZIZ**2+AMMU**2-AMMLSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMMU**2,AMMLSS**2))
          CALL SSSAVE(ISZIZ,WID,ISMUL,-IDMU,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISMUL,IDMU,0,0,0)
        END IF
        IF(MZIZ.GT.(AMERSS+AME)) THEN
          WID=BLI(IZ)**2*(MZIZ**2+AME**2-AMERSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AME**2,AMERSS**2))
          CALL SSSAVE(ISZIZ,WID,ISER,-IDE,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISER,IDE,0,0,0)
        END IF
        IF(MZIZ.GT.(AMMRSS+AMMU)) THEN
          WID=BLI(IZ)**2*(MZIZ**2+AMMU**2-AMMRSS**2)/MZIZ**3/
     $         32./PI*SQRT(SSXLAM(MZIZ**2,AMMU**2,AMMRSS**2))
          CALL SSSAVE(ISZIZ,WID,ISMUR,-IDMU,0,0,0)
          CALL SSSAVE(ISZIZ,WID,-ISMUR,IDMU,0,0,0)
        END IF
        IF(MZIZ.GT.(AML1SS+AMTAU)) THEN
          ZA=((ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*COSL
     $     -(ZI*ZBLIZ-ZPM*FL*ZMIXSS(2,IZ))*SINL)/2.
          ZB=((-ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*COSL
     $     -(ZI*ZBLIZ+ZPM*FL*ZMIXSS(2,IZ))*SINL)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=(AS*((AMTAU+MZIZ)**2-AML1SS**2)+BS*((MZIZ-AMTAU)**2-
     $     AML1SS**2))/16./PI/MZIZ**3*
     $     SQRT(SSXLAM(MZIZ**2,AML1SS**2,AMTAU**2))
            CALL SSSAVE(ISZIZ,WID,ISTAU1,-IDTAU,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISTAU1,IDTAU,0,0,0)
        END IF
        IF(MZIZ.GT.(AML2SS+AMTAU)) THEN
          ZA=((ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*SINL
     $     +(ZI*ZBLIZ-ZPM*FL*ZMIXSS(2,IZ))*COSL)/2.
          ZB=((-ZI*ZALIZ-ZPP*FL*ZMIXSS(2,IZ))*SINL
     $     +(ZI*ZBLIZ+ZPM*FL*ZMIXSS(2,IZ))*COSL)/2.
          AS=ZA*CONJG(ZA)
          BS=ZB*CONJG(ZB)
          WID=(AS*((AMTAU+MZIZ)**2-AML2SS**2)+BS*((MZIZ-AMTAU)**2-
     $     AML2SS**2))/16./PI/MZIZ**3*
     $     SQRT(SSXLAM(MZIZ**2,AML2SS**2,AMTAU**2))
            CALL SSSAVE(ISZIZ,WID,ISTAU2,-IDTAU,0,0,0)
            CALL SSSAVE(ISZIZ,WID,-ISTAU2,IDTAU,0,0,0)
        ENDIF
        IF(MZIZ.GT.AMN1SS) THEN
          WID=(MZIZ**2-AMN1SS**2)**2/32./PI/MZIZ**3
          CALL SSSAVE(ISZIZ,ANI(IZ)**2*WID,ISNEL,-IDNE,0,0,0)
          CALL SSSAVE(ISZIZ,ANI(IZ)**2*WID,-ISNEL,IDNE,0,0,0)
        END IF
        IF(MZIZ.GT.AMN2SS) THEN
          WID=(MZIZ**2-AMN2SS**2)**2/32./PI/MZIZ**3
          CALL SSSAVE(ISZIZ,ANI(IZ)**2*WID,ISNML,-IDNM,0,0,0)
          CALL SSSAVE(ISZIZ,ANI(IZ)**2*WID,-ISNML,IDNM,0,0,0)
        END IF
        IF(MZIZ.GT.AMN3SS) THEN
          WID=(MZIZ**2-AMN3SS**2)**2/32./PI/MZIZ**3
          CALL SSSAVE(ISZIZ,ANI(IZ)**2*WID,ISNTL,-IDNT,0,0,0)
          CALL SSSAVE(ISZIZ,ANI(IZ)**2*WID,-ISNTL,IDNT,0,0,0)
        END IF
245   CONTINUE
C
C          Compute decays to gravitino for GMSB models
C
      DO 250 IZ=1,4
        MZIZ=ABS(AMZISS(IZ))
        ISZIZ=ISZ(IZ)
        IF (MZIZ.GT.AMGVSS) THEN
        WID=(ZMIXSS(4,IZ)*CTHW+ZMIXSS(3,IZ)*STHW)**2*MZIZ**5/
     ,       48./PI/(AMGVSS*AMPL)**2
        CALL SSSAVE(ISZIZ,WID,ISGRAV,IDGM,0,0,0)
C          Dalitz decay
          IF (MZIZ.GT.(AMGVSS+2*AME)) THEN
            WIDEE=WID*2*ALFAEM/(3*PI)*LOG(MZIZ/AME)
            CALL SSSAVE(ISZIZ,WIDEE,ISGRAV,IDE,-IDE,0,0)
          END IF
        END IF
        IF (MZIZ.GT.(AMZ+AMGVSS)) THEN
          WID=(2*(ZMIXSS(4,IZ)*STHW-ZMIXSS(3,IZ)*CTHW)**2+
     ,        (ZMIXSS(1,IZ)*SINBE-ZMIXSS(2,IZ)*COSBE)**2)*
     ,        (MZIZ**2-AMZ**2)**4/96./PI/MZIZ**3/(AMGVSS*AMPL)**2
          CALL SSSAVE(ISZIZ,WID,ISGRAV,IDZ,0,0,0)
        END IF
        IF (MZIZ.GT.(AMHL+AMGVSS)) THEN
          WID=(ZMIXSS(1,IZ)*COSA+ZMIXSS(2,IZ)*SINA)**2/6./
     ,        (AMGVSS*AMPL)**2*(MZIZ**2-AMHL**2)**4/16./PI/MZIZ**3
          CALL SSSAVE(ISZIZ,WID,ISGRAV,ISHL,0,0,0)
        END IF
        IF (MZIZ.GT.(AMHH+AMGVSS)) THEN
          WID=(-ZMIXSS(1,IZ)*SINA+ZMIXSS(2,IZ)*COSA)**2/6./
     ,        (AMGVSS*AMPL)**2*(MZIZ**2-AMHH**2)**4/16./PI/MZIZ**3
          CALL SSSAVE(ISZIZ,WID,ISGRAV,ISHH,0,0,0)
        END IF
        IF (MZIZ.GT.(AMHA+AMGVSS)) THEN
          WID=(ZMIXSS(1,IZ)*COSBE+ZMIXSS(2,IZ)*SINBE)**2/6./
     ,        (AMGVSS*AMPL)**2*(MZIZ**2-AMHA**2)**4/16./PI/MZIZ**3
          CALL SSSAVE(ISZIZ,WID,ISGRAV,ISHA,0,0,0)
        END IF
250   CONTINUE
C
C          Normalize zi branching ratios
C
      CALL SSNORM(ISZ1)
      CALL SSNORM(ISZ2)
      CALL SSNORM(ISZ3)
      CALL SSNORM(ISZ4)
C
      RETURN
      END
+EOD
+DECK,SSZWF1
        REAL FUNCTION SSZWF1(E)
C-----------------------------------------------------------------------
C          SSWZBF: ziss -> wiss f fbar
C          Baer's Z2WFUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL MW,MZ,M,F1,F2,E,X,Y,WWID
C
      MW=TMP(1)
      MZ=TMP(2)
      X=TMP(3)
      Y=TMP(4)
      M=AMW
      WWID=GAMW
C
      F1=SQRT(MAX(0.,E**2-MW**2))/
     $((MZ**2+MW**2-M**2-2*MZ*E)**2+WWID**2*M**2)
      F2=(X**2+Y**2)*(3*(MZ**2+MW**2)*MZ*E-4*MZ**2*E*E-2*MZ**2*MW**2)
     $-3*(X**2-Y**2)*MZ*MW*(MZ**2+MW**2-2*MZ*E)
      SSZWF1=F1*F2
      RETURN
      END
+EOD
+DECK,SSZZF1
      REAL FUNCTION SSZZF1(X)
C-----------------------------------------------------------------------
C          SSWZBF: ziss -> zjss f fbar
C          Baer's TFUNC
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL X
      DOUBLE PRECISION N,S,Q,D,SQBRKT,TERM1,QS
      DOUBLE PRECISION MZ2,MZ1,M,DSN
C
      MZ2=TMP(1)
      MZ1=TMP(2)
      M=TMP(3)
      DSN=TMP(4)
C
      N=MZ1**2/MZ2**2
      S=M**2/MZ2**2
      Q=X*(1.D0-N)/2.
      QS=Q**2
      D=(S-2*S*Q-N)/((1.D0-2*Q)*(S-2*Q-N))
      IF(D.LE.0.) THEN
        WRITE(LOUT,*) 'ERROR IN SSZZF1: D,S,Q,N=',D,S,Q,N
        SSZZF1=0
        RETURN
      END IF
      SQBRKT=-Q*(1.D0-2*Q-N)/(1.D0-2*Q)-(2*Q-S+N)/2.D0*DLOG(D)
      TERM1=QS*(1.D0-2*Q-N)**2/(1.D0-2*Q-S)**2/(1.D0-2*Q)
     $+DSQRT(N)/2.D0/(1.D0-2*Q-S)*SQBRKT*DSN
      SSZZF1=(1.D0-N)/2.D0*TERM1
      RETURN
      END
+EOD
+DECK,SSZZF2
      REAL FUNCTION SSZZF2(E)
C-----------------------------------------------------------------------
C          SSWZBF: ziss -> zjss f fbar
C          Baer's Z2ZFUN
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL E
      DOUBLE PRECISION MZ1,MZ2,SN,M,PI,F1,F2,ZWID,MF,BF
      DATA PI/3.14159265D0/
C
      MZ2=TMP(1)
      MZ1=TMP(2)
      SN=TMP(4)
      MF=TMP(6)
      M=AMZ
      ZWID=GAMZ
      BF=DSQRT(MAX(0.D0,1.D0-4*MF**2/(MZ2**2+MZ1**2-2*E*MZ2)))
C
      F1=SQRT(MAX(0.D0,E**2-MZ1**2))/
     $((MZ1**2+MZ2**2-M**2-2*MZ2*E)**2+ZWID**2*M**2)
      F2=E*(MZ1**2+MZ2**2+2*SN*MZ1*MZ2)-MZ2*(E**2+MZ1**2)-
     $BF*MZ2*(E**2-MZ1**2)/3.D0-SN*MZ1*(MZ1**2+MZ2**2-2*MF**2)
      SSZZF2=MZ2*BF*F1*F2/2.D0/PI**3
      RETURN
      END
+EOD
+DECK,SSZZF3
        REAL FUNCTION SSZZF3(SP)
C-----------------------------------------------------------------------
C          SSWZBF: ziss -> zjss f fbar
C          Baer's FI
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL SP
      DOUBLE PRECISION S,PI,M2,M1,MS,E,QS,MUS,BKT
      DOUBLE PRECISION THZ,TERM,MZ,DFI,Q,MF,QP
      DATA PI/3.14159265D0/
C
      MZ=AMZ
      M2=TMP(1)
      M1=TMP(2)
      MS=TMP(3)
      THZ=TMP(4)
      MF=TMP(6)
C
      S=SP
      E=(S+M2**2-M1**2)/2.D0/M2
      QS=E**2-S
      Q=DSQRT(MAX(0.D0,QS))
      QP=Q*DSQRT(MAX(0.D0,1.D0-4*MF**2/S))
      MUS=MS**2+S-M1**2-MF**2
      BKT=(MS**2-M1**2-MF**2)*(MS**2-M2**2-MF**2)+THZ*M1*M2*(S-2*MF**2)
      TERM=DLOG((M2*(E+QP)-MUS)/(M2*(E-QP)-MUS))
      DFI=-.5D0*M2*E*QP-.5D0*(MS**2-M2**2-S-MF**2)*QP-BKT*TERM/4.D0/M2
      DFI=DFI*PI**2/2.D0/M2/(S-MZ**2)
      SSZZF3=DFI
      RETURN
      END
+EOD
+DECK,SSZZF4
      REAL FUNCTION SSZZF4(E)
C-----------------------------------------------------------------------
C          Z_I -> Z_J +B +BBAR VIA HIGGS
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL E
      DOUBLE PRECISION MZ1,MZ2,SN,EE,MH1,MH2,P,MF,BF,TM
C
      MZ2=TMP(1)
      MZ1=TMP(2)
      MH1=TMP(3)
      SN=TMP(4)
      MH2=TMP(5)
      MF=TMP(6)
      EE=E
C
      P=SQRT(MAX(0.D0,EE**2-MZ1**2))
      TM=1.D0-4*MF**2/(MZ2**2+MZ1**2-2*E*MZ2)
      BF=DSQRT(MAX(0.D0,TM))
      SSZZF4=P*BF*(MZ2**2+MZ1**2-2*MZ2*EE-2*MF**2)*
     $(MZ2*EE+SN*MZ2*MZ1)/(MZ2**2+MZ1**2-2*MZ2*EE-MH1**2)/
     $(MZ2**2+MZ1**2-2*MZ2*EE-MH2**2)
      RETURN
      END
+EOD
+DECK,SSZZF5
        REAL FUNCTION SSZZF5(SP)
C-----------------------------------------------------------------------
C          SSWZBF: ziss -> zjss f fbar
C          Drees' I26 integrand for higgs-sfermion interference
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
C
      REAL SP
      DOUBLE PRECISION S,M2,M1,MS,E,QS,MUS,BKT
      DOUBLE PRECISION THZ,TERM,MH,DFI,Q,MF,QP
C
      M2=TMP(1)
      M1=TMP(2)
      MS=TMP(3)
      MH=TMP(5)
      THZ=TMP(4)
      MF=TMP(6)
C
      S=SP
      E=(S+M2**2-M1**2)/2.D0/M2
      QS=E**2-S
      Q=DSQRT(MAX(0.D0,QS))
      QP=Q*DSQRT(MAX(0.D0,1.D0-4*MF**2/S))
      MUS=MS**2+S-M1**2-MF**2
      BKT=S*MS**2-MF**2*(M1**2+M2**2)+THZ*M1*M2*(S-2*MF**2)
      TERM=DLOG((M2*(E+QP)-MUS)/(M2*(E-QP)-MUS))
      DFI=(S*QP/2.D0+BKT*TERM/4.D0/M2)/(S-MH**2)
      SSZZF5=DFI
      RETURN
      END
+EOD
+DECK,SSZZG1
        REAL FUNCTION SSZZG1(XARG)
C-----------------------------------------------------------------------
C          SSZIBF: ziss -> zjss + gm
C          Corresponds to integral I_H in Tadas' notes
C
C          Change variables: XARG -> y, 0 < y < 1,
C          y = sqrt(1-x), dx = -2 y dy
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
      REAL XARG
      DOUBLE PRECISION XX,F,MF,MSF,MZINI,MZFIN,TOP,BOT
C
      MF=TMP(1)
      MSF=TMP(2)
      MZINI=TMP(3)
      MZFIN=TMP(4)
C
C          xx=1-xarg**2 with better precision
      XX=XARG
      XX=(1-XX)*(1+XX)
      TOP=-MZINI**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
      BOT=-MZFIN**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
      F=DLOG(TOP/BOT)/(MZINI**2-MZFIN**2)/(1.D0-XX)
      SSZZG1=2*XARG*F
      RETURN
      END
+EOD
+DECK,SSZZG2
        REAL FUNCTION SSZZG2(XARG)
C-----------------------------------------------------------------------
C          SSZIBF: ziss -> zjss + gm
C          Corresponds to integral I^2_H in Tadas' notes
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL XARG
        DOUBLE PRECISION XX,F,MF,MSF,MZINI,MZFIN,TOP,BOT
C
        MF=TMP(1)
        MSF=TMP(2)
        MZINI=TMP(3)
        MZFIN=TMP(4)
C
        XX=XARG
        TOP=-MZINI**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
        BOT=-MZFIN**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
        F=DLOG(TOP/BOT)/(MZINI**2-MZFIN**2)
        SSZZG2=F
        RETURN
        END
+EOD
+DECK,SSZZG3
        REAL FUNCTION SSZZG3(XARG)
C-----------------------------------------------------------------------
C          SSZIBF: ziss -> zjss + gm
C          Corresponds to integral K_H in Tadas' notes
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL XARG
        DOUBLE PRECISION XX,F,MF,MSF,MZINI,MZFIN,TOP,BOT
C
        MF=TMP(1)
        MSF=TMP(2)
        MZINI=TMP(3)
        MZFIN=TMP(4)
C
        XX=XARG
        TOP=-MZINI**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
        BOT=-MZFIN**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
        F=-(1+TOP*DLOG(TOP/BOT)/XX/(1.D0-XX)/(MZINI**2-
     $MZFIN**2))/(MZINI**2-MZFIN**2)
        SSZZG3=F
        RETURN
        END
+EOD
+DECK,SSZZG4
        REAL FUNCTION SSZZG4(XARG)
C-----------------------------------------------------------------------
C          SSZIBF: ziss -> zjss + gm
C          Corresponds to integral J_H in Tadas' notes
C-----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSSM
+CDE,SSPAR
+CDE,SSTMP
        REAL XARG
        DOUBLE PRECISION XX,F,MF,MSF,MZINI,MZFIN,TOP,BOT
C
        MF=TMP(1)
        MSF=TMP(2)
        MZINI=TMP(3)
        MZFIN=TMP(4)
C
        XX=XARG
        TOP=-MZINI**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
        BOT=-MZFIN**2*XX*(1.D0-XX)+MF**2*XX+MSF**2*(1.D0-XX)
        F=DLOG(TOP/BOT)/XX/(MZINI**2-MZFIN**2)
        SSZZG4=F
        RETURN
        END
C
C       End of functions added by Tadas
C
+EOD
+DECK,SUALFE
C----------------------------------------------------------------------
      FUNCTION SUALFE(QS)
C----------------------------------------------------------------------
C
C     Returns the running EM coupling alpha_em(q**2)
C
C-----SEE BARGER/PHILLIPS, P. 202 ---------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
      REAL SUALFE
      REAL PI,MB,SUM,A0,QD,QU,MS,ME,QS,MM,MD,MU,MTAU,MC
      DATA ME/.0005/,MM/.105/,MTAU/1.784/,MU/.01/,MD/.01/
      DATA MS/.5/,MC/1.6/,MB/5.0/,PI/3.1415926/
C
      SUM=0.
      QU=2./3.
      QD=-1./3.
      IF (QS.GT.4*ME**2) SUM=SUM+LOG(QS/4./ME**2)
      IF (QS.GT.4*MM**2) SUM=SUM+LOG(QS/4./MM**2)
      IF (QS.GT.4*MTAU**2) SUM=SUM+LOG(QS/4./MTAU**2)
      IF (QS.GT.4*MU**2) SUM=SUM+3*QU**2*LOG(QS/4./MU**2)
      IF (QS.GT.4*MD**2) SUM=SUM+3*QD**2*LOG(QS/4./MD**2)
      IF (QS.GT.4*MS**2) SUM=SUM+3*QD**2*LOG(QS/4./MS**2)
      IF (QS.GT.4*MC**2) SUM=SUM+3*QU**2*LOG(QS/4./MC**2)
      IF (QS.GT.4*MB**2) SUM=SUM+3*QD**2*LOG(QS/4./MB**2)
      A0=1./137.
      SUALFE=A0/(1.-A0/3./PI*SUM)
      RETURN
      END
+EOD
+DECK,SUALFS
C----------------------------------------------------------------------
      FUNCTION SUALFS(QSQ,ALAM4,TMASS,LOOP)
C----------------------------------------------------------------------
C
C       This function returns the 1, 2, or 3-loop value of alpha_s
C       Input:
C               QSQ     = Q**2 (real)
C               ALAM4   = Lambda for 4 active quark flavors (real)
C               TMASS   = top quark mass to determine lambda-6 (real)
C               LOOP    = number of loops for alpha_s (= 1, 2 or 3)
C       Parametrization of the strong coupling constant according to
C       LOOP = 1, 2 : from the book;
C       LOOP = 3:     W. J. Marciano, Phys. Rev. D 29 (1984) 580.
C       Note : threshold at 2*Mq
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
      REAL SUALFS, QSQ, ALAM4, TMASS
      INTEGER LOOP
      REAL PI, BMASS
      REAL ANF, ALAM, ALAMSQ, ALAM5, T, TT, B0, B1, B2, X, ALPHAS
      DATA PI/3.1415927/, BMASS/5.0/
C
      IF (QSQ .LT. 4.0*BMASS**2) THEN
        ANF   = 4.0
        ALAM  = ALAM4
      ELSE IF (QSQ .LT. 4.0*TMASS**2) THEN
        ANF   = 5.0
        ALAM  = ALAM4*(ALAM4/(2.0*BMASS))**(2.0/23.0)
     1           *(ALOG(4.0*BMASS**2/ALAM4**2))**(-963.0/13225.0)
      ELSE
        ANF   = 6.0
        ALAM5 = ALAM4*(ALAM4/(2.0*BMASS))**(2.0/23.0)
     1           *(ALOG(4.0*BMASS**2/ALAM4**2))**(-963.0/13225.0)
        ALAM  = ALAM5*(ALAM5/(2.0*TMASS))**(2.0/21.0)
     1           *(ALOG(4.0*TMASS**2/ALAM5**2))**(-107.0/1127.0)
      END IF
      B0       = 11.0-2.0/3.0*ANF
      ALAMSQ   = ALAM**2
      T        = ALOG(QSQ/ALAMSQ)
      IF (T .LE. 1.0) T = ALOG(4.0/ALAMSQ)
      ALPHAS   = 4*PI/B0/T
      IF (LOOP .EQ. 1) THEN
        SUALFS = ALPHAS
      ELSE IF (LOOP .EQ. 2) THEN
        B1 = 102.0-38.0/3.0*ANF
        X  = B1/(B0**2*T)
        TT = ALOG(T)
        SUALFS = ALPHAS*(1.0-X*TT)
      ELSE IF (LOOP .EQ. 3) THEN
        B1 = 102.0-38.0/3.0*ANF
        B2 = 0.5*(2857.0-5033.0/9.0*ANF+325.0/27.0*ANF**2)
        X  = B1/(B0**2*T)
        TT = ALOG(T)
        SUALFS = ALPHAS*(1.0-X*TT+X**2*((TT-0.5)**2
     $      +B2*B0/B1**2-1.25))
      ELSE
        WRITE(LOUT,*) ' WRONG LOOP NUMBER IN ALPHA-S EVALUATION!'
        STOP 99
      END IF
C
      RETURN
      END
+EOD
+DECK,SUGEFF
C-----------------------------------------------------------------
      SUBROUTINE SUGEFF(G0,SIG1,SIG2)
C-----------------------------------------------------------------
C
C     Compute Higgs mass shift due to 1-loop effective potential
C     remaining tadpoles added by Javier Ferrandis 5/20/03
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SUGPAS
+CDE,SUGMG
      REAL G0(31),SIG1,SIG2
      REAL DT1,DELT1S,SIG1T1,DMSDV2,FB,FT,MST2,MSB2,MSB1,SIG2B1,
     $SIG1B1,SIG2B2,SIG1B2,DB1,SIG1T2,SIG2T1,DELB1S,SIG2T2,MST1,COS2W, 
     $MT,PI,COTB,TANB,MB,SIG2B,SIG1B,G,GGP,SIG2T,E,FAC,SIG1T,QS,
     $BETA,SINB,COSB,FAC4,FL,ML,SIG1L,SIG2L,MSL1,MSL2,
     $DELL1S,DL1,SIG1L1,SIG2L1,SIG1L2,SIG2L2,VUQ,VDQ
      REAL VEVQ,MWQ,MZQ
      REAL M1Q,M2Q,MPHO
      REAL COS2B
      REAL SUGFN,QSC
      REAL ZESS1,ZESS2,ZESS3,ZESS4
      REAL W1SS,W2SS
      REAL MHL,MHH,MA
      REAL SIG1C1,SIG1C2,SIG2C1,SIG2C2,SIG1C,SIG2C
      REAL SIG1HL,SIG1HH,SIG2HL,SIG2HH,SIG1HI,SIG2HI
      REAL SIGNE1,SIGNE2,SIGNEUD,SIGNEUU,SIGNEDD
C     Statement function
      SUGFN(QSC)=QSC**2*(LOG(QSC**2/HIGFRZ**2)-1.)
C
      G=G2
      COS2W=1.-XW
      VUQ=G0(31)
      VDQ=G0(30)
      TANB=VUQ/VDQ
      COTB=1./TANB
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=COS(BETA)
      PI=4.*ATAN(1.)
      FAC=3./8./PI**2
      FAC4=FAC/3.
      E=EXP(1.)
      QS=HIGFRZ**2
C-----INITIALIZE EFF. POT'L CONTRIBUTIONS
      SIG1B=0.
      SIG1B1=0.
      SIG1B2=0.
      SIG1T=0.
      SIG1T1=0.
      SIG1T2=0.
      SIG1L=0.
      SIG1L1=0.
      SIG1L2=0.
      SIGNE1=0.
      SIG1C=0.
      SIG1HI=0.
      SIG2B=0.
      SIG2B1=0.
      SIG2B2=0.
      SIG2T=0.
      SIG2T1=0.
      SIG2T2=0.
      SIG2L=0.
      SIG2L1=0.
      SIG2L2=0.
      SIGNE2=0.
      SIG2C=0.
      SIG2HI=0.
C-----CALCULATE TOP AND BOTTOM CONTRIBUTIONS; USE RUNNING MASSES--
      FL=G0(4)
      FB=G0(5)
      FT=G0(6)
      ML=FL*VDQ
      MB=FB*VDQ
      MT=FT*VUQ
      SIG1T=0.
      SIG2T=-FAC*MT**2*G0(6)**2*LOG(MT**2/E/QS)
      SIG1B=-FAC*MB**2*G0(5)**2*LOG(MB**2/E/QS)
      SIG2B=0.
      SIG1L=-FAC4*ML**2*G0(4)**2*LOG(ML**2/E/QS)
      SIG2L=0.
      GGP=(G**2+GP**2)/2.
      MST1=MSS(12)
      MST2=MSS(13)
      MSB1=MSS(10)
      MSB2=MSS(11)
      MSL1=MSS(21)
      MSL2=MSS(22)
      VEVQ=SQRT(VUQ**2+VDQ**2)
      MWQ=G/SQRT(2.)*VEVQ
      MZQ=SQRT(GGP)*VEVQ
      COS2B=SIN(BETA)     
C-----CALCULATE STOP_1 CONTRIBUTION -------------------------------
      DELT1S=(.5*(G0(24)-G0(23))+(8*COS2W-5.)*GGP*
     $      (VDQ**2-VUQ**2)/12.)**2+G0(6)**2*VUQ**2*(G0(12)-MU*COTB)**2
      DT1=.5*(G0(24)-G0(23))+(8*COS2W-5.)*GGP*
     $       (VDQ**2-VUQ**2)/12.
      DMSDV2=GGP/4.-(2*DT1*(8*COS2W-5.)*GGP/12.-
     $        FT**2*MU*(G0(12)*TANB-MU))/2./SQRT(DELT1S)
      SIG1T1=FAC/2.*MST1**2*LOG(MST1**2/E/QS)*DMSDV2
      DMSDV2=-GGP/4.+FT**2-(-2*DT1*(8*COS2W-5.)*GGP/12.+
     $        FT**2*G0(12)*(G0(12)-MU*COTB))/2./SQRT(DELT1S)
      SIG2T1=FAC/2.*MST1**2*LOG(MST1**2/E/QS)*DMSDV2
C-----CALCULATE STOP_2 CONTRIBUTION -------------------------------
      DMSDV2=GGP/4.+(2*DT1*(8*COS2W-5.)*GGP/12.-
     $        FT**2*MU*(G0(12)*TANB-MU))/2./SQRT(DELT1S)
      SIG1T2=FAC/2.*MST2**2*LOG(MST2**2/E/QS)*DMSDV2
      DMSDV2=-GGP/4.+FT**2+(-2*DT1*(8*COS2W-5.)*GGP/12.+
     $        FT**2*G0(12)*(G0(12)-MU*COTB))/2./SQRT(DELT1S)
      SIG2T2=FAC/2.*MST2**2*LOG(MST2**2/E/QS)*DMSDV2
C-----CALCULATE SBOT_1 CONTRIBUTION -------------------------------
      DELB1S=(.5*(G0(24)-G0(22))-(4*COS2W-1.)*GGP*
     $  (VDQ**2-VUQ**2)/12.)**2+G0(5)**2*VDQ**2*(G0(11)-MU*TANB)**2
      DB1=.5*(G0(24)-G0(22))-(4*COS2W-1.)*GGP*
     $       (VDQ**2-VUQ**2)/12.
      DMSDV2=-GGP/4.+FB**2-(-2*DB1*(4*COS2W-1.)*GGP/12.+
     $        FB**2*G0(11)*(G0(11)-MU*TANB))/2./SQRT(DELB1S)
      SIG1B1=FAC/2.*MSB1**2*LOG(MSB1**2/E/QS)*DMSDV2
      DMSDV2=GGP/4.-(2*DB1*(4*COS2W-1.)*GGP/12.-
     $        FB**2*MU*(G0(11)*COTB-MU))/2./SQRT(DELB1S)
      SIG2B1=FAC/2.*MSB1**2*LOG(MSB1**2/E/QS)*DMSDV2
C-----CALCULATE SBOT_2 CONTRIBUTION -------------------------------
      DMSDV2=-GGP/4.+FB**2+(-2*DB1*(4*COS2W-1.)*GGP/12.+
     $        FB**2*G0(11)*(G0(11)-MU*TANB))/2./SQRT(DELB1S)
      SIG1B2=FAC/2.*MSB2**2*LOG(MSB2**2/E/QS)*DMSDV2
      DMSDV2=GGP/4.+(2*DB1*(4*COS2W-1.)*GGP/12.-
     $        FB**2*MU*(G0(11)*COTB-MU))/2./SQRT(DELB1S)
      SIG2B2=FAC/2.*MSB2**2*LOG(MSB2**2/E/QS)*DMSDV2
C-----CALCULATE STAU_1 CONTRIBUTION -------------------------------
      DELL1S=(.5*(G0(21)-G0(20))-(4*COS2W-3.)*GGP*
     $  (VDQ**2-VUQ**2)/4.)**2+G0(4)**2*VDQ**2*(G0(10)-MU*TANB)**2
      DL1=.5*(G0(21)-G0(20))-(4*COS2W-3.)*GGP*
     $       (VDQ**2-VUQ**2)/4.
      DMSDV2=-GGP/4.+FL**2-(-2*DL1*(4*COS2W-3.)*GGP/4.+
     $        FL**2*G0(10)*(G0(10)-MU*TANB))/2./SQRT(DELL1S)
      SIG1L1=FAC4/2.*MSL1**2*LOG(MSL1**2/E/QS)*DMSDV2
      DMSDV2=GGP/4.-(2*DL1*(4*COS2W-3.)*GGP/4.-
     $        FL**2*MU*(G0(10)*COTB-MU))/2./SQRT(DELL1S)
      SIG2L1=FAC4/2.*MSL1**2*LOG(MSL1**2/E/QS)*DMSDV2
C-----CALCULATE STAU_2 CONTRIBUTION -------------------------------
      DMSDV2=-GGP/4.+FL**2+(-2*DL1*(4*COS2W-3.)*GGP/4.+
     $        FL**2*G0(10)*(G0(10)-MU*TANB))/2./SQRT(DELL1S)
      SIG1L2=FAC4/2.*MSL2**2*LOG(MSL2**2/E/QS)*DMSDV2
      DMSDV2=GGP/4.+(2*DL1*(4*COS2W-3.)*GGP/4.-
     $        FL**2*MU*(G0(10)*COTB-MU))/2./SQRT(DELL1S)
      SIG2L2=FAC4/2.*MSL2**2*LOG(MSL2**2/E/QS)*DMSDV2
C-----CALCULATE NEUTRALINO CONTRIBUTION -------------------------------
      ZESS1=MSS(23)
      ZESS2=MSS(24)
      ZESS3=MSS(25)
      ZESS4=MSS(26)
      if(((ZESS1-ZESS2).eq.0.).
     #     or.((ZESS1-ZESS3).eq.0.).
     #     or.((ZESS1-ZESS4).eq.0.).
     #     or.((ZESS2-ZESS3).eq.0.).
     #     or.((ZESS2-ZESS4).eq.0.).
     #     or.((ZESS3-ZESS4).eq.0.)) then
        SIGNE1=0.
        SIGNE2=0.
        goto 111
      else
        continue
      endif  
      M1Q=G0(7)
      M2Q=G0(8)
      MPHO=COS2W*M1Q+XW*M2Q
      SIGNEUU=-GGP/4./2./PI**2*(
     # ZESS1**2*(ZESS1-MPHO)/(ZESS1-ZESS2)/(ZESS1-ZESS3)
     #     /(ZESS1-ZESS4)*SUGFN(ZESS1)+
     # ZESS2**2*(ZESS2-MPHO)/(ZESS2-ZESS1)/(ZESS2-ZESS3)
     #     /(ZESS2-ZESS4)*SUGFN(ZESS2)+
     # ZESS3**2*(ZESS3-MPHO)/(ZESS3-ZESS1)/(ZESS3-ZESS2)
     #    /(ZESS3-ZESS4)*SUGFN(ZESS3)+
     # ZESS4**2*(ZESS4-MPHO)/(ZESS4-ZESS1)/(ZESS4-ZESS2)
     #   /(ZESS4-ZESS3)*SUGFN(ZESS4))
      SIGNEDD=SIGNEUU
      SIGNEUD=-GGP/4./2./PI**2*MU*(
     # ZESS1*(ZESS1-MPHO)/(ZESS1-ZESS2)/(ZESS1-ZESS3)
     #     /(ZESS1-ZESS4)*SUGFN(ZESS1)+
     # ZESS2*(ZESS2-MPHO)/(ZESS2-ZESS1)/(ZESS2-ZESS3)
     #     /(ZESS2-ZESS4)*SUGFN(ZESS2)+
     # ZESS3*(ZESS3-MPHO)/(ZESS3-ZESS1)/(ZESS3-ZESS2)
     #    /(ZESS3-ZESS4)*SUGFN(ZESS3)+
     # ZESS4*(ZESS4-MPHO)/(ZESS4-ZESS1)/(ZESS4-ZESS2)
     #   /(ZESS4-ZESS3)*SUGFN(ZESS4))
      SIGNE1=SIGNEDD+TANB*SIGNEUD
      SIGNE2=SIGNEUU+COTB*SIGNEUD
C-----CALCULATE CHARGINO CONTRIBUTION -----------
      W1SS=MSS(23)
      W2SS=MSS(24)
      if((W1SS-W2SS).eq.0.) then
          SIG1C=0.
          SIG2C=0.
         goto 111
      else
         continue
      endif  
      SIG1C1=-G**2/16./PI**2*(1.-(2.*MWQ**2*COS2B+M2Q**2+MU**2)/
     #   (W2SS**2-W1SS**2)-
     #   TANB*2.*M2Q*MU/(W2SS**2-W1SS**2))*SUGFN(W1SS)
      SIG1C2=-G**2/16./PI**2*(1.+(2.*MWQ**2*COS2B+M2Q**2+MU**2)/
     #   (W2SS**2-W1SS**2)+
     #   TANB*2.*M2Q*MU/(W2SS**2-W1SS**2))*SUGFN(W2SS)
      SIG2C1=-G**2/16./PI**2*(1.-(-2.*MWQ**2*COS2B+M2Q**2+MU**2)/
     #   (W2SS**2-W1SS**2)-
     #   COTB*2.*M2Q*MU/(W2SS**2-W1SS**2))*SUGFN(W1SS)
      SIG2C2=-G**2/16./PI**2*(1.+(-2.*MWQ**2*COS2B+M2Q**2+MU**2)/
     #   (W2SS**2-W1SS**2)+
     #   COTB*2.*M2Q*MU/(W2SS**2-W1SS**2))*SUGFN(W2SS)
      SIG1C=SIG1C1+SIG1C2
      SIG2C=SIG2C1+SIG2C2
C-----CALCULATE HIGGSES CONTRIBUTION -------------------------------
      MHL=MSS(29)
      MHH=MSS(30)
      MA=MSS(31)
      IF(MHL.LT.1.) THEN
	      SIG1HI=0.
              SIG2HI=0.
	      GOTO 111
      ELSE
	      CONTINUE
      ENDIF
      IF(MHH.LT.1.) THEN
	      SIG1HI=0.
              SIG2HI=0.
	      GOTO 111
      ELSE
	      CONTINUE
      ENDIF
      SIG1HL=GGP**2/32./PI**2*(1.-(MZQ**2+
     #    MA**2*(1.-4.*COS2B+2.*COS2B**2))/
     #   (MHH**2-MHL**2))*SUGFN(MHL)
      SIG1HH=GGP**2/32./PI**2*(1.-(MZQ**2+
     #    MA**2*(1.-4.*COS2B+2.*COS2B**2))/
     #   (MHH**2-MHL**2))*SUGFN(MHH)
      SIG2HL=GGP**2/32./PI**2*(1.-(MZQ**2+
     #   MA**2*(1.+4.*COS2B+2.*COS2B**2))/
     #   (MHH**2-MHL**2))*SUGFN(MHL)
      SIG2HH=GGP**2/32./PI**2*(1.-(MZQ**2+
     #   MA**2*(1.+4.*COS2B+2.*COS2B**2))/
     #   (MHH**2-MHL**2))*SUGFN(MHH)
      SIG1HI=SIG1HL+SIG1HH
      SIG2HI=SIG2HL+SIG2HH
111    CONTINUE
C-----ADD ALL TERMS ------------------------------------------------
      SIG1=SIG1B+SIG1B1+SIG1B2+SIG1T+SIG1T1+SIG1T2+
     $SIG1L+SIG1L1+SIG1L2+SIGNE1+SIG1C+SIG1HI
      SIG2=SIG2B+SIG2B1+SIG2B2+SIG2T+SIG2T1+SIG2T2+
     $SIG2L+SIG2L1+SIG2L2+SIGNE2+SIG2C+SIG2HI
      RETURN
      END
+EOD
+DECK,SUGFRZ
C------------------------------------------------------------------
      SUBROUTINE SUGFRZ(Q,G,G0,IG)
C------------------------------------------------------------------
C
C     Freeze out final soft breaking parameters
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SUGPAS
+CDE,SSPAR
      INTEGER IG(31)
      REAL Q,MT,PI
      REAL*8 G(31),DPI
      REAL G0(31)
      INTEGER I
C
      MT=AMT
      PI=4.*ATAN(1.)
      DPI=4.D0*DATAN(1.D0)
      DO 200 I=1,3
        G0(I)=SNGL(G(I))
200   CONTINUE
C          Freeze out Yukawa couplings and A-terms at HIGFRZ
      DO 205 I=4,6
        IF (Q.LT.HIGFRZ.AND.IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
          IG(I)=1
          G0(I+6)=SNGL(G(I+6))
          IG(I+6)=1
        ELSE IF (IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
          G0(I+6)=SNGL(G(I+6))
        END IF
205   CONTINUE
C         Extract b Yukawa at mA for use in Higgs decay rates
      IF (Q.GT.AMHA) THEN
        FBMA=SNGL(G(5))
      END IF
C         Extract vu, vd at mt for mt calculation...
      IF (Q.GT.AMT) THEN
        VUMT=SNGL(G(30))
        VDMT=SNGL(G(31))
        ASMTP=SNGL(G(3)**2/4.D0/DPI)
      END IF
      IF (Q.GT.HIGFRZ) THEN
        ASMSS=SNGL(G(3)**2/4.D0/DPI)
        M3Q=SNGL(G(9))
      END IF
C          Freeze out running gluino mass at MGL
        IF (Q.LT.ABS(SNGL(G(9))).AND.IG(9).EQ.0) THEN
          G0(9)=SNGL(G(9))
          IG(9)=1
            ASM3=SNGL(G(3)**2/4.D0/DPI)
        ELSE IF (IG(9).EQ.0) THEN
          G0(9)=SNGL(G(9))
        END IF
C          Freeze out Higgs paremeters at HIGFRZ
      DO 211 I=13,14
        IF (Q.LT.HIGFRZ.AND.IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
          IG(I)=1
          G0(I-6)=SNGL(G(I-6))
          IG(I-6)=1
          G0(I+12)=SNGL(G(I+12))
          IG(I+12)=1
          G0(I+17)=SNGL(G(I+17))
          IG(I+17)=1
        ELSE IF (IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
          G0(I-6)=SNGL(G(I-6))
          G0(I+12)=SNGL(G(I+12))
          G0(I+17)=SNGL(G(I+17))
        END IF
211   CONTINUE
C          Freeze out 1st/2nd gen. soft terms at own masses
      DO 220 I=15,19
        IF (Q.LT.SQRT(ABS(SNGL(G(I)))).AND.IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
          IG(I)=1
        ELSE IF (IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
        END IF
220   CONTINUE
C          Freeze out third gen. soft terms at HIGFRZ
      DO 221 I=20,24
        IF (Q.LT.HIGFRZ.AND.IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
          IG(I)=1
        ELSE IF (IG(I).EQ.0) THEN
          G0(I)=SNGL(G(I))
        END IF
221   CONTINUE
C          Freeze our N_R parameters at Majorana mass scale
      DO 230 I=27,29
        IF (G(I).NE.0.D0) G0(I)=SNGL(G(I))
        IF (Q.LT.AMNRMJ.AND.IG(I).EQ.0.) THEN
          IG(I)=1
        END IF
230   CONTINUE
100   RETURN
      END
+EOD
+DECK,SUGMAS
C---------------------------------------------------------------
      SUBROUTINE SUGMAS(G0,ILOOP,IMODEL,SIGA)
C---------------------------------------------------------------
C
C     Compute tree level sparticle masses; output to MSS, XISAIN
C     Further tadpoles added to mA by Javier, 5/20/03
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSPAR
+CDE,SSSM
+CDE,SUGPAS
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SUGNU
+CDE,SSINF
      REAL MSB1,MSB2,MST1,MST2,SIGA
      REAL G0(31)
      REAL SUGMFN,SUALFS,SSPOLE,MHP,MGLMGL,MHPS,
     $RDEL,ASMGL,DELHPS,M1S,M2S,FNB,FCN,
     $MB,FNT,MT,MW,TANB,BETA,COSB,COTB,SINB,MZ,COS2B,
     $PI,T2S,G,AL,MSSS,AT,AB,BRKT,B2S,T1S,TERM,B1S,Q,
     $FNL,MSL1,MSL2,COS2W,MAJXS,MAJX,
     $SIGST,SIGT,SIGSB,SIGB,SIGSL,SIGL,RZT,RZB,RZL
      REAL AA,BB,CC,DA,DB,DC,L1,L2,EVAL1,RL1,RL2
      REAL SIGHIG,SIGCHA
      DOUBLE PRECISION SSMQCD
      INTEGER IALLOW,ILOOP,MHLNEG,MHCNEG,IMODEL
C
C          Statement function
C
      SUGMFN(Q)=Q**2*(LOG(Q**2/HIGFRZ**2)-1.)
C
      MHPNEG=0
      PI=4.*ATAN(1.)
      XW=.232
      G=G0(2)
      COS2W=1.-SN2THW
      TANB=VUQ/VDQ
      MT=AMT
      MZ=AMZ
      MW=AMW
      AMTP=MT
      BETA=ATAN(TANB)
      COTB=1./TANB
      SINB=SIN(BETA)
      COSB=COS(BETA)
      SIN2B=SIN(2*BETA)
      COS2B=COS(2*BETA)
      AT=G0(12)
      AB=G0(11)
      AL=G0(10)
      MLQ=G0(4)*VDQ
      MBQ=G0(5)*VDQ
      MTQ=G0(6)*VUQ
C
C          Compute some masses from RGE solution to prepare for SSMASS,
C          which computes the rest.
C
      MSSS=G0(19)+AMUP**2+(.5-2*XW/3.)*MZ**2*COS2B
      IF (MSSS.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
C          Squark and slepton masses
      MSS(2)=SQRT(MSSS)
      MSSS=G0(18)+AMUP**2+2./3.*XW*MZ**2*COS2B
      IF (MSSS.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      MSS(3)=SQRT(MSSS)
      MSS(4)=SQRT(G0(19)+AMDN**2+(-.5+XW/3.)*MZ**2*COS2B)
      MSS(5)=SQRT(G0(17)+AMDN**2-1./3.*XW*MZ**2*COS2B)
      MSS(6)=SQRT(G0(19)+AMST**2+(-.5+XW/3.)*MZ**2*COS2B)
      MSS(7)=SQRT(G0(17)+AMST**2-1./3.*XW*MZ**2*COS2B)
      MSS(8)=SQRT(G0(19)+AMCH**2+(.5-2*XW/3.)*MZ**2*COS2B)
      MSS(9)=SQRT(G0(18)+AMCH**2+2./3.*XW*MZ**2*COS2B)
      BRKT=(.5*(G0(24)-G0(22))-COS2B*(4*MW**2-MZ**2)/12.)**2+
     $       MBQ**2*(AB-MU*TANB)**2
      TERM=.5*(G0(24)+G0(22))+MBQ**2-MZ**2*COS2B/4.
      B1S=TERM-SQRT(BRKT)
      B2S=TERM+SQRT(BRKT)
      MSS(10)=SQRT(MAX(0.,B1S))
      MSS(11)=SQRT(MAX(0.,B2S))
      THETAB=ATAN((B1S-MBQ**2+MZ**2*COS2B*(.5-XW/3.)-
     $G0(24))/MBQ/(AB-MU*TANB))
      BRKT=(.5*(G0(24)-G0(23))+COS2B*(8*MW**2-5*MZ**2)/12.)**2+
     $       MTQ**2*(AT-MU*COTB)**2
      TERM=.5*(G0(24)+G0(23))+MTQ**2+MZ**2*COS2B/4.
      T1S=TERM-SQRT(BRKT)
      IF (T1S.LE.0..OR.B1S.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      T2S=TERM+SQRT(BRKT)
      MSS(12)=SQRT(MAX(0.,T1S))
      MSS(13)=SQRT(MAX(0.,T2S))
      THETAT=ATAN((T1S-MTQ**2+MZ**2*COS2B*(-.5+2*XW/3.)-
     $G0(24))/MTQ/(AT-MU*COTB))
      MSSS=G0(16)+.5*MZ**2*COS2B
      IF (MSSS.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      MSS(14)=SQRT(MSSS)
      MSS(15)=MSS(14)
      MSSS=G0(21)+.5*MZ**2*COS2B
      IF (MSSS.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      MSS(16)=SQRT(MSSS)
      MSSS=G0(16)+AME**2-.5*(2*MW**2-MZ**2)*COS2B
      IF (MSSS.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      MSS(17)=SQRT(MSSS)
      MSSS=G0(15)+AME**2+(MW**2-MZ**2)*COS2B
      IF (MSSS.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      MSS(18)=SQRT(MSSS)
      MSS(19)=SQRT(G0(16)+AMMU**2-.5*(2*MW**2-MZ**2)*COS2B)
      MSS(20)=SQRT(G0(15)+AMMU**2+(MW**2-MZ**2)*COS2B)
      BRKT=(.5*(G0(21)-G0(20))-COS2B*(4*MW**2-3*MZ**2)/4.)**2+
     $       MLQ**2*(AL-MU*TANB)**2
      TERM=.5*(G0(21)+G0(20))+MLQ**2-MZ**2*COS2B/4.
      T1S=TERM-SQRT(BRKT)
      IF (T1S.LE.0.) THEN
        NOGOOD=1
        GO TO 100
      END IF
      T2S=TERM+SQRT(BRKT)
      MSS(21)=SQRT(MAX(0.,T1S))
      MSS(22)=SQRT(MAX(0.,T2S))
      THETAL=ATAN((T1S-MLQ**2+MZ**2*COS2B*(.5-XW)-
     $G0(21))/MLQ/(AL-MU*TANB))

C          A0 mass
      M1S=MU**2+G0(13)
      M2S=MU**2+G0(14)
      MSB1=MSS(10)
      MSB2=MSS(11)
      MST1=MSS(12)
      MST2=MSS(13)
      MSL1=MSS(21)
      MSL2=MSS(22)
      MB=AMBT
      FNT=(SUGMFN(MST2)-SUGMFN(MST1))/(MST2**2-MST1**2)
     $*AT*MTQ**2/SINB**2
      FNB=(SUGMFN(MSB2)-SUGMFN(MSB1))/(MSB2**2-MSB1**2)
     $*AB*MBQ**2/COSB**2
      FNL=(SUGMFN(MSL2)-SUGMFN(MSL1))/(MSL2**2-MSL1**2)
     $*AL*MLQ**2/COSB**2
      FCN=FNT+FNB+FNL/3.
C      DELHPS=3*G0(2)**2*MU*(COTB+TANB)/32./PI**2/MW**2*FCN
      DELHPS=6*MU*(COTB+TANB)/32./PI**2/VEV**2*FCN
      RDEL=SQRT(ABS(DELHPS))
C     Try Javier/Xerxes improved mA formula
      RZT=.5*(G0(24)-G0(23))+MZ**2*(8*COS2W-5.)*COS2B/12.
      RZB=.5*(G0(24)-G0(22))-MZ**2*(4*COS2W-1.)*COS2B/12.
      RZL=.5*(G0(21)-G0(20))-MZ**2*(4*COS2W-3.)*COS2B/4.
C      ZT=.25*(MST2**2-MST1**2)**2-(G0(6)*VEV)**2*(AT*SINB-MU*COSB)**2
C      ZB=.25*(MSB2**2-MSB1**2)**2-(G0(5)*VEV)**2*(AB*COSB-MU*SINB)**2
C      ZL=.25*(MSL2**2-MSL1**2)**2-(G0(4)*VEV)**2*(AL*COSB-MU*SINB)**2
      SIGT=3*G0(6)**2*SUGMFN(MTQ)/8./PI/PI
      SIGB=-3*G0(5)**2*SUGMFN(MBQ)/8./PI/PI
      SIGL=-1*G0(4)**2*SUGMFN(MLQ)/8./PI/PI
      SIGST=-3.*((SUGMFN(MST1)+SUGMFN(MST2))*(G0(6)**2-.25*
     $(G**2+GP**2))+(SUGMFN(MST2)-SUGMFN(MST1))/(MST2**2-MST1**2)*
     $(G0(6)**2*(AT**2-MU**2)-(G**2+GP**2)*(8*COS2W-5.)*
     $RZT/6.))/16./PI/PI
      SIGSB=3.*((SUGMFN(MSB1)+SUGMFN(MSB2))*(G0(5)**2-.25*
     $(G**2+GP**2))+(SUGMFN(MSB2)-SUGMFN(MSB1))/(MSB2**2-MSB1**2)*
     $(G0(5)**2*(AB**2-MU**2)-(G**2+GP**2)*(4*COS2W-1.)*
     $RZB/6.))/16./PI/PI
      SIGSL=1.*((SUGMFN(MSL1)+SUGMFN(MSL2))*(G0(4)**2-.25*
     $(G**2+GP**2))+(SUGMFN(MSL2)-SUGMFN(MSL1))/(MSL2**2-MSL1**2)*
     $(G0(4)**2*(AL**2-MU**2)-(G**2+GP**2)*(2*COS2W-1.5)*
     $RZL/6.))/16./PI/PI
C          Tree level mhp not needed at this point so fix if negative
      IF (INUHM.NE.1) THEN
      IF (ILOOP.EQ.0) THEN
        MHPS=M1S+M2S
        IF (MHPS.LT.0.) MHPS=0.
      ELSE
C        MHPS=B*MU*(COTB+TANB)+DELHPS
C        Use improved Javier formula
        MHPS=(TANB**2+1.)/(TANB**2-1.)*(G0(13)-G0(14)+SIGT+SIGST+
     $SIGSB+SIGB+SIGSL+SIGL)-AMZ**2
C     If MHPS neg. on this round, set to MZ to AMHL can be
C     calculated, then check MHPS on next round...
        IF (MHPS.LT.0.) THEN
c          MHPNEG=1
          MHPS=AMZ**2
        END IF
      END IF
      MHP=SQRT(MHPS)
      ELSE
      MHP=AMHA
      END IF
      MSS(31)=MHP
C
C          Initialize SUSY parameters in /SSPAR/:
C
      AMGLSS=ABS(G0(9))
      AMULSS=MSS(2)
      AMURSS=MSS(3)
      AMDLSS=MSS(4)
      AMDRSS=MSS(5)
      AMSLSS=MSS(6)
      AMSRSS=MSS(7)
      AMCLSS=MSS(8)
      AMCRSS=MSS(9)
      AMN1SS=MSS(14)
      AMN2SS=MSS(15)
      AMN3SS=MSS(16)
      AMELSS=MSS(17)
      AMERSS=MSS(18)
      AMMLSS=MSS(19)
      AMMRSS=MSS(20)
      TWOM1=-MU
      RV2V1=1./XTANB
      AMTLSS=SIGN(1.,G0(24))*SQRT(ABS(G0(24)))
      AMTRSS=SIGN(1.,G0(23))*SQRT(ABS(G0(23)))
      AMBLSS=SQRT(G0(24))
      AMBRSS=SQRT(G0(22))
      AMLLSS=SQRT(G0(21))
      AMLRSS=SQRT(G0(20))
      AMB1SS=MSS(10)
      AMB2SS=MSS(11)
      AMT1SS=MSS(12)
      AMT2SS=MSS(13)
      AML1SS=MSS(21)
      AML2SS=MSS(22)
      AAT=G0(12)
      AAB=G0(11)
      AAL=G0(10)
      AMHA=MHP
C
C          Use SSMASS to diagonalize neutralino and chargino mass
C          matrices and calculate Higgs masses.
C
      MHLNEG=0
      MHCNEG=0
      CALL SSMASS(G0(9),G0(7),G0(8),IALLOW,ILOOP,MHLNEG,MHCNEG,IMODEL)
      IF(MHLNEG.EQ.1.OR.MHCNEG.EQ.1) THEN
        NOGOOD=8
      ENDIF
C      IF(IALLOW.NE.0.AND.ILOOP.NE.0) THEN
C        NOGOOD=5
C        GO TO 100
C      ENDIF
C
C          Save results also in MSS; re-save radiative corrected masses
C
      MSS(2)=AMULSS
      MSS(3)=AMURSS
      MSS(4)=AMDLSS
      MSS(5)=AMDRSS
      MSS(6)=AMSLSS
      MSS(7)=AMSRSS
      MSS(8)=AMCLSS
      MSS(9)=AMCRSS
      MSS(10)=AMB1SS
      MSS(11)=AMB2SS
      MSS(12)=AMT1SS
      MSS(13)=AMT2SS
      MSS(14)=AMN1SS
      MSS(15)=AMN2SS
      MSS(16)=AMN3SS
      MSS(17)=AMELSS
      MSS(18)=AMERSS
      MSS(19)=AMMLSS
      MSS(20)=AMMRSS
      MSS(21)=AML1SS
      MSS(22)=AML2SS
      MSS(23)=AMZ1SS
      MSS(24)=AMZ2SS
      MSS(25)=AMZ3SS
      MSS(26)=AMZ4SS
      MSS(27)=AMW1SS
      MSS(28)=AMW2SS
      MSS(29)=AMHL
      MSS(30)=AMHH
      MSS(31)=AMHA
      MSS(32)=AMHC
C
C     CALCULATE CHARGINO AND HIGGS ONE LOOP 
C     CORRECTIONS TO mA
      IF (ILOOP.EQ.0) THEN
        MHPS=M1S+M2S
        IF (MHPS.LT.0.) THEN
        MHPS=0.
        ENDIF
      ELSE
      SIGHIG= -(G**2+GP**2)/8.*AMHA**2*COS2B/2./PI**2*
     #   (SUGMFN(AMHH)-SUGMFN(AMHL))
     #   /(AMHH**2-AMHL**2)
      SIGCHA= -2*XW*(G**2+GP**2)/8.*MW**2*COS2B/PI**2*
     #   (SUGMFN(AMW1SS)-SUGMFN(AMW2SS))
     #   /(AMW1SS**2-AMW2SS**2)
      MHPS=(TANB**2+1.)/(TANB**2-1.)*(G0(13)-
     # G0(14)+SIGT+SIGST+
     # SIGSB+SIGB+SIGSL+SIGL+SIGHIG+SIGCHA)
     #     -AMZ**2
      SIGA=SIGT+SIGST+SIGSB+SIGB+SIGSL+SIGL+SIGHIG+SIGCHA
      IF (INUHM.NE.1) THEN
      IF (MHPS.GT.0) THEN
          MHP=SQRT(MHPS)
      ELSE
        MHPNEG=1
        MHPS=1.
      END IF
      MHP=SQRT(MHPS)
      ELSE
      MHP=AMHA
      END IF
      MSS(31)=MHP
      AMHA=MHP
      END IF
C          Gluino pole mass
      MGLMGL=G0(9)
      ASMGL=SUALFS(MGLMGL**2,.36,MT,3)
      XLAM=DLOG(DBLE(MGLMGL**2))
      MSS(1)=SSPOLE(MGLMGL,MGLMGL**2,ASMGL)
      AMGLSS=ABS(MSS(1))
      GSS(9)=G0(9)
C
100   RETURN
      END
+EOD
+DECK,SUGRA
C--------------------------------------------------------------------
      SUBROUTINE SUGRA(M0,MHF,A0,TANB,SGNMU,MT,IMODEL)
C--------------------------------------------------------------------
C
C     Calculate supergravity spectra for ISAJET using as inputs
C     M0    = M_0       = common scalar mass at GUT scale
C     MHF   = M_(1/2)   = common gaugino mass at GUT scale
C     A0    = A_0       = trilinear soft breaking parameter at GUT scale
C     TANB  = tan(beta) = ratio of vacuum expectation values v_1/v_2
C     SGNMU = sgn(mu)   = +-1 = sign of Higgsino mass term
C     MT    = M_t       = mass of t quark
C     M0    = Lambda    = ratio of vevs <F>/<S>
C     MHF   = M_Mes     = messenger scale
C     A0    = n_5       = number of messenger fields
C     IMODEL            = 1 for SUGRA model
C                       = 2 for GMSB model
C                       = 7 for AMSB model
C
C     Uses Runge-Kutta method to integrate RGE's from M_Z to M_GUT
C     and back, putting in correct thresholds. For the first iteration
C     only the first 6 couplings are included and a common threshold
C     is used.
C
C     See /SUGMG/ for definitions of couplings and masses.
C
C     Ver. 7.64: Use different convergence cuts for Higgs-related
C                soft couplings.
C     Ver. 7.70 Implement double precision RGE running
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSPAR
+CDE,SSSM
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SUGPAS
+CDE,SUGNU
      COMMON /BSG/ GISA
      REAL*8 GY(9),W1(27),G(31),W2(93),DT,T,DPI,DY
      REAL*8 BTHAT,BBHAT,BLHAT
      REAL G0(31),GISA(31)
      COMPLEX*16 SSB0,SSB1
      DOUBLE PRECISION DDILOG,XLM
      INTEGER IG(31)
      EXTERNAL SURG06,SURG26
      REAL M0,MHF,A0,TANB,SGNMU,MT,XLAMGM,XMESGM,XN5GM
      INTEGER NSTEP
      REAL M2,SUALFE,SUALFS,Q,A1I,AGUT,A3I,A2I,MTMT,ASMT,
     $TGUT,TZ,GGUT,SIG2,SIG1,MH1S,MH2S,AGUTI,
     $MUS,MBMZ,MB,MTAU,MZ,MW,SR2,PI,ALEM,MTAMZ,TANBQ,SIN2BQ,
     $MTAMB,MTAMTA,MBMB,ASMB,BETA,COTB,SINB,COS2B,COSB,XC,
     $L1,L2,L3
      REAL XTGSS,ATGSS,MUSGSS,MUGSS,MGLGSS,MBMZC,MZQ,SIGA
      INTEGER II,I,J,IMODEL
      REAL G0SAVE(31),DELG0,DEL,DELLIM(31),THRF,THRG,QOLD
      REAL CF,CA,ZETA2,ZETA3,ST2LP
      INTEGER MXITER,NSTEP0,IG0LIM
      LOGICAL BADMU
C
      DATA MZ/91.187/,MTAU/1.777/,MB/4.9/,ALEM/.0078186/
      DATA ZETA2/1.644934/,ZETA3/1.202057/
C          This choice is a compromise between precision and speed:
      DATA MXITER/25/,NSTEP0/1000/
C          The Higgs-related soft couplings converge much more slowly
C          than the others, so we use different error cuts:
      DATA DELLIM/
     $0.003, 0.003, 0.003, 0.003, 0.003, 0.003, 0.003, 0.003,
     $0.003, 0.003, 0.003, 0.003, 0.030, 0.030, 0.003, 0.003, 
     $0.003, 0.003, 0.003, 0.003, 0.003, 0.003, 0.003, 0.003, 
     $0.050, 0.050, 0.050, 0.050, 0.050, 0.050, 0.050/
C
C          Define REAL(COMPLEX*16) for g77. This might need to be
C          changed for 64-bit machines?
C
C          Save input parameters
C
      XSUGIN(1)=M0
      XSUGIN(2)=MHF
      XSUGIN(3)=A0
      XSUGIN(4)=TANB
      XSUGIN(5)=SGNMU
      XSUGIN(6)=MT
      XLAMGM=M0
      XMESGM=MHF
      XN5GM=A0
      XGMIN(1)=XLAMGM
      XGMIN(2)=XMESGM
      XGMIN(3)=XN5GM
      XGMIN(4)=TANB
      XGMIN(5)=SGNMU
      XGMIN(6)=MT
      IF (INUHM.EQ.1) THEN
        MU=XNUSUG(19)
        AMHA=XNUSUG(20)
      END IF
      IF (XGMIN(12).EQ.0.) XGMIN(12)=XN5GM
      IF (XGMIN(13).EQ.0.) XGMIN(13)=XN5GM
      IF (XGMIN(14).EQ.0.) XGMIN(14)=XN5GM
C
C          Compute gauge mediated threshold functions
C
      IF (IMODEL.EQ.2) THEN
        XLM=XLAMGM/XMESGM
        THRF=((1.D0+XLM)*(LOG(1.D0+XLM)-2*DDILOG(XLM/(1.D0+XLM))+
     ,        .5*DDILOG(2*XLM/(1.D0+XLM)))+
     ,       (1.D0-XLM)*(LOG(1.D0-XLM)-2*DDILOG(-XLM/(1.D0-XLM))+
     ,        .5*DDILOG(-2*XLM/(1.D0-XLM))))/XLM**2
        THRG=((1.D0+XLM)*LOG(1.D0+XLM)+(1.D0-XLM)*LOG(1.D0-XLM))/XLM**2
      END IF
C
C          Initialize standard model parameters in /SSSM/:
C
      AMUP=0.0056
      AMDN=0.0099
      AMST=0.199
      AMCH=1.35
      AMBT=4.9
      AMTP=MT
      AMT=MT
      AME=0.511E-3
      AMMU=0.105
      AMTAU=1.777
      AMZ=91.17
      GAMW=2.12
      GAMZ=2.487
      ALFAEM=1./128.
      SN2THW=0.231
      ALFA2=ALFAEM/SN2THW
      ALQCD4=0.177
      ALFA3=0.118
C
      NOGOOD=0
      ITACHY=0
      IGUTST=0
      PI=4.*ATAN(1.)
      DPI=4.D0*DATAN(1.D0)
      CF=4./3.
      CA=3.
      SR2=SQRT(2.)
C      XW=.2324-1.03E-7*(MT**2-138.**2)
      XW=.231
      MW=MZ*SQRT(1.-XW)
      AMW=MW
      A1MZ=5*ALEM/3./(1.-XW)
      A2MZ=ALEM/XW
      G2=SQRT(4*PI*A2MZ)
      GP=SQRT(3./5.*A1MZ*4.*PI)
      XTANB=TANB
      COTB=1./TANB
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=COS(BETA)
      SIN2B=SIN(2*BETA)
      COS2B=COS(2*BETA)
      IF (IMODEL.EQ.1) THEN
        MSUSY=SQRT(M0**2+4*MHF**2)
      ELSE IF (IMODEL.EQ.2) THEN
        MSUSY=XLAMGM/100.
      ELSE IF (IMODEL.EQ.7) THEN
        MSUSY=SQRT(M0**2+(.01*MHF)**2)
      END IF
C     USE PIERCE PRESCRIPTION FOR MAGNITUDE OF VEV 
      VEV=(248.6+0.9*LOG(MSUSY/AMZ))/SR2
      V=SQRT(VEV**2/(1.+COTB**2))
C     PREVIOUS PRESCRIPTION
C      V=SQRT(2*MW**2/G2**2/(1.+COTB**2))
      VP=V/TANB
C      VEV=SQRT(V**2+VP**2)
C
C          Compute m(tau), m(b) at z scale using qcd, qed
C          Update to DRbar masses used by Pierce et al.
C
C      MTAMTA=MTAU*(1.-SUALFE(MTAU**2)/PI)
C      MTAMB=MTAMTA*(SUALFE(MB**2)/SUALFE(MTAU**2))**(-27./76.)
C      MTAMZ=MTAMB*(SUALFE(MZ**2)/SUALFE(MB**2))**(-27./80.)
      MTAMZ=1.7463
      FTAMZ=MTAMZ/COSB/VEV
C      ASMB=SUALFS(MB**2,.36,MT,3)
C      MBMB=MB*(1.-4*ASMB/3./PI)
C      ASMZ=SUALFS(MZ**2,.36,MT,3)
C      MBMZ=MBMB*(ASMZ/ASMB)**(12./23.)*
C     $      (SUALFE(MZ**2)/SUALFE(MB**2))**(-3./80.)
      MBMZ=2.83
      ASMT=SUALFS(MT**2,.36,MT,3)
      ST2LP=CF*(ASMT/4./PI)**2*(-43.-12*ZETA2+CF*(-59./8.+30*ZETA2-
     ,48*LOG(2.)*ZETA2+12*ZETA3)+
     ,CA*(1093./24.-8*ZETA2+24*LOG(2.)*ZETA2-6*ZETA3))
      MTMT=MT/(1.+5*ASMT/3./PI+ST2LP)
      FTMT=MTMT/SINB/VEV
C     Here we input Drees' guesses for Z-scale soft terms
C     so we have a good initial guess for mb(mz)
C     Guesses come from hep-ph/9504324
C      IF (IMODEL.EQ.1) THEN
C      XTGSS=(MTMT/150./SINB)**2*(.9*M0**2+2.1*MHF**2+
C     $(1.-(MTMT/190./SINB)**3)*(.24*A0**2+A0*MHF))
C      ATGSS=A0*(1.-(MTMT/190./SINB)**2)-
C     $MHF*(3.47-1.9*(MTMT/190./SINB)**2)
C      MUSGSS=-M0**2-.52*MHF**2-.5*MZ**2+XTGSS/(1.-COTB**2)
C      MUGSS=SQRT(MAX(0.,MUSGSS))*SIGN(1.,SGNMU)
C      MGLGSS=MHF*ASMT/0.04
C      MBMZC=MBMZ*(1.+2*ASMZ/3./PI*MUGSS*MGLGSS/MSUSY**2*TANB+
C     $FTMT**2/16./PI**2*MUGSS*ATGSS/MSUSY**2)
C      ELSE
C      MBMZC=MBMZ
C      END IF
C      FBMZ=MBMZC/COSB/VEV
      FBMZ=MBMZ/COSB/VEV
      FNMZ=SQRT(XNRIN(2)*XNRIN(1)/(SINB*VEV)**2)
      AMNRMJ=XNRIN(2)
C     Initialize some parameters for SUGFRZ
      IF (INUHM.NE.1) AMHA=AMZ
      ASM3=ALFA3
C     Set GSS values to initial guess
      DO I=7,12
        GSS(I)=MSUSY
      END DO
      DO I=13,24
        GSS(I)=MSUSY**2
      END DO
C
C          Run the 3 gauge and 3 Yukawa's up to find M_GUT ,A_GUT and 
C          Yukawa_GUT
C
      NSTEP=NSTEP0
      GY(1)=DBLE(SQRT(4*PI*A1MZ))
      GY(2)=DBLE(SQRT(4*PI*A2MZ))
      GY(3)=DBLE(SQRT(4*PI*ALFA3))
      GY(4)=DBLE(FTAMZ)
      GY(5)=DBLE(FBMZ)
      GY(6)=0.D0
      GY(7)=0.D0
      GY(8)=DBLE(VP)
      GY(9)=DBLE(V)
      IF (IMODEL.EQ.1.OR.IMODEL.EQ.7) THEN
        IF (XSUGIN(7).EQ.0.) THEN
          MGUT=1.E19
        ELSE
          MGUT=XSUGIN(7)
        END IF
      ELSE IF (IMODEL.EQ.2) THEN
        MGUT=XMESGM
      END IF
      TZ=DLOG(DBLE(MZ)/DBLE(MGUT))
      TGUT=0.D0
      DT=(TGUT-TZ)/DBLE(FLOAT(NSTEP))
      DO 200 II=1,NSTEP
        T=TZ+(TGUT-TZ)*FLOAT(II-1)/FLOAT(NSTEP)
        Q=MGUT*EXP(SNGL(T))
        IF (Q.GT.MT.AND.GY(6).EQ.0.D0) GY(6)=DBLE(FTMT)
        IF (Q.GT.XNRIN(2).AND.GY(7).EQ.0.D0) GY(7)=DBLE(FNMZ)
        CALL DRKSTP(9,DT,T,GY,SURG06,W1)
        A1I=4*PI/SNGL(GY(1)**2)
        A2I=4*PI/SNGL(GY(2)**2)
        A3I=4*PI/SNGL(GY(3)**2)
        IF (GY(4).GT.5.D0.OR.GY(5).GT.5.D0.OR.
     $  GY(6).GT.5.D0.OR.GY(7).GT.5.D0) THEN
          NOGOOD=4
          GO TO 100
        END IF
        IF (A1I.LT.A2I.AND.XSUGIN(7).EQ.0.) GO TO 10
200   CONTINUE
      IF (MGUT.EQ.1.E19) THEN
        WRITE(LOUT,*) 'SUGRA: NO UNIFICATION FOUND'
        GO TO 100
      END IF
10    IF (XSUGIN(7).EQ.0.) THEN
        MGUT=Q
      ELSE
        MGUT=XSUGIN(7)
      END IF
      AGUT=SNGL((GY(1)**2/4.D0/DPI+GY(2)**2/4.D0/DPI)/2.D0)
      GGUT=SQRT(4*PI*AGUT)
      AGUTI=1./AGUT
      FTAGUT=SNGL(GY(4))
      FBGUT=SNGL(GY(5))
      FTGUT=SNGL(GY(6))
      IF (XNRIN(1).EQ.0..AND.XNRIN(2).LT.1.E19) THEN
C       UNIFY FN-FT
        FNGUT=SNGL(GY(6))
      ELSE
        FNGUT=SNGL(GY(7))
      END IF
C
C          Define parameters at GUT scale
C
      DO 210 J=1,3
        IF (IMODEL.EQ.1) THEN
          G(J)=GY(J)
          G(J+6)=DBLE(MHF)
          G(J+9)=DBLE(A0)
        ELSE IF (IMODEL.EQ.2) THEN
          G(J)=GY(J)
          G(J+6)=DBLE(XGMIN(11+J)*XGMIN(8)*THRG*(GY(J)/4./PI)**2*XLAMGM)
          G(J+9)=0.D0
        END IF
210   CONTINUE
      G(30)=GY(8)
      G(31)=GY(9)
C          Overwrite alfa_3 unification to get alfa_3(mz) right
      IF (IMODEL.EQ.1.AND.IAL3UN.NE.0) G(3)=DBLE(GGUT)
      G(4)=DBLE(FTAGUT)
      G(5)=DBLE(FBGUT)
      G(6)=DBLE(FTGUT)
C          If nr Majorana mass exists, set extra nr rge parameters
      IF (XNRIN(2).LT.1.E19) THEN
        G(27)=DBLE(FNGUT)
        G(28)=DBLE(XNRIN(4))**2
        G(29)=DBLE(XNRIN(3))
      ELSE
        G(27)=0.D0
        G(28)=0.D0
        G(29)=0.D0
      END IF
      IF (IMODEL.EQ.1) THEN
        DO 220 J=13,24
          G(J)=DBLE(M0)**2
220     CONTINUE
C       Set possible non-universal boundary conditions
        DO 230 J=1,6
          IF (XNUSUG(J).LT.1.E19) THEN
            G(J+6)=DBLE(XNUSUG(J))
          END IF
230     CONTINUE
        DO 231 J=7,18
          IF (XNUSUG(J).LT.1.E19) THEN
            G(J+6)=SIGN(1.,XNUSUG(J))*DBLE(XNUSUG(J))**2
          END IF
231     CONTINUE
      ELSE IF (IMODEL.EQ.2) THEN
        XC=2*THRF*XLAMGM**2
        DY=DSQRT(3.D0/5.D0)*GY(1)*XGMIN(11)
        G(13)=XC*(.75*XGMIN(13)*(GY(2)/4.D0/DPI)**4+.6D0*.25*
     ,  XGMIN(12)*(GY(1)/4.D0/DPI)**4)+DBLE(XGMIN(9))-DY
        G(14)=XC*(.75*XGMIN(13)*(GY(2)/4.D0/DPI)**4+.6D0*.25*
     ,  XGMIN(12)*(GY(1)/4.D0/DPI)**4)+DBLE(XGMIN(10))+DY
        G(15)=XC*(.6*XGMIN(12)*(GY(1)/4.D0/DPI)**4)+2*DY
        G(16)=XC*(.75*XGMIN(13)*(GY(2)/4.D0/DPI)**4+.6D0*.25*
     ,  XGMIN(12)*(GY(1)/4.D0/DPI)**4)-DY
        G(17)=XC*(4*XGMIN(14)*(GY(3)/4.D0/DPI)**4/3.D0+.6D0*
     ,  XGMIN(12)*(GY(1)/4.D0/DPI)**4/9.D0)+2*DY/3.D0
        G(18)=XC*(4*XGMIN(14)*(GY(3)/4.D0/DPI)**4/3.D0+.6D0*
     ,  4*XGMIN(12)*(GY(1)/4.D0/DPI)**4/9.D0)-4*DY/3.D0
        G(19)=XC*(4*XGMIN(14)*(GY(3)/4.D0/DPI)**4/3.D0+.75D0*
     ,  XGMIN(13)*(GY(2)/4.D0/DPI)**4+.6D0*XGMIN(12)*(GY(1)/
     ,  4.D0/DPI)**4/36.D0)+DY/3.D0
        G(20)=G(15)
        G(21)=G(16)
        G(22)=G(17)
        G(23)=G(18)
        G(24)=G(19)
      ELSE IF (IMODEL.EQ.7) THEN
        G(1)=GY(1)
        G(2)=GY(2)
        G(3)=GY(3)
        BLHAT=G(4)*(-9*G(1)**2/5.D0-3*G(2)**2+3*G(5)**2+4*G(4)**2)
        BBHAT=G(5)*(-7*G(1)**2/15.D0-3*G(2)**2-16*G(3)**2/3.D0+
     ,             G(6)**2+6*G(5)**2+G(4)**2)
        BTHAT=G(6)*(-13*G(1)**2/15.D0-3*G(2)**2-16*G(3)**2/3.D0+
     ,             6*G(6)**2+G(5)**2)
        G(7)=-33*MHF*G(1)**2/5.D0/16.D0/DPI**2
        G(8)=-MHF*G(2)**2/16.D0/DPI**2
        G(9)=3*MHF*G(3)**2/16.D0/DPI**2
        G(10)=BLHAT*MHF/G(4)/16.D0/DPI**2
        G(11)=BBHAT*MHF/G(5)/16.D0/DPI**2
        G(12)=BTHAT*MHF/G(6)/16.D0/DPI**2
        G(13)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0+3*G(5)*BBHAT+
     ,G(4)*BLHAT)*MHF**2/(16*DPI**2)**2+XAMIN(6)*DBLE(M0)**2
        G(14)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0+3*G(6)*BTHAT)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(7)*DBLE(M0)**2
        G(15)=(-198*G(1)**4/25.D0)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(5)*DBLE(M0)**2
        G(16)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(4)*DBLE(M0)**2
        G(17)=(-22*G(1)**4/25.D0+8*G(3)**4)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(2)*DBLE(M0)**2
        G(18)=(-88*G(1)**4/25.D0+8*G(3)**4)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(3)*DBLE(M0)**2
        G(19)=(-11*G(1)**4/50.D0-3*G(2)**4/2.D0+8*G(3)**4)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(1)*DBLE(M0)**2
        G(20)=(-198*G(1)**4/25.D0+2*G(4)*BLHAT)*MHF**2/(16*DPI**2)**2
     ,+XAMIN(5)*DBLE(M0)**2
        G(21)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0+G(4)*BLHAT)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(4)*DBLE(M0)**2
        G(22)=(-22*G(1)**4/25.D0+8*G(3)**4+2*G(5)*BBHAT)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(2)*DBLE(M0)**2
        G(23)=(-88*G(1)**4/25.D0+8*G(3)**4+2*G(6)*BTHAT)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(3)*DBLE(M0)**2
        G(24)=(-11*G(1)**4/50.D0-3*G(2)**4/2.D0+8*G(3)**4+G(5)*BBHAT+
     ,        G(6)*BTHAT)*MHF**2/(16*DPI**2)**2+XAMIN(1)*DBLE(M0)**2
      END IF
      G(25)=0.D0
      G(26)=0.D0
      DO 235 I=1,31
        IG(I)=0
235   CONTINUE
C          Check for tachyonic sleptons at GUT scale
      IF (G(15).LT.0.D0.OR.G(16).LT.0.D0) THEN
        ITACHY=1
      END IF
C
C          Initialize all masses to MSUSY scale
C
      DO 236 I=1,31
        MSS(I)=MSUSY
236   CONTINUE
      IF (INUHM.EQ.1) THEN 
        MSS(31)=AMHA
      END IF
C
C          Evolve parameters from mgut to mz
C
      TZ=DLOG(DBLE(MZ)/DBLE(MGUT))
      TGUT=0.D0
      DT=(TZ-TGUT)/DBLE(FLOAT(NSTEP))
C          Freeze Higgs parameters at HIGFRZ = Drees' value
C          AMTLSS, AMTRSS initialized to 0 for later use in HIGFRZ
      IF (IMODEL.EQ.1) THEN
        HIGFRZ=SQRT(M0**2+3*MHF**2)
      ELSE IF (IMODEL.EQ.2) THEN
        HIGFRZ=MSUSY
      ELSE IF (IMODEL.EQ.7) THEN
        HIGFRZ=SQRT(M0**2+(.01*MHF)**2)
      END IF
      AMTLSS=0.
      AMTRSS=0.
      DO 240 II=1,NSTEP+2
        T=TGUT+(TZ-TGUT)*FLOAT(II-1)/DBLE(FLOAT(NSTEP))
        QOLD=Q
        Q=SNGL(MGUT*DEXP(T))
        CALL DRKSTP(31,DT,T,G,SURG26,W2)
C       TEST YUKAWA DIVERGENCE
        IF (G(4).GT.5.D0.OR.G(5).GT.5.D0.OR.
     $  G(6).GT.5.D0.OR.G(27).GT.5.D0) THEN
          NOGOOD=4
          GO TO 100
        END IF
        IF (Q.LT.AMNRMJ.AND.QOLD.GE.AMNRMJ.AND.FNMZ.EQ.0.) THEN
          FNMZ=SNGL(G(27))
        END IF
        IF (Q.LT.AMNRMJ) THEN
          G(27)=0.D0
          G(28)=0.D0
          G(29)=0.D0
        END IF
        CALL SUGFRZ(Q,G,G0,IG)
        IF (NOGOOD.NE.0) GO TO 100
        IF (Q.LT.MZ) GO TO 20
240   CONTINUE
20    CONTINUE
      ASMZ=G0(3)**2/4./PI
      VUQ=G0(31)
      VDQ=G0(30)
      TANBQ=VUQ/VDQ
      SIN2BQ=SIN(2*ATAN(TANBQ))
      MZQ=SQRT((G0(2)**2+.6*G0(1)**2)*(VUQ**2+VDQ**2)/2.)
      IF (INUHM.NE.1) THEN
C          Electroweak breaking constraints 
C          Tree level
      MUS=(G0(13)-G0(14)*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
C          Calculate loop corrections using MSS=MSUSY masses set above
      CALL SUGEFF(G0,SIG1,SIG2)
      MH1S=G0(13)+SIG1
      MH2S=G0(14)+SIG2
      MUS=(MH1S-MH2S*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
C          If MUS<0, set it to MZ**2 so that spectra and real loop
C          corrections can be calculated
      IF (MUS.LT.0.) THEN
        MUS=MZ**2
      END IF
      MU=SQRT(MUS)*SIGN(1.,SGNMU)
      B=(G0(13)+G0(14)+2*MUS)*SIN2BQ/MU/2.
C          Compute tree level masses using first value of MU
      CALL SUGMAS(G0,0,IMODEL,SIGA)
      IF (NOGOOD.NE.0) GO TO 100
C          Compute effective potential corrections with tree masses
      CALL SUGEFF(G0,SIG1,SIG2)
      MH1S=G0(13)+SIG1
      MH2S=G0(14)+SIG2
      MUS=(MH1S-MH2S*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
C          MUS might still be negative. If so, set it to MZ**2 and hope
C          for the best....
      IF (MUS.LT.0.) THEN
C       NOGOOD=2
C       GO TO 100
        MUS=MZ**2
      END IF
      MU=SQRT(MUS)*SIGN(1.,SGNMU)
      B=(MH1S+MH2S+2*MUS)*SIN2BQ/MU/2.
C          Need loop corrected mass spectra to calculate fermion 
C          self energies
      CALL SUGMAS(G0,1,IMODEL,SIGA)
      ELSE 
      MUS=MU**2
      B=AMHA**2/MU/(COTB+TANB)
      CALL SUGMAS(G0,0,IMODEL,SIGA)
      MHDSQ=(-2*SIG1-MZQ**2-2*MUS+2*TANB**2*(AMHA**2+SIGA+MZQ**2+
     ,SIG2-SIG1)+TANB**4*(2*MUS-MZQ**2-2*SIG2-2*AMHA**2+2*SIGA))
     ,/2./(1.-TANB**4)
      MHUSQ=(2*AMHA**2+2*SIGA+MZQ**2-2*MUS-2*SIG1+2*TANB**2*(
     ,-AMHA**2+SIGA-MZQ**2-SIG1+SIG2)+TANB**4*(2*MUS+2*SIG2+MZQ**2))
     ,/2./(1.-TANB**4)
      END IF
C
C          Iterate entire process, increasing NSTEP each time
C          This time, freeze out parameters at sqrt(t_l t_r)
C
      HIGFRZ=(MAX(AMZ**4,G0(23)*G0(24)))**0.25
      MSUSY=HIGFRZ
      DO 300 I=1,MXITER
        DO 310 J=1,31
310     G0SAVE(J)=G0(J)
        NSTEP=1.2*NSTEP
        CALL SUGRGE(M0,MHF,A0,TANB,SGNMU,MT,G,G0,IG,W2,NSTEP,IMODEL,
     $  BADMU)
        HIGFRZ=(MAX(AMZ**4,G0(23)*G0(24)))**0.25
        MSUSY=HIGFRZ
        IF(NOGOOD.NE.0) GO TO 100
C            Check convergence relative to DELLIM
        DELG0=0.
        IG0LIM=0
        DO 320 J=1,31
          IF(G0(J).NE.0) THEN
            DEL=ABS((G0(J)-G0SAVE(J))/G0(J))
          ELSE
            DEL=0
          ENDIF
          IF(DEL-DELLIM(J).GT.DELG0) THEN
            DELG0=DEL
            IG0LIM=J
          ENDIF
320     CONTINUE
        IF(IG0LIM.EQ.0) GO TO 400
300   CONTINUE
C
C          No solution found in MXITER iterations
C
      WRITE(LOUT,1000) MXITER,DELG0,IG0LIM
1000  FORMAT(/' SUGRA: NO RGE CONVERGENCE IN',I4,' ITERATIONS'/
     $' WORST ERROR = ',E12.4,' FOR G0(',I2,')')
      NOGOOD=-1
      GO TO 100
C
C          Save results
C
400   DO 410 I=1,31
        GSS(I)=G0(I)
410   CONTINUE
C          Set flag for NOGOOD radiative EWSB. We allow MUS to be 
C          negative at intermediate steps but check here that it is
C          positive after all iterations.
      IF (BADMU) THEN
        NOGOOD=2
      END IF
C          Set flag for NOGOOD GUT stability in NUHM model
      IF (INUHM.EQ.1) THEN
      IF (MHUSMG+MUMG**2.LT.0..OR.MHDSMG+MUMG**2.LT.0.) THEN
        IGUTST=1
      END IF
      END IF
      MGUTSS=MGUT
      AGUTSS=AGUT
      GGUTSS=GGUT
C
C          Fill XISAIN common block
C
      XISAIN(1)=MSS(1)
      XISAIN(2)=MU
      XISAIN(3)=MSS(31)
      XISAIN(4)=TANB
      XISAIN(5)=SQRT(G0(19))
      XISAIN(6)=SQRT(G0(17))
      XISAIN(7)=SQRT(G0(18))
      XISAIN(8)=SQRT(G0(16))
      XISAIN(9)=SQRT(G0(15))
      XISAIN(10)=XISAIN(5)
      XISAIN(11)=XISAIN(6)
      XISAIN(12)=XISAIN(7)
      XISAIN(13)=XISAIN(8)
      XISAIN(14)=XISAIN(9)
C     KEEP TRACK OF SIGN OF SQUARED SSB TERMS MTL**2 AND MTR**2
      XISAIN(15)=SIGN(1.,G0(24))*SQRT(ABS(G0(24)))
      XISAIN(16)=SQRT(G0(22))
      XISAIN(17)=SIGN(1.,G0(23))*SQRT(ABS(G0(23)))
      XISAIN(18)=SQRT(G0(21))
      XISAIN(19)=SQRT(G0(20))
      XISAIN(20)=G0(12)
      XISAIN(21)=G0(11)
      XISAIN(22)=G0(10)
      XISAIN(23)=G0(7)
      XISAIN(24)=G0(8)
      M2=G0(8)
      DO 420 I=1,31
        GISA(I)=SNGL(G(I))
420   CONTINUE
C
100   RETURN
      END
+EOD
+DECK,SUGRGE
      SUBROUTINE SUGRGE(M0,MHF,A0,TANB,SGNMU,MT,G,G0,IG,W2
     $,NSTEP,IMODEL,BADMU)
C
C          Make one complete iteration of the renormalization group
C          equations from MZ to MGUT and back, setting the boundary
C          conditions on each end.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGPAS
+CDE,SUGNU
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SSINF
C
      EXTERNAL SURG26
      DOUBLE PRECISION DDILOG,XLM
      COMPLEX*16 SSB0,SSB1
      REAL*8 G(31),W2(93),T,DT,DY,DPI,DAS
      REAL*8 BTHAT,BBHAT,BLHAT
      REAL M0,MHF,A0,TANB,SGNMU,MT,G0(31)
      INTEGER IG(31),NSTEP,IMODEL
      REAL PI,TZ,A1I,A2I,A3I,GGUT,AGUTI,SIG1,SIG2,
     $MH1S,MH2S,MUS,MZ,TGUT,AGUT,Q,ASMT,MTMT,
     $QOLD,XLAMGM,XMESGM,XN5GM,XC,G3GUT,THRF,THRG,MBMZ,
     $M2,AM2,MSN,MG,MT1,MT2,MB1,MB2,MW1,MW2,AMU,
     $RSIGT,RSIGL,RSIGB,DAEM,ALEMDR,ALEM,MTAMZ,
     $TANBQ,SIN2BQ,SINB,COSB,XWMSB
      REAL SSRSGT,SSRSGB,SSRSGL,SUALFS,MZQ,SIGA
      REAL CF,CA,ZETA2,ZETA3,ST2LP,COTB
      INTEGER I,II
      LOGICAL BADMU
C
      DATA ZETA2/1.644934/,ZETA3/1.202057/
      DATA MZ/91.187/
C
C          Re-initialize weak scale parameters
C
      XLAMGM=M0
      XMESGM=MHF
      XN5GM=A0
      PI=4.*ATAN(1.)
      DPI=4.D0*DATAN(1.D0)
      CF=4./3.
      CA=3.
C     Here we input alpha_s^MSbar(MZ)
      ASMZ=0.1172
      MTAMZ=1.7463
C     Value of mb(MZ)^DRbar taken from PRD66, 074007 (2002).
      MBMZ=2.83
      SINB=SIN(ATAN(TANB))
      COSB=COS(ATAN(TANB))
      COTB=1./TANB
C
C     Calculate fermion masses including loop corrections
C
      M2=G0(8)
      AM2=ABS(M2)
      MSN=MSS(16)
      MG=ABS(MSS(1))
      MT1=MSS(12)
      MT2=MSS(13)
      MB1=MSS(10)
      MB2=MSS(11)
      MW1=ABS(MSS(27))
      MW2=ABS(MSS(28))
      AMU=ABS(MU)
      MUS=MU**2
      XLAM=DLOG(DBLE(HIGFRZ**2))
C      FTMT=MTMT/V
C      FBMZ=MBMZ/VP
C      FTAMZ=MTAMZ/VP
C          Be careful in using our convention vs Pierce et al.
C          cos(th)>1/sqrt(2):eigenstates same; cs-> -cs
C          cos(th)<1/sqrt(2);flip mass eigenstates; c <-> s interchange
C          Formula remains invariant under these switches
C          Use negative gaugino masses for consistency
C          Now input self-energies for consistency: RSIG*
C
C     here, add in 2 loop QCD correction to mt(DRbar) from Bednyakov
C     et al. Eq. 61.
      ST2LP=CF*(ASMTP/4./PI)**2*(-43.-12*ZETA2+CF*(-59./8.+30*ZETA2-
     ,48*LOG(2.)*ZETA2+12*ZETA3)+
     ,CA*(1093./24.-8*ZETA2+24*LOG(2.)*ZETA2-6*ZETA3))
      MTMT=MT/(1.+5*ASMTP/3./PI+ST2LP)
      FTMT=MTMT/SINB/VEV
      FBMZ=MBMZ/COSB/VEV
      FTAMZ=MTAMZ/COSB/VEV
      RSIGT=SSRSGT(MT**2)
      RSIGB=SSRSGB(MBQ**2)
      RSIGL=SSRSGL(MLQ**2)
C
C     Here, conversion from MSbar to DRbar is done at MZ.
C     Effect of sparticles is included by decoupling
C     beta functions in RGEs
      DAS=DBLE(ASMZ)/2.D0/DPI*(.5)
      ALEM=1./137.036
      DAEM=0.0682-ALEM/2./PI*(-7*LOG(AMW/AMZ))
      ALEMDR=ALEM/(1.-DAEM)
      XWMSB=.23113
C      XW=.2324-1.03E-7*(AMT**2-138.**2)
C     Convert XW to DRbar
      XW=1.-(1.-XWMSB)/(1.-ALEMDR/12./PI)      
      A1MZ=5*ALEMDR/3./(1.-XW)
      A2MZ=ALEMDR/XW
C      ALEM=1./128.
C      A1MZ=5*ALEM/3./(1.-XW)
C      A2MZ=ALEM/XW
      G(1)=DSQRT(4*DPI*A1MZ)
      G(2)=DSQRT(4*DPI*A2MZ)
      G(3)=DSQRT(4*DPI*ASMZ/(1.D0-DAS))
      G(4)=DBLE(FTAMZ)
      G(5)=DBLE(FBMZ)
      G(6)=G(6)
      G(25)=DBLE(MU)
      G(26)=DBLE(B)
      G(27)=0.D0
      G(28)=0.D0
      G(29)=0.D0
      G(30)=DBLE(VP)
      G(31)=DBLE(V)
C          Compute gauge mediated threshold functions
      IF (IMODEL.EQ.2) THEN
        XLM=XLAMGM/XMESGM
        THRF=((1.D0+XLM)*(LOG(1.D0+XLM)-2*DDILOG(XLM/(1.D0+XLM))+
     ,        .5*DDILOG(2*XLM/(1.D0+XLM)))+
     ,       (1.D0-XLM)*(LOG(1.D0-XLM)-2*DDILOG(-XLM/(1.D0-XLM))+
     ,        .5*DDILOG(-2*XLM/(1.D0-XLM))))/XLM**2
        THRG=((1.D0+XLM)*LOG(1.D0+XLM)+(1.D0-XLM)*LOG(1.D0-XLM))/XLM**2
      END IF
C
C          Run back up to mgut with approximate susy spectra
C
      IF (IMODEL.EQ.1) THEN
        IF (XSUGIN(7).EQ.0.) THEN 
          MGUT=1.E19
        ELSE
          MGUT=XSUGIN(7)
        END IF
      ELSE IF (IMODEL.EQ.2) THEN
        MGUT=XMESGM
      END IF
      TZ=DLOG(DBLE(MZ)/DBLE(MGUT))
      TGUT=0.D0
      DT=(TGUT-TZ)/DBLE(FLOAT(NSTEP))
      Q=MZ
      DO 250 II=1,NSTEP
        T=TZ+(TGUT-TZ)*FLOAT(II-1)/DBLE(FLOAT(NSTEP))
        QOLD=Q
        Q=SNGL(MGUT*DEXP(T))
        IF (QOLD.LE.MT.AND.Q.GT.MT) G(6)=DBLE(FTMT)
C       Implement sparticle threshold corrections at Q=HIGFRZ
        IF (QOLD.LE.HIGFRZ.AND.Q.GT.HIGFRZ) THEN
          G(6)=G(6)/(1.D0-DBLE(RSIGT))
          G(5)=G(5)/(1.D0-DBLE(RSIGB))
          G(4)=G(4)/(1.D0-DBLE(RSIGL))
          IF (INUHM.EQ.1) THEN
            G(13)=DBLE(MHDSQ)
            G(14)=DBLE(MHUSQ)
          END IF
        END IF
        IF (QOLD.LE.XNRIN(2).AND.Q.GT.XNRIN(2)) THEN
          G(27)=DBLE(FNMZ)
          G(28)=DBLE(G0(28))
          G(29)=DBLE(G0(29))
        END IF
        CALL DRKSTP(31,DT,T,G,SURG26,W2)
        A1I=SNGL(4*DPI/G(1)**2)
        A2I=SNGL(4*DPI/G(2)**2)
        A3I=SNGL(4*DPI/G(3)**2)
C       TEST YUKAWA DIVERGENCE
        IF (G(4).GT.5.D0.OR.G(5).GT.5.D0.OR.
     $G(6).GT.5.D0.OR.G(27).GT.5.D0) THEN
          NOGOOD=4
          GO TO 100
        END IF
        IF (A1I.LT.A2I.AND.XSUGIN(7).EQ.0.) GO TO 30
250   CONTINUE
      IF (IMODEL.EQ.1.AND.XSUGIN(7).EQ.0.) THEN
        WRITE(LOUT,*) 'SUGRGE ERROR: NO UNIFICATION FOUND'
        NOGOOD=1
        GO TO 100
      END IF
30    IF (XSUGIN(7).EQ.0.) THEN
        MGUT=Q
      ELSE
        MGUT=XSUGIN(7)
      END IF
      AGUT=SNGL((G(1)**2/4.D0/DPI+G(2)**2/4.D0/DPI)/2.D0)
      GGUT=SQRT(4*PI*AGUT)
      AGUTI=1./AGUT
      FTAGUT=SNGL(G(4))
      FBGUT=SNGL(G(5))
      FTGUT=SNGL(G(6))
      IF (INUHM.EQ.1) THEN
        MHDSMG=SNGL(G(13))
        MHUSMG=SNGL(G(14))
      END IF
      MUMG=SNGL(G(25))
      BMG=SNGL(G(26))
      IF (XNRIN(2).LT.1.E19.AND.XNRIN(1).EQ.0.) THEN
C     IMPOSE FN-FT UNIFICATION
        FNGUT=SNGL(G(6))
      ELSE
        FNGUT=SNGL(G(27))
      END IF
      G3GUT=SNGL(G(3))
      MGUTSS=MGUT
      AGUTSS=AGUT
      GGUTSS=GGUT
C
C          Set GUT boundary condition
C
      DO 260 I=1,3
        IF (IMODEL.EQ.1) THEN
          G(I)=G(I)
          G(I+6)=DBLE(MHF)
          G(I+9)=DBLE(A0)
        ELSE IF (IMODEL.EQ.2) THEN
          G(I)=G(I)
          G(I+6)=XGMIN(11+I)*XGMIN(8)*THRG*(G(I)/4.D0/DPI)**2*XLAMGM
          G(I+9)=0.D0
        END IF
      IF (XNRIN(2).LT.1.E19) THEN
        G(27)=DBLE(FNGUT)
        G(28)=DBLE(XNRIN(4))**2
        G(29)=DBLE(XNRIN(3))
      ELSE
        G(27)=0.D0
        G(28)=0.D0
        G(29)=0.D0
      END IF
260   CONTINUE
C     OVERWRITE ALFA_3 UNIFICATION TO GET ALFA_3(MZ) RIGHT
      IF (IMODEL.EQ.1.AND.IAL3UN.NE.0) G(3)=DBLE(GGUT)
      IF (IMODEL.EQ.1) THEN
        DO 270 I=13,24
          G(I)=DBLE(M0)**2
270     CONTINUE
      IF (INUHM.EQ.1) THEN
        G(13)=DBLE(MHDSMG)
        G(14)=DBLE(MHUSMG)
      END IF
C          Set possible non-universal GUT scale boundary conditions
      DO 280 I=1,6
        IF (XNUSUG(I).LT.1.E19) THEN
          G(I+6)=DBLE(XNUSUG(I))
        END IF
280   CONTINUE
      DO 281 I=7,18
        IF (XNUSUG(I).LT.1.E19) THEN
          G(I+6)=SIGN(1.,XNUSUG(I))*DBLE(XNUSUG(I))**2
        END IF
281   CONTINUE
      ELSE IF (IMODEL.EQ.2) THEN
       XC=2*THRF*XLAMGM**2
       DY=DSQRT(3.D0/5.D0)*G(1)*XGMIN(11)
       G(13)=XC*(.75*XGMIN(13)*(G(2)/4.D0/DPI)**4+.6D0*.25*
     , XGMIN(12)*(G(1)/4.D0/DPI)**4)+DBLE(XGMIN(9))-DY
       G(14)=XC*(.75*XGMIN(13)*(G(2)/4.D0/DPI)**4+.6D0*.25*
     , XGMIN(12)*(G(1)/4.D0/DPI)**4)+DBLE(XGMIN(10))+DY
       G(15)=XC*(.6*XGMIN(12)*(G(1)/4.D0/DPI)**4)+2*DY
       G(16)=XC*(.75*XGMIN(13)*(G(2)/4.D0/DPI)**4+.6D0*.25*
     , XGMIN(12)*(G(1)/4.D0/DPI)**4)-DY
       G(17)=XC*(4*XGMIN(14)*(G(3)/4.D0/DPI)**4/3.D0+.6D0*XGMIN(12)*
     , (G(1)/4.D0/DPI)**4/9.D0)+2*DY/3.D0
       G(18)=XC*(4*XGMIN(14)*(G(3)/4.D0/DPI)**4/3.D0+
     , .6D0*4*XGMIN(12)*(G(1)/4.D0/DPI)**4/9.D0)-4*DY/3.D0
       G(19)=XC*(4*XGMIN(14)*(G(3)/4.D0/DPI)**4/3.D0+.75*XGMIN(13)*
     ,(G(2)/4.D0/DPI)**4+.6*XGMIN(12)*(G(1)/4.D0/DPI)**4/36.D0)+DY/3.D0
       G(20)=G(15)
       G(21)=G(16)
       G(22)=G(17)
       G(23)=G(18)
       G(24)=G(19)
      ELSE IF (IMODEL.EQ.7) THEN
       G(1)=G(1)
       G(2)=G(2)
       G(3)=G(3)
       BLHAT=G(4)*(-9*G(1)**2/5.D0-3*G(2)**2+3*G(5)**2+4*G(4)**2)
       BBHAT=G(5)*(-7*G(1)**2/15.D0-3*G(2)**2-16*G(3)**2/3.D0+
     ,             G(6)**2+6*G(5)**2+G(4)**2)
       BTHAT=G(6)*(-13*G(1)**2/15.D0-3*G(2)**2-16*G(3)**2/3.D0+
     ,             6*G(6)**2+G(5)**2)
       G(7)=-33*MHF*G(1)**2/5.D0/16.D0/DPI**2
       G(8)=-MHF*G(2)**2/16.D0/DPI**2
       G(9)=3*MHF*G(3)**2/16.D0/DPI**2
       G(10)=BLHAT*MHF/G(4)/16.D0/DPI**2
       G(11)=BBHAT*MHF/G(5)/16.D0/DPI**2
       G(12)=BTHAT*MHF/G(6)/16.D0/DPI**2
       G(13)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0+3*G(5)*BBHAT+
     ,G(4)*BLHAT)*MHF**2/(16*DPI**2)**2+XAMIN(6)*DBLE(M0)**2
       G(14)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0+3*G(6)*BTHAT)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(7)*DBLE(M0)**2
       G(15)=(-198*G(1)**4/25.D0)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(5)*DBLE(M0)**2
       G(16)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0)*MHF**2/(16*DPI**2)**2
     ,+XAMIN(4)*DBLE(M0)**2
       G(17)=(-22*G(1)**4/25.D0+8*G(3)**4)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(2)*DBLE(M0)**2
       G(18)=(-88*G(1)**4/25.D0+8*G(3)**4)*MHF**2/(16*DPI**2)**2+
     ,XAMIN(3)*DBLE(M0)**2
       G(19)=(-11*G(1)**4/50.D0-3*G(2)**4/2.D0+8*G(3)**4)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(1)*DBLE(M0)**2
       G(20)=(-198*G(1)**4/25.D0+2*G(4)*BLHAT)*MHF**2/(16*DPI**2)**2
     ,+XAMIN(5)*DBLE(M0)**2
       G(21)=(-99*G(1)**4/50.D0-3*G(2)**4/2.D0+G(4)*BLHAT)*
     ,        MHF**2/(16*DPI**2)**2+XAMIN(4)*DBLE(M0)**2
       G(22)=(-22*G(1)**4/25.D0+8*G(3)**4+2*G(5)*BBHAT)*
     , MHF**2/(16*DPI**2)**2+XAMIN(2)*DBLE(M0)**2
       G(23)=(-88*G(1)**4/25.D0+8*G(3)**4+2*G(6)*BTHAT)*
     , MHF**2/(16*DPI**2)**2+XAMIN(3)*DBLE(M0)**2
       G(24)=(-11*G(1)**4/50.D0-3*G(2)**4/2.D0+8*G(3)**4+G(5)*BBHAT+
     ,        G(6)*BTHAT)*MHF**2/(16*DPI**2)**2+XAMIN(1)*DBLE(M0)**2
      END IF
      DO 285 I=1,31
        IG(I)=0
285   CONTINUE
C          Check for tachyonic sleptons at GUT scale
      IF (G(15).LT.0.D0.OR.G(16).LT.0.D0) THEN
        ITACHY=2
      ELSE
        ITACHY=0
      END IF
C
C          Run back down to weak scale
C
      TZ=DLOG(DBLE(MZ)/DBLE(MGUT))
      TGUT=0.D0
      DT=(TZ-TGUT)/DBLE(FLOAT(NSTEP))
      DO 290 II=1,NSTEP+2
        T=TGUT+(TZ-TGUT)*FLOAT(II-1)/DBLE(FLOAT(NSTEP))
        QOLD=Q
        Q=SNGL(MGUT*DEXP(T))
        CALL DRKSTP(31,DT,T,G,SURG26,W2)
C       TEST YUKAWA DIVERGENCE
        IF (G(4).GT.5.D0.OR.G(5).GT.5.D0.OR.
     $    G(6).GT.5.D0.OR.G(27).GT.5.D0) THEN
          NOGOOD=4
          GO TO 100
        END IF
        CALL SUGFRZ(Q,G,G0,IG)
        IF (QOLD.GE.AMNRMJ.AND.Q.LT.AMNRMJ.AND.XNRIN(1).EQ.0.) THEN
          FNMZ=SNGL(G(27))
        END IF
        IF (QOLD.GT.HIGFRZ.AND.Q.LE.HIGFRZ) THEN
          G(6)=G(6)*(1.D0-DBLE(RSIGT))
          G(5)=G(5)*(1.D0-DBLE(RSIGB))
          G(4)=G(4)*(1.D0-DBLE(RSIGL))
        END IF
        IF (Q.LT.AMNRMJ) THEN
          G(27)=0.D0
          G(28)=0.D0
          G(29)=0.D0
        END IF
        IF (NOGOOD.NE.0) GO TO 100
        IF (Q.LT.MZ) GO TO 40
290   CONTINUE
40    CONTINUE
C
C          Electroweak breaking constraints; tree level
C
      VUQ=G0(31)
      VDQ=G0(30)
      TANBQ=VUQ/VDQ
      SIN2BQ=SIN(2*ATAN(TANBQ))
      MZQ=SQRT((G0(2)**2+.6*G0(1)**2)*(VUQ**2+VDQ**2)/2.)
      BADMU=.FALSE.
      IF (INUHM.NE.1) THEN
      MUS=(G0(13)-G0(14)*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
C          Compute loop corrections using masses from last iteration
      CALL SUGEFF(G0,SIG1,SIG2)
      MH1S=G0(13)+SIG1
      MH2S=G0(14)+SIG2
      MUS=(MH1S-MH2S*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
C          If MUS<0, set it to MZ**2 and continue
      IF (MUS.LT.0.) THEN
        MUS=AMZ**2
      END IF
      MU=SQRT(MUS)*SIGN(1.,SGNMU)
      B=(G0(13)+G0(14)+2*MUS)*SIN2BQ/MU/2.
      CALL SUGMAS(G0,0,IMODEL,SIGA)
      IF (NOGOOD.NE.0) GO TO 100
C
C           Electroweak breaking constraints; loop level
C
      CALL SUGEFF(G0,SIG1,SIG2)
      MH1S=G0(13)+SIG1
      MH2S=G0(14)+SIG2
      MUS=(MH1S-MH2S*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
      IF (MUS.LT.0.) THEN
C        NOGOOD=2
C        GO TO 100
         MUS=MZ**2
      END IF
      MU=SQRT(MUS)*SIGN(1.,SGNMU)
      B=(MH1S+MH2S+2*MUS)*SIN2BQ/MU/2.
C
C     Once more, with feeling!
C
      CALL SUGEFF(G0,SIG1,SIG2)
      MH1S=G0(13)+SIG1
      MH2S=G0(14)+SIG2
      MUS=(MH1S-MH2S*TANBQ**2)/(TANBQ**2-1.)-MZQ**2/2.
      IF (MUS.LT.0.) THEN
C        NOGOOD=2
C        GO TO 100
         BADMU=.TRUE.
         MUS=MZ**2
      END IF
      MU=SQRT(MUS)*SIGN(1.,SGNMU)
      B=(MH1S+MH2S+2*MUS)*SIN2BQ/MU/2.
      CALL SUGMAS(G0,1,IMODEL,SIGA)
      ELSE
        MUS=MU**2
        B=AMHA**2/MU/(COTB+TANB)
        CALL SUGMAS(G0,0,IMODEL,SIGA)
        MHDSQ=(-2*SIG1-MZQ**2-2*MUS+2*TANB**2*(AMHA**2+SIGA+MZQ**2+
     ,SIG2-SIG1)+TANB**4*(2*MUS-MZQ**2-2*SIG2-2*AMHA**2+2*SIGA))
     ,/2./(1.-TANB**4)
        MHUSQ=(2*AMHA**2+2*SIGA+MZQ**2-2*MUS-2*SIG1+2*TANB**2*(
     ,-AMHA**2+SIGA-MZQ**2-SIG1+SIG2)+TANB**4*(2*MUS+2*SIG2+MZQ**2))
     ,/2./(1.-TANB**4)
      END IF
C

100   RETURN
      END
+EOD
+DECK,SURG06
C-----------------------------------------------------------------
      SUBROUTINE SURG06(T,GY,F)
C-----------------------------------------------------------------
C
C     Right hand side of truncated renormalization group equations
C          dG_i/dT = F_i(G)
C     using a single common scale MSUSY for SUSY mass thresholds.
C     Added GY(7) for neutrino Yukawa coupling on 9/24/99
C     THIS INCLUDES TWO-LOOP YUKAWAS FOR MSSM ONLY 11/18/99
C     Add GY(8)=vd and GY(9)=vu on 2/19/03
C     Extend to double precision 8/30/04
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SUGPAS
      REAL*8 T,GY(9),F(9)
      REAL*8 SINB,BETA,COSB,B1,B3,B2,B12,B11,B21,B13,
     $MT,TANB,PI,Q,B33,B23,B22,B32,B31
      REAL*8 A11,A12,A13,A21,A22,A23,A31,A32,A33
      REAL*8 C11,C12,C13,C21,C22,C23,C31,C32,C33
      REAL*8 D11,D12,D13,D21,D22,D23,D31,D32,D33
      REAL*8 C1,C2,C3,CP1,CP2,CP3,CPP1,CPP2,CPP3,BSY1,BSY2,BSY3
      INTEGER NSL,NSD,NSH,NSE,NSU,NSQ,NU,NSG,NSW,NH,NN,NE,ND
      INTEGER TH2LP,THTOP
      DATA ND/3/,NE/3/,NN/3/
      DATA B11/7.96/,B12/5.4/,B13/17.6/,B21/1.8/,B22/25./,B23/24./
      DATA B31/2.2/,B32/9./,B33/14./
      DATA A11/5.2/,A12/2.8/,A13/3.6/,A21/6./,A22/6./,A23/2./
      DATA A31/4./,A32/4./,A33/0./
      DATA C11/1.7/,C12/.5/,C13/1.5/,C21/1.5/,C22/1.5/,C23/.5/
      DATA C31/2./,C32/2./,C33/0./
      DATA D11/3.98/,D12/2.7/,D13/8.8/,D21/.9/,D22/5.833/,D23/12./
      DATA D31/1.1/,D32/4.5/,D33/-26./
      DATA C1/.8666667/,C2/3./,C3/5.333333/
      DATA CP1/.4666667/,CP2/3./,CP3/5.333333/
      DATA CPP1/1.8/,CPP2/3./,CPP3/0./
      DATA BSY1/6.6/,BSY2/1./,BSY3/-3./
      TANB=XTANB
      MT=AMT
C-----THESE ARE VALID FROM MZ TO MGUT 
      Q=MGUT*EXP(T)
      PI=4.*DATAN(1.D0)
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=SQRT(1.-SINB**2)
      IF (Q.GT.MSUSY) THEN
        NSQ=3
        NSU=3
        NSD=3
        NSL=3
        NSE=3
        NSH=2
        NSW=1
        NSG=1
        NH=2
        TH2LP=1
      ELSE
        NSQ=0
        NSU=0
        NSD=0
        NSL=0
        NSE=0
        NSH=0
        NSW=0
        NSG=0
        NH=1
        TH2LP=0
      END IF
      IF (Q.GT.MT) THEN
        NU=3
        THTOP=1
      ELSE
        NU=2
        THTOP=0
      END IF
      B1=2.D0*(17*NU/12.D0+5*ND/12.D0+5*NE/4.D0+NN/4.D0)/5.D0+
     $ NSQ/30.D0+4*NSU/15.D0+NSD/15.D0+NSL/10.D0+NSE/5.D0+
     $ 1.*NSH/5.D0+1.*NH/10.D0
      B2=-22./3.D0+.5D0*(NU+ND)+1.D0*(NE+NN)/6.D0+1.D0*NSQ/2.D0+
     $1.D0*NSL/6.D0+1.D0*NSH/3.D0+1.D0*NH/6.D0+4.D0*NSW/3.D0
      B3=2.D0*(NU+ND)/3.D0+1.D0*NSQ/3.D0+1.D0*NSU/6.D0+1.D0*NSD/6.D0+
     $2.D0*NSG-11.D0
      IF (Q.GT.MSUSY) THEN
      F(1)=GY(1)/16.D0/PI**2*(B1*GY(1)**2+TH2LP/16.D0/PI**2*GY(1)**2*
     $(B11*GY(1)**2+B12*GY(2)**2+B13*GY(3)**2-A11*GY(6)**2-A12*GY(5)**2
     $-A13*GY(4)**2))
      F(2)=GY(2)/16.D0/PI**2*(B2*GY(2)**2+TH2LP/16.D0/PI**2*GY(2)**2*
     $(B21*GY(1)**2+B22*GY(2)**2+B23*GY(3)**2-A21*GY(6)**2-A22*GY(5)**2
     $-A23*GY(4)**2))
      F(3)=GY(3)/16.D0/PI**2*(B3*GY(3)**2+TH2LP/16.D0/PI**2*GY(3)**2*
     $(B31*GY(1)**2+B32*GY(2)**2+B33*GY(3)**2-A31*GY(6)**2-A32*GY(5)**2
     $-A33*GY(4)**2))
      ELSE
      F(1)=GY(1)/16.D0/PI**2*(B1*GY(1)**2+TH2LP/16.D0/PI**2*GY(1)**2*
     $(D11*GY(1)**2+D12*GY(2)**2+D13*GY(3)**2-C11*GY(6)**2-C12*GY(5)**2
     $-C13*GY(4)**2))
      F(2)=GY(2)/16.D0/PI**2*(B2*GY(2)**2+TH2LP/16.D0/PI**2*GY(2)**2*
     $(D21*GY(1)**2+D22*GY(2)**2+D23*GY(3)**2-C21*GY(6)**2-C22*GY(5)**2
     $-C23*GY(4)**2))
      F(3)=GY(3)/16.D0/PI**2*(B3*GY(3)**2+TH2LP/16.D0/PI**2*GY(3)**2*
     $(D31*GY(1)**2+D32*GY(2)**2+D33*GY(3)**2-C31*GY(6)**2-C32*GY(5)**2
     $-C33*GY(4)**2))
      ENDIF
      IF (Q.LT.MSUSY) THEN
        F(4)=GY(4)/16.D0/PI**2*(5*GY(4)**2*COSB**2/2.D0+
     $3*GY(6)**2*SINB**2*THTOP+3*GY(5)**2*COSB**2-9*GY(1)**2/4.D0-
     $9*GY(2)**2/4.D0-SINB**2*(3*GY(6)**2*THTOP-3*GY(5)**2-GY(4)**2))
        F(5)=GY(5)/16.D0/PI**2*(9*GY(5)**2*COSB**2/2.D0+
     $3*GY(6)**2*SINB**2*THTOP/2.D0+GY(4)**2*COSB**2-GY(1)**2/4.D0-
     $9*GY(2)**2/4.D0-8*GY(3)**2-SINB**2*(3*GY(6)**2*THTOP-
     $3*GY(5)**2-GY(4)**2))
        F(6)=GY(6)/16.D0/PI**2*(9*GY(6)**2*SINB**2/2.D0*THTOP+
     $3*GY(5)**2*COSB**2/2.D0+GY(4)**2*COSB**2-17.*GY(1)**2/20.D0
     $-9*GY(2)**2/4.D0-8*GY(3)**2+COSB**2*
     $(3*GY(6)**2*THTOP-3*GY(5)**2-GY(4)**2))
      ELSE
        F(4)=GY(4)/16.D0/PI**2*(4*GY(4)**2+3*GY(5)**2+GY(7)**2-
     $9*GY(1)**2/5.D0-3*GY(2)**2+TH2LP/16.D0/PI**2*
     $((CPP1*BSY1+CPP1**2/2.D0)*GY(1)**4+
     $(CPP2*BSY2+CPP2**2/2.D0)*GY(2)**4+(CPP3*BSY3+CPP3**2/2.D0)*
     $GY(3)**4+9*GY(1)**2*GY(2)**2/5.D0+
     $GY(5)**2*(-.4*GY(1)**2+16*GY(3)**2)+
     $GY(4)**2*(1.2*GY(1)**2+6*GY(2)**2)-
     $(3*GY(6)**2*GY(5)**2+9*GY(5)**4+9*GY(5)**2*GY(4)**2+
     $10*GY(4)**4)))
        F(5)=GY(5)/16.D0/PI**2*(6*GY(5)**2+GY(6)**2*THTOP+
     $GY(4)**2-7*GY(1)**2/15.D0-3*GY(2)**2-16*GY(3)**2/3.D0+
     $TH2LP/16.D0/PI**2*((CP1*BSY1+CP1**2/2.D0)*GY(1)**4+
     $(CP2*BSY2+CP2**2/2.D0)*GY(2)**4+(CP3*BSY3+CP3**2/2.D0)*
     $GY(3)**4+GY(1)**2*GY(2)**2+8*GY(1)**2*GY(3)**2/9.D0+
     $8*GY(2)**2*GY(3)**2+.8*GY(6)**2*GY(1)**2+
     $GY(5)**2*(.4*GY(1)**2+6*GY(2)**2+16*GY(3)**2)+
     $1.2*GY(4)**2*GY(1)**2-
     $(22*GY(5)**4+5*GY(6)**2*GY(5)**2+3*GY(5)**2*GY(4)**2+
     $3*GY(4)**4+5*GY(6)**4)))
        F(6)=GY(6)/16.D0/PI**2*(6*GY(6)**2*THTOP+GY(5)**2+GY(7)**2-
     $13*GY(1)**2/15.D0-3*GY(2)**2-16*GY(3)**2/3.D0+
     $TH2LP/16.D0/PI**2*((C1*BSY1+C1**2/2.D0)*GY(1)**4+
     $(C2*BSY2+C2**2/2.D0)*GY(2)**4+(C3*BSY3+C3**2/2.D0)*
     $GY(3)**4+GY(1)**2*GY(2)**2+136*GY(1)**2*GY(3)**2/45.D0+
     $8*GY(2)**2*GY(3)**2+GY(6)**2*(1.2*GY(1)**2+6*GY(2)**2+
     $16*GY(3)**2)+.4*GY(5)**2*GY(1)**2-
     $(22*GY(6)**4+5*GY(6)**2*GY(5)**2+5*GY(5)**4+
     $GY(5)**2*GY(4)**2)))
      END IF
C     THE NEUTRINO YUKAWA IS TO 1-LOOP ONLY FOR NOW...
      IF (Q.GT.AMNRMJ) THEN
        F(7)=GY(7)/16.D0/PI**2*(3*GY(6)**2+GY(4)**2+4*GY(7)**2-
     $        3*GY(2)**2-3*GY(1)**2/5.D0)
      ELSE
        F(7)=0.
      END IF
      F(8)=GY(8)*(.75*(GY(1)**2/5.D0+GY(2)**2)-3*GY(5)**2-GY(4)**2)/
     $16.D0/PI**2
      F(9)=GY(9)*(.75*(GY(1)**2/5.D0+GY(2)**2)-3*GY(6)**2)/16.D0/PI**2
      RETURN
      END
+EOD
+DECK,SURG26
C-----------------------------------------------------------------
      SUBROUTINE SURG26(T,G,F)
C-----------------------------------------------------------------
C
C     Right hand side of full renormalization group equations
C          dG_i/dT = F_i(G)
C     using the thresholds MSS for each mass calculated with the 
C     couplings G0 frozen by SUGFRZ. 
C     Added right neutrino RGE's on 9/24/99
C     Upgrade to 2-loop RGE's for MSSM on 2/11/00
C     Add RGEs for vd and vu on 2/19/03
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,SSLUN
+CDE,SUGMG
+CDE,SUGPAS
      REAL*8 T,G(31),F(31)
      REAL*8 FAC,COSB,B3,B2,XTAU,XT,XB,B1,B12,B11,TANB,MT,
     $Q,B33,B32,PI,SINB,BETA,B21,B13,B22,B31,B23,XN,SMV,SPMV
      REAL*8 A11,A12,A13,A21,A22,A23,A31,A32,A33,A14,A24
      REAL*8 C11,C12,C13,C21,C22,C23,C31,C32,C33
      REAL*8 D11,D12,D13,D21,D22,D23,D31,D32,D33
      REAL*8 C1,C2,C3,CP1,CP2,CP3,CPP1,CPP2,CPP3,BSY1,BSY2,BSY3
      REAL*8 BY4,BY5,BY6,SIG1,SIG2,SIG3
      REAL*8 G72LP,G82LP,G92LP,FAC2LP,G102lP,G112lP,G122lP
      REAL*8 G132LP,G142LP,G152LP,G162LP,G172LP,G182LP,G192LP,G262LP
      REAL*8 G202LP,G212LP,G222LP,G232LP,G242LP,G252LP,G292LP,G282LP
      INTEGER THHL,THHH,THSHL,THSHH,THQ,THU,THD,THL,THE
      INTEGER TH1,TH2,TH3,TH2LP,THTOP
      INTEGER NSL,NSD,NSE,NSW,NSH,NSU,NSQ,NH,NSG,NU,NE,ND,NN
C
      DATA ND/3/,NE/3/,NN/3/
      DATA B11/7.96/,B12/5.4/,B13/17.6/,B21/1.8/,B22/25./,B23/24./
      DATA B31/2.2/,B32/9./,B33/14./
      DATA A11/5.2/,A12/2.8/,A13/3.6/,A21/6./,A22/6./,A23/2./
      DATA A31/4./,A32/4./,A33/0./,A14/1.2/,A24/2./
      DATA C11/1.7/,C12/.5/,C13/1.5/,C21/1.5/,C22/1.5/,C23/.5/
      DATA C31/2./,C32/2./,C33/0./
      DATA D11/3.98/,D12/2.7/,D13/8.8/,D21/.9/,D22/5.833/,D23/12./
      DATA D31/1.1/,D32/4.5/,D33/-26./
      DATA C1/.8666667/,C2/3./,C3/5.333333/
      DATA CP1/.4666667/,CP2/3./,CP3/5.333333/
      DATA CPP1/1.8/,CPP2/3./,CPP3/0./
      DATA BSY1/6.6/,BSY2/1./,BSY3/-3./
C
C-----THESE ARE VALID FROM MZ TO MGUT --------------------------------
      PI=4.*DATAN(1.D0)
      TANB=XTANB
      MT=AMT
      Q=MGUT*EXP(T)
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=SQRT(1.-SINB**2)
      FAC=2./16.D0/PI**2
C-----CALCULATE 1-LOOP THRESHOLD EFFECTS -----------------------------
      TH2LP=1
      IF (Q.GT.DBLE(MSS(2))) THEN
        NSQ=3
        NSU=3
        NSD=3
      ELSE
        NSQ=0
        NSU=0
        NSD=0
      END IF
      IF (Q.GT.DBLE(MSS(17))) THEN
        NSL=3
        NSE=3
      ELSE
        NSL=0
        NSE=0
      END IF
      IF (Q.GT.DBLE(ABS(MU))) THEN
        NSH=2
      ELSE 
        NSH=0
      END IF
      IF (Q.GT.DBLE(ABS(MSS(27)))) THEN
        NSW=1
      ELSE
        NSW=0
      END IF
      IF (Q.GT.DBLE(ABS(MSS(1)))) THEN
        NSG=1
      ELSE
        NSG=0
      END IF
      IF (Q.GT.DBLE(MSS(31))) THEN
        NH=2
      ELSE
        NH=1
      END IF
      IF (Q.GT.DBLE(ABS(GSS(7)))) THEN
        TH1=1
      ELSE
        TH1=0
      END IF
      IF (Q.GT.DBLE(ABS(GSS(8)))) THEN
        TH2=1
      ELSE
        TH2=0
      END IF
      IF (Q.GT.MT) THEN
        NU=3
        THTOP=1
      ELSE
        NU=2
        THTOP=0
      END IF
      THHL=1
      THHH=NH/2
      THSHL=NSH/2
      THSHH=NSH/2
      THQ=NSQ/3
      THU=NSQ/3
      THD=NSQ/3
      THL=NSL/3
      THE=NSE/3
      TH3=NSG
      B1=2.*(17*NU/12.D0+5*ND/12.D0+5*NE/4.D0+NN/4.D0)/5.D0+
     $ NSQ/30.D0+4*NSU/15.D0+NSD/15.D0+NSL/10.D0+NSE/5.D0+
     $ 1.*NSH/5.D0+1.*NH/10.D0
      B2=-22./3.D0+.5D0*(NU+ND)+1.*(NE+NN)/6.D0+
     $ 1.*NSQ/2.D0+1.*NSL/6.D0+1.*NSH/3.D0+1.*NH/6.D0+4.*NSW/3.D0
      B3=2.*(NU+ND)/3.D0+1.*NSQ/3.D0+1.*NSU/6.D0+1.*NSD/6.D0+
     $2.D0*NSG-11.D0
      IF (Q.GT.DBLE(MSUSY)) THEN
      F(1)=G(1)/16.D0/PI**2*(B1*G(1)**2+TH2LP/16.D0/PI**2*G(1)**2*
     $(B11*G(1)**2+B12*G(2)**2+B13*G(3)**2-A11*G(6)**2-A12*G(5)**2
     $-A13*G(4)**2-A14*G(27)**2))
      F(2)=G(2)/16.D0/PI**2*(B2*G(2)**2+TH2LP/16.D0/PI**2*G(2)**2*
     $(B21*G(1)**2+B22*G(2)**2+B23*G(3)**2-A21*G(6)**2-A22*G(5)**2
     $-A23*G(4)**2-A24*G(27)**2))
      F(3)=G(3)/16.D0/PI**2*(B3*G(3)**2+TH2LP/16.D0/PI**2*G(3)**2*
     $(B31*G(1)**2+B32*G(2)**2+B33*G(3)**2-A31*G(6)**2-A32*G(5)**2
     $-A33*G(4)**2))
      ELSE
      F(1)=G(1)/16.D0/PI**2*(B1*G(1)**2+TH2LP/16.D0/PI**2*G(1)**2*
     $(D11*G(1)**2+D12*G(2)**2+D13*G(3)**2-C11*G(6)**2-C12*G(5)**2
     $-C13*G(4)**2))
      F(2)=G(2)/16.D0/PI**2*(B2*G(2)**2+TH2LP/16.D0/PI**2*G(2)**2*
     $(D21*G(1)**2+D22*G(2)**2+D23*G(3)**2-C21*G(6)**2-C22*G(5)**2
     $-C23*G(4)**2))
      F(3)=G(3)/16.D0/PI**2*(B3*G(3)**2+TH2LP/16.D0/PI**2*G(3)**2*
     $(D31*G(1)**2+D32*G(2)**2+D33*G(3)**2-C31*G(6)**2-C32*G(5)**2
     $-C33*G(4)**2))
      ENDIF
      IF (Q.LT.MSUSY) THEN
        F(4)=G(4)/16.D0/PI**2*(5*G(4)**2*COSB**2/2.D0+3*G(6)**2*SINB**2*
     $   THTOP+3*G(5)**2*COSB**2-9*G(1)**2/4.D0-9*G(2)**2/4.D0
     $   -SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
        F(5)=G(5)/16.D0/PI**2*(9*G(5)**2*COSB**2/2.D0+
     $3*G(6)**2*SINB**2*THTOP/2.D0+G(4)**2*COSB**2-G(1)**2/4.D0-
     $9*G(2)**2/4.D0-8*G(3)**2-SINB**2*(3*G(6)**2*THTOP-
     $3*G(5)**2-G(4)**2))
        F(6)=G(6)/16.D0/PI**2*(9*G(6)**2*SINB**2/2.D0*THTOP+
     $3*G(5)**2*COSB**2/2.D0+G(4)**2*COSB**2-17.*G(1)**2/20.D0
     $-9*G(2)**2/4.D0-8*G(3)**2+COSB**2*
     $(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
      ELSE
        BY4=2.5D0*(COSB**2*THHL+SINB**2*THHH)*G(4)**2+
     $1.5D0*(COSB**2*THSHL+SINB**2*THSHH)*G(4)**2+
     $3*SINB**2*(THHL-THHH)*G(6)**2+3*(COSB**2*THHL+SINB**2*THHH)*
     $G(5)**2-
     $(3*G(1)**2/5.D0*(15./4.D0+3*THSHL/4.D0-TH1*
     $(THL/4.D0+THE+THSHL/4.D0))+G(2)**2*(9./4.D0+9*THSHL/4.D0-
     $3*(THL+THSHL)*TH2/4.D0))
        BY4=BY4+G(27)**2
        BY5=4.5D0*(COSB**2*THHL+SINB**2*THHH)*G(5)**2+
     $1.5D0*(COSB**2*THSHL+SINB**2*THSHH)*G(5)**2+
     $.5D0*(SINB**2*THHL+COSB**2*THHH-
     $4*SINB**2*(THHL-THHH))*G(6)**2+.5D0*(SINB**2*THSHL+COSB**2*THSHH)*
     $G(6)**2+3*SINB**2*(THHL-THHH)*G(6)**2+
     $(COSB**2*THHL+SINB**2*THHH)*G(4)**2-
     $(3*G(1)**2/5.D0*(5./12.D0+3*THSHL/4.D0-
     $TH1*(THQ/36.D0+THD/9.D0+THSHL/4.D0))
     $+G(2)**2*(9./4.D0+9*THSHL/4.D0-3*(THQ+THSHL)*TH2/4.D0)+
     $G(3)**2*(8.D0-4*(THQ+THD)*TH3/3.D0))
        BY6=4.5D0*(SINB**2*THHL+COSB**2*THHH)*G(6)**2+
     $1.5D0*(SINB**2*THSHL+COSB**2*THSHH)*G(6)**2+
     $.5D0*(COSB**2*THHL+SINB**2*THHH-
     $4*COSB**2*(THHL-THHH))*G(5)**2+.5D0*(COSB**2*THSHL+SINB**2*THSHH)*
     $G(5)**2+COSB**2*(THHL-THHH)*(3*G(5)**2+G(4)**2)-
     $(3*G(1)**2/5.D0*(17./12.D0+3*THSHL/4.D0-
     $TH1*(THQ/36.D0+4*THU/9.D0+THSHL/4.D0))
     $+G(2)**2*(9./4.D0+9*THSHL/4.D0-3*(THQ+THSHL)*TH2/4.D0)+
     $G(3)**2*(8.D0-4*(THQ+THU)*TH3/3.D0))
        BY6=BY6+G(27)**2
        F(4)=G(4)/16.D0/PI**2*(BY4+
     $       TH2LP/16.D0/PI**2*((CPP1*BSY1+CPP1**2/2.D0)*G(1)**4+
     $       (CPP2*BSY2+CPP2**2/2.D0)*G(2)**4+(CPP3*BSY3+CPP3**2/2.D0)*
     $       G(3)**4+9*G(1)**2*G(2)**2/5.D0+
     $       G(5)**2*(-.4*G(1)**2+16*G(3)**2)+
     $       G(4)**2*(1.2*G(1)**2+6*G(2)**2)-
     $       (3*G(6)**2*G(5)**2+9*G(5)**4+9*G(5)**2*G(4)**2+
     $       10*G(4)**4)-3*G(27)**4-3*G(27)**2*G(6)**2
     $       -3*G(27)**2*G(4)**2))
        F(5)=G(5)/16.D0/PI**2*(BY5+
     $       TH2LP/16.D0/PI**2*((CP1*BSY1+CP1**2/2.D0)*G(1)**4+
     $       (CP2*BSY2+CP2**2/2.D0)*G(2)**4+(CP3*BSY3+CP3**2/2.D0)*
     $       G(3)**4+G(1)**2*G(2)**2+8*G(1)**2*G(3)**2/9.D0+
     $       8*G(2)**2*G(3)**2+.8*G(6)**2*G(1)**2+
     $       G(5)**2*(.4*G(1)**2+6*G(2)**2+16*G(3)**2)+
     $       1.2*G(4)**2*G(1)**2-
     $       (22*G(5)**4+5*G(6)**2*G(5)**2+3*G(5)**2*G(4)**2+
     $       3*G(4)**4+5*G(6)**4)-G(27)**2*G(6)**2-G(27)**2*G(4)**2))
        F(6)=G(6)/16.D0/PI**2*(BY6+
     $       TH2LP/16.D0/PI**2*((C1*BSY1+C1**2/2.D0)*G(1)**4+
     $       (C2*BSY2+C2**2/2.D0)*G(2)**4+(C3*BSY3+C3**2/2.D0)*
     $       G(3)**4+G(1)**2*G(2)**2+136*G(1)**2*G(3)**2/45.D0+
     $       8*G(2)**2*G(3)**2+G(6)**2*(1.2*G(1)**2+6*G(2)**2+
     $       16*G(3)**2)+.4*G(5)**2*G(1)**2-
     $       (22*G(6)**4+5*G(6)**2*G(5)**2+5*G(5)**4+
     $       G(5)**2*G(4)**2)-3*G(27)**4-3*G(27)**2*G(6)**2-
     $       G(27)**2*G(4)**2))
      END IF
      FAC2LP=(FAC/2.D0)**2
      G72LP=2*G(1)**2*(B11*G(1)**2*(G(7)+G(7))+
     $B12*G(2)**2*(G(7)+G(8))+B13*G(3)**2*(G(7)+G(9))+
     $A11*G(6)**2*(G(12)-G(7))+A12*G(5)**2*(G(11)-G(7))+
     $A13*G(4)**2*(G(10)-G(7))+A14*G(27)**2*(G(29)-G(7)))
      G82LP=2*G(2)**2*(B21*G(1)**2*(G(7)+G(8))+
     $B22*G(2)**2*(G(8)+G(8))+B23*G(3)**2*(G(8)+G(9))+
     $A21*G(6)**2*(G(12)-G(8))+A22*G(5)**2*(G(11)-G(8))+
     $A23*G(4)**2*(G(10)-G(8))+A24*G(27)**2*(G(29)-G(8)))
      G92LP=2*G(3)**2*(B31*G(1)**2*(G(9)+G(7))+
     $B32*G(2)**2*(G(9)+G(8))+B33*G(3)**2*(G(9)+G(9))+
     $A31*G(6)**2*(G(12)-G(9))+A32*G(5)**2*(G(11)-G(9))+
     $A33*G(4)**2*(G(10)-G(9)))
      F(7)=FAC*B1*G(1)**2*G(7)+TH2LP*FAC2LP*G72LP
      F(8)=FAC*B2*G(2)**2*G(8)+TH2LP*FAC2LP*G82LP
      F(9)=FAC*B3*G(3)**2*G(9)+TH2LP*FAC2LP*G92LP
      XTAU=G(21)+G(20)+G(13)+G(10)**2
      XB=G(24)+G(22)+G(13)+G(11)**2
      XT=G(24)+G(23)+G(14)+G(12)**2
      XN=G(21)+G(28)+G(14)+G(29)**2
      SMV=G(14)-G(13)+(2*G(19)+G(24))-(2*G(16)+G(21))
     $    -2*(2*G(18)+G(23))+(2*G(17)+G(22))+(2*G(15)+G(20))
      SPMV=-2*G(4)**2*G(20)+(6*G(1)**2*(2*G(15)+G(20)))/5.D0+ 
     $G(4)**2*(G(13)+G(21))-(3*(G(1)**2+5*G(2)**2)*
     $(G(13)-G(14)+2*G(16)+G(21)))/10.D0-2*G(5)**2*G(22)+ 
     $(2*(G(1)**2+20*G(3)**2)*(2*G(17)+G(22)))/15.D0+
     $4*G(6)**2*G(23)-(16*(G(1)**2+5*G(3)**2)*(2*G(18)+G(23)))/15.D0+
     $G(5)**2*(3*G(13)-G(24))-G(6)**2*(3*G(14)+G(24))+ 
     $((G(1)**2+45*G(2)**2+80*G(3)**2)*(2*G(19)+G(24)))/30.D0
     $+G(27)**2*(G(21)-G(14))
      SIG1=.2*G(1)**2*(3*(G(14)+G(13))+(2*G(19)+G(24))+
     $3*(2*G(16)+G(21))+8*(2*G(18)+G(23))+2*(2*G(17)+G(22))+
     $6*(2*G(15)+G(20)))
      SIG2=G(2)**2*(G(14)+G(13)+3*(2*G(19)+G(24))+(2*G(16)+G(21)))
      SIG3=G(3)**2*(2*(2*G(19)+G(24))+(2*G(18)+G(23))+
     $(2*G(17)+G(22)))
C
      G102LP=(-54*G(1)**4-(18*G(1)**2*G(2)**2)/5.D0- 
     $(12*G(1)**2*G(4)**2)/5.D0+(4*G(1)**2*G(5)**2)/5.D0)*G(7)+ 
     $((-18*G(1)**2*G(2)**2)/5.D0-30*G(2)**4- 
     $12*G(2)**2*G(4)**2)*G(8)-32*G(3)**2*G(5)**2*G(9)+ 
     $(12*G(1)**2*G(4)**2*G(10))/5.D0+12*G(2)**2*G(4)**2*G(10)-
     $40*G(4)**4*G(10)-36*G(5)**4*G(11)+G(5)**2*
     $((-4*G(1)**2)/5.D0+32*G(3)**2-18*G(4)**2-6*G(6)**2)*G(11)+ 
     $G(5)**2*(-18*G(4)**2*G(10)-6*G(6)**2*G(12))
     $-6*G(27)**2*(G(12)*G(6)**2+G(10)*G(4)**2+G(29)*
     $(G(6)**2+2*G(27)**2+G(4)**2))
      G112LP=((-574*G(1)**4)/45.D0-2*G(1)**2*G(2)**2- 
     $(16*G(1)**2*G(3)**2)/9.D0-(12*G(1)**2*G(4)**2)/5.D0- 
     $(4*G(1)**2*G(5)**2)/5.D0-(8*G(1)**2*G(6)**2)/5.D0)*G(7)+ 
     $(-2*G(1)**2*G(2)**2-30*G(2)**4-16*G(2)**2*G(3)**2-
     $12*G(2)**2*G(5)**2)*G(8)+((-16*G(1)**2*G(3)**2)/9.D0- 
     $16*G(2)**2*G(3)**2+(64*G(3)**4)/9.D0-
     $32*G(3)**2*G(5)**2)*G(9)+(12*G(1)**2*G(4)**2*G(10))/5.D0- 
     $12*G(4)**4*G(10)-88*G(5)**4*G(11)+G(5)**2*((4*G(1)**2)/5.D0+
     $12*G(2)**2+32*G(3)**2-6*G(4)**2-10*G(6)**2)*G(11)+ 
     $(8*G(1)**2*G(6)**2*G(12))/5.D0-20*G(6)**4*G(12)+ 
     $G(5)**2*(-6*G(4)**2*G(10)-10*G(6)**2*G(12))
     $-2*G(27)**2*(G(12)*G(6)**2+G(10)*G(4)**2+G(29)*
     $(G(6)**2+G(4)**2))
      G122LP=((-5486*G(1)**4)/225.D0-2*G(1)**2*G(2)**2- 
     $(272*G(1)**2*G(3)**2)/45.D0-(4*G(1)**2*G(5)**2)/5.D0- 
     $(12*G(1)**2*G(6)**2)/5.D0)*G(7)+(-2*G(1)**2*G(2)**2-
     $30*G(2)**4-16*G(2)**2*G(3)**2-12*G(2)**2*G(6)**2)*G(8)+
     $((-272*G(1)**2*G(3)**2)/45.D0-16*G(2)**2*G(3)**2+
     $(64*G(3)**4)/9.D0-32*G(3)**2*G(6)**2)*G(9)- 
     $2*G(4)**2*G(5)**2*G(10)+(4*G(1)**2*G(5)**2*G(11))/5.D0- 
     $2*G(4)**2*G(5)**2*G(11)-20*G(5)**4*G(11)- 
     $10*G(5)**2*G(6)**2*G(11)+((12*G(1)**2)/5.D0+12*G(2)**2+
     $32*G(3)**2-10*G(5)**2)*G(6)**2*G(12)-88*G(6)**4*G(12)
     $-2*G(27)**2*(3*G(12)*G(6)**2+G(10)*G(4)**2+G(29)*
     $(3*G(6)**2+6*G(27)**2+G(4)**2))
      G132LP=XB*((-4*G(1)**2)/5.D0+32*G(3)**2)*G(5)**2- 
     $(12*G(1)**2*G(4)**2*(-XTAU-2*G(7)**2+2*G(7)*G(10)))/5.D0- 
     $12*G(4)**4*(XTAU+G(10)**2)-36*G(5)**4*(XB+G(11)**2)+ 
     $G(5)**2*((8*G(1)**2*G(7)*(-G(7)+G(11)))/5.D0- 
     $64*G(3)**2*G(9)*(-G(9)+G(11)))-6*G(5)**2*G(6)**2*
     $(XB+XT+2*G(11)*G(12))-1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+
     $3.6*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(7)*G(8))+
     $24.84*G(1)**4*G(7)**2+3*G(2)**2*SIG2+.6*G(1)**2*SIG1
     $-2*G(4)**2*G(27)**2*(2*G(29)*G(10)+XN+XTAU)
      G142LP=XT*((8*G(1)**2)/5.D0+32*G(3)**2)*G(6)**2- 
     $6*G(5)**2*G(6)**2*(XB+XT+2*G(11)*G(12))- 
     $36*G(6)**4*(XT+G(12)**2)+G(6)**2*((-16*G(1)**2*G(7)*
     $(-G(7)+G(12)))/5.D0-64*G(3)**2*G(9)*(-G(9)+G(12)))+
     $1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+
     $3.6*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(7)*G(8))+
     $24.84*G(1)**4*G(7)**2+3*G(2)**2*SIG2+.6*G(1)**2*SIG1
     $-12*G(27)**4*(G(29)**2+XN)-2*G(4)**2*G(27)**2*
     $(2*G(29)*G(10)+XN+XTAU)
      G152LP=2.4*G(1)**2*SPMV+112.32*G(1)**4*G(7)**2+2.4*G(1)**2*SIG1
      G162LP=-1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+3.6*G(2)**2*G(1)**2*
     $(G(8)**2+G(7)**2+G(8)*G(7))+24.84*G(1)**4*G(7)**2+
     $3*G(2)**2*SIG2+.6*G(1)**2*SIG1
      G172LP=.8*G(1)**2*SPMV-42.66667*G(3)**4*G(9)**2+
     $128*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.D0+808*
     $G(1)**4*G(7)**2/75.D0+16*G(3)**2*SIG3/3.D0+4*G(1)**2*SIG1/15.D0
      G182LP=-1.6*G(1)**2*SPMV-42.66667*G(3)**4*G(9)**2+
     $512*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.D0+
     $3424*G(1)**4*G(7)**2/75.D0+16*G(3)**2*SIG3/3.D0+
     $16*G(1)**2*SIG1/15.D0
      G192LP=.4*G(1)**2*SPMV-128.*G(3)**4*G(9)**2/3.D0+
     $32*G(3)**2*G(2)**2*(G(9)**2+G(8)**2+G(9)*G(8))+
     $32*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(9)*G(7))/45.D0+
     $33*G(2)**4*G(8)**2+
     $.4*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(8)*G(7))+
     $199*G(1)**4*G(7)**2/75.D0+16*G(3)**2*SIG3/3.D0+
     $3*G(2)**2*SIG2+G(1)**2*SIG1/15.D0
      G202LP=XTAU*((-12*G(1)**2)/5.D0+12*G(2)**2)*G(4)**2- 
     $16*G(4)**4*(XTAU+G(10)**2)+G(4)**2*((24*G(1)**2*G(7)*
     $(-G(7)+G(10)))/5.D0-24*G(2)**2*G(8)*(-G(8)+G(10)))- 
     $12*G(4)**2*G(5)**2*(XB+XTAU+2*G(10)*G(11))+
     $2.4*G(1)**2*SPMV+112.32*G(1)**4*G(7)**2+2.4*G(1)**2*SIG1
     $-4*G(27)**2*G(4)**2*(2*G(29)*G(10)+XN+XTAU)
      G212LP=(-12*G(1)**2*G(4)**2*(-XTAU-2*G(7)**2+2*G(7)*G(10)))/5.D0-
     $12*G(4)**4*(XTAU+G(10)**2)-6*G(4)**2*G(5)**2*
     $(XB+XTAU+2*G(10)*G(11))
     $-1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+3.6*G(2)**2*G(1)**2*
     $(G(8)**2+G(7)**2+G(8)*G(7))+24.84*G(1)**4*G(7)**2+
     $3*G(2)**2*SIG2+.6*G(1)**2*SIG1
     $-6*G(27)**2*(2*G(12)*G(29)*G(6)**2+G(6)**2*XT+
     $G(6)**2*XN+2*G(27)**2*(XN+G(29)**2))
      G222LP=XB*((4*G(1)**2)/5.D0+12*G(2)**2)*G(5)**2- 
     $4*G(4)**2*G(5)**2*(XB+XTAU+2*G(10)*G(11))-32*G(5)**4*
     $(XB+G(11)**2)+G(5)**2*((-8*G(1)**2*G(7)*(-G(7)+G(11)))/5.D0- 
     $24*G(2)**2*G(8)*(-G(8)+G(11)))-4*G(5)**2*G(6)**2*(XB+XT+
     $2*G(11)*G(12))+.8*G(1)**2*SPMV-42.66667*G(3)**4*G(9)**2+
     $128*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.D0+808*
     $G(1)**4*G(7)**2/75.D0+16*G(3)**2*SIG3/3.D0+4*G(1)**2*SIG1/15.D0
      G232LP=XT*((-4*G(1)**2)/5.D0+12*G(2)**2)*G(6)**2- 
     $4*G(5)**2*G(6)**2*(XB+XT+2*G(11)*G(12))-32*G(6)**4*
     $(XT+G(12)**2)+G(6)**2*((8*G(1)**2*G(7)*(-G(7)+G(12)))/5.D0- 
     $24*G(2)**2*G(8)*(-G(8)+G(12)))-1.6*G(1)**2*SPMV-42.66667*
     $G(3)**4*G(9)**2+
     $512*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.D0+3424*
     $G(1)**4*G(7)**2/75.D0+16*G(3)**2*SIG3/3.D0+16*G(1)**2*SIG1/15.D0
     $-4*G(6)**2*G(27)**2*(2*G(12)*G(29)+XT+XN)
      G242LP=(-4*G(1)**2*G(5)**2*(-XB-2*G(7)**2+2*G(7)*G(11)))/5.D0- 
     $2*G(4)**2*G(5)**2*(XB+XTAU+2*G(10)*G(11))-20*G(5)**4*
     $(XB+G(11)**2)-(8*G(1)**2*G(6)**2*(-XT-2*G(7)**2+
     $2*G(7)*G(12)))/5.D0-20*G(6)**4*(XT+G(12)**2)
     $+.4*G(1)**2*SPMV-128.*G(3)**4*G(9)**2/3.D0+
     $32*G(3)**2*G(2)**2*(G(9)**2+G(8)**2+G(9)*G(8))+
     $32*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(9)*G(7))/45.D0+
     $33*G(2)**4*G(8)**2+
     $.4*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(8)*G(7))+
     $199*G(1)**4*G(7)**2/75.D0+16*G(3)**2*SIG3/3.D0+
     $3*G(2)**2*SIG2+G(1)**2*SIG1/15.D0
     $-2*G(6)**2*G(27)**2*(2*G(12)*G(29)+XT+XN)
C     ADD IN MU 2-LOOP TERM SOMETIME...
      G252LP=0.
      G282LP=-16*G(27)**4*(G(29)**2+XN)-12*G(6)**2*G(27)**2*
     $(2*G(12)*G(29)+XT+XN)-4*G(4)**2*G(27)**2*(2*G(29)*G(10)+
     $XN+XTAU)+G(27)**2*G(29)*(-24*G(7)*G(1)**2/5.D0-24*G(2)**2*G(8))
     $+G(27)**2*(2.4*G(1)**2*(2*G(7)**2+XN)+12*G(2)**2*
     $(2*G(8)**2+XN))
      G292LP=-32*G(3)**2*G(6)**2*G(9)+(12*G(1)**2*G(4)**2*G(10))/5.D0
     $-12*G(4)**4*G(10)-6*G(4)**2*G(5)**2*G(10)- 
     $6*G(4)**2*G(5)**2*G(11)-6*G(5)**2*G(6)**2*G(11)+ 
     $(8*G(1)**2*G(6)**2*G(12))/5.D0+32*G(3)**2*G(6)**2*G(12)- 
     $6*G(5)**2*G(6)**2*G(12)-36*G(6)**4*G(12)+ 
     $(-6*G(4)**2*G(10)-18*G(6)**2*G(12))*G(27)**2+
     $((12*G(1)**2)/5.D0+12*G(2)**2-6*G(4)**2-
     $18*G(6)**2)*G(29)*G(27)**2-40*G(29)*G(27)**4+ 
     $G(7)*((-414*G(1)**4)/25.D0-(18*G(1)**2*G(2)**2)/5.D0- 
     $(12*G(1)**2*G(4)**2)/5.D0-(8*G(1)**2*G(6)**2)/5.D0- 
     $(12*G(1)**2*G(27)**2)/5.D0)+G(8)*((-18*G(1)**2*G(2)**2)/5.D0- 
     $30*G(2)**4-12*G(2)**2*G(27)**2)
C
      F(10)=FAC*(9*G(1)**2*G(7)/5.D0+3*G(2)**2*G(8)+3*G(5)**2*G(11)+
     $4*G(4)**2*G(10)+G(27)**2*G(29))+FAC2LP*TH2LP*G102LP
      F(11)=FAC*(7*G(1)**2*G(7)/15.D0+3*G(2)**2*G(8)+16*G(3)**2*
     $G(9)/3.D0+6*G(5)**2*G(11)+G(6)**2*G(12)+G(4)**2*G(10))
     $+FAC2LP*TH2LP*G112LP
      F(12)=FAC*(13*G(1)**2*G(7)/15.D0+3*G(2)**2*G(8)+16*G(3)**2*
     $G(9)/3.D0+G(5)**2*G(11)+6*G(6)**2*G(12)+G(27)**2*G(29))
     $+FAC2LP*TH2LP*G122LP
      F(13)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2+
     $3*G(5)**2*XB+G(4)**2*XTAU-.3*G(1)**2*SMV)+FAC2LP*TH2LP*G132LP
      F(14)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2+3*G(6)**2*XT
     $+G(27)**2*XN+.3*G(1)**2*SMV)+FAC2LP*TH2LP*G142LP
      F(15)=FAC*(-2.4*G(1)**2*G(7)**2+.6*G(1)**2*SMV)
     $+FAC2LP*TH2LP*G152LP
      F(16)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2-.3*G(1)**2*SMV)
     $+FAC2LP*TH2LP*G162LP
      F(17)=FAC*(-4*G(1)**2*G(7)**2/15.D0-16*G(3)**2*G(9)**2/3.D0+
     $.2*G(1)**2*SMV)+FAC2LP*TH2LP*G172LP
      F(18)=FAC*(-16*G(1)**2*G(7)**2/15.D0-16*G(3)**2*G(9)**2/3.D0-
     $.4*G(1)**2*SMV)+FAC2LP*TH2LP*G182LP
      F(19)=FAC*(-G(1)**2*G(7)**2/15.D0-3*G(2)**2*G(8)**2-
     $16*G(3)**2*G(9)**2/3.D0+.1*G(1)**2*SMV)+FAC2LP*TH2LP*G192LP
      F(20)=FAC*(-2.4*G(1)**2*G(7)**2+2*G(4)**2*XTAU+.6*G(1)**2*SMV)+
     $FAC2LP*TH2LP*G202LP
      F(21)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2+G(4)**2*XTAU
     $+G(27)**2*XN-.3*G(1)**2*SMV)+FAC2LP*TH2LP*G212LP
      F(22)=FAC*(-4*G(1)**2*G(7)**2/15.D0-16*G(3)**2*G(9)**2/3.D0+
     $2*G(5)**2*XB+.2*G(1)**2*SMV)+FAC2LP*TH2LP*G222LP
      F(23)=FAC*(-16*G(1)**2*G(7)**2/15.D0-16*G(3)**2*G(9)**2/3.D0+
     $2*G(6)**2*XT-.4*G(1)**2*SMV)+FAC2LP*TH2LP*G232LP
      F(24)=FAC*(-G(1)**2*G(7)**2/15.D0-3*G(2)**2*G(8)**2-
     $16*G(3)**2*G(9)**2/3.D0+G(6)**2*XT+G(5)**2*XB+.1*G(1)**2*SMV)
     $+FAC2LP*TH2LP*G242LP
      F(25)=FAC*G(25)/2.D0*(-.6*G(1)**2-3*G(2)**2+3*G(6)**2+
     $       3*G(5)**2+G(4)**2+G(27)**2)+FAC2LP*TH2LP*G252LP
      F(26)=FAC*(-.6*G(1)**2*G(7)-3*G(2)**2*G(8)+3*G(6)**2*G(12)+
     $       3*G(5)**2*G(11)+G(4)**2*G(10))
      IF (Q.GT.AMNRMJ) THEN
      F(27)=G(27)/16.D0/PI**2*(3*G(6)**2+G(4)**2+4*G(27)**2-
     $       3*G(2)**2-3*G(1)**2/5.D0+TH2LP/16.D0/PI**2*(-10*G(27)**4
     $       +G(27)**2*(1.2*G(1)**2+3*(2*G(2)**2-3*G(6)**2-
     $       G(4)**2))+207*G(1)**4/50.D0+.2*G(1)**2*(9*G(2)**2+
     $       4*G(6)**2+6*G(4)**2)+.5*(15*G(2)**4-18*G(6)**4-
     $       6*G(4)**4+32*G(3)**2*G(6)**2-6*G(5)**2*G(6)**2-
     $       6*G(5)**2*G(4)**2)))
      F(28)=FAC*2*G(27)**2*XN+FAC2LP*TH2LP*G282LP
      F(29)=FAC*(3*G(1)**2*G(7)/5.D0+3*G(2)**2*G(8)+3*G(6)**2*G(12)+
     $4*G(27)**2*G(29)+G(4)**2*G(10))+FAC2LP*TH2LP*G292LP
      ELSE
      F(27)=0.
      F(28)=0.
      F(29)=0.
      END IF
      F(30)=G(30)*(.75*(G(1)**2/5.D0+G(2)**2)-3*G(5)**2-G(4)**2)/
     $16.D0/PI**2
      F(31)=G(31)*(.75*(G(1)**2/5.D0+G(2)**2)-3*G(6)**2)/16.D0/PI**2
      RETURN
      END
+EOD
+DECK,TQL2,IF=NOCERN
      SUBROUTINE TQL2(NM,N,D,E,Z,IERR)
C     FROM CERN PROGRAM LIBRARY
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER I,J,K,L,M,N,II,NM,MML,IERR
      REAL D(N),E(N),Z(NM,N)
      REAL B,C,F,G,H,P,R,S,MACHEP
      MACHEP=2.**(-23)
+SELF,IF=CDC.
      MACHEP=2.**(-47)
+SELF.
      IERR = 0
      IF (N .EQ. 1) GO TO 1001
      DO 100 I = 2, N
  100 E(I-1) = E(I)
      F = 0.0
      B = 0.0
      E(N) = 0.0
      DO 240 L = 1, N
         J = 0
         H = MACHEP * (ABS(D(L)) + ABS(E(L)))
         IF (B .LT. H) B = H
         DO 110 M = L, N
            IF (ABS(E(M)) .LE. B) GO TO 120
  110    CONTINUE
  120    IF (M .EQ. L) GO TO 220
  130    IF (J .EQ. 30) GO TO 1000
         J = J + 1
         P = (D(L+1) - D(L)) / (2.0 * E(L))
         R = SQRT(P*P+1.0)
         H = D(L) - E(L) / (P + SIGN(R,P))
         DO 140 I = L, N
  140    D(I) = D(I) - H
         F = F + H
         P = D(M)
         C = 1.0
         S = 0.0
         MML = M - L
         DO 200 II = 1, MML
            I = M - II
            G = C * E(I)
            H = C * P
            IF (ABS(P) .LT. ABS(E(I))) GO TO 150
            C = E(I) / P
            R = SQRT(C*C+1.0)
            E(I+1) = S * P * R
            S = C / R
            C = 1.0 / R
            GO TO 160
  150       C = P / E(I)
            R = SQRT(C*C+1.0)
            E(I+1) = S * E(I) * R
            S = 1.0 / R
            C = C * S
  160       P = C * D(I) - S * G
            D(I+1) = H + S * (C * G + S * D(I))
            DO 180 K = 1, N
               H = Z(K,I+1)
               Z(K,I+1) = S * Z(K,I) + C * H
               Z(K,I) = C * Z(K,I) - S * H
  180       CONTINUE
  200    CONTINUE
         E(L) = S * P
         D(L) = C * P
         IF (ABS(E(L)) .GT. B) GO TO 130
  220    D(L) = D(L) + F
  240 CONTINUE
      DO 300 II = 2, N
         I = II - 1
         K = I
         P = D(I)
         DO 260 J = II, N
            IF (D(J) .GE. P) GO TO 260
            K = J
            P = D(J)
  260    CONTINUE
         IF (K .EQ. I) GO TO 300
         D(K) = D(I)
         D(I) = P
         DO 280 J = 1, N
            P = Z(J,I)
            Z(J,I) = Z(J,K)
            Z(J,K) = P
  280    CONTINUE
  300 CONTINUE
      GO TO 1001
 1000 IERR = L
 1001 RETURN
      END
+EOD
+DECK,TRED2,IF=NOCERN
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
C     FROM CERN PROGRAM LIBRARY
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER I,J,K,L,N,II,NM,JP1
      REAL A(NM,N),D(N),E(N),Z(NM,N)
      REAL F,G,H,HH,SCALE
      DO 100 I = 1, N
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
      IF (N .EQ. 1) GO TO 320
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0
         SCALE = 0.0
         IF (L .LT. 2) GO TO 130
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(Z(I,K))
         IF (SCALE .NE. 0.0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
         F = Z(I,L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / (SCALE * H)
            G = 0.0
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
         HH = F / (H + H)
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
         DO 280 K = 1, L
  280    Z(I,K) = SCALE * Z(I,K)
  290    D(I) = H
  300 CONTINUE
  320 D(1) = 0.0
      E(1) = 0.0
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0) GO TO 380
         DO 360 J = 1, L
            G = 0.0
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0
         IF (L .LT. 1) GO TO 500
         DO 400 J = 1, L
            Z(I,J) = 0.0
            Z(J,I) = 0.0
  400    CONTINUE
  500 CONTINUE
      RETURN
      END
+EOD
+DECK,TRIINT,IF=NOCERN
      FUNCTION  TRIINT(F,NSD,NPT,EPS,X1,Y1,X2,Y2,X3,Y3)
C
C     INTEGRATION OVER A TRIANGLE USING A 7-, 25- OR 64-POINT FORMULA,
C     WITH OR WITHOUT SUBDIVISION OF THE TRIANGLE.
C
C     From triint.F of Cernlib/Mathlib D105
C
      CHARACTER NAME*(*)
      CHARACTER*80 ERRTXT
      PARAMETER (NAME = 'TRIINT')

      PARAMETER (Z1 = 1, HALF = Z1/2, KMX = 35)

      DIMENSION R(KMX),XP1(KMX),XP2(KMX),XP3(KMX),YP1(KMX),YP2(KMX)
      DIMENSION YP3(KMX)
      DIMENSION U(8,3),V(32,3),W(32,3),UU(5,2),WW(5,2)
      DIMENSION G1(32),G2(32)
      DIMENSION JZ(3),JZ0(3),JZ1(3),IZ(3,3)

      DATA JZ /2,5,8/, JZ0 /2,10,32/, JZ1 /3,5,0/
      DATA ((IZ(I,M),I=1,3),M=1,3) /1,0,1, 5,5,1, 8,24,8/

      DATA (U(J,1),J=1,2)
     1/0.89871 34926 76543 661D0, 0.52985 79358 94884 910D0/

      DATA (UU(J,1),J=1,3)
     1/0.20257 30146 46912 678D0, 0.94028 41282 10230 180D0,
     2 0.66666 66666 66666 667D0/

      DATA (V(J,1),J=1,2)
     1/0.69614 04780 29630 984D0,-0.41042 61923 15345 269D0/

      DATA (W(J,1),J=1,2)
     1/0.12593 91805 44827 153D0, 0.13239 41527 88506 181D0/

      DATA (WW(J,1),J=1,3)
     1/0.12593 91805 44827 153D0, 0.13239 41527 88506 181D0,
     2 0.22500 00000 00000 000D0/

      DATA (U(J,2),J=1,5)
     1/0.09853 50857 98826 426D0, 0.30453 57266 46363 905D0,
     2 0.56202 51897 52613 856D0, 0.80198 65821 26391 827D0,
     3 0.96019 01429 48531 258D0/

      DATA (UU(J,2),J=1,5)
     1/0.09853 50857 98826 426D0, 0.30453 57266 46363 905D0,
     2 0.56202 51897 52613 856D0, 0.80198 65821 26391 827D0,
     3 0.96019 01429 48531 258D0/

      DATA (V(J,2),J=1,10)
     1/0.08929 05088 68733 569D0, 0.27596 41378 55221 135D0,
     2 0.50929 58998 63672 021D0, 0.72674 40774 36169 444D0,
     3 0.87010 49558 08923 811D0, 0.05305 81196 71298 357D0,
     4 0.16398 31426 29800 463D0, 0.30263 33161 88105 613D0,
     5 0.43184 51615 91612 961D0, 0.51703 29238 43772 854D0/

      DATA (W(J,2),J=1,10)
     1/0.00373 11043 33755 67687D0, 0.01751 09983 64327 66347D0,
     2 0.03468 30128 62731 40026D0, 0.03960 81662 64094 70756D0,
     3 0.02293 01607 03185 09559D0, 0.00753 74033 90655 24076D0,
     4 0.03537 49042 20966 93175D0, 0.07006 50090 06743 44063D0,
     5 0.08001 45747 72320 84819D0, 0.04632 24438 58996 77269D0/

      DATA (WW(J,2),J=1,5)
     1/0.00895 88135 94562 71712D0, 0.04204 59349 74644 15024D0,
     2 0.08327 79304 30389 93562D0, 0.09510 37941 15908 01948D0,
     3 0.05505 79713 28939 62198D0/

      DATA (U(J,3),J=1,8)
     1/0.04463 39552 89969 851D0, 0.14436 62570 42145 571D0,
     2 0.28682 47571 44430 519D0, 0.45481 33151 96573 351D0,
     3 0.62806 78354 16727 698D0, 0.78569 15206 04369 242D0,
     4 0.90867 63921 00206 044D0, 0.98222 00848 52636 548D0/

      DATA (V(J,3),J=1,32)
     1/0.04286 15345 20322 596D0, 0.13863 34522 58088 400D0,
     2 0.27543 49048 78165 863D0, 0.43675 26131 83286 138D0,
     3 0.60312 71715 43047 645D0, 0.75449 15975 72500 770D0,
     4 0.87259 27221 72605 828D0, 0.94321 59843 32136 212D0,
     5 0.03555 83759 33897 592D0, 0.11501 17574 55156 297D0,
     6 0.22850 36689 09272 431D0, 0.36233 45216 98467 603D0,
     7 0.50036 05900 18245 933D0, 0.62593 40960 53638 777D0,
     8 0.72391 20204 03394 633D0, 0.78250 18150 44463 514D0,
     9 0.02345 65900 87635 536D0, 0.07586 91469 73958 963D0,
     A 0.15073 57058 45778 370D0, 0.23901 91375 97290 126D0,
     B 0.33007 00031 37485 188D0, 0.41290 63582 74039 218D0,
     C 0.47753 88941 74496 369D0, 0.51618 84882 60827 229D0,
     D 0.00818 74136 31782 437D0, 0.02648 17727 48961 059D0,
     E 0.05261 35967 85690 189D0, 0.08342 85178 75344 723D0,
     F 0.11520 93988 52684 066D0, 0.14412 30431 93925 944D0,
     G 0.16668 27291 29138 200D0, 0.18017 31901 16990 201D0/

      DATA (W(J,3),J=1,32)
     1/0.00033 35674 06495 41982D0, 0.00180 62109 19037 15084D0,
     2 0.00459 97558 03491 41419D0, 0.00801 72595 31391 49525D0,
     3 0.01073 50189 73158 61631D0, 0.01138 87974 04616 51588D0,
     4 0.00922 38453 90918 29977D0, 0.00450 98127 16079 21752D0,
     5 0.00073 27880 81649 19485D0, 0.00396 79231 50289 07586D0,
     6 0.01010 48428 76312 33624D0, 0.01761 24888 63394 88637D0,
     7 0.02358 29214 92410 93797D0, 0.02501 91560 68339 84265D0,
     8 0.02026 31427 34638 24614D0, 0.00990 72539 59652 71520D0,
     9 0.00103 37234 54873 38862D0, 0.00559 74371 44935 08001D0,
     A 0.01425 46165 12792 75399D0, 0.02484 54407 11607 46855D0,
     B 0.03326 77614 32852 32482D0, 0.03529 38169 93822 26192D0,
     C 0.02858 46432 80634 70277D0, 0.01397 58834 07425 66299D0,
     D 0.00119 51124 99230 79556D0, 0.00647 13314 41724 90169D0,
     E 0.01648 01043 12102 39366D0, 0.02872 44103 85925 30995D0,
     F 0.03846 16575 37508 13161D0, 0.04080 40290 04108 74571D0,
     G 0.03304 73922 30182 37768D0, 0.01615 78542 78398 33562D0/

      IF(NPT .EQ. 7) THEN
       M=1
      ELSE IF(NPT .EQ. 25) THEN
       M=2
      ELSE IF(NPT .EQ. 64) THEN
       M=3
      ELSE
       H=0
C      WRITE(ERRTXT,101) NPT
C      CALL MTLPRT(NAME,'D105.1',ERRTXT)
       PRINT*, 'TRIINT: WRONG NUMBER OF POINTS = ',NPT
       GO TO 99
      END IF
      K=0
      C1=X1
      D1=Y1
      C2=X2
      D2=Y2
      C3=X3
      D3=Y3
      A11=HALF*(C2+C3)-C1
      A12=HALF*(C3-C2)
      A21=HALF*(D2+D3)-D1
      A22=HALF*(D3-D2)
      DO 1 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 1 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    1 G2(J+I)=G2(J)
      S=0
      DO 2 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    2 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 3 J = 1,JZ1(M)
    3 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-D3)+C2*(D3-D1)+C3*(D1-D2))*S
      H=S
      IF(NSD .EQ. 0) GO TO 99
      H=0

   10 K=K+1
      SUM0=S
      U1=C1
      V1=D1
      U2=C2
      V2=D2
      U3=C3
      V3=D3
   11 C1=HALF*(U2+U3)
      D1=HALF*(V2+V3)
      C2=U1
      D2=V1
      C3=U2
      D3=V2
      XP1(K)=C1
      YP1(K)=D1
      XP2(K)=C2
      YP2(K)=D2
      XP3(K)=U3
      YP3(K)=V3
      A11=HALF*(C2+U3)-C1
      A12=HALF*(U3-C2)
      A21=HALF*(D2+V3)-D1
      A22=HALF*(V3-D2)
      DO 4 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 4 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    4 G2(J+I)=G2(J)
      S=0
      DO 5 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    5 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 6 J = 1,JZ1(M)
    6 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-V3)+C2*(V3-D1)+U3*(D1-D2))*S
      R(K)=S
      A11=HALF*(C2+C3)-C1
      A12=HALF*(C3-C2)
      A21=HALF*(D2+D3)-D1
      A22=HALF*(D3-D2)
      DO 7 J = 1,JZ(M)
      G1(J)=A11*U(J,M)+C1
      G2(J)=A21*U(J,M)+D1
      DO 7 I = IZ(1,M),IZ(2,M),IZ(3,M)
      G1(J+I)=G1(J)
    7 G2(J+I)=G2(J)
      S=0
      DO 8 J = 1,JZ0(M)
      H1=A12*V(J,M)
      H2=A22*V(J,M)
    8 S=S+W(J,M)*(F(G1(J)+H1,G2(J)+H2)+F(G1(J)-H1,G2(J)-H2))
      DO 9 J = 1,JZ1(M)
    9 S=S+WW(J,M)*F(A11*UU(J,M)+C1,A21*UU(J,M)+D1)
      S=HALF*ABS(C1*(D2-D3)+C2*(D3-D1)+C3*(D1-D2))*S
      SUM=S+R(K)
      IF(ABS(SUM0-SUM) .GT. EPS*(1+ABS(SUM))) THEN
       IF(K .LT. KMX) GO TO 10
       H=0
C      CALL MTLPRT(NAME,'D105.2','TOO HIGH ACCURACY REQUIRED')
       PRINT*,'TRIINT: TOO HIGH ACCURACY REQUIRED'
       GO TO 99
      ELSE
       H=H+SUM
       K=K-1
       IF(K .LE. 0)  GO TO 99
       U1=XP1(K)
       V1=YP1(K)
       U2=XP2(K)
       V2=YP2(K)
       U3=XP3(K)
       V3=YP3(K)
       SUM0=R(K)
       GO TO 11
      END IF

   99 TRIINT=H
      RETURN
  101 FORMAT('INCORRECT NUMBER OF POINTS =',I5)
      END
+EOD
+PATCH,ISATOOLS.
+EOD
+DECK,ISAAMU,IF=ISATOOLS
C---------------------------------------------------------------------
       SUBROUTINE ISAAMU (
     ,        SRV2V1 ,SALEMI ,SGAMMAL,SGAMMAR,STWOM1 ,SAAL   ,SAMMLSS,
     ,        SAMMRSS,SAMZ1SS,SAMZ2SS,SAMZ3SS,SAMZ4SS,SAMW1SS,SAMW2SS,
     ,        SAMN2SS,SZMIXSS,iprt,DAMU
     ,                        )
C---------------------------------------------------------------------
      IMPLICIT NONE
      
      REAL*8 DAMU
      
      Real    SRV2V1 ,SALEMI ,SGAMMAL,SGAMMAR,STWOM1,SAAL,      SAMMLSS,
     ,        SAMMRSS,SAMZ1SS,SAMZ2SS,SAMZ3SS,SAMZ4SS,SAMW1SS  ,SAMW2SS,
     ,	      SAMN2SS,SZMIXSS(4,4)
C      SUSY parameters
C      SRV2V1		    = ratio v2/v1 of vev's
c      SALEMI		    = 1/alfa_em
C      SGAMMAL,SGAMMAR      = Wi left, right mixing angles
C      STWOM1		    = Higgsino mass = - mu
C      SAAL		    = stau trilinear term
C      SAMZiSS  	    = signed mass of Zi
C      SAMWiSS  	    = signed Wi mass
C      SAMNiSS  	    = sneutrino mass for generation i
C      SZMIXSS  	    = Zi mixing matrix
c      
      Real*8  RV2V1,ALEMI,GAMMAL,GAMMAR,TWOM1,AAL,AMMLSS,AMMRSS,
     ,        AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,AMW1SS,AMW2SS,AMN2SS,
     ,        ZMIXSS(4,4),ANWI,AMUZI
     
      COMPLEX*16 N1L(4),N1R(4),N2L(4),N2R(4)
 
      REAL*8 AMZISS(4),TH(4),XM1(4),XM2(4),AM1Z(4),AM2Z(4)
 
      COMPLEX*16 ZI
      REAL*8 AMW,AMZ,SN2THW,AMMU
      DATA ZI/(0.d0,1.d0)/,AMW/80.41d0/,AMZ/91.19d0/,SN2THW/.232d0/,
     ,     AMMU/.10566d0/
           
      REAL*8 ALFAEM,PI,SR2,BE,G,GP,FMU,SINB,COSB,TANB,COS2B,XM,YM,THX,
     ,       THY,AMM1SS,AMM2SS,TANTHM,THETAM,COSM,SINM,CW1L,CW2L,CW1R,
     ,       CW2R,AM1ZI,AM2ZI, XN1,XN2,TW1,TW2,ANW1,ANW2
      
      INTEGER I,J,iprt
      real*8 SM11,SM12,SM21,SM22,PNOM1,PNOM2
      
      real*8 amml,ammr,nom1,nom2,den,
     &       MSTAUL2,MSTAUR2,SQRTSTAU,MSTAU12,MSTAU22
      
CsB >
      Real*8 eps 
      eps=0.005
CsB <
     
      RV2V1=SRV2V1
      ALEMI=SALEMI
      GAMMAL=SGAMMAL
      GAMMAR=SGAMMAR
      TWOM1=STWOM1
      AAL=SAAL
      AMMLSS=SAMMLSS
      AMMRSS=SAMMRSS
      
      AMZ1SS=SAMZ1SS
      AMZ2SS=SAMZ2SS
      AMZ3SS=SAMZ3SS
      AMZ4SS=SAMZ4SS
      AMW1SS=SAMW1SS
      AMW2SS=SAMW2SS
      AMN2SS=SAMN2SS
      
      AMW=AMZ*DSQRT(1.D0-SN2THW)
      
      DO I=1,4
        DO J=1,4
          ZMIXSS(I,J)=SZMIXSS(I,J)
	ENDDO
      ENDDO
      
c----------------------------------------
      
      ALFAEM=1.d0/ALEMI
      PI=4.d0*DATAN(1.d0)
      SR2=DSQRT(2.d0)
      BE=DATAN(1.d0/RV2V1)
      G=SQRT(4*PI*ALFAEM/SN2THW)
      GP=G*DSQRT(SN2THW/(1.d0-SN2THW))
      FMU=G*AMMU/SR2/AMW/DCOS(BE)
      SINB=DSIN(BE)
      COSB=DCOS(BE)
      TANB=SINB/COSB
      COS2B=DCOS(2.d0*BE)
      XM=1.d0/TAN(GAMMAL)
      YM=1.d0/TAN(GAMMAR)
      THX=DSIGN(1.d0,XM)
      THY=DSIGN(1.d0,YM)
      AMZISS(1)=AMZ1SS
      AMZISS(2)=AMZ2SS
      AMZISS(3)=AMZ3SS
      AMZISS(4)=AMZ4SS
     
    
c----- MSTAUL2,MSTAUR2 are 1loop corrected values of soft-masses squared
c----- we just resonstruct them back to use in Moroi formulae
 
      MSTAUL2=AMMLSS**2-AMMU**2-AMZ**2*COS2B*(-.5+SN2THW)
      MSTAUR2=AMMRSS**2-AMMU**2-AMZ**2*COS2B*(-SN2THW)
c------------      

      SQRTSTAU=sqrt( 
     &((MSTAUL2-MSTAUR2)/2d0-COS2B*(4d0*AMW**2-3d0*AMZ**2)/4d0)**2
     &+AMMU**2*(-AAL-TWOM1*SINB/COSB)**2
     &)
      
      MSTAU12=(MSTAUL2+MSTAUR2)/2d0-AMZ**2*COS2B/4d0+AMMU**2-SQRTSTAU
      MSTAU22=(MSTAUL2+MSTAUR2)/2d0-AMZ**2*COS2B/4d0+AMMU**2+SQRTSTAU
      
      AMM1SS=sqrt(min(MSTAU12,MSTAU22))
      AMM2SS=sqrt(max(MSTAU12,MSTAU22))
      
      nom1=(AMM1SS**2-AMMU**2+AMZ**2*COS2B*(.5-SN2THW)-MSTAUL2)
     
      den=AMMU*(TWOM1*SINB/COSB+AAL)
      
      TANTHM =NOM1/den
       
      THETAM=DATAN(TANTHM)

      COSM=   DCOS(THETAM)
      SINM=   DSIN(THETAM)
          
      if(IPRT.ge.4) then
        print *,'AMML=',AMMLSS,' AMM1=',AMM1SS
        print *,'AMMR=',AMMRSS,' AMM2=',AMM2SS
        print *,'tan=', TANTHM,THETAM
        print *,'COSM=',COSM, ',' , 'SINM=',SINM
      ENDIF
      
      CW1L=-FMU*COS(GAMMAL)
      CW2L=FMU*THX*SIN(GAMMAL)
      CW1R=-SIGN(1d0,AMW1SS)*G*SIN(GAMMAR)
      CW2R=-SIGN(1d0,AMW2SS)*G*THY*COS(GAMMAR)
      
      DO I=1,4
      
        IF (AMZISS(I).GT.0.) THEN
         TH(I)=0.d0
        ELSE
         TH(I)=1.d0
        END IF

      N1L(I)=(-ZI)**TH(I)*
     ,(-FMU*ZMIXSS(2,I)*COSM+SR2*GP*ZMIXSS(4,I)*SINM)
    
      N1R(I)=ZI**TH(I)*((G/SR2*ZMIXSS(3,I)+GP/SR2*ZMIXSS(4,I))*COSM
     ,+FMU*ZMIXSS(2,I)*SINM)
    
      N2L(I)=-(-ZI)**TH(I)*
     ,(FMU*ZMIXSS(2,I)*SINM+SR2*GP*ZMIXSS(4,I)*COSM)
    
      N2R(I)=ZI**TH(I)*((G/SR2*ZMIXSS(3,I)+GP/SR2*ZMIXSS(4,I))*SINM
     ,-FMU*ZMIXSS(2,I)*COSM)

      
      XM1(I)=(AMZISS(I)/AMM1SS)**2
      XM2(I)=(AMZISS(I)/AMM2SS)**2

      IF (Abs(XM1(I)-1.d0).LT.eps)
     &  XM1(I)=1.d0+Sign(1.d0,XM2(I)-1.d0)*eps
      IF (Abs(XM2(I)-1.d0).LT.eps)
     &	XM2(I)=1.d0+Sign(1.d0,XM2(I)-1.d0)*eps


      if(iprt.ge.4) THEN
        print *,'==========================='
        print *,'I=',I
        print '(3A15)'	  ,'ZMIXSS(2,I)','ZMIXSS(3,I)','ZMIXSS(4,I)'
        print '(3D15.4)'    , ZMIXSS(2,I),  ZMIXSS(3,I),  ZMIXSS(4,I)
        print *,'--'
        print '(2A20)',     'N1L(I)','N1R(I)'
        print * ,    N1L(I) , N1R(I) 
        print * ,'--'
        print '(2A20)',     'N2L(I)','N2R(I)'
        print * ,    N2L(I) , N2R(I)
        print * ,'==========================='
      endif 
      END DO     
      
C======NEUTRALINO LOOPS================================================
      AM1ZI=0.d0
      AM2ZI=0.d0
      
  
      DO I=1,4
        AM1Z(I)=
     &-AMMU/(6.d0*AMM1SS**2*(1.d0-XM1(I))**4)
     & *(N1L(I)*DCONJG(N1L(I))+N1R(I)*DCONJG(N1R(I)))
     & *(1.d0-6*XM1(I)+
     &   3.d0*XM1(I)**2+2.d0*XM1(I)**3-6.d0*XM1(I)**2*LOG(XM1(I)))
     &-ABS(AMZISS(I))/(AMM1SS**2*(1.d0-XM1(I))**3)
     & *N1L(I)*DCONJG(N1R(I))*(1.d0-XM1(I)**2+2.d0*XM1(I)*LOG(XM1(I)))

        AM1ZI=AM1ZI+AM1Z(I)

        AM2Z(I)=
     &-AMMU/(6.d0*AMM2SS**2*(1.d0-XM2(I))**4)
     & *(N2L(I)*DCONJG(N2L(I))+N2R(I)*DCONJG(N2R(I)))
     & *(1.d0-6.d0*XM2(I)+
     &   3.d0*XM2(I)**2+2.d0*XM2(I)**3-6.d0*XM2(I)**2*LOG(XM2(I)))
     &-ABS(AMZISS(I))/(AMM2SS**2*(1.d0-XM2(I))**3)
     & *N2L(I)*DCONJG(N2R(I))*(1.d0-XM2(I)**2+2.d0*XM2(I)*LOG(XM2(I)))

        AM2ZI=AM2ZI+AM2Z(I)
      
      if(iprt.ge.4) THEN
        print *,'I, AM1Z(I), AM2Z(I):', I, AM1Z(I), AM2Z(I)
      endif 
      
c      print *,I, AMM1SS, AMM2SS, AMZISS(I), XM1(I),XM2(I)
c      print *,I, N1L(I)*DCONJG(N1L(I)), N1R(I)*DCONJG(N1R(I))
c      print *,I, N1L(I)*DCONJG(N1R(I))
c      print *,I, N2L(I)*DCONJG(N2L(I)), N2R(I)*DCONJG(N2R(I))
c      print *,I, N2L(I)*DCONJG(N2R(I)) 

      END DO

      AMUZI=(AM1ZI+AM2ZI)/16.d0/PI**2*AMMU
      
      if(iprt.ge.4) THEN
        print *,'AM1ZI, AM2ZI,AMUZI :',
     &          (AM1ZI)/16.d0/PI**2*AMMU,
     &          (AM2ZI)/16.d0/PI**2*AMMU,
     &          (AM1ZI+AM2ZI)/16.d0/PI**2*AMMU
      endif 
 
c=======CHARGINO LOOPS=================================================
     
      XN1=(AMW1SS/AMN2SS)**2
      XN2=(AMW2SS/AMN2SS)**2

      IF (Abs(XN1-1.d0).LT.eps) XN1=1.d0+Sign(1.d0,XN1-1.d0)*eps
      IF (Abs(XN2-1.d0).LT.eps) XN2=1.d0+Sign(1.d0,XN2-1.d0)*eps

    
      TW1=AMMU/(3.d0*AMN2SS**2*(1.d0-XN1)**4)*(CW1L*CW1L+CW1R*CW1R)*
     ,(1.d0+1.5d0*XN1-3.d0*XN1**2+.5d0*XN1**3+3.d0*XN1*DLOG(XN1))
     
      TW2=-(3.d0*ABS(AMW1SS))/(AMN2SS**2*(1.d0-XN1)**3)*CW1L*CW1R*
     ,(1.d0-4.d0*XN1/3.d0+XN1**2/3.d0+2.d0*DLOG(XN1)/3.d0)
     
      ANW1=TW1+TW2
      
      TW1=AMMU/(3.d0*AMN2SS**2*(1.d0-XN2)**4)*(CW2L*CW2L+CW2R*CW2R)*
     ,(1.d0+1.5d0*XN2-3.d0*XN2**2+.5d0*XN2**3+3.d0*XN2*DLOG(XN2))

      TW2=-(3.d0*ABS(AMW2SS))/(AMN2SS**2*(1.d0-XN2)**3)*CW2L*CW2R*
     ,(1.d0-4.d0*XN2/3.d0+XN2**2/3.d0+2.d0*DLOG(XN2)/3.d0)
      ANW2=TW1+TW2

      if(iprt.ge.4) THEN
        print *,'ANW1  ,ANW2  ,ANW  :', 
     &           ANW1/16.d0/PI**2*AMMU,ANW2/16.d0/PI**2*AMMU,
     &           ANW1/16.d0/PI**2*AMMU+ANW2/16.d0/PI**2*AMMU
      endif
      
      ANWI=(ANW1+ANW2)/16.d0/PI**2*AMMU
      DAMU=ANWI+AMUZI

      if(iprt.ge.4) THEN
      print*, 'AMU=',ANWI+AMUZI
      print *,'==========================================='
      print *,'==========================================='
      endif
      
      Return
      End
+EOD
+DECK,ISABMM,IF=ISATOOLS
C  04/27/02
C
C  BR(B_s -> mu+ m-)  and BR(B_d -> tau+ tau-)
C
C  Formula (4), (18) and  CORRECT (19)  from Borzumati, Huang, Kolda 
C  and Logan (BHKL)
C    
C  Eq. (19) has a wrong sign
C
C  Warning!   ISAJET notation: sin(alpha) -> - sin(alpha)
C                              cos(alpha) ->   cos(alpha)
C
C  b-mass correction from Pierce at al., Nucl. Phys. B491, 3 (1997)
C  programmed in the ISAJET gives (in leading tan\beta)
C
C  del_mb/mb = epsg tanb + epsu y_t^2 tanb + aw tanb (c_t^2 C_0(...) +
C  s_t^2 C_0(...))
C
C  ag * C_0(...)   = epsg,   ag = -2 alphas/(3pi) \mu mg 
C  au * C_0(...)   = epsu,   au = -g^2/(16 pi^2) \mu A_t
C                            aw = g^2/(16 pi^2) \mu M_2
C
C Matching with ISAJET notation
C
C      mhl = mss(29)
C      mhh = mss(30)
C      mha = mss(31)
C      mg = mss(1)
C      mb1 = mss(10)
C      mb2 = mss(11)
C      mt1 = mss(12)
C      mt2 = mss(13)
C      msl = mss(6)
C      mcl = mss(8) 
C      mer = mss(18)
C      mtau1 = mss(21)
C      mz1 = mss(23)
C      mw1 = mss(27)
C      m2 = gss(8)
C      aab = gss(11)
C      aat = gss(12)
C      mu = mu  WARNING: gss(25) does not give the same value as mu
C      alphah = alfah
C
C-------------------------------------------------------------------------
      SUBROUTINE ISABMM(MT,TANB,MHL,MHH,MHA,MG,MB1,MB2,AAB,
     &THETAB,MT1,MT2,AAT,THETAT,MU,M2,ALPHAH,MSL,MCL,BRBS,BRBD)
      IMPLICIT NONE
      REAL MBS, TAUBS, FBS, VTB, VTS, CQ1MU, CQ2MU, GF
      REAL MBD, TAUBD, FBD, VTD, CQ1TAU, CQ2TAU
      REAL PI
      PARAMETER(PI=3.1415926)
      REAL MZ, MW, G, G2, SW, CW, SW2, VEV, MB, MBMB, MTMT, MMU
      REAL MTAU, ALPHA, E, MBMZ
      REAL AM2, AMU, BETA, SINB, COSB, SINA, COSA
      REAL FTMT,  ASMB, ASMT, ASMZ, FBMZ
      REAL COS2B, COSBA, SINBA
      REAL EPSG, EPSU, EPSUA, EPSUB, CHIFC, CHIFCBABU
      REAL SUALFS, SUALFE
      COMPLEX*16 SSB0, SSB1, ZZZ
      REAL*8 REAL8
      REAL PSGEV, C0, D0
      REAL EPSGBABU, EPSUBABU, TERM1, TERM2, TERM3, CCOUNT
      REAL C10, AG, AW, AU, DEN, NUM, TEST1, TEST2
      REAL MT, TANB, MHL, MHH, MHA, MG, MB1, MB2, AAB, 
     &       THETAB, MT1, MT2, AAT, THETAT, MU,  M2, ALPHAH,
     &       MSL, MCL, BRBS, BRBD
C
C*************************************************************************
C
      REAL8(ZZZ) = DREAL(ZZZ)
C
      MB = 4.9
      MZ = 91.188
      MW = 80.419
      MMU = 0.1056
      MTAU = 1.777
C
C B_s meson
      MBS = 5.3696
      FBS = 0.250  
      TAUBS = 1.493   !(IN UNITS OF PS)
C
C B_d meson
      MBD = 5.2794
      FBD = 0.208
      TAUBD = 1.548   !(IN UNITS OF PS)
C
      PSGEV = 1.E+13/6.582
      TAUBS = TAUBS*PSGEV
      TAUBD = TAUBD*PSGEV
C
C CKM matrix
      VTB = 0.999
      VTS = 0.039
      VTD = 0.009
C
CCC      SW2 = 0.2309
      SW2 = .2324-1.03E-7*(MT**2-138.**2)
CC      PRINT*, 'SW2=', SW2
      SW  = SQRT(SW2)
      CW  = SQRT(1. - SW2)
      VEV = 246./SQRT(2.)
      ALPHA = 1./128.
      E = SQRT(4.*PI*ALPHA)
      G = E/SW
      G2 = G
CC      GF = SQRT(2.)*G**2/8./MW**2
      GF = 1.166E-5
C
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=COS(BETA)
      COS2B=COS(2*BETA)
C
C Running mass for B
C
      ASMB = SUALFS(MB**2, .36, MT, 3)
CC      MBMB = MB*(1. - 4.*ASMB/3./PI)
      MBMB=MB*(1.-4*ASMB/3./PI-12.4*(ASMB/PI)**2)
C
      ASMZ=0.118
C
      MBMZ = 2.92
C
      COSA = COS(ALPHAH)
      SINA = SIN(ALPHAH)
      COSBA = COSB*COSA - SINB*SINA
      SINBA = SINB*COSA + COSB*SINA
      AMU = ABS(MU)
      AM2 = ABS(M2)
C
      FTMT = 0.94
C
C-------------------------------------------------------------------
C
C squark/gluino contribution
C Pierce et al., second term of the Eq. (8) with t -> b
C
C In an effective Lagrangian method
C
C                               H_u
C                                
C       _    H_d                 |
C      / \                      / \
C     /   \  |                 /   \
C  ---+++++--X---          ---/+++++\----
C  Q_L     Q_L  d_R        Q_L        d_R
C
C      Diagram 1             Diagram 2
C
C In the leading tan\beta contribution Pierce et al. and effective 
C Lagrangian, with sq_L sq_R H_u vertex, give same answer. In this 
C approximaion, set 
C 
C \sin 2\theta  = 2 m_b (\mu tanb - A_b)/(...) -> 2 m_b \mu tanb /(...)
C
C----------------------------------------------------------------------
C
C According to Pierce's definition, f_1 is mostly left-handed
C  
C M2 -> -M2, MG -> -MG, sc -> -sc
C squark/gluino contribution, diagram 2 contribution
C
ccc      delmb1 = -ASMZ/3./PI*SIN(2*THETAB)*(-MG)/MBMZ*
ccc     $        (REAL8(SSB0(MZ**2,MG,MB1))-REAL8(SSB0(MZ**2,MG,MB2)))
C
      AG = -2.*ASMZ/3./PI*MU*MG
      EPSG = AG*C0(MG,MB1,MB2)
C
C---------------------------------------------------------------------
C squark/chargino contribution
C
C       H_u                       
C                                 
C        |                      _  st_L, st_R
C st_R  / \  sQ_L              / \
C      /   \                  /   \
C   ---+++++----          ---/++X++\----
C   Q_L      d_R          Q_L        d_R
C       chi1, chi2           chi1 chi2  mass insertion
C
C      Diagram 1             Diagram 2
C
C----------------------------------------------------------------------
C 
C M2 -> -M2, MG -> -MG
C squark/chargino contribution, diagram 1 (delmb2) + 2 (delmb3)
C
CC       delmb2 = FTMT**2*MU*(-AAT*TANB+MU)/16./PI**2/(MT1**2-MT2**2)*
CC     $     (REAL8(SSB0(MZ**2,AMU,MT1))-REAL8(SSB0(MZ**2,AMU,MT2)))
C
CC       delmb3 = G2**2*MU*(-M2)*TANB/16./PI**2/(AMU**2-M2**2)*
CC     $     (COS(THETAT)**2*(REAL8(SSB0(MZ**2,AM2,MT1))-
CC     $     REAL8(SSB0(MZ**2,AMU,MT1)))+
CC     $     SIN(THETAT)**2*(REAL8(SSB0(MZ**2,AM2,MT2))-
CC     $     REAL8(SSB0(MZ**2,AMU,MT2))))
C
      AU = -1./16./PI**2*MU*AAT
      EPSU = AU*C0(MU,MT1,MT2)
C
      AW = G2**2/16./PI**2*MU*M2
C
      NUM = EPSU*FTMT**2 + AG*(C0(MG,MB1,MB2) - SIN(THETAB)**2*
     &      C0(MG,MSL,MB1) - COS(THETAB)**2*C0(MG,MSL,MB2)) +
     &      AW*(COS(THETAT)**2*C0(MU,M2,MT1) + SIN(THETAT)**2*
     &      C0(MU,M2,MT2) - C0(MU,M2,MCL))
C
      DEN = (1. + AG*TANB*(SIN(THETAB)**2*C0(MG,MSL,MB1) +
     &      COS(THETAB)**2*C0(MG,MSL,MB2)) + AW*TANB*C0(MU,M2,MCL))*
     &      (1. + EPSG*TANB + AW*TANB*(COS(THETAT)**2*C0(MU,M2,MT1) + 
     &      SIN(THETAT)**2*C0(MU,M2,MT2)) + EPSU*FTMT**2*TANB)
C
      CHIFC = -NUM*TANB/DEN
C
C----------------------------------------------------------------------
C FINAL STATE WITH MUONS
C
      CQ1MU = -2.*PI/ALPHA*CHIFC*MBMB*MMU/COSB**2/SINB*
     &      (-COSBA*SINA/MHL**2 + SINBA*COSA/MHH**2)

      CQ2MU = -2.*PI/ALPHA*CHIFC*MBMB*MMU/COSB**2*(-1./MHA**2)
C
C WITH TAUS
C
      CQ1TAU = -2.*PI/ALPHA*CHIFC*MBMB*MTAU/COSB**2/SINB*
     &      (-COSBA*SINA/MHL**2 + SINBA*COSA/MHH**2)

      CQ2TAU = -2.*PI/ALPHA*CHIFC*MBMB*MTAU/COSB**2*(-1./MHA**2)
C
C------------------------------------------------------------------------
C BRANCHING RATIOS
C
      C10 = -4.221
C
C B_S -> MU+ MU-
C
      BRBS = GF**2*ALPHA**2*MBS**3*TAUBS*FBS**2/64./PI**3*(VTB*VTS)**2*
     &     SQRT(1.-4.*MMU**2/MBS**2)*
     &     ((1.-4.*MMU**2/MBS**2)*CQ1MU**2 + 
     &      (CQ2MU - 2.*MMU/MBS*C10)**2)
C
C B_D -> TAU+ TAU-
C
      BRBD = GF**2*ALPHA**2*MBD**3*TAUBD*FBD**2/64./PI**3*(VTB*VTD)**2*
     &     SQRT(1.-4.*MTAU**2/MBD**2)*
     &     ((1.-4.*MTAU**2/MBD**2)*CQ1TAU**2 + 
     &      (CQ2TAU - 2.*MTAU/MBD*C10)**2)
C
      RETURN
      END
C
C
C**********************************************************************      
C Given by Pierce, (Eq. C19)
C
C----------------------------------------------------------------------
      FUNCTION C0(M1,M2,M3)
C
      REAL C0, M1, M2, M3
      REAL*8 X, Y, Z, X2, Y2, Z2, FRACXY, FRACXZ, FRACYZ
C
      X = M1*M1
      Y = M2*M2
      Z = M3*M3
C
      FRACXY = ABS(X-Y)/(X+Y)
      FRACXZ = ABS(X-Z)/(X+Z)
      FRACYZ = ABS(Y-Z)/(Y+Z)
      IF(FRACXY.LT.1.D-4) Y = X
      IF(FRACXZ.LT.1.D-4) Z = X
      IF(FRACYZ.LT.1.D-4) Y = Z
C
      IF(X.NE.0.AND.Y.NE.0.AND.Z.NE.0)THEN
         IF(X.NE.Y.AND.X.NE.Z.AND.Y.NE.Z)THEN
            C0 = 1.D0/(Y-Z)*(Y/(X-Y)*DLOG(Y/X)-Z/(X-Z)*DLOG(Z/X))
         ELSE
            IF(X.EQ.Y.AND.X.NE.Z)THEN
               C0 = -(1.D0 - Z/(Y-Z)*DLOG(Y/Z))/(Y-Z)
            ELSE
               IF(X.EQ.Y.AND.X.EQ.Z)THEN
                  C0 = -1.D0/2.D0/Z
               END IF
            END IF
         END IF
         IF(X.NE.Y)THEN
            IF(X.EQ.Z)THEN
               C0 = -(1.D0 - Y/(X-Y)*DLOG(X/Y))/(X-Y)
            ELSE
               IF(Y.EQ.Z)THEN
                  C0 = -(1.D0 - X/(Y-X)*DLOG(Y/X))/(Y-X)
               END IF
            END IF
         END IF
      ELSE
         WRITE(*,*) 'C0 COM ARGUMENTO NULO!' 
      END IF
      RETURN
      END
C
C----------------------------------------------------------------------
      FUNCTION D0(M1,M2,M3,M4)
      REAL M1, M2, M3, M4, X, Y, Z, W, C0, FRACXY, FRACXZ, FRACXW
      INTEGER FLAG
C
      X = M1*M1
      Y = M2*M2
      Z = M3*M3
      W = M4*M4
      FRACXY = (X-Y)/(X+Y)
      FRACXZ = (X-Z)/(X+Z)
      FRACXW = (X-W)/(X+W)
C
      IF(FRACXY.LT.1.E-2) Y = X
      IF(FRACXZ.LT.1.E-2) Z = X
      IF(FRACXW.LT.1.E-2) W = X
C
      FLAG = 0
      IF(X.NE.0.AND.Y.NE.0.AND.Z.NE.0.AND.W.NE.0)THEN
         IF(X.NE.Y)THEN
            D0 = (C0(X,Z,W) - C0(Y,Z,W))/(X-Y)
            FLAG = 1
         END IF
         IF(X.EQ.Y.AND.X.NE.Z.AND.X.NE.W)THEN
            D0 = -(-(Y**2-Z*W)/(Y-Z)**2/(Y-W)**2*LOG(Y/W) +
     &           Z/(Y-Z)**2/(Z-W)*LOG(Z/W) + 1./(Y-Z)/(Y-W))
            FLAG = 1
         END IF
         IF(X.EQ.Y.AND.X.EQ.Z.AND.X.NE.W)THEN
            D0 = -(1./2./Y - 1./(Y-W) + W/(Y-W)**2*LOG(Y/W))/(Y-W)
            FLAG = 1
         END IF
         IF(X.EQ.Y.AND.X.NE.Z.AND.X.EQ.W)THEN
            D0 = -(1./(X-Z)*(-1./2./X - Z/X/(X-Z)) + 
     &           Z/(X-Z)**3*LOG(X/Z))
            FLAG = 1
         END IF
         IF(X.EQ.Y.AND.X.EQ.Z.AND.X.EQ.W)THEN
            D0 = 1./6./W**2
            FLAG = 1
         END IF
      END IF
C
      IF(FLAG.EQ.0) WRITE(*,*) 'D0: ARGUMENTOS ESTRANHOS'
      RETURN
      END
C
C**********************************************************************
C FUNCTION B0 FROM PIERCE, PAG. 12
C
      FUNCTION B0FUNC(SCALE,M1,M2)
      REAL B0FUNC, SCALE, M1, M2, MC2, ML2
C
      IF(M1.GT.M2)THEN
         MC2 = M1*M1
         ML2 = M2*M2
      ELSE
         MC2 = M2*M2
         ML2 = M1*M1
      END IF
C
      B0FUNC = -LOG(MC2/SCALE**2) + 1. + ML2/(ML2-MC2)*LOG(MC2/ML2)
C
      RETURN
      END
C
+EOD
+DECK,ISABSG,IF=ISATOOLS
C--------------------------------------------------------------------
      subroutine ISABSG(IMODEL,AMHC,M0,MHF,A0,MTQ,MBQ,BFBSG,IWR)
C     This version uses just running MBQ
      IMPLICIT REAL (A-H,M,O-Z)
      REAL G(137),W2(411),GISA(31)
c
C     G( 1) = g_1        G( 2) = g_2        G( 3) = g_3
C     G( 4) = y_tau      G( 5) = y_b        G( 6) = y_t
C     G( 7) = M_1        G( 8) = M_2        G( 9) = M_3
C     G(10) = A_tau      G(11) = A_b        G(12) = A_t
C     G(13) = M_hd^2     G(14) = M_hu^2     G(15) = M_er^2
C     G(16) = M_el^2     G(17) = M_dnr^2    G(18) = M_upr^2
C     G(19) = M_upl^2    G(20) = M_taur^2   G(21) = M_taul^2
C     G(22) = M_btr^2    G(23) = M_tpr^2    G(24) = M_tpl^2
C     G(25) = mu         G(26) = B
c     G(27) = y_e
c     G(28) = y_mu
c     G(29) = y_d
c     G(30) = y_s
c     G(31) = y_u
c     G(32) = y_c
c     G(33) = ???        
c     G(34) = ???        
c     G(36) = ???        
c     G(36)-G(44) = Y_U
c     G(45)-G(53) = Y_D
c     G(54)-G(62) = Y_E
c     G(63)-G(71) = m_Q^2
c     G(72)-G(80) = m_U^2
c     G(81)-G(90) = m_D^2
c     G(91)-G(98) = m_L^2
c     G(99)-G(107) = m_E^2
c     G(108)-G(116) = a_U
c     G(117)-G(125) = a_D
c     G(126)-G(134) = a_E
c     G(135) = Y_NR
c     G(136) = m_NR
c     G(137) = a_N
c     
      REAL CKM(3,3),HUP(3,3),DUP(3,3),HDO(3,3),DDO(3,3)
      REAL HUGUT(9),HDGUT(9),HEGUT(9)
      REAL CSM(9),CH1(9),CH2(19),
     $     CC111(12),CC112(12),CC113(12),
     $     CC121(12),CC122(12),CC123(12),
     $     CC211(17),CC212(17),CC213(17),
     $     CC221(17),CC222(17),CC223(17),
     $     DSSM(9),DSH1(9),DSH2(9),
     $     DSC111(9),DSC112(9),DSC113(9),
     $     DSC121(9),DSC122(9),DSC123(9),
     $     DSC211(9),DSC212(9),DSC213(9),
     $     DSC221(9),DSC222(9),DSC223(9),
     $     WSM(27),WHP1(27),WHP2(57),
     $     WSC111(36),WSC112(36),WSC113(36),
     $     WSC121(36),WSC122(36),WSC123(36),
     $     WSC211(51),WSC212(51),WSC213(51),
     $     WSC221(51),WSC222(51),WSC223(51),
     $     CI1(8),WCI1(24),CI2(8),WCI2(24),
     $     MCHA(2),MSQU(3),MSQD(3),MGLU,
     $     MCH0(4),MDSB(6),
     $     GK(2,3),HK(2,3),
     $     SMIX(6),RMIX(2),ABMIX(2)
      REAL GAM(6,6)

      REAL AGE(4,6,6),AHE(4,6,6)
      INTEGER IG(137)
      EXTERNAL ALL,GAMMASM,GAMMAHP,GAMMAC1,GAMMAC2,GAMMAWB1,GAMMAWB2
C
+CDE,SUGXIN
+CDE,SUGPAS
+CDE,SUGNU
+CDE,SIGMG
+CDE,SSSM
C-FP  include 'sugxin.h'
C-FP  include 'sugpas.h'
C-FP  include 'sugnu.h'
C-FP  include 'sugmg.h'
C-FP  include 'sssm.h'
C
      COMMON /CHRGN/ MCHA,MSQU,MSQD,SMIX,RMIX,ABMIX              
      COMMON /GLNN/ MCH0,MDSB
      COMMON /GGN/ M1,M2,M3,ABOT,ATOP,ATAU
      COMMON /G3/ G3
      COMMON /BSG/ GISA
    
      DATA MZ/91.187/,MTAU/1.784/,MB/4.8/,MW/80.3/,ALEM/.0078186/,
     $     MC/1.5/,MS/0.2/,NSTEP/50000/
      COMMON/SCALEQ/Q
      
      pi=acos(-1.)
      
      
c      G3MW=SQRT(4*PI*SUALFS(MW**2,.36,AMT,3))
c      WRITE(6,*) 'MTQ,MBQ ISABSG=',MTQ,MBQ
      DO III=1,137
        G(III)=0.d0
      ENDDO
      DO III=1,26
        G(III)=GISA(III)
      ENDDO
      G(135)=GISA(27)
      G(136)=GISA(28)
      G(137)=GISA(29)
      M1=G(7)
      M2=G(8)
      M3=G(9)
      ABOT=G(11)
      ATOP=G(12)
      ATAU=G(10)
C-----DEFINE CKM MATRIX -------------------------------------------------
      S12=0.22
      C12=SQRT(1.-S12**2)
      S23=0.04
      C13=SQRT(1.-S13**2)
      S13=0.003
      C23=SQRT(1.-S23**2)
      CKM(1,1)= C12*C13
      CKM(1,2)= S12*C13
      CKM(1,3)= S13
      CKM(2,1)=-S12*C23-C12*S23*S13
      CKM(2,2)= C12*C23-S12*S23*S13
      CKM(2,3)= S23*C13
      CKM(3,1)= S12*S23-C12*C23*S13
      CKM(3,2)=-C12*S23-S12*C23*S13
      CKM(3,3)= C23*C13
C---------------------------------------------
      MHPLUS=AMHC
      MGLU  =XISAIN(1)
      CALL CHARGINO(GK,HK,XISAIN(15),XISAIN(17),MTQ,MBQ)
      CALL GLUNENO(G,GAM,AGE,AHE)
c      write(6,*) 'mdsb1=',mdsb     
      BFBSG=-1.
      YRIGHT=0.
ccc      NOGOOD=0
      SR2=SQRT(2.)
      MT=AMT
      MW=MZ*SQRT(1.-XW)
      MZS=MZ**2

      a1mzi=1./a1mz
      a2mzi=1./a2mz
      
      G2=SQRT(4*PI*A2MZ)
      GP=SQRT(3./5.*A1MZ*4.*PI)
      amt=mt
      TANB=XTANB
      COTB=1./TANB
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=COS(BETA)       
      SIN2B=SIN(2.*BETA)
      COS2B=COS(2.*BETA)

C          Compute gauge mediated threshold functions
      IF (IMODEL.EQ.2) THEN
        XLAMGM=M0
        XMESGM=MHF
        XN5GM=A0
        XLM=XLAMGM/XMESGM
        THRF=((1.D0+XLM)*(LOG(1.D0+XLM)-2*DDILOG(XLM/(1.D0+XLM))+
     ,        .5*DDILOG(2*XLM/(1.D0+XLM)))+
     ,       (1.D0-XLM)*(LOG(1.D0-XLM)-2*DDILOG(-XLM/(1.D0-XLM))+
     ,        .5*DDILOG(-2*XLM/(1.D0-XLM))))/XLM**2
        THRG=((1.D0+XLM)*LOG(1.D0+XLM)+(1.D0-XLM)*LOG(1.D0-XLM))/XLM**2
      END IF

C-----DEFINE FERMION MASSES AND YUKAWA COUPLINGS AT MZ---------------------
C     FOR THIRD GENERATION, USE LOOP CORRECTED VALUE OF MBQ
      MELMZ=0.00051
      MMUMZ=0.106
      MUPMZ=0.0027
      MDOMZ=0.0058
      MCHMZ=0.620
      MSTMZ=0.113
      FELMZ=MELMZ/COSB/VEV
      FMUMZ=MMUMZ/COSB/VEV
      FUPMZ=MUPMZ/SINB/VEV
      FDOMZ=MDOMZ/COSB/VEV
      FCHMZ=MCHMZ/SINB/VEV
      FSTMZ=MSTMZ/COSB/VEV
      
      
         DUP(1,1)=FUPMZ
         DUP(1,2)=0.
         DUP(1,3)=0.
         DUP(2,1)=0.
         DUP(2,2)=FCHMZ
         DUP(2,3)=0.
         DUP(3,1)=0.
         DUP(3,2)=0.
         DUP(3,3)=G(6)
         DDO(1,1)=FDOMZ
         DDO(1,2)=0.
         DDO(1,3)=0.
         DDO(2,1)=0.
         DDO(2,2)=FSTMZ
         DDO(2,3)=0.
         DDO(3,1)=0.
         DDO(3,2)=0.
         DDO(3,3)=G(5)
         DO I=1,3
         DO J=1,3
          HUP(I,J)=0.
          HDO(I,J)=0.
          DO K=1,3
          HUP(I,J)=HUP(I,J)+DUP(I,K)*CKM(K,J)
          HDO(I,J)=HDO(I,J)+CKM(I,K)*DDO(K,J)
          ENDDO
         ENDDO
         ENDDO
         G(36)=HUP(1,1)
         G(37)=HUP(1,2)
         G(38)=HUP(1,3)
         G(39)=HUP(2,1)
         G(40)=HUP(2,2)
         G(41)=HUP(2,3)
         G(42)=HUP(3,1)
         G(43)=HUP(3,2)
         G(44)=HUP(3,3)
         G(45)=FDOMZ
         G(46)=0.
         G(47)=0.
         G(48)=0.
         G(49)=FSTMZ
         G(50)=0.
         G(51)=0.
         G(52)=0.
         G(53)=G(5)
         G(54)=FELMZ
         G(55)=0.
         G(56)=0.
         G(57)=0.
         G(58)=FMUMZ
         G(59)=0.
         G(60)=0.
         G(61)=0.
         G(62)=G(4)
         DO I=63,134
           G(I)=0.
         ENDDO
C        SET SQUARK MASS MATRICES AT MZ
         G(63)=G(19)
         G(67)=G(19)
         G(71)=G(24)
         G(72)=G(18)
         G(76)=G(18)
         G(80)=G(23)
         G(81)=G(17)
         G(85)=G(17)
         G(89)=G(22)
         G(90)=G(16)
         G(94)=G(16)
         G(98)=G(21)
         G(99)=G(15)
         G(103)=G(15)
         G(107)=G(20)
	 
c	 print*, 'at MZ:',(g(ii),ii=1,137)
C
C-----RUN RGES FROM MZ TO MGUT -------------------------------------
C
      TZ=LOG(MZ/MGUT)
      TGUT=0.
      DT=(TGUT-TZ)/FLOAT(NSTEP)
      DO II=1,NSTEP
        T=TZ+DT*FLOAT(II-1)
        QOLD=Q
        Q=MGUT*EXP(T)
        IF (QOLD.LE.XNRIN(2).AND.Q.GT.XNRIN(2)) THEN
          G(135)=FNMZ
          G(136)=GISA(28)
          G(137)=GISA(29)
        END IF
        CALL RKSTP(137,DT,T,G,ALL,W2)   
          if(Q.ge.MSUSY.and.QOLD.lt.MSUSY) then
	  ENDIF
      END DO
      IF (XNRIN(2).LT.1.E19.AND.XNRIN(1).EQ.0.) THEN
C     IMPOSE FN-FT UNIFICATION
        FNGUT=G(6)
      ELSE
        FNGUT=G(27)
      END IF
C-----BACK DOWN TO THE E-WEAK SCALE ----
      DO 260 I=1,3
        IF (IMODEL.EQ.1) THEN
          G(I)=G(I)
          G(I+6)=MHF
          G(I+9)=A0
        ELSE IF (IMODEL.EQ.2) THEN
          G(I)=G(I)
          G(I+6)=XGMIN(11+I)*XGMIN(8)*THRG*(G(I)/4./PI)**2*XLAMGM
          G(I+9)=0.
        END IF
      IF (XNRIN(2).LT.1.E19) THEN
        G(27)=FNGUT
        G(28)=XNRIN(4)**2
        G(29)=XNRIN(3)
      ELSE
        G(27)=0.
        G(28)=0.
        G(29)=0.
      END IF
260   CONTINUE
C     OVERWRITE ALFA_3 UNIFICATION TO GET ALFA_3(MZ) RIGHT
      IF (IMODEL.EQ.1.AND.IAL3UN.NE.0) G(3)=GGUTSS
      IF (IMODEL.EQ.1) THEN
        DO 270 I=13,24
          G(I)=M0**2
270     CONTINUE
C          Set possible non-universal GUT scale boundary conditions
      DO 280 I=1,6
        IF (XNUSUG(I).LT.1.E19) THEN
          G(I+6)=XNUSUG(I)
        END IF
280   CONTINUE
      DO 281 I=7,18
        IF (XNUSUG(I).LT.1.E19) THEN
          G(I+6)=SIGN(1.,XNUSUG(I))*XNUSUG(I)**2
        END IF
281   CONTINUE
      ELSE IF (IMODEL.EQ.2) THEN
       XC=2*THRF*XLAMGM**2
       DY=SQRT(3./5.)*G(1)*XGMIN(11)
       G(13)=XC*(.75*XGMIN(13)*(G(2)/4./PI)**4+.6*.25*
     , XGMIN(12)*(G(1)/4./PI)**4)+XGMIN(9)-DY
       G(14)=XC*(.75*XGMIN(13)*(G(2)/4./PI)**4+.6*.25*
     , XGMIN(12)*(G(1)/4./PI)**4)+XGMIN(10)+DY
       G(15)=XC*(.6*XGMIN(12)*(G(1)/4./PI)**4)+2*DY
       G(16)=XC*(.75*XGMIN(13)*(G(2)/4./PI)**4+.6*.25*
     , XGMIN(12)*(G(1)/4./PI)**4)-DY
       G(17)=XC*(4*XGMIN(14)*(G(3)/4./PI)**4/3.+.6*XGMIN(12)*
     , (G(1)/4./PI)**4/9.)+2*DY/3.
       G(18)=XC*(4*XGMIN(14)*(G(3)/4./PI)**4/3.+.6*4*XGMIN(12)*
     , (G(1)/4./PI)**4/9.)-4*DY/3.
       G(19)=XC*(4*XGMIN(14)*(G(3)/4./PI)**4/3.+.75*XGMIN(13)*
     , (G(2)/4./PI)**4+.6*XGMIN(12)*(G(1)/4./PI)**4/36.)+DY/3.
       G(20)=G(15)
       G(21)=G(16)
       G(22)=G(17)
       G(23)=G(18)
       G(24)=G(19)
      ELSE IF (IMODEL.EQ.7) THEN
       BLHAT=G(4)*(-9*G(1)**2/5.-3*G(2)**2+3*G(5)**2+4*G(4)**2)
       BBHAT=G(5)*(-7*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.+
     ,             G(6)**2+6*G(5)**2+G(4)**2)
       BTHAT=G(6)*(-13*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.+
     ,             6*G(6)**2+G(5)**2)
       G(7)=-33*MHF*G(1)**2/5./16./PI**2
       G(8)=-MHF*G(2)**2/16./PI**2
       G(9)=3*MHF*G(3)**2/16./PI**2
       G(10)=BLHAT*MHF/G(4)/16./PI**2
       G(11)=BBHAT*MHF/G(5)/16./PI**2
       G(12)=BTHAT*MHF/G(6)/16./PI**2
       G(13)=(-99*G(1)**4/50.-3*G(2)**4/2.+3*G(5)*BBHAT+G(4)*BLHAT)*
     ,        MHF**2/(16*PI**2)**2+XAMIN(6)*M0**2
       G(14)=(-99*G(1)**4/50.-3*G(2)**4/2.+3*G(6)*BTHAT)*
     ,        MHF**2/(16*PI**2)**2+XAMIN(7)*M0**2
       G(15)=(-198*G(1)**4/25.)*MHF**2/(16*PI**2)**2+XAMIN(5)*M0**2
       G(16)=(-99*G(1)**4/50.-3*G(2)**4/2.)*MHF**2/(16*PI**2)**2
     ,+XAMIN(4)*M0**2
       G(17)=(-22*G(1)**4/25.+8*G(3)**4)*MHF**2/(16*PI**2)**2+
     ,XAMIN(2)*M0**2
       G(18)=(-88*G(1)**4/25.+8*G(3)**4)*MHF**2/(16*PI**2)**2+
     ,XAMIN(3)*M0**2
       G(19)=(-11*G(1)**4/50.-3*G(2)**4/2.+8*G(3)**4)*
     ,        MHF**2/(16*PI**2)**2+XAMIN(1)*M0**2
       G(20)=(-198*G(1)**4/25.+2*G(4)*BLHAT)*MHF**2/(16*PI**2)**2+
     ,XAMIN(5)*M0**2
       G(21)=(-99*G(1)**4/50.-3*G(2)**4/2.+G(4)*BLHAT)*
     ,        MHF**2/(16*PI**2)**2+XAMIN(4)*M0**2
       G(22)=(-22*G(1)**4/25.+8*G(3)**4+2*G(5)*BBHAT)*
     , MHF**2/(16*PI**2)**2+XAMIN(2)*M0**2
       G(23)=(-88*G(1)**4/25.+8*G(3)**4+2*G(6)*BTHAT)*
     , MHF**2/(16*PI**2)**2+XAMIN(3)*M0**2
       G(24)=(-11*G(1)**4/50.-3*G(2)**4/2.+8*G(3)**4+G(5)*BBHAT+
     ,        G(6)*BTHAT)*MHF**2/(16*PI**2)**2+XAMIN(1)*M0**2
      END IF
      DO 285 I=1,29
        IG(I)=0
285   CONTINUE
C-------------------------------------------------------------------
      FTAGUT=G(4)
      FBGUT=G(5)
      FTGUT=G(6)
      FELGUT=G(27)
      FMUGUT=G(28)
      FDOGUT=G(29)
      FSTGUT=G(30)
      FUPGUT=G(31)
      FCHGUT=G(32)         
      HUGUT(1)=G(36)
      HUGUT(2)=G(37)
      HUGUT(3)=G(38)
      HUGUT(4)=G(39)
      HUGUT(5)=G(40)
      HUGUT(6)=G(41)
      HUGUT(7)=G(42)
      HUGUT(8)=G(43)
      HUGUT(9)=G(44)
      HDGUT(1)=G(45)
      HDGUT(2)=G(46)
      HDGUT(3)=G(47)
      HDGUT(4)=G(48)
      HDGUT(5)=G(49)
      HDGUT(6)=G(50)
      HDGUT(7)=G(51)
      HDGUT(8)=G(52)
      HDGUT(9)=G(53)
      HEGUT(1)=G(54)
      HEGUT(2)=G(55)
      HEGUT(3)=G(56)
      HEGUT(4)=G(57)
      HEGUT(5)=G(58)
      HEGUT(6)=G(59)
      HEGUT(7)=G(60)
      HEGUT(8)=G(61)
      HEGUT(9)=G(62)
      YRIGHT=FNGUT
      DO J=1,9
        G(35+J)=HUGUT(J)
        G(44+J)=HDGUT(J)
        G(53+J)=HEGUT(J)
      END DO                      
C-----LEAVE G(54)-G(106) AS IS
      DO J=1,9
        G(107+J)=A0*HUGUT(J)
        G(116+J)=A0*HDGUT(J)
        G(125+J)=A0*HEGUT(J)
      END DO                      
        G(135)=YRIGHT
        G(136)=G(28)
        G(137)=G(29)
      DO I=1,35
        IG(I)=0
      END DO
C-------------------------------------------------------------------
C-------NOW WE  RUN from MGUT to MZ and then to MB------------------
C-------------------------------------------------------------------
C       SET VALUES OF WILSON COEFFICIENTS
        CSM(1)=-1./2.
        CSM(2)=-1./2.
        CSM(3)=1.
        CSM(4)=11./18.
        CSM(5)=-8./9.
        CSM(6)=11./18.
        CSM(7)=1./2.
        CSM(8)=-9./4.
        CSM(9)=3./2.
c
        X=(MT/MW)**2
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        DSSM(1)=-X*FN4+1./2.
        DSSM(2)=-X/2.*(FN3+FN4)+1./2.        
        DSSM(3)=-2.*DSSM(2)
        DSSM(4)=(X+2.)/3.*(2.*FN2+FN3+2.*FN4)-11./18.        
        DSSM(5)=2.*(X+2.)/3.*(FN2-FN3-2.*FN4)+8./9.   
        DSSM(6)=(X+2.)/3.*(2.*FN2+FN3+2.*FN4)-11./18.        
        DSSM(7)=(X-2.)*FN4-1./2.   
        DSSM(8)=-3.*((X+2.)*(1./2.*FN3+FN4-LOG(X)/6./(X-1.))
     $          -3./4.)        
        DSSM(9)=-3*(7./2.-2*X*FN3-5*X*FN4)
        c3smnai=-1./2.*(CSM(1)+DSSM(1))
     $          +(CSM(3)+DSSM(3))
     $          -1./2.*(CSM(4)+DSSM(4)+2./9.)
     $          -1./4.*(CSM(5)+DSSM(5)-7./9.)
     $          +1./4.*(CSM(7)+DSSM(7)+1.)
     $          -1./4.*(CSM(9)+DSSM(9)+9.)          
        c2smnai=-1./2.*(CSM(1)+DSSM(1))
     $          +(CSM(2)+DSSM(2))
     $          -1./2.*(CSM(4)+DSSM(4)+2./9.)
     $          -1./4.*(CSM(5)+DSSM(5)-7./9.)
     $          +1./4.*(CSM(7)+DSSM(7)+1.)         
C
        CH1(1)=1./2.
        CH1(2)=1./2.
        CH1(3)=-1.
        CH1(4)=11./18./TANB**2
        CH1(5)=-8./9./TANB**2
        CH1(6)=11./18./TANB**2
        CH1(7)=1./2./TANB**2
        CH1(8)=-9./4./TANB**2
        CH1(9)=3./2./TANB**2     
c
        X=(MT/MHPLUS)**2
        CH2(1)=1./2.*X
        CH2(2)=-1./2.*X
        CH2(3)=X
        CH2(4)=-1./9.*X/TANB**2
        CH2(5)=7./18.*X/TANB**2
        CH2(6)=-1./9.*X/TANB**2
        CH2(7)=1./2.*X/TANB**2
        CH2(8)=3./4.*X/TANB**2
        CH2(9)=3./2.*X/TANB**2     
        CH2(10)=0.
        CH2(12)=0.
        CH2(13)=0.
        CH2(14)=0.
        CH2(15)=0.     
        CH2(16)=0.
        CH2(18)=0.
        CH2(19)=0.
c
        X=(MT/MHPLUS)**2
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        DSH1(1)=X*FN4-1./2.
        DSH1(2)=X/2.*(FN3+FN4)-1./2.        
        DSH1(3)=-2*DSH1(2)
        DSH1(4)=(X/3.*(2*FN2+FN3+2*FN4)-11./18.)/TANB**2        
        DSH1(5)=(2*X/3.*(FN2-FN3-2*FN4)+8./9.)/TANB**2   
        DSH1(6)=(X/3.*(2*FN2+FN3+2*FN4)-11./18.)/TANB**2        
        DSH1(7)=(X*FN4-1./2.)/TANB**2   
        DSH1(8)=-3*(X*(1./2.*FN3+FN4-LOG(X)/6./(X-1.))
     $          -3./4.)/TANB**2        
        DSH1(9)=3*DSH1(7)
        c3hpnai=-1./2.*(CH1(1)+DSH1(1))
     $          +(CH1(3)+DSH1(3))
     $          -1./2.*(CH1(4)+DSH1(4))
     $          -1./4.*(CH1(5)+DSH1(5))
     $          +1./4.*(CH1(7)+DSH1(7))
     $          -1./4.*(CH1(9)+DSH1(9))        
c
        X=(MT/MHPLUS)**2
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        DSH2(1)=X*(FN4-1./2.)
        DSH2(2)=X/2.*(FN3+FN4+1.)        
     $          +(MT/MHPLUS)**2*LOG(MT/MHPLUS)
        DSH2(3)=-2.*DSH2(2)
c     $          -2.*(MT/MHPLUS)**2*LOG(MT/MHPLUS)
        DSH2(4)=(X/3.*(2*FN2+FN3+2*FN4+1./3.))/TANB**2        
        DSH2(5)=(2*X/3.*(FN2-FN3-2*FN4)-7./18.*X)/TANB**2   
        DSH2(6)=(X/3.*(2*FN2+FN3+2*FN4+1./3.))/TANB**2        
        DSH2(7)=X*(FN4-1./2.)/TANB**2   
        DSH2(8)=-3*(X*(1./2.*FN3+FN4)-LOG(X)/6./(X-1.)
     $          +1./4.*X)/TANB**2        
        DSH2(9)=3*DSH2(7)                
C
        IF(MCHA(1).GT.MW) THEN
         SCALE=MCHA(1)
        ELSE
         SCALE=MW
        ENDIF
C
        XWA=(MW/MSQU(1))**2
        XCB=MCHA(1)/MBQ
        CC111(1)=-GK(1,1)*HK(1,1)*XCB*XWA
        CC111(2)=0.
        CC111(3)=3.*GK(1,1)*HK(1,1)*XCB*XWA
        CC111(4)=5./18.*GK(1,1)*GK(1,1)*XWA
        CC111(5)=-2./9.*GK(1,1)*GK(1,1)*XWA
        CC111(6)=5./18.*GK(1,1)*GK(1,1)*XWA
        CC111(7)=0.
        CC111(8)=-3./2.*GK(1,1)*GK(1,1)*XWA
        CC111(9)=-3.*GK(1,1)*GK(1,1)*XWA         
c
        X=(MCHA(1)/MSQU(1))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC111(1)=-GK(1,1)*HK(1,1)*XCB*XWA*(2.*FN4-1.)
         DSC111(2)=0.
         DSC111(3)=-3.*GK(1,1)*HK(1,1)*XCB*XWA*
     $               (FN3+FN4+1.+2.*LOG(SCALE/MSQU(1))) 
         DSC111(4)=1./3.*GK(1,1)*GK(1,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC111(5)=2./3.*GK(1,1)*GK(1,1)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.)+1./3.)
         DSC111(6)=1./3.*GK(1,1)*GK(1,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC111(7)=0.
         DSC111(8)=6.*GK(1,1)*GK(1,1)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.)+1./4.+
     $                2./3.*LOG(SCALE/MSQU(1)))
         DSC111(9)=-6.*GK(1,1)*GK(1,1)*XWA*(FN4-1./2.)
        ELSE
         DSC111(1)=GK(1,1)*HK(1,1)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC111(1)
         DSC111(2)=0.
         DSC111(3)=GK(1,1)*HK(1,1)*XCB*XWA*
     $               (-3./2.+YPS
     $             -6.*LOG(SCALE/MSQU(1)))-CC111(3) 
         DSC111(4)=GK(1,1)*GK(1,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC111(4) 
         DSC111(5)=GK(1,1)*GK(1,1)*XWA*
     $               (-1./6.+1./30.*YPS)-CC111(5)
         DSC111(6)=GK(1,1)*GK(1,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC111(6) 
         DSC111(7)=0.
         DSC111(8)=GK(1,1)*GK(1,1)*XWA*
     $               (1.-3./4.*YPS
     $               + 4.*LOG(SCALE/MSQU(1)))-CC111(8)
         DSC111(9)=GK(1,1)*GK(1,1)*XWA*
     $             (-1.+1./2.*YPS)-CC111(9)
        ENDIF
C                                                                       
        XWB=(MW/MCHA(1))**2
        XCB=MCHA(1)/MBQ
        CC211(1)=-GK(1,1)*HK(1,1)*XCB*XWB
        CC211(2)=0.
        CC211(3)=-3.*GK(1,1)*HK(1,1)*XCB*XWB
        CC211(4)=-5./18.*GK(1,1)*GK(1,1)*XWB
        CC211(5)=11./9.*GK(1,1)*GK(1,1)*XWB
        CC211(6)=-5./18.*GK(1,1)*GK(1,1)*XWB
        CC211(7)=0.
        CC211(8)=9./2.*GK(1,1)*GK(1,1)*XWB
        CC211(9)=-3.*GK(1,1)*GK(1,1)*XWB      
        CC211(10)=-2.*GK(1,1)*HK(1,1)*XCB*XWB      
        CC211(11)=0.
        CC211(12)=2.*GK(1,1)*GK(1,1)*XWB      
        CC211(13)=2.*GK(1,1)*GK(1,1)*XWB      
        CC211(14)=0.
        CC211(15)=0.    
        CC211(16)=0.
        CC211(17)=0.
C
        X=(MCHA(1)/MSQU(1))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC211(1)=-GK(1,1)*HK(1,1)*XCB*XWA*2.*FN4-CC211(1)
         DSC211(2)=0.
         DSC211(3)=-3.*GK(1,1)*HK(1,1)*XCB*XWA*
     $                (FN3+FN4)-CC211(3)
         DSC211(4)=1./3.*GK(1,1)*GK(1,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC211(4)
         DSC211(5)=2./3.*GK(1,1)*GK(1,1)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.))-CC211(5)
         DSC211(6)=1./3.*GK(1,1)*GK(1,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC211(6)
         DSC211(7)=0.
         DSC211(8)=6.*GK(1,1)*GK(1,1)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.))-CC211(8)
         DSC211(9)=-6.*GK(1,1)*GK(1,1)*XWA*FN4-CC211(9)                  
        ELSE
         DSC211(1)=GK(1,1)*HK(1,1)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC211(1)
         DSC211(2)=0.
         DSC211(3)=GK(1,1)*HK(1,1)*XCB*XWA*
     $               (-3./2.+YPS)-CC211(3) 
         DSC211(4)=GK(1,1)*GK(1,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC211(4) 
         DSC211(5)=GK(1,1)*GK(1,1)*XWA*
     $               (-1./6.+1./30.*YPS)-CC211(5)
         DSC211(6)=GK(1,1)*GK(1,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC211(6) 
         DSC211(7)=0.
         DSC211(8)=GK(1,1)*GK(1,1)*XWA*
     $               (1.-3./4.*YPS)-CC211(8)
         DSC211(9)=GK(1,1)*GK(1,1)*XWA*
     $             (-1.+1./2.*YPS)-CC211(9)
        ENDIF
c
        c3c11nai=-1./2.*(CC211(1)+DSC211(1))                                
     $          +(CC211(3)+DSC211(3))
     $          -1./2.*(CC211(4)+DSC211(4))
     $          -1./4.*(CC211(5)+DSC211(5))
     $          +1./4.*(CC211(7)+DSC211(7))
     $          -1./4.*(CC211(9)+DSC211(9))                  
C
        XWA=(MW/MSQU(2))**2
        XCB=MCHA(1)/MBQ
        CC112(1)=-GK(1,2)*HK(1,2)*XCB*XWA
        CC112(2)=0.
        CC112(3)=3.*GK(1,2)*HK(1,2)*XCB*XWA
        CC112(4)=5./18.*GK(1,2)*GK(1,2)*XWA
        CC112(5)=-2./9.*GK(1,2)*GK(1,2)*XWA
        CC112(6)=5./18.*GK(1,2)*GK(1,2)*XWA
        CC112(7)=0.
        CC112(8)=-3./2.*GK(1,2)*GK(1,2)*XWA
        CC112(9)=-3.*GK(1,2)*GK(1,2)*XWA         
c
        X=(MCHA(1)/MSQU(2))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC112(1)=-GK(1,2)*HK(1,2)*XCB*XWA*(2.*FN4-1.)
         DSC112(2)=0.
         DSC112(3)=-3.*GK(1,2)*HK(1,2)*XCB*XWA*
     $               (FN3+FN4+1.+2.*LOG(SCALE/MSQU(2)))
         DSC112(4)=1./3.*GK(1,2)*GK(1,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC112(5)=2./3.*GK(1,2)*GK(1,2)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.)+1./3.)
         DSC112(6)=1./3.*GK(1,2)*GK(1,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC112(7)=0.
         DSC112(8)=6.*GK(1,2)*GK(1,2)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.)+1./4.+
     $                2./3.*LOG(SCALE/MSQU(2)))
         DSC112(9)=-6.*GK(1,2)*GK(1,2)*XWA*(FN4-1./2.)
        ELSE
         DSC112(1)=GK(1,2)*HK(1,2)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC112(1)
         DSC112(2)=0.
         DSC112(3)=GK(1,2)*HK(1,2)*XCB*XWA*
     $               (-3./2.+YPS
     $             -6.*LOG(SCALE/MSQU(2)))-CC112(3) 
         DSC112(4)=GK(1,2)*GK(1,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC112(4) 
         DSC112(5)=GK(1,2)*GK(1,2)*XWA*
     $               (-1./6.+1./30.*YPS)-CC112(5)
         DSC112(6)=GK(1,1)*GK(1,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC112(6) 
         DSC112(7)=0.
         DSC112(8)=GK(1,2)*GK(1,2)*XWA*
     $               (1.-3./4.*YPS
     $               + 4.*LOG(SCALE/MSQU(2)))-CC112(8)
         DSC112(9)=GK(1,2)*GK(1,2)*XWA*
     $             (-1.+1./2.*YPS)-CC112(9)
        ENDIF
C                                                                       
        XWB=(MW/MCHA(1))**2
        XCB=MCHA(1)/MBQ
        CC212(1)=-GK(1,2)*HK(1,2)*XCB*XWB
        CC212(2)=0.
        CC212(3)=-3.*GK(1,2)*HK(1,2)*XCB*XWB
        CC212(4)=-5./18.*GK(1,2)*GK(1,2)*XWB
        CC212(5)=11./9.*GK(1,2)*GK(1,2)*XWB
        CC212(6)=-5./18.*GK(1,2)*GK(1,2)*XWB
        CC212(7)=0.
        CC212(8)=9./2.*GK(1,2)*GK(1,2)*XWB
        CC212(9)=-3.*GK(1,2)*GK(1,2)*XWB      
        CC212(10)=-2.*GK(1,2)*HK(1,2)*XCB*XWB      
        CC212(11)=0.
        CC212(12)=2.*GK(1,2)*GK(1,2)*XWB      
        CC212(13)=2.*GK(1,2)*GK(1,2)*XWB      
        CC212(14)=0.
        CC212(15)=0.    
        CC212(16)=0.
        CC212(17)=0.
C
        X=(MCHA(1)/MSQU(2))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC212(1)=-GK(1,2)*HK(1,2)*XCB*XWA*2.*FN4-CC212(1)
         DSC212(2)=0.
         DSC212(3)=-3.*GK(1,2)*HK(1,2)*XCB*XWA*
     $                (FN3+FN4)-CC212(3)
         DSC212(4)=1./3.*GK(1,2)*GK(1,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC212(4)
         DSC212(5)=2./3.*GK(1,2)*GK(1,2)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.))-CC212(5)
         DSC212(6)=1./3.*GK(1,2)*GK(1,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC212(6)
         DSC212(7)=0.
         DSC212(8)=6.*GK(1,2)*GK(1,2)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.))-CC212(8)
         DSC212(9)=-6.*GK(1,2)*GK(1,2)*XWA*FN4-CC212(9)          
        ELSE
         DSC212(1)=GK(1,2)*HK(1,2)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC212(1)
         DSC212(2)=0.
         DSC212(3)=GK(1,2)*HK(1,2)*XCB*XWA*
     $               (-3./2.+YPS)-CC212(3) 
         DSC212(4)=GK(1,2)*GK(1,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC212(4) 
         DSC212(5)=GK(1,2)*GK(1,2)*XWA*
     $               (-1./6.+1./30.*YPS)-CC212(5)
         DSC212(6)=GK(1,2)*GK(1,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC212(6) 
         DSC212(7)=0.
         DSC212(8)=GK(1,2)*GK(1,2)*XWA*
     $               (1.-3./4.*YPS)-CC212(8)
         DSC212(9)=GK(1,2)*GK(1,2)*XWA*
     $             (-1.+1./2.*YPS)-CC212(9)
        ENDIF
C                                                                        
        c3c12nai=-1./2.*(CC212(1)+DSC212(1))
     $          +(CC212(3)+DSC212(3))
     $          -1./2.*(CC212(4)+DSC212(4))
     $          -1./4.*(CC212(5)+DSC212(5))
     $          +1./4.*(CC212(7)+DSC212(7))
     $          -1./4.*(CC212(9)+DSC212(9))                  
c
        XWA=(MW/MSQU(3))**2
        XCB=MCHA(1)/MBQ
        CC113(1)=-HK(1,3)*XCB*XWA
        CC113(2)=0.
        CC113(3)=3.*HK(1,3)*XCB*XWA
        CC113(4)=5./18.*GK(1,3)*XWA
        CC113(5)=-2./9.*GK(1,3)*XWA
        CC113(6)=5./18.*GK(1,3)*XWA
        CC113(7)=0.
        CC113(8)=-3./2.*GK(1,3)*XWA
        CC113(9)=-3.*GK(1,3)*XWA         
c
        X=(MCHA(1)/MSQU(3))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC113(1)=-HK(1,3)*XCB*XWA*(2.*FN4-1.)
         DSC113(2)=0.
         DSC113(3)=-3.*HK(1,3)*XCB*XWA*
     $               (FN3+FN4+1.+2.*LOG(SCALE/MSQU(3)))
         DSC113(4)=1./3.*GK(1,3)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC113(5)=2./3.*GK(1,3)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.)+1./3.)
         DSC113(6)=1./3.*GK(1,3)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC113(7)=0.
         DSC113(8)=6.*GK(1,3)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.)+1./4.+
     $                2./3.*LOG(SCALE/MSQU(3)))
         DSC113(9)=-6.*GK(1,3)*XWA*(FN4-1./2.)
        ELSE
         DSC113(1)=HK(1,3)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC113(1)
         DSC113(2)=0.
         DSC113(3)=HK(1,3)*XCB*XWA*
     $               (-3./2.+YPS
     $             -6.*LOG(SCALE/MSQU(3)))-CC113(3) 
         DSC113(4)=GK(1,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC113(4) 
         DSC113(5)=GK(1,3)*XWA*
     $               (-1./6.+1./30.*YPS)-CC113(5)
         DSC113(6)=GK(1,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC113(6) 
         DSC113(7)=0.
         DSC113(8)=GK(1,3)*XWA*
     $               (1.-3./4.*YPS
     $               + 4.*LOG(SCALE/MSQU(3)))-CC113(8)
         DSC113(9)=GK(1,3)*XWA*
     $             (-1.+1./2.*YPS)-CC113(9)
        ENDIF
C                                                                              
        XWB=(MW/MCHA(1))**2
        XCB=MCHA(1)/MBQ
        CC213(1)=-HK(1,3)*XCB*XWB
        CC213(2)=0.
        CC213(3)=-3.*HK(1,3)*XCB*XWB
        CC213(4)=-5./18.*GK(1,3)*XWB
        CC213(5)=11./9.*GK(1,3)*XWB
        CC213(6)=-5./18.*GK(1,3)*XWB
        CC213(7)=0.
        CC213(8)=9./2.*GK(1,3)*XWB
        CC213(9)=-3.*GK(1,3)*XWB      
        CC213(10)=-2.*HK(1,3)*XCB*XWB      
        CC213(11)=0.
        CC213(12)=2.*GK(1,3)*XWB      
        CC213(13)=2.*GK(1,3)*XWB      
        CC213(14)=0.
        CC213(15)=0.    
        CC213(16)=0.
        CC213(17)=0.
C
        X=(MCHA(1)/MSQU(3))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC213(1)=-HK(1,3)*XCB*XWA*2.*FN4-CC213(1)
         DSC213(2)=0.
         DSC213(3)=-3.*HK(1,3)*XCB*XWA*
     $                (FN3+FN4)-CC213(3)
         DSC213(4)=1./3.*GK(1,3)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC213(4)
         DSC213(5)=2./3.*GK(1,3)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.))-CC213(5)
         DSC213(6)=1./3.*GK(1,3)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC213(6)
         DSC213(7)=0.
         DSC213(8)=6.*GK(1,3)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.))-CC213(8)
         DSC213(9)=-6.*GK(1,3)*XWA*FN4-CC213(9)          
        ELSE
         DSC213(1)=HK(1,3)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC213(1)
         DSC213(2)=0.
         DSC213(3)=HK(1,3)*XCB*XWA*
     $               (-3./2.+YPS)-CC213(3) 
         DSC213(4)=GK(1,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC213(4) 
         DSC213(5)=GK(1,3)*XWA*
     $               (-1./6.+1./30.*YPS)-CC213(5)
         DSC213(6)=GK(1,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC213(6) 
         DSC213(7)=0.
         DSC213(8)=GK(1,3)*XWA*
     $               (1.-3./4.*YPS)-CC213(8)
         DSC213(9)=GK(1,3)*XWA*
     $             (-1.+1./2.*YPS)-CC213(9)
        ENDIF
c
        c3c13nai=-1./2.*(CC213(1)+DSC213(1))
     $          +(CC213(3)+DSC213(3))
     $          -1./2.*(CC213(4)+DSC213(4))
     $          -1./4.*(CC213(5)+DSC213(5))
     $          +1./4.*(CC213(7)+DSC213(7))
     $          -1./4.*(CC213(9)+DSC213(9))                    
c
        IF(MCHA(2).GT.MW) THEN
         SCALE=MCHA(2)
        ELSE
         SCALE=MW
        ENDIF
C
        XWA=(MW/MSQU(1))**2
        XCB=MCHA(2)/MBQ
        CC121(1)=-GK(2,1)*HK(2,1)*XCB*XWA
        CC121(2)=0.
        CC121(3)=3.*GK(2,1)*HK(2,1)*XCB*XWA
        CC121(4)=5./18.*GK(2,1)*GK(2,1)*XWA
        CC121(5)=-2./9.*GK(2,1)*GK(2,1)*XWA
        CC121(6)=5./18.*GK(2,1)*GK(2,1)*XWA
        CC121(7)=0.
        CC121(8)=-3./2.*GK(2,1)*GK(2,1)*XWA
        CC121(9)=-3.*GK(2,1)*GK(2,1)*XWA         
c
        X=(MCHA(2)/MSQU(1))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC121(1)=-GK(2,1)*HK(2,1)*XCB*XWA*(2.*FN4-1.)
         DSC121(2)=0.
         DSC121(3)=-3.*GK(2,1)*HK(2,1)*XCB*XWA*
     $               (FN3+FN4+1.+2.*LOG(SCALE/MSQU(1)))
         DSC121(4)=1./3.*GK(2,1)*GK(2,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC121(5)=2./3.*GK(2,1)*GK(2,1)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.)+1./3.)
         DSC121(6)=1./3.*GK(2,1)*GK(2,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC121(7)=0.
         DSC121(8)=6.*GK(2,1)*GK(2,1)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.)+1./4.+
     $                2./3.*LOG(SCALE/MSQU(1)))
         DSC121(9)=-6.*GK(2,1)*GK(2,1)*XWA*(FN4-1./2.)
        ELSE
         DSC121(1)=GK(2,1)*HK(2,1)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC121(1)
         DSC121(2)=0.
         DSC121(3)=GK(2,1)*HK(2,1)*XCB*XWA*
     $               (-3./2.+YPS
     $             -6.*LOG(SCALE/MSQU(1)))-CC121(3) 
         DSC121(4)=GK(2,1)*GK(2,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC121(4) 
         DSC121(5)=GK(2,1)*GK(2,1)*XWA*
     $               (-1./6.+1./30.*YPS)-CC121(5)
         DSC121(6)=GK(2,1)*GK(2,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC121(6) 
         DSC121(7)=0.
         DSC121(8)=GK(2,1)*GK(2,1)*XWA*
     $               (1.-3./4.*YPS
     $               + 4.*LOG(SCALE/MSQU(1)))-CC121(8)
         DSC121(9)=GK(2,1)*GK(2,1)*XWA*
     $             (-1.+1./2.*YPS)-CC121(9)
        ENDIF
C                                                                        
        XWB=(MW/MCHA(2))**2
        XCB=MCHA(2)/MBQ
        CC221(1)=-GK(2,1)*HK(2,1)*XCB*XWB
        CC221(2)=0.
        CC221(3)=-3.*GK(2,1)*HK(2,1)*XCB*XWB
        CC221(4)=-5./18.*GK(2,1)*GK(2,1)*XWB
        CC221(5)=11./9.*GK(2,1)*GK(2,1)*XWB
        CC221(6)=-5./18.*GK(2,1)*GK(2,1)*XWB
        CC221(7)=0.
        CC221(8)=9./2.*GK(2,1)*GK(2,1)*XWB
        CC221(9)=-3.*GK(2,1)*GK(2,1)*XWB      
        CC221(10)=-2.*GK(2,1)*HK(2,1)*XCB*XWB      
        CC221(11)=0.
        CC221(12)=2.*GK(2,1)*GK(2,1)*XWB      
        CC221(13)=2.*GK(2,1)*GK(2,1)*XWB      
        CC221(14)=0.
        CC221(15)=0.    
        CC221(16)=0.
        CC221(17)=0.
C
        X=(MCHA(2)/MSQU(1))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC221(1)=-GK(2,1)*HK(2,1)*XCB*XWA*2.*FN4-CC221(1)
         DSC221(2)=0.
         DSC221(3)=-3.*GK(2,1)*HK(2,1)*XCB*XWA*
     $                (FN3+FN4)-CC221(3)
         DSC221(4)=1./3.*GK(2,1)*GK(2,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC221(4)
         DSC221(5)=2./3.*GK(2,1)*GK(2,1)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.))-CC221(5)
         DSC221(6)=1./3.*GK(2,1)*GK(2,1)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC221(6)
         DSC221(7)=0.
         DSC221(8)=6.*GK(2,1)*GK(2,1)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.))-CC221(8)
         DSC221(9)=-6.*GK(2,1)*GK(2,1)*XWA*FN4-CC221(9)                  
        ELSE
         DSC221(1)=GK(2,1)*HK(2,1)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC221(1)
         DSC221(2)=0.
         DSC221(3)=GK(2,1)*HK(2,1)*XCB*XWA*
     $               (-3./2.+YPS)-CC221(3) 
         DSC221(4)=GK(2,1)*GK(2,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC221(4) 
         DSC221(5)=GK(2,1)*GK(2,1)*XWA*
     $               (-1./6.+1./30.*YPS)-CC221(5)
         DSC221(6)=GK(2,1)*GK(2,1)*XWA*
     $               (1./6.-1./20.*YPS)-CC221(6) 
         DSC221(7)=0.
         DSC221(8)=GK(2,1)*GK(2,1)*XWA*
     $               (1.-3./4.*YPS)-CC221(8)
         DSC221(9)=GK(2,1)*GK(2,1)*XWA*
     $             (-1.+1./2.*YPS)-CC221(9)
        ENDIF
c
        c3c21nai=-1./2.*(CC221(1)+DSC221(1))
     $          +(CC221(3)+DSC221(3))
     $          -1./2.*(CC221(4)+DSC221(4))
     $          -1./4.*(CC221(5)+DSC221(5))
     $          +1./4.*(CC221(7)+DSC221(7))
     $          -1./4.*(CC221(9)+DSC221(9))                         
C
        XWA=(MW/MSQU(2))**2
        XCB=MCHA(2)/MBQ
        CC122(1)=-GK(2,2)*HK(2,2)*XCB*XWA
        CC122(2)=0.
        CC122(3)=3.*GK(2,2)*HK(2,2)*XCB*XWA
        CC122(4)=5./18.*GK(2,2)*GK(2,2)*XWA
        CC122(5)=-2./9.*GK(2,2)*GK(2,2)*XWA
        CC122(6)=5./18.*GK(2,2)*GK(2,2)*XWA
        CC122(7)=0.
        CC122(8)=-3./2.*GK(2,2)*GK(2,2)*XWA
        CC122(9)=-3.*GK(2,2)*GK(2,2)*XWA         
c
        X=(MCHA(2)/MSQU(2))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC122(1)=-GK(2,2)*HK(2,2)*XCB*XWA*(2.*FN4-1.)
         DSC122(2)=0.
         DSC122(3)=-3.*GK(2,2)*HK(2,2)*XCB*XWA*
     $               (FN3+FN4+1.+2.*LOG(SCALE/MSQU(2)))
         DSC122(4)=1./3.*GK(2,2)*GK(2,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC122(5)=2./3.*GK(2,2)*GK(2,2)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.)+1./3.)
         DSC122(6)=1./3.*GK(2,2)*GK(2,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC122(7)=0.
         DSC122(8)=6.*GK(2,2)*GK(2,2)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.)+1./4.+
     $                2./3.*LOG(SCALE/MSQU(2)))
         DSC122(9)=-6.*GK(2,2)*GK(2,2)*XWA*(FN4-1./2.)
        ELSE
         DSC122(1)=GK(2,2)*HK(2,2)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC122(1)
         DSC122(2)=0.
         DSC122(3)=GK(2,2)*HK(2,2)*XCB*XWA*
     $               (-3./2.+YPS
     $             -6.*LOG(SCALE/MSQU(2)))-CC122(3) 
         DSC122(4)=GK(2,2)*GK(2,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC122(4) 
         DSC122(5)=GK(2,2)*GK(2,2)*XWA*
     $               (-1./6.+1./30.*YPS)-CC122(5)
         DSC122(6)=GK(2,2)*GK(2,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC122(6) 
         DSC122(7)=0.
         DSC122(8)=GK(2,2)*GK(2,2)*XWA*
     $               (1.-3./4.*YPS
     $               + 4.*LOG(SCALE/MSQU(2)))-CC122(8)
         DSC122(9)=GK(2,2)*GK(2,2)*XWA*
     $             (-1.+1./2.*YPS)-CC122(9)
        ENDIF
C                                                                       
        XWB=(MW/MCHA(2))**2
        XCB=MCHA(2)/MBQ
        CC222(1)=-GK(2,2)*HK(2,2)*XCB*XWB
        CC222(2)=0.
        CC222(3)=-3.*GK(2,2)*HK(2,2)*XCB*XWB
        CC222(4)=-5./18.*GK(2,2)*GK(2,2)*XWB
        CC222(5)=11./9.*GK(2,2)*GK(2,2)*XWB
        CC222(6)=-5./18.*GK(2,2)*GK(2,2)*XWB
        CC222(7)=0.
        CC222(8)=9./2.*GK(2,2)*GK(2,2)*XWB
        CC222(9)=-3.*GK(2,2)*GK(2,2)*XWB      
        CC222(10)=-2.*GK(2,2)*HK(2,2)*XCB*XWB      
        CC222(11)=0.
        CC222(12)=2.*GK(2,2)*GK(2,2)*XWB      
        CC222(13)=2.*GK(2,2)*GK(2,2)*XWB      
        CC222(14)=0.
        CC222(15)=0.    
        CC222(16)=0.
        CC222(17)=0.
C
        X=(MCHA(2)/MSQU(2))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC222(1)=-GK(2,2)*HK(2,2)*XCB*XWA*2.*FN4-CC222(1)
         DSC222(2)=0.
         DSC222(3)=-3.*GK(2,2)*HK(2,2)*XCB*XWA*
     $                (FN3+FN4)-CC222(3)
         DSC222(4)=1./3.*GK(2,2)*GK(2,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC222(4)
         DSC222(5)=2./3.*GK(2,2)*GK(2,2)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.))-CC222(5)
         DSC222(6)=1./3.*GK(2,2)*GK(2,2)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC222(6)
         DSC222(7)=0.
         DSC222(8)=6.*GK(2,2)*GK(2,2)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.))-CC222(8)
         DSC222(9)=-6.*GK(2,2)*GK(2,2)*XWA*FN4-CC222(9)          
        ELSE
         DSC222(1)=GK(2,2)*HK(2,2)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC222(1)
         DSC222(2)=0.
         DSC222(3)=GK(2,2)*HK(2,2)*XCB*XWA*
     $               (-3./2.+YPS)-CC222(3) 
         DSC222(4)=GK(2,2)*GK(2,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC222(4) 
         DSC222(5)=GK(2,2)*GK(2,2)*XWA*
     $               (-1./6.+1./30.*YPS)-CC222(5)
         DSC222(6)=GK(2,2)*GK(2,2)*XWA*
     $               (1./6.-1./20.*YPS)-CC222(6) 
         DSC222(7)=0.
         DSC222(8)=GK(2,2)*GK(2,2)*XWA*
     $               (1.-3./4.*YPS)-CC222(8)
         DSC222(9)=GK(2,2)*GK(2,2)*XWA*
     $             (-1.+1./2.*YPS)-CC222(9)
        ENDIF
c       
        c3c22nai=-1./2.*(CC222(1)+DSC222(1))
     $          +(CC222(3)+DSC222(3))
     $          -1./2.*(CC222(4)+DSC222(4))
     $          -1./4.*(CC222(5)+DSC222(5))
     $          +1./4.*(CC222(7)+DSC222(7))
     $          -1./4.*(CC222(9)+DSC222(9))                               
c
        XWA=(MW/MSQU(3))**2
        XCB=MCHA(2)/MBQ
        CC123(1)=-HK(2,3)*XCB*XWA
        CC123(2)=0.
        CC123(3)=3.*HK(2,3)*XCB*XWA
        CC123(4)=5./18.*GK(2,3)*XWA
        CC123(5)=-2./9.*GK(2,3)*XWA
        CC123(6)=5./18.*GK(2,3)*XWA
        CC123(7)=0.
        CC123(8)=-3./2.*GK(2,3)*XWA
        CC123(9)=-3.*GK(2,3)*XWA         
c
        X=(MCHA(2)/MSQU(3))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4)
        IF(ABS(YPS).GT.0.05) THEN
         DSC123(1)=-HK(2,3)*XCB*XWA*(2.*FN4-1.)
         DSC123(2)=0.
         DSC123(3)=-3.*HK(2,3)*XCB*XWA*
     $               (FN3+FN4+1.+2.*LOG(SCALE/MSQU(3)))
         DSC123(4)=1./3.*GK(2,3)*XWA*
     $               (4.*FN2-FN3+2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC123(5)=2./3.*GK(2,3)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.)+1./3.)
         DSC123(6)=1./3.*GK(2,3)*XWA*
     $              (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.)-5./6.)
         DSC123(7)=0.
         DSC123(8)=6.*GK(2,3)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.)+1./4.+
     $                2./3.*LOG(SCALE/MSQU(3)))
         DSC123(9)=-6.*GK(2,3)*XWA*(FN4-1./2.)
        ELSE
         DSC123(1)=HK(2,3)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC123(1)
         DSC123(2)=0.
         DSC123(3)=HK(2,3)*XCB*XWA*
     $               (-3./2.+YPS
     $             -6.*LOG(SCALE/MSQU(3)))-CC123(3) 
         DSC123(4)=GK(2,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC123(4) 
         DSC123(5)=GK(2,3)*XWA*
     $               (-1./6.+1./30.*YPS)-CC123(5)
         DSC123(6)=GK(2,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC123(6) 
         DSC123(7)=0.
         DSC123(8)=GK(2,3)*XWA*
     $               (1.-3./4.*YPS
     $               + 4.*LOG(SCALE/MSQU(3)))-CC123(8)
         DSC123(9)=GK(2,3)*XWA*
     $             (-1.+1./2.*YPS)-CC123(9)
        ENDIF
C                                                                       
        XWB=(MW/MCHA(2))**2
        XCB=MCHA(2)/MBQ
        CC223(1)=-HK(2,3)*XCB*XWB
        CC223(2)=0.
        CC223(3)=-3.*HK(2,3)*XCB*XWB
        CC223(4)=-5./18.*GK(2,3)*XWB
        CC223(5)=11./9.*GK(2,3)*XWB
        CC223(6)=-5./18.*GK(2,3)*XWB
        CC223(7)=0.
        CC223(8)=9./2.*GK(2,3)*XWB
        CC223(9)=-3.*GK(2,3)*XWB      
        CC223(10)=-2.*HK(2,3)*XCB*XWB      
        CC223(11)=0.
        CC223(12)=2.*GK(2,3)*XWB      
        CC223(13)=2.*GK(2,3)*XWB      
        CC223(14)=0.
        CC223(15)=0.    
        CC223(16)=0.
        CC223(17)=0.
C
        X=(MCHA(2)/MSQU(3))**2
        YPS=X-1.
        CALL FUNS(X,FN1,FN2,FN3,FN4) 
        IF(ABS(YPS).GT.0.05) THEN
         DSC223(1)=-HK(2,3)*XCB*XWA*2.*FN4-CC223(1)
         DSC223(2)=0.
         DSC223(3)=-3.*HK(2,3)*XCB*XWA*
     $                (FN3+FN4)-CC223(3)
         DSC223(4)=1./3.*GK(2,3)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC223(4)
         DSC223(5)=2./3.*GK(2,3)*XWA*
     $               (2.*FN2+FN3+2.*FN4-LOG(X)/(X-1.))-CC223(5)
         DSC223(6)=1./3.*GK(2,3)*XWA*
     $               (4.*FN2-FN3-2.*FN4+LOG(X)/(X-1.))-CC223(6)
         DSC223(7)=0.
         DSC223(8)=6.*GK(2,3)*XWA*
     $               (1./2.*FN3+FN4-LOG(X)/6./(X-1.))-CC223(8)
         DSC223(9)=-6.*GK(2,3)*XWA*FN4-CC223(9)          
        ELSE
         DSC223(1)=HK(2,3)*XCB*XWA*
     $               (-1./3.+1./6.*YPS)-CC223(1)
         DSC223(2)=0.
         DSC223(3)=HK(2,3)*XCB*XWA*
     $               (-3./2.+YPS)-CC223(3) 
         DSC223(4)=GK(2,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC223(4) 
         DSC223(5)=GK(2,3)*XWA*
     $               (-1./6.+1./30.*YPS)-CC223(5)
         DSC223(6)=GK(2,3)*XWA*
     $               (1./6.-1./20.*YPS)-CC223(6) 
         DSC223(7)=0.
         DSC223(8)=GK(2,3)*XWA*
     $               (1.-3./4.*YPS)-CC223(8)
         DSC223(9)=GK(2,3)*XWA*
     $             (-1.+1./2.*YPS)-CC223(9)
        ENDIF
c       
        c3c23nai=-1./2.*(CC223(1)+DSC223(1))
     $          +(CC223(3)+DSC223(3))
     $          -1./2.*(CC223(4)+DSC223(4))
     $          -1./4.*(CC223(5)+DSC223(5))
     $          +1./4.*(CC223(7)+DSC223(7))
     $          -1./4.*(CC223(9)+DSC223(9))                           

C-----EVOLVE BACK PAST WEAK SCALE TO Q=1 GEV-------------------------
C
      TZ=LOG(1./MGUT)
      DT=TZ/FLOAT(NSTEP)
C
      DO II=1,NSTEP+2   
        T=    DT*FLOAT(II-1)
        Q   = MGUT*EXP(T)
        QNEW= MGUT*EXP(T+dt)
C
        RMIX(1)=0.
        RMIX(2)=0.  
        SMIX(1)=0.
        SMIX(2)=0.  
        SMIX(3)=0.
        SMIX(4)=0.  
        SMIX(5)=0.
        SMIX(6)=0.  
        ABMIX(1)=0.
        ABMIX(2)=0.      
C
        CALL RKSTP(137,DT,T,G,ALL,W2)
        G3=G(3)
C
        ALES=G(3)**2/4./PI
        ALEL=SUALFE(MW**2)
c
c_____ b->s gamma branching ratio ______________________________
c----- a) calculate the Wilson coefficients at MW --------------
C
c ...  SM contribution
       IF(Q.LT.MT.AND.Q.GT.MW) THEN
        CALL RKSTP(9,DT,T,CSM,GAMMASM,WSM)
       ENDIF

       IF(Q.GT.MW.AND.QNEW.LT.MW) THEN  
         CSM(1)=CSM(1)+DSSM(1)
         CSM(2)=CSM(2)+DSSM(2)
         CSM(3)=CSM(3)+DSSM(3)       
         CSM(4)=CSM(4)+2./9.+DSSM(4)
         CSM(5)=CSM(5)-7./9.+DSSM(5)
         CSM(6)=CSM(6)+2./9.+DSSM(6)
         CSM(7)=CSM(7)+1.+DSSM(7)
         CSM(8)=CSM(8)-3./2.+DSSM(8)
         CSM(9)=CSM(9)+9.+DSSM(9)             
       ENDIF
        C2SMEFF=-1./2.*CSM(1)+CSM(2)-1./2.*CSM(4)-1./4.*CSM(5)
     $          +1./4.*CSM(7)            
        C3SMEFF=-1./2.*CSM(1)+CSM(3)-1./2.*CSM(4)-1./4.*CSM(5)
     $          +1./4.*CSM(7)-1./4.*CSM(9) 
     
     

C ...  CH (charged higgs) contribution  
C
       IF(Q.GT.MHPLUS.AND.QNEW.LT.MHPLUS) THEN
        G3MHP=G(3)
        X=(MT/MHPLUS)**2
        CH2(11)=-1./2.*X/TANB**2
        CH2(17)=16*PI**2*X/G3MHP**2
       ENDIF
C       
       IF(MHPLUS.LT.MT) THEN
        IF(Q.LT.MT.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CH1,GAMMASM,WHP1)     
         IF(Q.GT.MHPLUS.AND.QNEW.LE.MHPLUS) THEN
          CH1(1)=CH1(1)+DSH1(1)   
          CH1(2)=CH1(2)+DSH1(2)
          CH1(3)=CH1(3)+DSH1(3)
          CH1(4)=CH1(4)+DSH1(4)
          CH1(5)=CH1(5)+DSH1(5)
          CH1(6)=CH1(6)+DSH1(6)
          CH1(7)=CH1(7)+DSH1(7)
          CH1(8)=CH1(8)+DSH1(8)
          CH1(9)=CH1(9)+DSH1(9)    
         ENDIF
         C2HPEFF=-1./2.*CH1(1)+CH1(2)-1./2.*CH1(4)-1./4.*CH1(5)
     $           +1./4.*CH1(7)      
         C3HPEFF=-1./2.*CH1(1)+CH1(3)-1./2.*CH1(4)-1./4.*CH1(5)
     $           +1./4.*CH1(7)-1./4.*CH1(9)       
        ENDIF
       ELSE
        IF(Q.LT.MHPLUS.AND.Q.GT.MT) THEN
         CALL RKSTP(19,DT,T,CH2,GAMMAHP,WHP2)     
          SMIX(1)=CH2(10)
          SMIX(2)=CH2(11)
          SMIX(3)=CH2(12)
          SMIX(4)=CH2(13)
          SMIX(5)=CH2(14)
          SMIX(6)=CH2(15)
C
         IF(Q.GT.MT.AND.QNEW.LE.MT) THEN
          CH2(1)=CH2(1)+DSH2(1) 
          CH2(2)=CH2(2)+DSH2(2)
          CH2(3)=CH2(3)+DSH2(3)
          CH2(4)=CH2(4)+DSH2(4)
          CH2(5)=CH2(5)+DSH2(5)
          CH2(6)=CH2(6)+DSH2(6)
          CH2(7)=CH2(7)+DSH2(7)
          CH2(8)=CH2(8)+DSH2(8)
          CH2(9)=CH2(9)+DSH2(9)    
         ENDIF
        ENDIF                           
C       
       IF(Q.LT.MT.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CH2,GAMMASM,WHP2)    
C
         C2HPEFF=-1./2.*CH2(1)+CH2(2)-1./2.*CH2(4)-1./4.*CH2(5)
     $          +1./4.*CH2(7)       
         C3HPEFF=-1./2.*CH2(1)+CH2(3)-1./2.*CH2(4)-1./4.*CH2(5)
     $          +1./4.*CH2(7)-1./4.*CH2(9) 
        
	ENDIF
       ENDIF
C ...  chargino(1)-squark(1) contribution  
       MSQ=MSQU(1)
       MCH=MCHA(1)    
C
       IF(Q.GT.MSQ.AND.QNEW.LE.MSQ) THEN
        G3SS=G(3)
        X=(MW/MSQU(1))**2
        Y=MCHA(1)/MBQ
        CC111(10)=GK(1,1)*HK(1,1)*16.*PI**2*X*Y/G3SS**2
        CC111(11)=GK(1,1)*HK(1,1)*16.*PI**2*X*Y/G3SS**2
        CC111(12)=-GK(1,1)*GK(1,1)*16.*PI**2*X/G3SS**2
       ENDIF    
C
       IF(MSQU(1).GT.MCHA(1)) THEN
        IF(MCHA(1).GT.(MW+0.5)) THEN
         QMAX=MCH
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MSQ.AND.Q.GT.QMAX) THEN  
         CALL RKSTP(12,DT,T,CC111,GAMMAC1,WSC111)        
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LT.QMAX) THEN
         CC111(1)=CC111(1)+DSC111(1)        
         CC111(2)=CC111(2)+DSC111(2)
         CC111(3)=CC111(3)+DSC111(3)
         CC111(4)=CC111(4)+DSC111(4)
         CC111(5)=CC111(5)+DSC111(5)
         CC111(6)=CC111(6)+DSC111(6)
         CC111(7)=CC111(7)+DSC111(7)
         CC111(8)=CC111(8)+DSC111(8)
         CC111(9)=CC111(9)+DSC111(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,C111,GAMMASM,WSC111)       
        ENDIF
c
         C2C11EFF=-1./2.*CC111(1)+CC111(2)
     $          -1./2.*CC111(4)-1./4.*CC111(5)
     $          +1./4.*CC111(7)       
         C3C11EFF=-1./2.*CC111(1)+CC111(3)
     $          -1./2.*CC111(4)-1./4.*CC111(5)
     $          +1./4.*CC111(7)-1./4.*CC111(9)       
       ELSE 
        IF(Q.LT.MCH.AND.Q.GT.MSQ) THEN
         SWI1=1.
        ELSE
         SWI1=0.
        ENDIF              
        RMIX(1)=RMIX(1)+SWI1*CC211(13)
        RMIX(2)=RMIX(2)+SWI1*CC211(14)       
        IF(MSQU(1).GT.MT) THEN
         SMIX(1)=0.
         SMIX(2)=0.
         SMIX(3)=0.
         SMIX(4)=0.
         SMIX(5)=0.
         SMIX(6)=0.
        ENDIF
        IF(Q.LT.MCHA(1).AND.Q.GT.MSQU(2)) THEN
         SWI2=1.
        ELSE
         SWI2=0.
        ENDIF                
        IF(Q.LT.MCHA(1).AND.Q.GT.MSQU(3)) THEN
         SWI3=1.
        ELSE
         SWI3=0.
        ENDIF                
        ABMIX(1)=SWI2*CC212(13)+SWI3*CC213(13)
        ABMIX(2)=SWI2*CC212(14)+SWI3*CC213(14)
C 
        IF(MSQU(1).GT.(MW+0.5)) THEN
         QMAX=MSQ
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MCH.AND.Q.GT.QMAX) THEN
         CALL RKSTP(17,DT,T,CC211,GAMMAC2,WSC211)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LT.QMAX) THEN
         CC211(1)=CC211(1)+DSC211(1)        
         CC211(2)=CC211(2)+DSC211(2)
         CC211(3)=CC211(3)+DSC211(3)
         CC211(4)=CC211(4)+DSC211(4)
         CC211(5)=CC211(5)+DSC211(5)
         CC211(6)=CC211(6)+DSC211(6)
         CC211(7)=CC211(7)+DSC211(7)
         CC211(8)=CC211(8)+DSC211(8)
         CC211(9)=CC211(9)+DSC211(9)        
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC211,GAMMASM,WSC211)      
        ENDIF                  
         C2C11EFF=-1./2.*CC211(1)+CC211(2)
     $           -1./2.*CC211(4)-1./4.*CC211(5)
     $           +1./4.*CC211(7)      
         C3C11EFF=-1./2.*CC211(1)+CC211(3)
     $           -1./2.*CC211(4)-1./4.*CC211(5)
     $           +1./4.*CC211(7)-1./4.*CC211(9)       
       ENDIF
C
C ...  chargino(1)-squark(2) contribution  
C

       MSQ=MSQU(2)
       MCH=MCHA(1)    
c
       IF(Q.GT.MSQ.AND.QNEW.LE.MSQ) THEN
        G3SS=G(3)
        X=(MW/MSQU(2))**2
        Y=MCHA(1)/MBQ
        CC112(10)=GK(1,2)*HK(1,2)*16.*PI**2*X*Y/G3SS**2
        CC112(11)=GK(1,2)*HK(1,2)*16.*PI**2*X*Y/G3SS**2
        CC112(12)=-GK(1,2)*GK(1,2)*16.*PI**2*X/G3SS**2
       ENDIF  
       
C
       IF(MSQU(2).GT.MCHA(1)) THEN
        IF(MCHA(1).GT.(MW+0.5)) THEN
         QMAX=MCH
        ELSE
         QMAX=MW
        ENDIF
	
	
        IF(Q.LT.MSQ.AND.Q.GT.QMAX) THEN
         CALL RKSTP(12,DT,T,CC112,GAMMAC1,WSC112)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LT.QMAX) THEN
         CC112(1)=CC112(1)+DSC112(1)        
         CC112(2)=CC112(2)+DSC112(2)
         CC112(3)=CC112(3)+DSC112(3)
         CC112(4)=CC112(4)+DSC112(4)
         CC112(5)=CC112(5)+DSC112(5)
         CC112(6)=CC112(6)+DSC112(6)
         CC112(7)=CC112(7)+DSC112(7)
         CC112(8)=CC112(8)+DSC112(8)
         CC112(9)=CC112(9)+DSC112(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC112,GAMMASM,WSC112)      
        ENDIF
         C2C12EFF=-1./2.*CC112(1)+CC112(2)
     $          -1./2.*CC112(4)-1./4.*CC112(5)
     $          +1./4.*CC112(7)       
         C3C12EFF=-1./2.*CC112(1)+CC112(3)
     $          -1./2.*CC112(4)-1./4.*CC112(5)
     $          +1./4.*CC112(7)-1./4.*CC112(9)
     
           
       ELSE 
        IF(Q.LT.MCH.AND.Q.GT.MSQ) THEN
         SWI1=1.
        ELSE
         SWI1=0.
        ENDIF              
        RMIX(1)=RMIX(1)+SWI1*CC212(13)
        RMIX(2)=RMIX(2)+SWI1*CC212(14)
        IF(MSQU(2).GT.MT) THEN
         SMIX(1)=0.
         SMIX(2)=0.
         SMIX(3)=0.
         SMIX(4)=0.
         SMIX(5)=0.
         SMIX(6)=0.
        ENDIF
        IF(Q.LT.MCHA(1).AND.Q.GT.MSQU(1)) THEN
         SWI2=1.
        ELSE
         SWI2=0.
        ENDIF                
        IF(Q.LT.MCHA(1).AND.Q.GT.MSQU(3)) THEN
         SWI3=1.
        ELSE
         SWI3=0.
        ENDIF                
        ABMIX(1)=SWI2*CC211(13)+SWI3*CC213(13)
        ABMIX(2)=SWI2*CC211(14)+SWI3*CC213(14)
C 
        IF(MSQU(2).GT.(MW+0.5)) THEN
         QMAX=MSQ
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MCH.AND.Q.GT.QMAX) THEN
         CALL RKSTP(17,DT,T,CC212,GAMMAC2,WSC212)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC212(1)=CC212(1)+DSC212(1)        
         CC212(2)=CC212(2)+DSC212(2)
         CC212(3)=CC212(3)+DSC212(3)
         CC212(4)=CC212(4)+DSC212(4)
         CC212(5)=CC212(5)+DSC212(5)
         CC212(6)=CC212(6)+DSC212(6)
         CC212(7)=CC212(7)+DSC212(7)
         CC212(8)=CC212(8)+DSC212(8)
         CC212(9)=CC212(9)+DSC212(9)        
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC212,GAMMASM,WSC212)      
        ENDIF                  
         C2C12EFF=-1./2.*CC212(1)+CC212(2)
     $           -1./2.*CC212(4)-1./4.*CC212(5)
     $           +1./4.*CC212(7)       
         C3C12EFF=-1./2.*CC212(1)+CC212(3)
     $           -1./2.*CC212(4)-1./4.*CC212(5)
     $           +1./4.*CC212(7)-1./4.*CC212(9) 
       ENDIF

  
C ...  chargino(1)-squark(3) contribution  
C
       MSQ=MSQU(3)
       MCH=MCHA(1)    
       IF(Q.GT.MSQ.AND.QNEW.LE.MSQ) THEN
        G3SS=G(3)
        X=(MW/MSQU(3))**2
        Y=MCHA(1)/MBQ
        CC113(10)=HK(1,3)*16.*PI**2*X*Y/G3SS**2
        CC113(11)=HK(1,3)*16.*PI**2*X*Y/G3SS**2
        CC113(12)=-GK(1,3)*16.*PI**2*X/G3SS**2
       ENDIF    
C
       IF(MSQU(3).GT.MCHA(1)) THEN
        IF(MCHA(1).GT.(MW+0.5)) THEN
         QMAX=MCH
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MSQ.AND.Q.GT.QMAX) THEN
         CALL RKSTP(12,DT,T,CC113,GAMMAC1,WSC113)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC113(1)=CC113(1)+DSC113(1)        
         CC113(2)=CC113(2)+DSC113(2)
         CC113(3)=CC113(3)+DSC113(3)
         CC113(4)=CC113(4)+DSC113(4)
         CC113(5)=CC113(5)+DSC113(5)
         CC113(6)=CC113(6)+DSC113(6)
         CC113(7)=CC113(7)+DSC113(7)
         CC113(8)=CC113(8)+DSC113(8)
         CC113(9)=CC113(9)+DSC113(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC113,GAMMASM,WSC113)      
        ENDIF
         C2C13EFF=-1./2.*CC113(1)+CC113(2)
     $          -1./2.*CC113(4)-1./4.*CC113(5)
     $          +1./4.*CC113(7)       
         C3C13EFF=-1./2.*CC113(1)+CC113(3)
     $          -1./2.*CC113(4)-1./4.*CC113(5)
     $          +1./4.*CC113(7)-1./4.*CC113(9)       
       ELSE 
        IF(Q.LT.MCH.AND.Q.GT.MSQ) THEN
         SWI1=1.
        ELSE
         SWI1=0.
        ENDIF              
        RMIX(1)=RMIX(1)+SWI1*CC213(13)
        RMIX(2)=RMIX(2)+SWI1*CC213(14)
        IF(MSQU(3).GT.MT) THEN
         SMIX(1)=0.
         SMIX(2)=0.
         SMIX(3)=0.
         SMIX(4)=0.
         SMIX(5)=0.
         SMIX(6)=0.
        ENDIF
        IF(Q.LT.MCHA(1).AND.Q.GT.MSQU(1)) THEN
         SWI2=1.
        ELSE
         SWI2=0.
        ENDIF                
        IF(Q.LT.MCHA(1).AND.Q.GT.MSQU(2)) THEN
         SWI3=1.
        ELSE
         SWI3=0.
        ENDIF                
        ABMIX(1)=SWI2*CC211(13)+SWI3*CC212(13)
        ABMIX(2)=SWI2*CC211(14)+SWI3*CC212(14)
C 
        IF(MSQU(3).GT.(MW+0.5)) THEN
         QMAX=MSQ
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MCH.AND.Q.GT.QMAX) THEN
         CALL RKSTP(17,DT,T,CC213,GAMMAC2,WSC213)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LT.QMAX) THEN
         CC213(1)=CC213(1)+DSC213(1)        
         CC213(2)=CC213(2)+DSC213(2)
         CC213(3)=CC213(3)+DSC213(3)
         CC213(4)=CC213(4)+DSC213(4)
         CC213(5)=CC213(5)+DSC213(5)
         CC213(6)=CC213(6)+DSC213(6)
         CC213(7)=CC213(7)+DSC213(7)
         CC213(8)=CC213(8)+DSC213(8)
         CC213(9)=CC213(9)+DSC213(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC213,GAMMASM,WSC213)      
        ENDIF                  
         C2C13EFF=-1./2.*CC213(1)+CC213(2)
     $           -1./2.*CC213(4)-1./4.*CC213(5)
     $           +1./4.*CC213(7)       
         C3C13EFF=-1./2.*CC213(1)+CC213(3)
     $           -1./2.*CC213(4)-1./4.*CC213(5)
     $           +1./4.*CC213(7)-1./4.*CC213(9)       
       ENDIF
C
C ...  chargino(2)-squark(1) contribution  
C
       MSQ=MSQU(1)
       MCH=MCHA(2)    
       IF(Q.GT.MSQ.AND.QNEW.LE.MSQ) THEN
        G3SS=G(3)
        X=(MW/MSQU(1))**2
        Y=MCHA(2)/MBQ
        CC121(10)=GK(2,1)*HK(2,1)*16.*PI**2*X*Y/G3SS**2
        CC121(11)=GK(2,1)*HK(2,1)*16.*PI**2*X*Y/G3SS**2
        CC121(12)=-GK(2,1)*GK(2,1)*16.*PI**2*X/G3SS**2
       ENDIF    
C
       IF(MSQU(1).GT.MCHA(2)) THEN
        IF(MCHA(2).GT.(MW+0.5)) THEN
         QMAX=MCH
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MSQ.AND.Q.GT.QMAX) THEN
         CALL RKSTP(12,DT,T,CC121,GAMMAC1,WSC121)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC121(1)=CC121(1)+DSC121(1)        
         CC121(2)=CC121(2)+DSC121(2)
         CC121(3)=CC121(3)+DSC121(3)
         CC121(4)=CC121(4)+DSC121(4)
         CC121(5)=CC121(5)+DSC121(5)
         CC121(6)=CC121(6)+DSC121(6)
         CC121(7)=CC121(7)+DSC121(7)
         CC121(8)=CC121(8)+DSC121(8)
         CC121(9)=CC121(9)+DSC121(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC121,GAMMASM,WSC121)      
        ENDIF
         C2C21EFF=-1./2.*CC121(1)+CC121(2)
     $          -1./2.*CC121(4)-1./4.*CC121(5)
     $          +1./4.*CC121(7)       
         C3C21EFF=-1./2.*CC121(1)+CC121(3)
     $          -1./2.*CC121(4)-1./4.*CC121(5)
     $          +1./4.*CC121(7)-1./4.*CC121(9)       
       ELSE 
        IF(Q.LT.MCH.AND.Q.GT.MSQ) THEN
         SWI1=1.
        ELSE
         SWI1=0.
        ENDIF              
        RMIX(1)=RMIX(1)+SWI1*CC221(13)
        RMIX(2)=RMIX(2)+SWI1*CC221(14)
        IF(MSQU(1).GT.MT) THEN
         SMIX(1)=0.
         SMIX(2)=0.
         SMIX(3)=0.
         SMIX(4)=0.
         SMIX(5)=0.
         SMIX(6)=0.
        ENDIF
        IF(Q.LT.MCHA(2).AND.Q.GT.MSQU(2)) THEN
         SWI2=1.
        ELSE
         SWI2=0.
        ENDIF                
        IF(Q.LT.MCHA(2).AND.Q.GT.MSQU(3)) THEN
         SWI3=1.
        ELSE
         SWI3=0.
        ENDIF                    
        ABMIX(1)=SWI2*CC222(13)+SWI3*CC223(13)
        ABMIX(2)=SWI2*CC222(14)+SWI3*CC223(14)
C 
        IF(MSQU(1).GT.MW) THEN
         QMAX=MSQ
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MCH.AND.Q.GT.QMAX) THEN
         CALL RKSTP(17,DT,T,CC221,GAMMAC2,WSC221)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC221(1)=CC221(1)+DSC221(1)        
         CC221(2)=CC221(2)+DSC221(2)
         CC221(3)=CC221(3)+DSC221(3)
         CC221(4)=CC221(4)+DSC221(4)
         CC221(5)=CC221(5)+DSC221(5)
         CC221(6)=CC221(6)+DSC221(6)
         CC221(7)=CC221(7)+DSC221(7)
         CC221(8)=CC221(8)+DSC221(8)
         CC221(9)=CC221(9)+DSC221(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC221,GAMMASM,WSC221)      
        ENDIF                  
         C2C21EFF=-1./2.*CC221(1)+CC221(2)
     $           -1./2.*CC221(4)-1./4.*CC221(5)
     $           +1./4.*CC221(7)      
         C3C21EFF=-1./2.*CC221(1)+CC221(3)
     $           -1./2.*CC221(4)-1./4.*CC221(5)
     $           +1./4.*CC221(7)-1./4.*CC221(9)       
       ENDIF
C
C ...  chargino(2)-squark(2) contribution  
C
       MSQ=MSQU(2)
       MCH=MCHA(2)    
       IF(Q.GT.MSQ.AND.QNEW.LE.MSQ) THEN
        G3SS=G(3)
        X=(MW/MSQU(2))**2
        Y=MCHA(2)/MBQ
        CC122(10)=GK(2,2)*HK(2,2)*16.*PI**2*X*Y/G3SS**2
        CC122(11)=GK(2,2)*HK(2,2)*16.*PI**2*X*Y/G3SS**2
        CC122(12)=-GK(2,2)*GK(2,2)*16.*PI**2*X/G3SS**2
       ENDIF    
C
       IF(MSQU(2).GT.MCHA(2)) THEN
        IF(MCHA(2).GT.(MW+0.5)) THEN
         QMAX=MCH
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MSQ.AND.Q.GT.QMAX) THEN
         CALL RKSTP(12,DT,T,CC122,GAMMAC1,WSC122)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC122(1)=CC122(1)+DSC122(1)        
         CC122(2)=CC122(2)+DSC122(2)
         CC122(3)=CC122(3)+DSC122(3)
         CC122(4)=CC122(4)+DSC122(4)
         CC122(5)=CC122(5)+DSC122(5)
         CC122(6)=CC122(6)+DSC122(6)
         CC122(7)=CC122(7)+DSC122(7)
         CC122(8)=CC122(8)+DSC122(8)
         CC122(9)=CC122(9)+DSC122(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC122,GAMMASM,WSC122)      
C
        ENDIF
         C2C22EFF=-1./2.*CC122(1)+CC122(2)
     $          -1./2.*CC122(4)-1./4.*CC122(5)
     $          +1./4.*CC122(7)           
         C3C22EFF=-1./2.*CC122(1)+CC122(3)
     $          -1./2.*CC122(4)-1./4.*CC122(5)
     $          +1./4.*CC122(7)-1./4.*CC122(9)           
       ELSE 
        IF(Q.LT.MCH.AND.Q.GT.MSQ) THEN
         SWI1=1.
        ELSE
         SWI1=0.
        ENDIF              
        RMIX(1)=RMIX(1)+SWI1*CC222(13)
        RMIX(2)=RMIX(2)+SWI1*CC222(14)
        IF(MSQU(2).GT.MT) THEN
         SMIX(1)=0.
         SMIX(2)=0.
         SMIX(3)=0.
         SMIX(4)=0.
         SMIX(5)=0.
         SMIX(6)=0.
        ENDIF
        IF(Q.LT.MCHA(2).AND.Q.GT.MSQU(1)) THEN
         SWI2=1.
        ELSE
         SWI2=0.
        ENDIF                
        IF(Q.LT.MCHA(2).AND.Q.GT.MSQU(3)) THEN
         SWI3=1.
        ELSE
         SWI3=0.
        ENDIF                    
        ABMIX(1)=SWI2*CC221(13)+SWI3*CC223(13)
        ABMIX(2)=SWI2*CC221(14)+SWI3*CC223(14)
C 
        IF(MSQU(2).GT.(MW+0.5)) THEN
         QMAX=MSQ
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MCH.AND.Q.GT.QMAX) THEN
         CALL RKSTP(17,DT,T,CC222,GAMMAC2,WSC222)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC222(1)=CC222(1)+DSC222(1)        
         CC222(2)=CC222(2)+DSC222(2)
         CC222(3)=CC222(3)+DSC222(3)
         CC222(4)=CC222(4)+DSC222(4)
         CC222(5)=CC222(5)+DSC222(5)
         CC222(6)=CC222(6)+DSC222(6)
         CC222(7)=CC222(7)+DSC222(7)
         CC222(8)=CC222(8)+DSC222(8)
         CC222(9)=CC222(9)+DSC222(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC222,GAMMASM,WSC222)      
        ENDIF                  
         C2C22EFF=-1./2.*CC222(1)+CC222(2)
     $           -1./2.*CC222(4)-1./4.*CC222(5)
     $           +1./4.*CC222(7)       
         C3C22EFF=-1./2.*CC222(1)+CC222(3)
     $           -1./2.*CC222(4)-1./4.*CC222(5)
     $           +1./4.*CC222(7)-1./4.*CC222(9)       
       ENDIF
C
C ...  chargino(2)-squark(3) contribution  
C
       MSQ=MSQU(3)
       MCH=MCHA(2)   
       IF(Q.GT.MSQ.AND.QNEW.LE.MSQ) THEN
        G3SS=G(3)
        X=(MW/MSQU(3))**2
        Y=MCHA(2)/MBQ
        CC123(10)=HK(2,3)*16.*PI**2*X*Y/G3SS**2
        CC123(11)=HK(2,3)*16.*PI**2*X*Y/G3SS**2
        CC123(12)=-GK(2,3)*16.*PI**2*X/G3SS**2
       ENDIF    
C
       IF(MSQU(3).GT.MCHA(2)) THEN
        IF(MCHA(2).GT.(MW+0.5)) THEN
         QMAX=MCH
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MSQ.AND.Q.GT.QMAX) THEN
         CALL RKSTP(12,DT,T,CC123,GAMMAC1,WSC123)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC123(1)=CC123(1)+DSC123(1)        
         CC123(2)=CC123(2)+DSC123(2)
         CC123(3)=CC123(3)+DSC123(3)
         CC123(4)=CC123(4)+DSC123(4)
         CC123(5)=CC123(5)+DSC123(5)
         CC123(6)=CC123(6)+DSC123(6)
         CC123(7)=CC123(7)+DSC123(7)
         CC123(8)=CC123(8)+DSC123(8)
         CC123(9)=CC123(9)+DSC123(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CC123,GAMMASM,WSC123)      
        ENDIF
         C2C23EFF=-1./2.*CC123(1)+CC123(2)
     $          -1./2.*CC123(4)-1./4.*CC123(5)
     $          +1./4.*CC123(7)       
         C3C23EFF=-1./2.*CC123(1)+CC123(3)
     $          -1./2.*CC123(4)-1./4.*CC123(5)
     $          +1./4.*CC123(7)-1./4.*CC123(9)       
       ELSE 
        IF(Q.LT.MCH.AND.Q.GT.MSQ) THEN
         SWI1=1.
        ELSE
         SWI1=0.
        ENDIF              
        RMIX(1)=RMIX(1)+SWI1*CC223(13)
        RMIX(2)=RMIX(2)+SWI1*CC223(14)
        IF(MSQU(3).GT.MT) THEN
         SMIX(1)=0.
         SMIX(2)=0.
         SMIX(3)=0.
         SMIX(4)=0.
         SMIX(5)=0.
         SMIX(6)=0.
        ENDIF
        IF(Q.LT.MCHA(2).AND.Q.GT.MSQU(1)) THEN
         SWI2=1.
        ELSE
         SWI2=0.
        ENDIF                
        IF(Q.LT.MCHA(2).AND.Q.GT.MSQU(2)) THEN
         SWI3=1.
        ELSE
         SWI3=0.
        ENDIF                    
        ABMIX(1)=SWI2*CC221(13)+SWI3*CC222(13)
        ABMIX(2)=SWI2*CC221(14)+SWI3*CC222(14)
C 
        IF(MSQU(3).GT.(MW+0.5)) THEN
         QMAX=MSQ
        ELSE
         QMAX=MW
        ENDIF
        IF(Q.LT.MCH.AND.Q.GT.QMAX) THEN
         CALL RKSTP(17,DT,T,CC223,GAMMAC2,WSC223)      
        ENDIF
        IF(Q.GT.QMAX.AND.QNEW.LE.QMAX) THEN
         CC223(1)=CC223(1)+DSC223(1)        
         CC223(2)=CC223(2)+DSC223(2)
         CC223(3)=CC223(3)+DSC223(3)
         CC223(4)=CC223(4)+DSC223(4)
         CC223(5)=CC223(5)+DSC223(5)
         CC223(6)=CC223(6)+DSC223(6)
         CC223(7)=CC223(7)+DSC223(7)
         CC223(8)=CC223(8)+DSC223(8)
         CC223(9)=CC223(9)+DSC223(9)
        ENDIF
        IF(QMAX.GT.MW.AND.Q.LT.QMAX.AND.Q.GT.MW) THEN
         CALL RKSTP(9,DT,T,CSC223,GAMMASM,WPO223)      
        ENDIF                  
         C2C23EFF=-1./2.*CC223(1)+CC223(2)
     $           -1./2.*CC223(4)-1./4.*CC223(5)
     $           +1./4.*CC223(7)       
         C3C23EFF=-1./2.*CC223(1)+CC223(3)
     $           -1./2.*CC223(4)-1./4.*CC223(5)
     $           +1./4.*CC223(7)-1./4.*CC223(9)       
       ENDIF
c
c ... gluino and neutralino contributions ...
c      must recall GLUNENO to set squark mass matrices
c
c
       IF(Q.GT.MW.AND.QNEW.LE.MW) THEN  

       CALL GLUNENO(G,GAM,AGE,AHE)
       CER=4./3.
       CEG=3.
       ALFA2=ALFAEM/SN2THW
       RALPH=ALES/ALFA2
       FACG7=6*(-1./3.)*RALPH*CER/(CKM(3,2)*CKM(3,3))
       FACG8=-RALPH/(CKM(3,2)*CKM(3,3))
       FACN7=3.*(-1./3.)/(CKM(3,2)*CKM(3,3))
       FACN8=-1./(CKM(3,2)*CKM(3,3))
C
C ...  gluino-dsquark1 ...
C              
       X=MGLU**2/MDSB(1)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3GS1EFF=FACG7*(MW/MDSB(1))**2*(GAM(3,1)*GAM(2,1)*FN2-
     $            GAM(6,1)*GAM(2,1)*MGLU/MBQ*FN4)
       
     
       C2GS1EFF=FACG8*(MW/MDSB(1))**2*(GAM(3,1)*GAM(2,1)*
     $            (-CEG*FN1+(2*CER-CEG)*FN2)-
     $            GAM(6,1)*GAM(2,1)*MGLU/MBQ*
     $            (-CEG*FN3+(2*CER-CEG)*FN4))
C
C ...  gluino-dsquark2 ...
C             
       X=MGLU**2/MDSB(2)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3GS2EFF=FACG7*(MW/MDSB(2))**2*(GAM(3,2)*GAM(2,2)*FN2-
     $            GAM(6,2)*GAM(2,2)*MGLU/MBQ*FN4)
       C2GS2EFF=FACG8*(MW/MDSB(2))**2*(GAM(3,2)*GAM(2,2)*
     $            (-CEG*FN1+(2*CER-CEG)*FN2)-
     $            GAM(6,2)*GAM(2,2)*MGLU/MBQ*
     $            (-CEG*FN3+(2*CER-CEG)*FN4))
C
C ...  gluino-dsquark3 ...
C       
C       
       X=MGLU**2/MDSB(3)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3GS3EFF=FACG7*(MW/MDSB(3))**2*(GAM(3,3)*GAM(2,3)*FN2-
     $            GAM(6,3)*GAM(2,3)*MGLU/MBQ*FN4)
       C2GS3EFF=FACG8*(MW/MDSB(3))**2*(GAM(3,3)*GAM(2,3)*
     $            (-CEG*FN1+(2*CER-CEG)*FN2)-
     $            GAM(6,3)*GAM(2,3)*MGLU/MBQ*
     $            (-CEG*FN3+(2*CER-CEG)*FN4))
C
C ...  gluino-dsquark4 ...
C       
       X=MGLU**2/MDSB(4)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3GS4EFF=FACG7*(MW/MDSB(4))**2*(GAM(3,4)*GAM(2,4)*FN2-
     $            GAM(6,4)*GAM(2,4)*MGLU/MBQ*FN4)
       C2GS4EFF=FACG8*(MW/MDSB(4))**2*(GAM(3,4)*GAM(2,4)*
     $            (-CEG*FN1+(2*CER-CEG)*FN2)-
     $            GAM(6,4)*GAM(2,4)*MGLU/MBQ*
     $            (-CEG*FN3+(2*CER-CEG)*FN4))
C
C ...  gluino-dsquark5 ...
C       
       X=MGLU**2/MDSB(5)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3GS5EFF=FACG7*(MW/MDSB(5))**2*(GAM(3,5)*GAM(2,5)*FN2-
     $            GAM(6,5)*GAM(2,5)*MGLU/MBQ*FN4)
       C2GS5EFF=FACG8*(MW/MDSB(5))**2*(GAM(3,5)*GAM(2,5)*
     $            (-CEG*FN1+(2*CER-CEG)*FN2)-
     $            GAM(6,5)*GAM(2,5)*MGLU/MBQ*
     $            (-CEG*FN3+(2*CER-CEG)*FN4))
C
C ...  gluino-dsquark6 ...
C       
       X=MGLU**2/MDSB(6)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3GS6EFF=FACG7*(MW/MDSB(6))**2*(GAM(3,6)*GAM(2,6)*FN2-
     $            GAM(6,6)*GAM(2,6)*MGLU/MBQ*FN4)
       C2GS6EFF=FACG8*(MW/MDSB(6))**2*(GAM(3,6)*GAM(2,6)*
     $            (-CEG*FN1+(2*CER-CEG)*FN2)-
     $            GAM(6,6)*GAM(2,6)*MGLU/MBQ*
     $            (-CEG*FN3+(2*CER-CEG)*FN4))
C
C ...  neutralino-dsquark1 ...
C              
       C3NS1EFF=0.
       C2NS1EFF=0.
       DO K=1,4
       X=MCH0(K)**2/MDSB(1)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3NS1EFF=C3NS1EFF+
     $          FACN7*(MW/MDSB(1))**2*
     $          (2.*AGE(K,3,1)*AGE(K,2,1)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,1)-AHE(K,3,1))
     $           *AGE(K,2,1)*MCH0(K)/MBQ*FN4)  
       C2NS1EFF=C2NS1EFF+
     $           FACN8*(MW/MDSB(1))**2*
     $           (2.*AGE(K,3,1)*AGE(K,2,1)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,1)-AHE(K,3,1))
     $           *AGE(K,2,1)*MCH0(K)/MBQ*FN4)  

       ENDDO
       
C
C ...  neutralino-dsquark2 ...
C              
       C3NS2EFF=0.
       C2NS2EFF=0.
       DO K=1,4
       X=MCH0(K)**2/MDSB(2)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3NS2EFF=C3NS2EFF+
     $          FACN7*(MW/MDSB(2))**2*
     $          (2.*AGE(K,3,2)*AGE(K,2,2)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,2)-AHE(K,3,2))
     $           *AGE(K,2,2)*MCH0(K)/MBQ*FN4)  
       C2NS2EFF=C2NS2EFF+
     $          FACN8*(MW/MDSB(2))**2*
     $          (2.*AGE(K,3,2)*AGE(K,2,2)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,2)-AHE(K,3,2))
     $           *AGE(K,2,2)*MCH0(K)/MBQ*FN4)  
       ENDDO
C
C ...  neutralino-dsquark3 ...
C              
       C3NS3EFF=0.
       C2NS3EFF=0.
       DO K=1,4
       X=MCH0(K)**2/MDSB(3)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3NS3EFF=C3NS3EFF+
     $          FACN7*(MW/MDSB(3))**2*
     $          (2.*AGE(K,3,3)*AGE(K,2,3)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,3)-AHE(K,3,3))
     $           *AGE(K,2,3)*MCH0(K)/MBQ*FN4)  
       C2NS3EFF=C2NS3EFF+
     $          FACN8*(MW/MDSB(3))**2*
     $          (2.*AGE(K,3,3)*AGE(K,2,3)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,3)-AHE(K,3,3))
     $           *AGE(K,2,3)*MCH0(K)/MBQ*FN4)  
       ENDDO
C
C ...  neutralino-dsquark4 ...
C              
       C3NS4EFF=0.
       C2NS4EFF=0.
       DO K=1,4
       X=MCH0(K)**2/MDSB(4)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3NS4EFF=C3NS4EFF+
     $          FACN7*(MW/MDSB(4))**2*
     $          (2.*AGE(K,3,4)*AGE(K,2,4)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,4)-AHE(K,3,4))
     $           *AGE(K,2,4)*MCH0(K)/MBQ*FN4)  
       C2NS4EFF=C2NS4EFF+
     $          FACN8*(MW/MDSB(4))**2*
     $          (2.*AGE(K,3,4)*AGE(K,2,4)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,4)-AHE(K,3,4))
     $           *AGE(K,2,4)*MCH0(K)/MBQ*FN4)  
       ENDDO
       
c
C ...  neutralino-dsquark5 ...
C              
       C3NS5EFF=0.
       C2NS5EFF=0.
       DO K=1,4
       X=MCH0(K)**2/MDSB(5)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3NS5EFF=C3NS5EFF+
     $          FACN7*(MW/MDSB(5))**2*
     $          (2.*AGE(K,3,5)*AGE(K,2,5)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,5)-AHE(K,3,5))
     $           *AGE(K,2,5)*MCH0(K)/MBQ*FN4)  
       C2NS5EFF=C2NS5EFF+
     $          FACN8*(MW/MDSB(5))**2*
     $          (2.*AGE(K,3,5)*AGE(K,2,5)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,5)-AHE(K,3,5))
     $           *AGE(K,2,5)*MCH0(K)/MBQ*FN4)  
       ENDDO
C
C ...  neutralino-dsquark6 ...
C              
       C3NS6EFF=0.
       C2NS6EFF=0.
       DO K=1,4
       X=MCH0(K)**2/MDSB(6)**2
       CALL FUNS(X,FN1,FN2,FN3,FN4) 
       C3NS6EFF=C3NS6EFF+
     $          FACN7*(MW/MDSB(6))**2*
     $          (2.*AGE(K,3,6)*AGE(K,2,6)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,6)-AHE(K,3,6))
     $           *AGE(K,2,6)*MCH0(K)/MBQ*FN4)  
       C2NS6EFF=C2NS6EFF+
     $          FACN8*(MW/MDSB(6))**2*
     $          (2.*AGE(K,3,6)*AGE(K,2,6)*FN2-
     $           SQRT(2.)*(SQRT(2.)*AGE(K,6,6)-AHE(K,3,6))
     $           *AGE(K,2,6)*MCH0(K)/MBQ*FN4)  
       ENDDO
      ENDIF
C
      SINTW2I=1./SN2THW
      
      XTW=MT**2/MW**2
C
c ... here we switch from Anlauf's and Ciuchini's 
c     normalization to that of Greub:
C     Ci(Greub)=Ci(Ciuchini,Buras)                for i=1,...,6
c     C7(Greub)=-Qb*C7(Anlauf)=1/3*C7(Anlauf)
c     C8(Greub)=-C8(Anlauf)
c ...
c

      IF(Q.GT.MW.AND.QNEW.LE.MW) THEN 
       CI1(1)=ALES/4./PI*11./2.
       CI1(2)=1.-ALES/4./PI*11./6.
       CI1(3)=-ALES/24./PI*(EI(XTW)-2./3.)
     $        +ALEL/6./PI*SINTW2I*(2.*BI(XTW)+CI(XTW))
       CI1(4)=ALES/8./PI*(EI(XTW)-2./3.)
       CI1(5)=-ALES/24./PI*(EI(XTW)-2./3.)
       CI1(6)=ALES/8./PI*(EI(XTW)-2./3.)
       CI1(7)=1./3.*(C3SMEFF
     $             +C3HPEFF
     $             +C3C11EFF+C3C12EFF+C3C13EFF
     $             +C3C21EFF+C3C22EFF+C3C23EFF
     $             +C3GS1EFF+C3GS2EFF+C3GS3EFF
     $             +C3GS4EFF+C3GS5EFF+C3GS6EFF
     $             +C3NS1EFF+C3NS2EFF+C3NS3EFF
     $             +C3NS4EFF+C3NS5EFF+C3NS6EFF
     $)
C      write(6,*) 'c3=',c3smeff,c3hpeff,c3c11eff,c3c12eff,C3C13EFF,
C     $C3C21EFF,C3C22EFF,C3C23EFF,
C     $C3GS1EFF,C3GS2EFF,C3GS3EFF,
C     $C3GS4EFF,C3GS5EFF,C3GS6EFF,
C     $C3NS1EFF,C3NS2EFF,C3NS3EFF,
C     $C3NS4EFF,C3NS5EFF,C3NS6EFF
       CI1(8)=-1.*(C2SMEFF
     $            +C2HPEFF
     $            +C2C11EFF+C2C12EFF+C2C13EFF
     $            +C2C21EFF+C2C22EFF+C2C23EFF
     $            +C2GS1EFF+C2GS2EFF+C2GS3EFF
     $            +C2GS4EFF+C2GS5EFF+C2GS6EFF
     $            +C2NS1EFF+C2NS2EFF+C2NS3EFF
     $            +C2NS4EFF+C2NS5EFF+C2NS6EFF
     $)
C      write(6,*) 'c2=',c2smeff,c2hpeff,c2c11eff,c2c12eff,C2C13EFF,
C     $C2C21EFF,C2C22EFF,C2C23EFF,
C     $C2GS1EFF,C2GS2EFF,C2GS3EFF,
C     $C2GS4EFF,C2GS5EFF,C2GS6EFF,
C     $C2NS1EFF,C2NS2EFF,C2NS3EFF,
C     $C2NS4EFF,C2NS5EFF,C2NS6EFF
       CI2(1)=ALES/4./PI*11./2.
       CI2(2)=1.-ALES/4./PI*11./6.
       CI2(3)=-ALES/24./PI*(EI(XTW)-2./3.)
     $         +ALEL/6./PI*SINTW2I*(2.*BI(XTW)+CI(XTW))
       CI2(4)=ALES/8./PI*(EI(XTW)-2./3.)
       CI2(5)=-ALES/24./PI*(EI(XTW)-2./3.)
       CI2(6)=ALES/8./PI*(EI(XTW)-2./3.)
       CI2(7)=1./3.*(C3SMEFF+C3HPEFF
     $              +C3C11EFF+C3C12EFF+C3C13EFF
     $              +C3C21EFF+C3C22EFF+C3C23EFF
     $              +C3GS1EFF+C3GS2EFF+C3GS3EFF
     $              +C3GS4EFF+C3GS5EFF+C3GS6EFF
     $              +C3NS1EFF+C3NS2EFF+C3NS3EFF
     $              +C3NS4EFF+C3NS5EFF+C3NS6EFF)

       CI2(8)=-1.*(C2SMEFF+C2HPEFF
     $            +C2C11EFF+C2C12EFF+C2C13EFF
     $            +C2C21EFF+C2C22EFF+C2C23EFF
     $            +C2GS1EFF+C2GS2EFF+C2GS3EFF
     $            +C2GS4EFF+C2GS5EFF+C2GS6EFF
     $            +C2NS1EFF+C2NS2EFF+C2NS3EFF
     $            +C2NS4EFF+C2NS5EFF+C2NS6EFF)
        C3CHEFF=C3C11EFF+C3C12EFF+C3C13EFF
     $         +C3C21EFF+C3C22EFF+C3C23EFF
        C3GLEFF=C3GS1EFF+C3GS2EFF+C3GS3EFF
     $         +C3GS4EFF+C3GS5EFF+C3GS6EFF
        C3NEEFF=C3NS1EFF+C3NS2EFF+C3NS3EFF
     $         +C3NS4EFF+C3NS5EFF+C3NS6EFF
        C2CHEFF=C2C11EFF+C2C12EFF+C2C13EFF
     $         +C2C21EFF+C2C22EFF+C2C23EFF
        C2GLEFF=C2GS1EFF+C2GS2EFF+C2GS3EFF
     $         +C2GS4EFF+C2GS5EFF+C2GS6EFF
        C2NEEFF=C2NS1EFF+C2NS2EFF+C2NS3EFF
     $         +C2NS4EFF+C2NS5EFF+C2NS6EFF
      ENDIF
C
C           
      IF(Q.LT.MW) THEN
       CALL RKSTP(8,DT,T,CI1,GAMMAWB1,WCI1)
       CALL RKSTP(8,DT,T,CI2,GAMMAWB2,WCI2)
       IF ((1.*ii-(ii/10)*10.).eq.0.) then
       ENDIF
C
       IF(Q.GT.(2.*MB)) THEN
        ASMB=SUALFS(Q**2,.36,AMT,3)
        AEMB=SUALFE(Q**2)
        ALFA2=AEMB/SN2THW
        G2=SQRT(4*PI*ALFA2)
        GEF=SQRT(2.)/8.*G2**2/MW**2      
       ENDIF
       BQLOG=LOG(MB/Q)
       ZI=(MC/MB)**2
       LOGZI=LOG(ZI)
       RER2=2./243.*(-833.+144.*PI**2*ZI**(3./2.)
     $      +(1728.-180.*PI**2-1296.*1.20206
     $        +(1296.-324.*PI**2)*LOGZI+108.*LOGZI**2
     $        +36.*LOGZI**3)*ZI
     $      +(648.+72.*PI**2+(432.-216.*PI**2)*LOGZI
     $        +36.*LOGZI**3)*ZI**2
     $      +(-54.-84.*PI**2+1092.*LOGZI
     $        -756.*LOGZI**2)*ZI**3)
       IMR2=16.*PI/81.*(-5.+(45.-3.*PI**2+9.*LOGZI
     $        +9.*LOGZI**2)*ZI
     $      +(-3.*PI**2+9.*LOGZI**2)*ZI**2
     $      +(28.-12.*LOGZI)*ZI**3)
       RER7=8./9.*(4.-PI**2)
       IMR7=0.
       RER8=-4./27.*(-33.+2.*PI**2)
       IMR8=-4./27.*(-6.*PI)
       REDE=ASMB/4./PI*
     $    ((416./81.*BQLOG+RER2)*CI1(2)
     $    +(32./3.*BQLOG+RER7)*CI1(7)
     $    -(32./9.*BQLOG+RER8)*CI1(8))
       IMDE=ASMB/4./PI*
     $    (IMR2*CI1(2)+IMR7*CI1(7)+IMR8*CI1(8))
       EF=(1.-8./3.*ASMB/PI)
C
       CALL BREMS(AEMB,ASMB,MS,MC,MB,Q,CI1,GBREMS)
       GVIRT=AEMB/32./PI**4*EF*
     $       (CI2(7)**2+2.*CI2(7)*REDE)
     
       
       GAMMASG=GVIRT+GBREMS
       gammasg0=AEMB/32./PI**4*EF*CI1(7)**2
       GAMMASL=1./192./PI**3*GES(MC/MB)*
     $         (1.-2./3./PI*ASMB*FES(MC/MB))
c
       BRSL=0.104
       COBA=0.95
       BRSG=COBA*GAMMASG/GAMMASL*BRSL
       BRSG0=COBA*GAMMASG0/GAMMASL*BRSL

C
      if(q.Gt.(2.*MB).AND.QNEW.LT.(2.*MB)) then
       brup=BRSG*1.E+4
      ENDIF
      if(q.Gt.(1./2.*MB).AND.QNEW.LT.(1./2.*MB)) then
       brdo=BRSG*1.E+4
c       write(11,*)m0,mhf,brup,brdo
      ENDIF
      if(q.Gt.MB.AND.QNEW.LT.MB) then
       BFBSG =BRSG*1.E+4
       BFBSG0=BRSG0*1.E+4
C       write(6,*) 'q=',q,ci1(7),ci2(7),rede,gvirt,gbrems
C       write(6,*) 'ci=',ci1(2),ci1(7),ci1(8),rer2,rer7,rer8,asmb
C       write(6,*) 'brsg,brsg0=',brsg,brsg0
      ENDIF
      ENDIF
c---------------------------------------------------------------
81    END DO  
82    CONTINUE
c
        C3C1NAI=C3C11NAI+C3C12NAI+C3C13NAI
        C3C2NAI=C3C21NAI+C3C22NAI+C3C23NAI
        C3CHNAI=C3C11NAI+C3C12NAI+C3C13NAI
     $         +C3C21NAI+C3C22NAI+C3C23NAI
        C3GLNAI=C3GS1EFF+C3GS2EFF+C3GS3EFF
     $         +C3GS4EFF+C3GS5EFF+C3GS6EFF
        C3NENAI=C3NS1EFF+C3NS2EFF+C3NS3EFF
     $         +C3NS4EFF+C3NS5EFF+C3NS6EFF

C
        C3C1EFF=C3C11EFF+C3C12EFF+C3C13EFF
        C3C2EFF=C3C21EFF+C3C22EFF+C3C23EFF
        C3CHEFF=C3C11EFF+C3C12EFF+C3C13EFF
     $         +C3C21EFF+C3C22EFF+C3C23EFF
        C3GLEFF=C3GS1EFF+C3GS2EFF+C3GS3EFF
     $         +C3GS4EFF+C3GS5EFF+C3GS6EFF
        C3NEEFF=C3NS1EFF+C3NS2EFF+C3NS3EFF
     $         +C3NS4EFF+C3NS5EFF+C3NS6EFF
c
      IF (IWR.EQ.1) THEN
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'sm:          '
        WRITE(6,*)'QCD corrected=',c3smeff,' naive=',C3SMNAI                
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'higgs:       '
        WRITE(6,*)'QCD corrected=',c3hpeff,' naive=',C3HPNAI      
        WRITE(6,*)'charged Higgs mass=',mhplus
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'chargino(1)-stop(1): '
        WRITE(6,*)'QCD corrected=',c3c11eff,' naive=',C3C11NAI       
        WRITE(6,*)'chargino mass=',mcha(1),'squark mass=',msqu(1)  
        WRITE(6,*)'G=',gk(1,1),'H=',hk(1,1)
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'chargino(1)-stop(2): '
        WRITE(6,*)'QCD corrected=',c3c12eff,' naive=',C3C12NAI        
        WRITE(6,*)'chargino mass=',mcha(1),'squark mass=',msqu(2)  
        WRITE(6,*)'G=',gk(1,2),'H=',hk(1,2)
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'chargino(1)-up+charm squarks: '
        WRITE(6,*)'QCD corrected=',c3c13eff,' naive=',C3C13NAI       
        WRITE(6,*)'chargino mass=',mcha(1),'squark mass=',msqu(3)  
        WRITE(6,*)'G=',gk(1,3),'H=',hk(1,3)
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'chargino(2)-stop(1): '
        WRITE(6,*)'QCD corrected=',c3c21eff,' naive=',C3C21NAI       
        WRITE(6,*)'chargino mass=',mcha(2),'squark mass=',msqu(1)  
        WRITE(6,*)'G=',gk(2,1),'H=',hk(2,1)
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'chargino(2)-stop(2): '
        WRITE(6,*)'QCD corrected=',c3c22eff,' naive=',C3C22NAI        
        WRITE(6,*)'chargino mass=',mcha(2),'squark mass=',msqu(2)  
        WRITE(6,*)'G=',gk(2,2),'H=',hk(2,2)
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'chargino(2)-up+charm squarks: '
        WRITE(6,*)'QCD corrected=',c3c23eff,' naive=',C3C23NAI       
        WRITE(6,*)'chargino mass=',mcha(2),'squark mass=',msqu(3)  
        WRITE(6,*)'G=',gk(2,3),'H=',hk(2,3)
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'sum of chargino-squarks contributions: '
        WRITE(6,*)'chargino(1)'
        WRITE(6,*)'QCD corrected=',c3c1eff,' naive=',C3C1NAI   
        WRITE(6,*)'chargino(2)'
        WRITE(6,*)'QCD corrected=',c3c2eff,' naive=',C3C2NAI    
        WRITE(6,*)'total'
        WRITE(6,*)'QCD corrected=',c3cheff,' naive=',C3ChNAI    
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'sum of gluino-squarks contributions: '
        WRITE(6,*)'QCD corrected=',1./3.*c3gleff,' naive=',
     $              1./3.*C3glNAI    
        WRITE(6,*)'____________________________________________'
        WRITE(6,*)'sum of neutralino-squarks contributions: '
        WRITE(6,*)'QCD corrected=',c3neeff,' naive=',C3neNAI    
        WRITE(6,*)'____________________________________________'
      write(6,*) 'BFBSG,BFBSG0=',BFBSG,BFBSG0
      END IF
Cc        WRITE(11,*)tanb,c3gleff
C         WRITE(11,*)'moje gluino  : ',mglu 
C         WRITE(11,*)'moje squarky-1,2,3 :',mdsb(1),mdsb(2),mdsb(3)
C         WRITE(11,*)'moje squarky-4,5,6 :',mdsb(4),mdsb(5),mdsb(6) 
c              
ccC                
c        WRITE(13,*)M16,1./3.*C3C11eff     
c        WRITE(14,*)M0,1./3.*C3C12eff       
c        WRITE(15,*)M0,1./3.*C3C13eff
c        WRITE(16,*)M0,1./3.*C3C21eff       
c        WRITE(17,*)M0,1./3.*C3C22eff
c        WRITE(18,*)M0,1./3.*C3C23eff                                 
Cccc   
c          WRITE(11,*)'(',mhplus,c3hpeff 
c          WRITE(11,*)mhplus,c3hpnai,')'    
c          WRITE(11,*)mhplus,c3hpeff/c3hpnai-1.    
C          WRITE(11,*)mt,Abs(delc3-1.)                                         
140    CONTINUE
C--------------------------------------------------------------
1000  continue              
      RETURN
      END
C-----------------------------------------------------------------
      SUBROUTINE ALL(T,G,F)
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,N,O-Z)
      REAL G(137),F(137)
      REAL HU(3,3),HD(3,3),HE(3,3),SQ(3,3),SU(3,3),SD(3,3),
     $       SL(3,3),SE(3,3),AU(3,3),AD(3,3),AE(3,3)
      REAL UN(3,3),PO(3,3)
C
+CDE,SUGMG
+CDE,SUGPAS
C-FP  include 'sugmg.h'
C-FP  include 'sugpas.h'
      
      COMMON/SCALEQ/Q
C-----THESE ARE VALID FROM MZ TO MGUT 
      DATA MZ/91.17/
      DATA ND/3/,NE/3/,NN/3/
      DATA B11/7.96/,B12/5.4/,B13/17.6/,B21/1.8/,B22/25./,B23/24./
      DATA B31/2.2/,B32/9./,B33/14./
      
      
      DATA A11/5.2/,A12/2.8/,A13/3.6/,A21/6./,A22/6./,A23/2./
      DATA A31/4./,A32/4./,A33/0./,A14/1.2/,A24/2./
      
      DATA C11/1.7/,C12/.5/,C13/1.5/,C21/1.5/,C22/1.5/,C23/.5/
      DATA C31/2./,C32/2./,C33/0./
      
      DATA D11/3.98/,D12/2.7/,D13/8.8/,D21/.9/,D22/5.833/,D23/12./
      DATA D31/1.1/,D32/4.5/,D33/-26./

      DATA C1/.8666667/,C2/3./,C3/5.333333/
      DATA CP1/.4666667/,CP2/3./,CP3/5.333333/
      DATA CPP1/1.8/,CPP2/3./,CPP3/0./
      DATA BSY1/6.6/,BSY2/1./,BSY3/-3./
      

      PI=4.*ATAN(1.)
      TANB=XTANB
      BETA=ATAN(TANB)
      SINB=SIN(BETA)
      COSB=SQRT(1.-SINB**2)
      FAC=2./16./PI**2
      UN(1,1)=1.
      UN(1,2)=0.
      UN(1,3)=0.
      UN(2,1)=0.
      UN(2,2)=1.
      UN(2,3)=0.
      UN(3,1)=0.
      UN(3,2)=0.
      UN(3,3)=1.
c      write(*,*)msusy,MSS(1),MSS(2),MSS(17),MSS(27)
C.............new version..........
c     
C-----CALCULATE 1-LOOP THRESHOLD EFFECTS -----------------------------
      IF (Q.GT.MSUSY) THEN
        TH2LP=1.
      ELSE
        TH2LP=0.
      END IF
      IF (Q.GT.MSS(2)) THEN
        NSQ=3
        NSU=3
        NSD=3
      ELSE
        NSQ=0
        NSU=0
        NSD=0
      END IF
      IF (Q.GT.MSS(17)) THEN
        NSL=3
        NSE=3
      ELSE
        NSL=0
        NSE=0
      END IF
      IF (Q.GT.ABS(MU)) THEN
        NSH=2
      ELSE
        NSH=0
      END IF
      IF (Q.GT.ABS(MSS(27))) THEN
        NSW=1
      ELSE
        NSW=0
      END IF
      IF (Q.GT.MSS(1)) THEN
        NSG=1
      ELSE
        NSG=0
      END IF
      IF (Q.GT.MSS(31)) THEN
        NH=2
      ELSE
        NH=1
      END IF
      IF (Q.GT.G(7)) THEN
        TH1=1
      ELSE
        TH1=0
      END IF
      IF (Q.GT.G(8)) THEN
        TH2=1
      ELSE
        TH2=0
      END IF
      IF (Q.GT.AMT) THEN
        NU=3
        THTOP=1.
      ELSE
        NU=2
        THTOP=0.
      END IF
      TH2LP=1.
      THTOP=1.
      THHL=1.
      THHH=NH/2.
      THSHL=NSH/2.
      THSHH=NSH/2.
      THQ=NSQ/3.
      THU=NSQ/3.
      THD=NSQ/3.
      THL=NSL/3.
      THE=NSE/3.
      TH3=NSG
      B1=2.*(17*NU/12.+5*ND/12.+5*NE/4.+NN/4.)/5.+
     $ NSQ/30.+4*NSU/15.+NSD/15.+NSL/10.+NSE/5.+
     $ 1.*NSH/5.+1.*NH/10.
      B2=-22./3.+.5*(NU+ND)+1.*(NE+NN)/6.+
     $ 1.*NSQ/2.+1.*NSL/6.+1.*NSH/3.+1.*NH/6.+4.*NSW/3.
      B3=2.*(NU+ND)/3.+1.*NSQ/3.+1.*NSU/6.+1.*NSD/6.+2.*NSG-11.

      IF (Q.GT.MSUSY) THEN
      F(1)=G(1)/16./PI**2*(B1*G(1)**2+TH2LP/16./PI**2*G(1)**2*
     $(B11*G(1)**2+B12*G(2)**2+B13*G(3)**2-A11*G(6)**2-A12*G(5)**2
     $-A13*G(4)**2-A14*G(135)**2))
      F(2)=G(2)/16./PI**2*(B2*G(2)**2+TH2LP/16./PI**2*G(2)**2*
     $(B21*G(1)**2+B22*G(2)**2+B23*G(3)**2-A21*G(6)**2-A22*G(5)**2
     $-A23*G(4)**2-A24*G(135)**2))
     
      F(3)=G(3)/16./PI**2*(B3*G(3)**2+TH2LP/16./PI**2*G(3)**2*
     $(B31*G(1)**2+B32*G(2)**2+B33*G(3)**2-A31*G(6)**2-A32*G(5)**2
     $-A33*G(4)**2))
      ELSE
      F(1)=G(1)/16./PI**2*(B1*G(1)**2+TH2LP/16./PI**2*G(1)**2*
     $(D11*G(1)**2+D12*G(2)**2+D13*G(3)**2-C11*G(6)**2-C12*G(5)**2
     $-C13*G(4)**2))
     
      F(2)=G(2)/16./PI**2*(B2*G(2)**2+TH2LP/16./PI**2*G(2)**2*
     $(D21*G(1)**2+D22*G(2)**2+D23*G(3)**2-C21*G(6)**2-C22*G(5)**2
     $-C23*G(4)**2))
      
      F(3)=G(3)/16./PI**2*(B3*G(3)**2+TH2LP/16./PI**2*G(3)**2*
     $(D31*G(1)**2+D32*G(2)**2+D33*G(3)**2-C31*G(6)**2-C32*G(5)**2
     $-C33*G(4)**2))
     
     
      ENDIF
      IF (Q.LT.MSUSY) THEN
        F(4)=G(4)/16./PI**2*(5*G(4)**2*COSB**2/2.+3*G(6)**2*SINB**2*
     $   THTOP+3*G(5)**2*COSB**2-9*G(1)**2/4.-9*G(2)**2/4.
     $   -SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
        F(5)=G(5)/16./PI**2*(9*G(5)**2*COSB**2/2.+3*G(6)**2*SINB**2*
     $   THTOP/2.+G(4)**2*COSB**2-G(1)**2/4.-9*G(2)**2/4.
     $   -8*G(3)**2-SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
        F(6)=G(6)/16./PI**2*(9*G(6)**2*SINB**2/2.*THTOP+
     $   3*G(5)**2*COSB**2/2.+G(4)**2*COSB**2-17.*G(1)**2/20.
     $   -9*G(2)**2/4.-8*G(3)**2+COSB**2*
     $   (3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
      ELSE
C        BY4=4*G(4)**2+3*G(5)**2-9*G(1)**2/5.-3*G(2)**2+G(135)**2
C        BY5=6*G(5)**2+G(6)**2*THTOP+G(4)**2-7*G(1)**2/15.-3*G(2)**2-
C     $16*G(3)**2/3.+
C        BY6=6*G(6)**2*THTOP+G(5)**2-13*G(1)**2/15.-3*G(2)**2-
C     $16*G(3)**2/3.+G(135)**2
        BY4=2.5*(COSB**2*THHL+SINB**2*THHH)*G(4)**2+
     $1.5*(COSB**2*THSHL+SINB**2*THSHH)*G(4)**2+
     $3*SINB**2*(THHL-THHH)*G(6)**2+3*(COSB**2*THHL+SINB**2*THHH)*
     $G(5)**2-
     $(3*G(1)**2/5.*(15./4.+3*THSHL/4.-TH1*(THL/4.+THE+THSHL/4.))
     $+G(2)**2*(9./4.+9*THSHL/4.-3*(THL+THSHL)*TH2/4.))
        BY4=BY4+G(135)**2
        BY5=4.5*(COSB**2*THHL+SINB**2*THHH)*G(5)**2+
     $1.5*(COSB**2*THSHL+SINB**2*THSHH)*G(5)**2+
     $.5*(SINB**2*THHL+COSB**2*THHH-
     $4*SINB**2*(THHL-THHH))*G(6)**2+.5*(SINB**2*THSHL+COSB**2*THSHH)*
     $G(6)**2+3*SINB**2*(THHL-THHH)*G(6)**2+
     $(COSB**2*THHL+SINB**2*THHH)*G(4)**2-
     $(3*G(1)**2/5.*(5./12.+3*THSHL/4.-TH1*(THQ/36.+THD/9.+THSHL/4.))
     $+G(2)**2*(9./4.+9*THSHL/4.-3*(THQ+THSHL)*TH2/4.)+
     $G(3)**2*(8.-4*(THQ+THD)*TH3/3.))
        BY6=4.5*(SINB**2*THHL+COSB**2*THHH)*G(6)**2+
     $1.5*(SINB**2*THSHL+COSB**2*THSHH)*G(6)**2+
     $.5*(COSB**2*THHL+SINB**2*THHH-
     $4*COSB**2*(THHL-THHH))*G(5)**2+.5*(COSB**2*THSHL+SINB**2*THSHH)*
     $G(5)**2+COSB**2*(THHL-THHH)*(3*G(5)**2+G(4)**2)-
     $(3*G(1)**2/5.*(17./12.+3*THSHL/4.-TH1*(THQ/36.+4*THU/9.+THSHL/4.))
     $+G(2)**2*(9./4.+9*THSHL/4.-3*(THQ+THSHL)*TH2/4.)+
     $G(3)**2*(8.-4*(THQ+THU)*TH3/3.))
        BY6=BY6+G(135)**2
        F(4)=G(4)/16./PI**2*(BY4+
     $       TH2LP/16./PI**2*((CPP1*BSY1+CPP1**2/2.)*G(1)**4+
     $       (CPP2*BSY2+CPP2**2/2.)*G(2)**4+(CPP3*BSY3+CPP3**2/2.)*
     $       G(3)**4+9*G(1)**2*G(2)**2/5.+
     $       G(5)**2*(-.4*G(1)**2+16*G(3)**2)+
     $       G(4)**2*(1.2*G(1)**2+6*G(2)**2)-
     $       (3*G(6)**2*G(5)**2+9*G(5)**4+9*G(5)**2*G(4)**2+
     $       10*G(4)**4)-3*G(135)**4-3*G(135)**2*G(6)**2
     $       -3*G(135)**2*G(4)**2))
        F(5)=G(5)/16./PI**2*(BY5+
     $       TH2LP/16./PI**2*((CP1*BSY1+CP1**2/2.)*G(1)**4+
     $       (CP2*BSY2+CP2**2/2.)*G(2)**4+(CP3*BSY3+CP3**2/2.)*
     $       G(3)**4+G(1)**2*G(2)**2+8*G(1)**2*G(3)**2/9.+
     $       8*G(2)**2*G(3)**2+.8*G(6)**2*G(1)**2+
     $       G(5)**2*(.4*G(1)**2+6*G(2)**2+16*G(3)**2)+
     $       1.2*G(4)**2*G(1)**2-
     $       (22*G(5)**4+5*G(6)**2*G(5)**2+3*G(5)**2*G(4)**2+
     $       3*G(4)**4+5*G(6)**4)-G(135)**2*G(6)**2-G(135)**2*G(4)**2))
        F(6)=G(6)/16./PI**2*(BY6+
     $       TH2LP/16./PI**2*((C1*BSY1+C1**2/2.)*G(1)**4+
     $       (C2*BSY2+C2**2/2.)*G(2)**4+(C3*BSY3+C3**2/2.)*
     $       G(3)**4+G(1)**2*G(2)**2+136*G(1)**2*G(3)**2/45.+
     $       8*G(2)**2*G(3)**2+G(6)**2*(1.2*G(1)**2+6*G(2)**2+
     $       16*G(3)**2)+.4*G(5)**2*G(1)**2-
     $       (22*G(6)**4+5*G(6)**2*G(5)**2+5*G(5)**4+
     $       G(5)**2*G(4)**2)-3*G(135)**4-3*G(135)**2*G(6)**2-
     $       G(135)**2*G(4)**2))
      END IF
      FAC2LP=(FAC/2.)**2
      G72LP=2*G(1)**2*(B11*G(1)**2*(G(7)+G(7))+
     $B12*G(2)**2*(G(7)+G(8))+B13*G(3)**2*(G(7)+G(9))+
     $A11*G(6)**2*(G(12)-G(7))+A12*G(5)**2*(G(11)-G(7))+
     $A13*G(4)**2*(G(10)-G(7))+A14*G(135)**2*(G(137)-G(7)))
      G82LP=2*G(2)**2*(B21*G(1)**2*(G(7)+G(8))+
     $B22*G(2)**2*(G(8)+G(8))+B23*G(3)**2*(G(8)+G(9))+
     $A21*G(6)**2*(G(12)-G(8))+A22*G(5)**2*(G(11)-G(8))+
     $A23*G(4)**2*(G(10)-G(8))+A24*G(135)**2*(G(137)-G(8)))
      G92LP=2*G(3)**2*(B31*G(1)**2*(G(9)+G(7))+
     $B32*G(2)**2*(G(9)+G(8))+B33*G(3)**2*(G(9)+G(9))+
     $A31*G(6)**2*(G(12)-G(9))+A32*G(5)**2*(G(11)-G(9))+
     $A33*G(4)**2*(G(10)-G(9)))
      F(7)=FAC*B1*G(1)**2*G(7)+TH2LP*FAC2LP*G72LP
      F(8)=FAC*B2*G(2)**2*G(8)+TH2LP*FAC2LP*G82LP
      F(9)=FAC*B3*G(3)**2*G(9)+TH2LP*FAC2LP*G92LP
      XTAU=G(21)+G(20)+G(13)+G(10)**2
      XB=G(24)+G(22)+G(13)+G(11)**2
      XT=G(24)+G(23)+G(14)+G(12)**2
      XN=G(21)+G(136)+G(14)+G(137)**2
      SMV=G(14)-G(13)+(2*G(19)+G(24))-(2*G(16)+G(21))
     $    -2*(2*G(18)+G(23))+(2*G(17)+G(22))+(2*G(15)+G(20))
      SPMV=-2*G(4)**2*G(20)+(6*G(1)**2*(2*G(15)+G(20)))/5.+
     $G(4)**2*(G(13)+G(21))-(3*(G(1)**2+5*G(2)**2)*
     $(G(13)-G(14)+2*G(16)+G(21)))/10.-2*G(5)**2*G(22)+
     $(2*(G(1)**2+20*G(3)**2)*(2*G(17)+G(22)))/15.+
     $4*G(6)**2*G(23)-(16*(G(1)**2+5*G(3)**2)*(2*G(18)+G(23)))/15.+
     $G(5)**2*(3*G(13)-G(24))-G(6)**2*(3*G(14)+G(24))+
     $((G(1)**2+45*G(2)**2+80*G(3)**2)*(2*G(19)+G(24)))/30.
     $+G(135)**2*(G(21)-G(14))
      SIG1=.2*G(1)**2*(3*(G(14)+G(13))+(2*G(19)+G(24))+
     $3*(2*G(16)+G(21))+8*(2*G(18)+G(23))+2*(2*G(17)+G(22))+
     $6*(2*G(15)+G(20)))
      SIG2=G(2)**2*(G(14)+G(13)+3*(2*G(19)+G(24))+(2*G(16)+G(21)))
      SIG3=G(3)**2*(2*(2*G(19)+G(24))+(2*G(18)+G(23))+
     $(2*G(17)+G(22)))
C
      G102LP=(-54*G(1)**4-(18*G(1)**2*G(2)**2)/5.-
     $(12*G(1)**2*G(4)**2)/5.+(4*G(1)**2*G(5)**2)/5.)*G(7)+
     $((-18*G(1)**2*G(2)**2)/5.-30*G(2)**4-
     $12*G(2)**2*G(4)**2)*G(8)-32*G(3)**2*G(5)**2*G(9)+
     $(12*G(1)**2*G(4)**2*G(10))/5.+12*G(2)**2*G(4)**2*G(10)-
     $40*G(4)**4*G(10)-36*G(5)**4*G(11)+G(5)**2*
     $((-4*G(1)**2)/5.+32*G(3)**2-18*G(4)**2-6*G(6)**2)*G(11)+
     $G(5)**2*(-18*G(4)**2*G(10)-6*G(6)**2*G(12))
     $-6*G(135)**2*(G(12)*G(6)**2+G(10)*G(4)**2+G(137)*
     $(G(6)**2+2*G(135)**2+G(4)**2))
      G112LP=((-574*G(1)**4)/45.-2*G(1)**2*G(2)**2-
     $(16*G(1)**2*G(3)**2)/9.-(12*G(1)**2*G(4)**2)/5.-
     $(4*G(1)**2*G(5)**2)/5.-(8*G(1)**2*G(6)**2)/5.)*G(7)+
     $(-2*G(1)**2*G(2)**2-30*G(2)**4-16*G(2)**2*G(3)**2-
     $12*G(2)**2*G(5)**2)*G(8)+((-16*G(1)**2*G(3)**2)/9.-
     $16*G(2)**2*G(3)**2+(64*G(3)**4)/9.-
     $32*G(3)**2*G(5)**2)*G(9)+(12*G(1)**2*G(4)**2*G(10))/5.-
     $12*G(4)**4*G(10)-88*G(5)**4*G(11)+G(5)**2*((4*G(1)**2)/5.+
     $12*G(2)**2+32*G(3)**2-6*G(4)**2-10*G(6)**2)*G(11)+
     $(8*G(1)**2*G(6)**2*G(12))/5.-20*G(6)**4*G(12)+
     $G(5)**2*(-6*G(4)**2*G(10)-10*G(6)**2*G(12))
     $-2*G(135)**2*(G(12)*G(6)**2+G(10)*G(4)**2+G(137)*
     $(G(6)**2+G(4)**2))
      G122LP=((-5486*G(1)**4)/225.-2*G(1)**2*G(2)**2-
     $(272*G(1)**2*G(3)**2)/45.-(4*G(1)**2*G(5)**2)/5.-
     $(12*G(1)**2*G(6)**2)/5.)*G(7)+(-2*G(1)**2*G(2)**2-
     $30*G(2)**4-16*G(2)**2*G(3)**2-12*G(2)**2*G(6)**2)*G(8)+
     $((-272*G(1)**2*G(3)**2)/45.-16*G(2)**2*G(3)**2+
     $(64*G(3)**4)/9.-32*G(3)**2*G(6)**2)*G(9)-
     $2*G(4)**2*G(5)**2*G(10)+(4*G(1)**2*G(5)**2*G(11))/5.-
     $2*G(4)**2*G(5)**2*G(11)-20*G(5)**4*G(11)-
     $10*G(5)**2*G(6)**2*G(11)+((12*G(1)**2)/5.+12*G(2)**2+
     $32*G(3)**2-10*G(5)**2)*G(6)**2*G(12)-88*G(6)**4*G(12)
     $-2*G(135)**2*(3*G(12)*G(6)**2+G(10)*G(4)**2+G(137)*
     $(3*G(6)**2+6*G(135)**2+G(4)**2))
      G132LP=XB*((-4*G(1)**2)/5.+32*G(3)**2)*G(5)**2-
     $(12*G(1)**2*G(4)**2*(-XTAU-2*G(7)**2+2*G(7)*G(10)))/5.-
     $12*G(4)**4*(XTAU+G(10)**2)-36*G(5)**4*(XB+G(11)**2)+
     $G(5)**2*((8*G(1)**2*G(7)*(-G(7)+G(11)))/5.-
     $64*G(3)**2*G(9)*(-G(9)+G(11)))-6*G(5)**2*G(6)**2*
     $(XB+XT+2*G(11)*G(12))-1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+
     $3.6*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(7)*G(8))+
     $24.84*G(1)**4*G(7)**2+3*G(2)**2*SIG2+.6*G(1)**2*SIG1
     $-2*G(4)**2*G(135)**2*(2*G(137)*G(10)+XN+XTAU)
      G142LP=XT*((8*G(1)**2)/5.+32*G(3)**2)*G(6)**2-
     $6*G(5)**2*G(6)**2*(XB+XT+2*G(11)*G(12))-
     $36*G(6)**4*(XT+G(12)**2)+G(6)**2*((-16*G(1)**2*G(7)*
     $(-G(7)+G(12)))/5.-64*G(3)**2*G(9)*(-G(9)+G(12)))+
     $1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+
     $3.6*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(7)*G(8))+
     $24.84*G(1)**4*G(7)**2+3*G(2)**2*SIG2+.6*G(1)**2*SIG1
     $-12*G(135)**4*(G(137)**2+XN)-2*G(4)**2*G(135)**2*
     $(2*G(137)*G(10)+XN+XTAU)
      G152LP=2.4*G(1)**2*SPMV+112.32*G(1)**4*G(7)**2+2.4*G(1)**2*SIG1
      G162LP=-1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+3.6*G(2)**2*G(1)**2*
     $(G(8)**2+G(7)**2+G(8)*G(7))+24.84*G(1)**4*G(7)**2+
     $3*G(2)**2*SIG2+.6*G(1)**2*SIG1
      G172LP=.8*G(1)**2*SPMV-42.66667*G(3)**4*G(9)**2+
     $128*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.+
     $808*G(1)**4*G(7)**2/75.+16*G(3)**2*SIG3/3.+4*G(1)**2*SIG1/15.
      G182LP=-1.6*G(1)**2*SPMV-42.66667*G(3)**4*G(9)**2+
     $512*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.+
     $3424*G(1)**4*G(7)**2/75.+16*G(3)**2*SIG3/3.+16*G(1)**2*SIG1/15.
      G192LP=.4*G(1)**2*SPMV-128.*G(3)**4*G(9)**2/3.+
     $32*G(3)**2*G(2)**2*(G(9)**2+G(8)**2+G(9)*G(8))+
     $32*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(9)*G(7))/45.+
     $33*G(2)**4*G(8)**2+
     $.4*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(8)*G(7))+
     $199*G(1)**4*G(7)**2/75.+16*G(3)**2*SIG3/3.+
     $3*G(2)**2*SIG2+G(1)**2*SIG1/15.
      G202LP=XTAU*((-12*G(1)**2)/5.+12*G(2)**2)*G(4)**2-
     $16*G(4)**4*(XTAU+G(10)**2)+G(4)**2*((24*G(1)**2*G(7)*
     $(-G(7)+G(10)))/5.-24*G(2)**2*G(8)*(-G(8)+G(10)))-
     $12*G(4)**2*G(5)**2*(XB+XTAU+2*G(10)*G(11))+
     $2.4*G(1)**2*SPMV+112.32*G(1)**4*G(7)**2+2.4*G(1)**2*SIG1
     $-4*G(135)**2*G(4)**2*(2*G(137)*G(10)+XN+XTAU)
      G212LP=(-12*G(1)**2*G(4)**2*(-XTAU-2*G(7)**2+2*G(7)*G(10)))/5.-
     $12*G(4)**4*(XTAU+G(10)**2)-6*G(4)**2*G(5)**2*
     $(XB+XTAU+2*G(10)*G(11))
     $-1.2*G(1)**2*SPMV+33*G(2)**4*G(8)**2+3.6*G(2)**2*G(1)**2*
     $(G(8)**2+G(7)**2+G(8)*G(7))+24.84*G(1)**4*G(7)**2+
     $3*G(2)**2*SIG2+.6*G(1)**2*SIG1
     $-6*G(135)**2*(2*G(12)*G(137)*G(6)**2+G(6)**2*XT+
     $G(6)**2*XN+2*G(135)**2*(XN+G(137)**2))
      G222LP=XB*((4*G(1)**2)/5.+12*G(2)**2)*G(5)**2-
     $4*G(4)**2*G(5)**2*(XB+XTAU+2*G(10)*G(11))-32*G(5)**4*
     $(XB+G(11)**2)+G(5)**2*((-8*G(1)**2*G(7)*(-G(7)+G(11)))/5.-
     $24*G(2)**2*G(8)*(-G(8)+G(11)))-4*G(5)**2*G(6)**2*(XB+XT+
     $2*G(11)*G(12))+.8*G(1)**2*SPMV-42.66667*G(3)**4*G(9)**2+
     $128*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.+
     $808*G(1)**4*G(7)**2/75.+16*G(3)**2*SIG3/3.+4*G(1)**2*SIG1/15.
      G232LP=XT*((-4*G(1)**2)/5.+12*G(2)**2)*G(6)**2-
     $4*G(5)**2*G(6)**2*(XB+XT+2*G(11)*G(12))-32*G(6)**4*
     $(XT+G(12)**2)+G(6)**2*((8*G(1)**2*G(7)*(-G(7)+G(12)))/5.-
     $24*G(2)**2*G(8)*(-G(8)+G(12)))-1.6*G(1)**2*SPMV-42.66667*
     $G(3)**4*G(9)**2+
     $512*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(7)*G(9))/45.+
     $3424*G(1)**4*G(7)**2/75.+16*G(3)**2*SIG3/3.+16*G(1)**2*SIG1/15.
     $-4*G(6)**2*G(135)**2*(2*G(12)*G(137)+XT+XN)
      G242LP=(-4*G(1)**2*G(5)**2*(-XB-2*G(7)**2+2*G(7)*G(11)))/5.-
     $2*G(4)**2*G(5)**2*(XB+XTAU+2*G(10)*G(11))-20*G(5)**4*
     $(XB+G(11)**2)-(8*G(1)**2*G(6)**2*(-XT-2*G(7)**2+
     $2*G(7)*G(12)))/5.-20*G(6)**4*(XT+G(12)**2)
     $+.4*G(1)**2*SPMV-128.*G(3)**4*G(9)**2/3.+
     $32*G(3)**2*G(2)**2*(G(9)**2+G(8)**2+G(9)*G(8))+
     $32*G(3)**2*G(1)**2*(G(9)**2+G(7)**2+G(9)*G(7))/45.+
     $33*G(2)**4*G(8)**2+
     $.4*G(2)**2*G(1)**2*(G(8)**2+G(7)**2+G(8)*G(7))+
     $199*G(1)**4*G(7)**2/75.+16*G(3)**2*SIG3/3.+
     $3*G(2)**2*SIG2+G(1)**2*SIG1/15.
     $-2*G(6)**2*G(135)**2*(2*G(12)*G(137)+XT+XN)
C     ADD IN MU 2-LOOP TERM SOMETIME...
      G252LP=0.
      G282LP=-16*G(135)**4*(G(137)**2+XN)-12*G(6)**2*G(135)**2*
     $(2*G(12)*G(137)+XT+XN)-4*G(4)**2*G(135)**2*(2*G(137)*G(10)+
     $XN+XTAU)+G(135)**2*G(137)*(-24*G(7)*G(1)**2/5.-24*G(2)**2*G(8))
     $+G(135)**2*(2.4*G(1)**2*(2*G(7)**2+XN)+12*G(2)**2*
     $(2*G(8)**2+XN))
      G292LP=-32*G(3)**2*G(6)**2*G(9)+(12*G(1)**2*G(4)**2*G(10))/5.
     $-12*G(4)**4*G(10)-6*G(4)**2*G(5)**2*G(10)-
     $6*G(4)**2*G(5)**2*G(11)-6*G(5)**2*G(6)**2*G(11)+
     $(8*G(1)**2*G(6)**2*G(12))/5.+32*G(3)**2*G(6)**2*G(12)-
     $6*G(5)**2*G(6)**2*G(12)-36*G(6)**4*G(12)+
     $(-6*G(4)**2*G(10)-18*G(6)**2*G(12))*G(135)**2+
     $((12*G(1)**2)/5.+12*G(2)**2-6*G(4)**2-
     $18*G(6)**2)*G(137)*G(135)**2-40*G(137)*G(135)**4+
     $G(7)*((-414*G(1)**4)/25.-(18*G(1)**2*G(2)**2)/5.-
     $(12*G(1)**2*G(4)**2)/5.-(8*G(1)**2*G(6)**2)/5.-
     $(12*G(1)**2*G(135)**2)/5.)+G(8)*((-18*G(1)**2*G(2)**2)/5.-
     $30*G(2)**4-12*G(2)**2*G(135)**2)
C
      F(10)=FAC*(9*G(1)**2*G(7)/5.+3*G(2)**2*G(8)+3*G(5)**2*G(11)+
     $4*G(4)**2*G(10)+G(135)**2*G(137))+FAC2LP*TH2LP*G102LP
      F(11)=FAC*(7*G(1)**2*G(7)/15.+3*G(2)**2*G(8)+16*G(3)**2*G(9)/3.+
     $6*G(5)**2*G(11)+G(6)**2*G(12)+G(4)**2*G(10))
     $+FAC2LP*TH2LP*G112LP
      F(12)=FAC*(13*G(1)**2*G(7)/15.+3*G(2)**2*G(8)+16*G(3)**2*G(9)/3.+
     $G(5)**2*G(11)+6*G(6)**2*G(12)+G(135)**2*G(137))
     $+FAC2LP*TH2LP*G122LP
      F(13)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2+
     $3*G(5)**2*XB+G(4)**2*XTAU-.3*G(1)**2*SMV)+FAC2LP*TH2LP*G132LP
      F(14)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2+3*G(6)**2*XT
     $+G(135)**2*XN+.3*G(1)**2*SMV)+FAC2LP*TH2LP*G142LP
      F(15)=FAC*(-2.4*G(1)**2*G(7)**2+.6*G(1)**2*SMV)
     $+FAC2LP*TH2LP*G152LP
      F(16)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2-.3*G(1)**2*SMV)
     $+FAC2LP*TH2LP*G162LP
      F(17)=FAC*(-4*G(1)**2*G(7)**2/15.-16*G(3)**2*G(9)**2/3.+
     $.2*G(1)**2*SMV)+FAC2LP*TH2LP*G172LP
      F(18)=FAC*(-16*G(1)**2*G(7)**2/15.-16*G(3)**2*G(9)**2/3.-
     $.4*G(1)**2*SMV)+FAC2LP*TH2LP*G182LP
      F(19)=FAC*(-G(1)**2*G(7)**2/15.-3*G(2)**2*G(8)**2-
     $16*G(3)**2*G(9)**2/3.+.1*G(1)**2*SMV)+FAC2LP*TH2LP*G192LP
      F(20)=FAC*(-2.4*G(1)**2*G(7)**2+2*G(4)**2*XTAU+.6*G(1)**2*SMV)+
     $FAC2LP*TH2LP*G202LP
      F(21)=FAC*(-.6*G(1)**2*G(7)**2-3*G(2)**2*G(8)**2+G(4)**2*XTAU
     $+G(135)**2*XN-.3*G(1)**2*SMV)+FAC2LP*TH2LP*G212LP
      F(22)=FAC*(-4*G(1)**2*G(7)**2/15.-16*G(3)**2*G(9)**2/3.+
     $2*G(5)**2*XB+.2*G(1)**2*SMV)+FAC2LP*TH2LP*G222LP
      F(23)=FAC*(-16*G(1)**2*G(7)**2/15.-16*G(3)**2*G(9)**2/3.+
     $2*G(6)**2*XT-.4*G(1)**2*SMV)+FAC2LP*TH2LP*G232LP
      F(24)=FAC*(-G(1)**2*G(7)**2/15.-3*G(2)**2*G(8)**2-
     $16*G(3)**2*G(9)**2/3.+G(6)**2*XT+G(5)**2*XB+.1*G(1)**2*SMV)
     $+FAC2LP*TH2LP*G242LP
      F(25)=FAC*G(25)/2.*(-.6*G(1)**2-3*G(2)**2+3*G(6)**2+
     $       3*G(5)**2+G(4)**2+G(135)**2)+FAC2LP*TH2LP*G252LP
      F(26)=FAC*(-.6*G(1)**2*G(7)-3*G(2)**2*G(8)+3*G(6)**2*G(12)+
     $       3*G(5)**2*G(11)+G(4)**2*G(10))
      IF (Q.GT.AMNRMJ) THEN
      F(135)=G(135)/16./PI**2*(3*G(6)**2+G(4)**2+4*G(135)**2-
     $       3*G(2)**2-3*G(1)**2/5.+TH2LP/16./PI**2*(-10*G(135)**4
     $       +G(135)**2*(1.2*G(1)**2+3*(2*G(2)**2-3*G(6)**2-
     $       G(4)**2))+207*G(1)**4/50.+.2*G(1)**2*(9*G(2)**2+
     $       4*G(6)**2+6*G(4)**2)+.5*(15*G(2)**4-18*G(6)**4-
     $       6*G(4)**4+32*G(3)**2*G(6)**2-6*G(5)**2*G(6)**2-
     $       6*G(5)**2*G(4)**2)))
      F(136)=FAC*2*G(135)**2*XN+FAC2LP*TH2LP*G282LP
      F(137)=FAC*(3*G(1)**2*G(7)/5.+3*G(2)**2*G(8)+3*G(6)**2*G(12)+
     $4*G(135)**2*G(137)+G(4)**2*G(10))+FAC2LP*TH2LP*G292LP
      ELSE
      F(135)=0.
      F(136)=0.
      F(137)=0.
      END IF
c  stop    G(27),G(28),G(29) 
c........
c
      IF (Q.LT.MSUSY) THEN
       F(27)=G(27)/16./PI**2*(3*G(27)**2*COSB**2/2.
     $  +G(4)**2*COSB**2+3*G(6)**2*SINB**2*
     $  THTOP+3*G(5)**2*COSB**2-9*G(1)**2/4.-9*G(2)**2/4.
     $  -SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2)) 
       F(28)=G(28)/16./PI**2*(3*G(28)**2*COSB**2/2.
     $  +G(4)**2*COSB**2+3*G(6)**2*SINB**2*
     $  THTOP+3*G(5)**2*COSB**2-9*G(1)**2/4.-9*G(2)**2/4.
     $  -SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
       F(29)=G(29)/16./PI**2*(3*G(29)**2*COSB**2/2.
     $  -3*G(31)**2*SINB**2/2.+3*G(6)**2*SINB**2*THTOP
     $  +3*G(5)**2*COSB**2+G(4)**2*COSB**2-G(1)**2/4.-9*G(2)**2/4.
     $  -8*G(3)**2-SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
       F(30)=G(30)/16./PI**2*(3*G(30)**2*COSB**2/2.
     $  -3*G(32)**2*SINB**2/2.+3*G(6)**2*SINB**2*THTOP
     $  +3*G(5)**2*COSB**2+G(4)**2*COSB**2-17*G(1)**2/20.-9*G(2)**2/4.
     $  -8*G(3)**2-SINB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
       F(31)=G(31)/16./PI**2*(3*G(31)**2*COSB**2/2.
     $  -3*G(29)**2*SINB**2/2.+3*G(6)**2*SINB**2*THTOP
     $  +3*G(5)**2*COSB**2+G(4)**2*COSB**2-G(1)**2/4.-9*G(2)**2/4.
     $  -8*G(3)**2+COSB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
       F(32)=G(32)/16./PI**2*(3*G(32)**2*COSB**2/2.
     $  -3*G(30)**2*SINB**2/2.+3*G(6)**2*SINB**2*THTOP
     $  +3*G(5)**2*COSB**2+G(4)**2*COSB**2-G(1)**2/4.-9*G(2)**2/4.
     $  -8*G(3)**2+COSB**2*(3*G(6)**2*THTOP-3*G(5)**2-G(4)**2))
      ELSE
       F(27)=G(27)/16./PI**2*(3*G(27)**2+3*G(5)**2+
     $       G(4)**2-9*G(1)**2/5.-3*G(2)**2)
       F(28)=G(28)/16./PI**2*(3*G(28)**2+3*G(5)**2+
     $       G(4)**2-9*G(1)**2/5.-3*G(2)**2)
       F(29)=G(29)/16./PI**2*(3*G(29)**2+G(31)**2+3*G(5)**2+
     $       G(4)**2-7*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.)
       F(30)=G(30)/16./PI**2*(3*G(30)**2+G(32)**2+3*G(5)**2+
     $       G(4)**2-7*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.)
       F(31)=G(31)/16./PI**2*(3*G(31)**2+G(29)**2+3*G(6)**2
     $       *THTOP-13*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.)    
       F(32)=G(32)/16./PI**2*(3*G(32)**2+G(30)**2+3*G(6)**2
     $       *THTOP-13*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.)     
      END IF                             
       F(33)=2./16./PI**2*(9*G(1)**2*G(7)/5.+3*G(2)**2*G(8)+
     $       G(5)**2*G(11)+G(4)**2*G(10)/3.)
       F(34)=2./16./PI**2*(7*G(1)**2*G(7)/15.+3*G(2)**2*G(8)+
     $       16*G(3)**2*G(9)/3.+G(5)**2*G(11)+G(4)**2*G(10)/3.)
       F(35)=2./16./PI**2*(13*G(1)**2*G(7)/15.+3*G(2)**2*G(8)+
     $       16*G(3)**2*G(9)/3.+G(6)**2*G(12))               
c... matrices...
      HU(1,1)=G(36)
      HU(1,2)=G(37)
      HU(1,3)=G(38)
      HU(2,1)=G(39)
      HU(2,2)=G(40)
      HU(2,3)=G(41)
      HU(3,1)=G(42)
      HU(3,2)=G(43)
      HU(3,3)=G(44)*THTOP
      HD(1,1)=G(45)
      HD(1,2)=G(46)
      HD(1,3)=G(47)
      HD(2,1)=G(48)
      HD(2,2)=G(49)
      HD(2,3)=G(50)
      HD(3,1)=G(51)
      HD(3,2)=G(52)
      HD(3,3)=G(53)
      HE(1,1)=G(54)
      HE(1,2)=G(55)
      HE(1,3)=G(56)
      HE(2,1)=G(57)
      HE(2,2)=G(58)
      HE(2,3)=G(59)
      HE(3,1)=G(60)
      HE(3,2)=G(61)
      HE(3,3)=G(62)
      SQ(1,1)=G(63)
      SQ(1,2)=G(64)
      SQ(1,3)=G(65)
      SQ(2,1)=G(66)
      SQ(2,2)=G(67)
      SQ(2,3)=G(68)
      SQ(3,1)=G(69)
      SQ(3,2)=G(79)
      SQ(3,3)=G(71)
      SU(1,1)=G(72)
      SU(1,2)=G(73)
      SU(1,3)=G(74)
      SU(2,1)=G(75)
      SU(2,2)=G(76)
      SU(2,3)=G(77)
      SU(3,1)=G(78)
      SU(3,2)=G(79)
      SU(3,3)=G(80)
      SD(1,1)=G(81)
      SD(1,2)=G(82)
      SD(1,3)=G(83)
      SD(2,1)=G(84)
      SD(2,2)=G(85)
      SD(2,3)=G(86)
      SD(3,1)=G(87)
      SD(3,2)=G(88)
      SD(3,3)=G(89)
      SL(1,1)=G(90)
      SL(1,2)=G(91)
      SL(1,3)=G(92)
      SL(2,1)=G(93)
      SL(2,2)=G(94)
      SL(2,3)=G(95)
      SL(3,1)=G(96)
      SL(3,2)=G(97)
      SL(3,3)=G(98)
      SE(1,1)=G(99)
      SE(1,2)=G(100)
      SE(1,3)=G(101)
      SE(2,1)=G(102)
      SE(2,2)=G(103)
      SE(2,3)=G(104)
      SE(3,1)=G(105)
      SE(3,2)=G(106)
      SE(3,3)=G(107)
      AU(1,1)=G(108)
      AU(1,2)=G(109)
      AU(1,3)=G(110)
      AU(2,1)=G(111)
      AU(2,2)=G(112)
      AU(2,3)=G(113)
      AU(3,1)=G(114)
      AU(3,2)=G(115)
      AU(3,3)=G(116)
      AD(1,1)=G(117)
      AD(1,2)=G(118)
      AD(1,3)=G(119)
      AD(2,1)=G(120)
      AD(2,2)=G(121)
      AD(2,3)=G(122)
      AD(3,1)=G(123)
      AD(3,2)=G(124)
      AD(3,3)=G(125)
      AE(1,1)=G(126)
      AE(1,2)=G(127)
      AE(1,3)=G(128)
      AE(2,1)=G(129)
      AE(2,2)=G(130)
      AE(2,3)=G(131)
      AE(3,1)=G(132)
      AE(3,2)=G(133)
      AE(3,3)=G(134)
C....
      IF(Q.LT.MSUSY) THEN
      Y2=0.
      DO I=1,3
      DO J=1,3
       Y2=Y2+3.*(HU(I,J)*HU(I,J)*SINB**2
     $   +HD(I,J)*HD(I,J)*COSB**2)+HE(I,J)*HE(I,J)*COSB**2
     $   +COSB**2*(3.*HU(I,J)*HU(I,J)-3.*HD(I,J)*HD(I,J)
     $             -HE(I,J)*HE(I,J))
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+(-17*G(1)**2/20.-9*G(2)**2/4.-8*G(3)**2
     $           +Y2)*UN(I,K)*UN(K,L)*HU(L,J)
     $         +3./2.*(HU(I,K)*HU(L,K)*SINB**2
     $                 -HD(I,K)*HD(L,K)*COSB**2)*HU(L,J)
       ENDDO
       ENDDO
      ENDDO
      ENDDO
      F(36)=1./16./PI**2*PO(1,1)
      F(37)=1./16./PI**2*PO(1,2)
      F(38)=1./16./PI**2*PO(1,3)
      F(39)=1./16./PI**2*PO(2,1)
      F(40)=1./16./PI**2*PO(2,2)
      F(41)=1./16./PI**2*PO(2,3)
      F(42)=1./16./PI**2*PO(3,1)
      F(43)=1./16./PI**2*PO(3,2)
      F(44)=1./16./PI**2*PO(3,3)
      Y2=0.
      DO I=1,3
      DO J=1,3
       Y2=Y2+3.*(HU(I,J)*HU(I,J)*SINB**2
     $   +HD(I,J)*HD(I,J)*COSB**2)+HE(I,J)*HE(I,J)*COSB**2
     $   -SINB**2*(3.*HU(I,J)*HU(I,J)-3.*HD(I,J)*HD(I,J)
     $             -HE(I,J)*HE(I,J))
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+(-1*G(1)**2/4.-9*G(2)**2/4.-8*G(3)**2
     $           +Y2)*UN(I,K)*UN(K,L)*HD(L,J)
     $          -3./2.*(HU(I,K)*HU(L,K)*SINB**2
     $                 -HD(I,K)*HD(L,K)*COSB**2)*HD(L,J)
       ENDDO
       ENDDO
      ENDDO
      ENDDO
      F(45)=1./16./PI**2*PO(1,1)
      F(46)=1./16./PI**2*PO(1,2)
      F(47)=1./16./PI**2*PO(1,3)
      F(48)=1./16./PI**2*PO(2,1)
      F(49)=1./16./PI**2*PO(2,2)
      F(50)=1./16./PI**2*PO(2,3)
      F(51)=1./16./PI**2*PO(3,1)
      F(52)=1./16./PI**2*PO(3,2)
      F(53)=1./16./PI**2*PO(3,3)
      Y2=0.
      DO I=1,3
      DO J=1,3
       Y2=Y2+3.*(HU(I,J)*HU(I,J)*SINB**2
     $   +HD(I,J)*HD(I,J)*COSB**2)+HE(I,J)*HE(I,J)*COSB**2
     $   -SINB**2*(3.*HU(I,J)*HU(I,J)-3.*HD(I,J)*HD(I,J)
     $             -HE(I,J)*HE(I,J))
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+(-9*G(1)**2/4.-9*G(2)**2/4.
     $           +Y2)*UN(I,K)*UN(K,L)*HE(L,J)
     $          +3./2.*(HE(I,K)*HE(L,K)*COSB**2)*HE(L,J)
       ENDDO
       ENDDO
      ENDDO
      ENDDO
      F(54)=1./16./PI**2*PO(1,1)
      F(55)=1./16./PI**2*PO(1,2)
      F(56)=1./16./PI**2*PO(1,3)
      F(57)=1./16./PI**2*PO(2,1)
      F(58)=1./16./PI**2*PO(2,2)
      F(59)=1./16./PI**2*PO(2,3)
      F(60)=1./16./PI**2*PO(3,1)
      F(61)=1./16./PI**2*PO(3,2)
      F(62)=1./16./PI**2*PO(3,3)
      ELSE
      Y2=0.
      DO I=1,3
      DO J=1,3
       Y2=Y2+3.*HU(I,J)*HU(I,J)
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+(-13*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.
     $           +Y2)*UN(I,K)*UN(K,L)*HU(L,J)
     $         +(3.*HU(I,K)*HU(L,K)+HD(I,K)*HD(L,K))*HU(L,J)
       ENDDO
       ENDDO
      ENDDO
      ENDDO
      F(36)=1./16./PI**2*PO(1,1)
      F(37)=1./16./PI**2*PO(1,2)
      F(38)=1./16./PI**2*PO(1,3)
      F(39)=1./16./PI**2*PO(2,1)
      F(40)=1./16./PI**2*PO(2,2)
      F(41)=1./16./PI**2*PO(2,3)
      F(42)=1./16./PI**2*PO(3,1)
      F(43)=1./16./PI**2*PO(3,2)
      F(44)=1./16./PI**2*PO(3,3)
      Y2=0.
      DO I=1,3
      DO J=1,3
       Y2=Y2+3.*HD(I,J)*HD(I,J)+HE(I,J)*HE(I,J)
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+(-7*G(1)**2/15.-3*G(2)**2-16*G(3)**2/3.
     $           +Y2)*UN(I,K)*UN(K,L)*HD(L,J)
     $          +(3.*HD(I,K)*HD(L,K)+HU(I,K)*HU(L,K))*HD(L,J)
       ENDDO
       ENDDO
      ENDDO
      ENDDO
      F(45)=1./16./PI**2*PO(1,1)
      F(46)=1./16./PI**2*PO(1,2)
      F(47)=1./16./PI**2*PO(1,3)
      F(48)=1./16./PI**2*PO(2,1)
      F(49)=1./16./PI**2*PO(2,2)
      F(50)=1./16./PI**2*PO(2,3)
      F(51)=1./16./PI**2*PO(3,1)
      F(52)=1./16./PI**2*PO(3,2)
      F(53)=1./16./PI**2*PO(3,3)
      Y2=0.
      DO I=1,3
      DO J=1,3
       PO(I,J)=0.
       Y2=Y2+3.*HD(I,J)*HD(I,J)+HE(I,J)*HE(I,J)
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+(-9.*G(1)**2/5.-3.*G(2)**2
     $           +Y2)*UN(I,K)*UN(K,L)*HE(L,J)
     $          +(3.*HE(I,K)*HE(L,K))*HE(L,J)
       ENDDO
       ENDDO
      ENDDO
      ENDDO
      F(54)=1./16./PI**2*PO(1,1)
      F(55)=1./16./PI**2*PO(1,2)
      F(56)=1./16./PI**2*PO(1,3)
      F(57)=1./16./PI**2*PO(2,1)
      F(58)=1./16./PI**2*PO(2,2)
      F(59)=1./16./PI**2*PO(2,3)
      F(60)=1./16./PI**2*PO(3,1)
      F(61)=1./16./PI**2*PO(3,2)
      F(62)=1./16./PI**2*PO(3,3)
      ENDIF
c
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+1./2.*(HU(I,K)*HU(L,K)*SQ(L,J)+
     $          SQ(I,K)*HU(K,L)*HU(J,L)+
     $          2.*(HU(I,K)*SU(K,L)*HU(J,L)+
     $              G(14)*UN(I,K)*HU(K,L)*HU(J,L)+
     $              UN(I,K)*AU(K,L)*AU(J,L)))+
     $          1./2.*(HD(I,K)*HD(L,K)*SQ(L,J)+
     $          SQ(I,K)*HD(K,L)*HD(J,L)+
     $          2.*(HD(I,K)*SD(K,L)*HD(J,L)+
     $              G(13)*UN(I,K)*HD(K,L)*HD(J,L)+
     $              UN(I,K)*AD(K,L)*AD(J,L)))
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-G(1)**2*G(7)**2/15.-3*G(2)**2*G(8)**2
     $         -16*G(3)**2*G(9)**2/3.+G(1)**2*SMV/10.)*UN(I,J)
      ENDDO
      ENDDO
      F(63)=FAC*PO(1,1)
      F(64)=FAC*PO(1,2)
      F(65)=FAC*PO(1,3)
      F(66)=FAC*PO(2,1)
      F(67)=FAC*PO(2,2)
      F(68)=FAC*PO(2,3)
      F(69)=FAC*PO(3,1)
      F(70)=FAC*PO(3,2)
      F(71)=FAC*PO(3,3)
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+HU(K,I)*HU(K,L)*SU(L,J)+
     $          SU(I,K)*HU(L,K)*HU(L,J)+
     $          2.*(HU(K,I)*SQ(K,L)*HU(L,J)+
     $              G(14)*UN(I,K)*HU(L,K)*HU(L,J)+
     $              UN(I,K)*AU(L,K)*AU(L,J))
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-16*G(1)**2*G(7)**2/15.
     $         -16*G(3)**2*G(9)**2/3.-2.*G(1)**2*SMV/5.)*UN(I,J)
      ENDDO
      ENDDO
      F(72)=FAC*PO(1,1)
      F(73)=FAC*PO(1,2)
      F(74)=FAC*PO(1,3)
      F(75)=FAC*PO(2,1)
      F(76)=FAC*PO(2,2)
      F(77)=FAC*PO(2,3)
      F(78)=FAC*PO(3,1)
      F(79)=FAC*PO(3,2)
      F(80)=FAC*PO(3,3)
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+HD(K,I)*HD(K,L)*SD(L,J)+
     $          SD(I,K)*HD(L,K)*HD(L,J)+
     $          2.*(HD(K,I)*SQ(K,L)*HD(L,J)+
     $              G(13)*UN(I,K)*HD(L,K)*HD(L,J)+
     $              UN(I,K)*AD(L,K)*AD(L,J))
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-4*G(1)**2*G(7)**2/15.
     $         -16*G(3)**2*G(9)**2/3.+G(1)**2*SMV/5.)*UN(I,J)
      ENDDO
      ENDDO
      F(81)=FAC*PO(1,1)
      F(82)=FAC*PO(1,2)
      F(83)=FAC*PO(1,3)
      F(84)=FAC*PO(2,1)
      F(85)=FAC*PO(2,2)
      F(86)=FAC*PO(2,3)
      F(87)=FAC*PO(3,1)
      F(88)=FAC*PO(3,2)
      F(89)=FAC*PO(3,3)
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+1./2.*(HE(I,K)*HE(L,K)*SL(L,J)+
     $          SL(I,K)*HE(K,L)*HE(J,L)+
     $          2.*(HE(I,K)*SE(K,L)*HE(J,L)+
     $              G(13)*UN(I,K)*HU(K,L)*HU(J,L)+
     $              UN(I,K)*AE(K,L)*AE(J,L)))
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-3*G(1)**2*G(7)**2/5.
     $         -3*G(2)**2*G(8)**2-3.*G(1)**2*SMV/10.)*UN(I,J)
      ENDDO
      ENDDO
      F(90)=FAC*PO(1,1)
      F(91)=FAC*PO(1,2)
      F(92)=FAC*PO(1,3)
      F(93)=FAC*PO(2,1)
      F(94)=FAC*PO(2,2)
      F(95)=FAC*PO(2,3)
      F(96)=FAC*PO(3,1)
      F(97)=FAC*PO(3,2)
      F(98)=FAC*PO(3,3)
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+HE(K,I)*HE(K,L)*SE(L,J)+
     $          SE(I,K)*HE(L,K)*HE(L,J)+
     $          2.*(HE(K,I)*SL(K,L)*HE(L,J)+
     $              G(13)*UN(I,K)*HE(L,K)*HE(L,J)+
     $              UN(I,K)*AE(L,K)*AE(L,J))
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-12*G(1)**2*G(7)**2/15.
     &                  +3.*G(1)**2*SMV/5.)*UN(I,J)
      ENDDO
      ENDDO
      F(99)=FAC*PO(1,1)
      F(100)=FAC*PO(1,2)
      F(101)=FAC*PO(1,3)
      F(102)=FAC*PO(2,1)
      F(103)=FAC*PO(2,2)
      F(104)=FAC*PO(2,3)
      F(105)=FAC*PO(3,1)
      F(106)=FAC*PO(3,2)
      F(107)=FAC*PO(3,3)
c
      Y1=0.
      Y2=0.
      DO I=1,3
      DO J=1,3
       DO K=1,3
        Y1=Y1+6.*AU(I,K)*HU(J,K)
        Y2=Y2+3.*HU(I,K)*HU(J,K)
       ENDDO
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+4.*AU(I,K)*HU(L,K)*HU(L,J)+
     $          5.*HU(I,K)*HU(L,K)*AU(L,J)+
     $          2.*AD(I,K)*HD(L,K)*HU(L,J)+
     $          HD(I,K)*HD(L,K)*AU(L,J)
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-13*G(1)**2/15.-3*G(2)**2
     $         -16*G(3)**2/3.+Y2)*AU(I,J)+
     $         2.*(13*G(1)**2*G(7)/15.+3*G(2)**2*G(8)
     $             +16*G(3)**2*G(9)/3.+Y1)*HU(I,J)
      ENDDO
      ENDDO
      F(108)=1./16./PI**2*PO(1,1)
      F(109)=1./16./PI**2*PO(1,2)
      F(110)=1./16./PI**2*PO(1,3)
      F(111)=1./16./PI**2*PO(2,1)
      F(112)=1./16./PI**2*PO(2,2)
      F(113)=1./16./PI**2*PO(2,3)
      F(114)=1./16./PI**2*PO(3,1)
      F(115)=1./16./PI**2*PO(3,2)
      F(116)=1./16./PI**2*PO(3,3)
      Y1=0.
      Y2=0.
      DO I=1,3
      DO J=1,3
       DO K=1,3
        Y1=Y1+6.*AD(I,K)*HD(J,K)+2.*AE(I,K)*HE(J,K)
        Y2=Y2+3.*HD(I,K)*HD(J,K)+HE(I,K)*HE(J,K)
       ENDDO
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+4.*AD(I,K)*HD(L,K)*HD(L,J)+
     $          5.*HD(I,K)*HD(L,K)*AD(L,J)+
     $          2.*AU(I,K)*HU(L,K)*HD(L,J)+
     $          HU(I,K)*HU(L,K)*AD(L,J)
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-7*G(1)**2/15.-3*G(2)**2
     $         -16*G(3)**2/3.+Y2)*AD(I,J)+
     $         2.*(7*G(1)**2*G(7)/15.+3*G(2)**2*G(8)
     $             +16*G(3)**2*G(9)/3.+Y1)*HD(I,J)
      ENDDO
      ENDDO
      F(117)=1./16./PI**2*PO(1,1)
      F(118)=1./16./PI**2*PO(1,2)
      F(119)=1./16./PI**2*PO(1,3)
      F(120)=1./16./PI**2*PO(2,1)
      F(121)=1./16./PI**2*PO(2,2)
      F(122)=1./16./PI**2*PO(2,3)
      F(123)=1./16./PI**2*PO(3,1)
      F(124)=1./16./PI**2*PO(3,2)
      F(125)=1./16./PI**2*PO(3,3)
      Y1=0.
      Y2=0.
      DO I=1,3
      DO J=1,3
       DO K=1,3
        Y1=Y1+2.*AE(I,K)*HE(J,K)
        Y2=Y2+HE(I,K)*HE(J,K)
       ENDDO
      ENDDO
      ENDDO
      DO I=1,3
      DO J=1,3
       PO(I,J)=0. 
       DO K=1,3
       DO L=1,3
        PO(I,J)=PO(I,J)+4.*AE(I,K)*HE(L,K)*HE(L,J)+
     $          5.*HE(I,K)*HE(L,K)*AE(L,J)+
     $          6.*AD(I,K)*HD(L,K)*HE(L,J)+
     $          3.*HD(I,K)*HD(L,K)*AE(L,J)
       ENDDO
       ENDDO
       PO(I,J)=PO(I,J)+(-3*G(1)**2-3*G(2)**2+Y2)*AD(I,J)+
     $         2.*(3*G(1)**2*G(7)+3*G(2)**2*G(8)+Y1)*HD(I,J)
      ENDDO
      ENDDO
      F(126)=1./16./PI**2*PO(1,1)
      F(127)=1./16./PI**2*PO(1,2)
      F(128)=1./16./PI**2*PO(1,3)
      F(129)=1./16./PI**2*PO(2,1)
      F(130)=1./16./PI**2*PO(2,2)
      F(131)=1./16./PI**2*PO(2,3)
      F(132)=1./16./PI**2*PO(3,1)
      F(133)=1./16./PI**2*PO(3,2)
      F(134)=1./16./PI**2*PO(3,3)
c
c
      F(44)=F(6)
      F(53)=F(5)
      F(62)=F(4)
      F(71)=F(24)
      F(80)=F(23)
      F(89)=F(22)
      F(98)=F(21)
      F(107)=F(20)
      F(116)=F(6)*G(12)+G(6)*F(12)
      F(125)=F(5)*G(11)+G(5)*F(11)     
      F(134)=F(4)*G(10)+G(4)*F(10)
c
      RETURN
      END
C_________________________________________________________________
      SUBROUTINE GAMMASM(T,CSM,F)            
C-----------------------------------------------------------------
C     Eq. 24 of Anlauf
      IMPLICIT REAL (A-H,M,O-Z)
      REAL CSM(9),F(9)
      COMMON /G3/ G3         
      PI=4.*ATAN(1.)
      FAC=G3**2/(8.*PI**2)
C
      F(1)=FAC*(20./3.*CSM(1)-8.*CSM(2)+6.*CSM(4)
     $         +4.*CSM(5)+2.*CSM(6))
      F(2)=FAC*(CSM(1)+2./3.*CSM(2)+2.*CSM(4)
     $         +3./2.*CSM(5)+CSM(6)+1./2.*CSM(7))
      F(3)=FAC*(-2.*CSM(1)+4./3.*CSM(2)+16./3.*CSM(3)
     $         -CSM(4)+CSM(6)+2.*CSM(7)+4./3.*CSM(9))
      F(4)=FAC*(2./3.*CSM(4)-113./36.*CSM(5)-2.*CSM(6)
     $         -113./36.*CSM(7))
      F(5)=FAC*(2.*CSM(4)+137./18.*CSM(5)+2.*CSM(6)
     $         +89./18.*CSM(7))
      F(6)=FAC*(-2.*CSM(4)-113./36.*CSM(5)+2./3.*CSM(6)
     $         -113./36.*CSM(7))
      F(7)=FAC*(-2.*CSM(4)-4./3.*CSM(5)-2.*CSM(6)
     $         +4./3.*CSM(7))
      F(8)=FAC*(9./4.*CSM(5)+9./4.*CSM(7))
      F(9)=0.
      RETURN
      END
C-----------------------------------------------------------------
      SUBROUTINE GAMMAHP(T,CH2,F)            
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      REAL CH2(19),F(19),SMIX(6),RMIX(2),ABMIX(2),MCHA(2),
     $       MSQU(3),MSQD(3),BB
+CDE,SIGPAS
C-FP  include 'sugpas.h'
C
      COMMON /CHRGN/ MCHA,MSQU,MSQD,SMIX,RMIX,ABMIX     
      COMMON/SCALEQ/Q
      COMMON /G3/G3
      DATA MZ/91.17/
C
      NS=0.
      IF(MSQU(1).LT.Q) THEN
       NS=NS+1.
      ENDIF
      IF(MSQU(2).LT.Q) THEN
       NS=NS+1.
      ENDIF
      IF(MSQU(3).LT.Q) THEN
       NS=NS+10.
      ENDIF             
      NF=6.
      NFT=3.-2.*3.
      BB=-11./2.+1./3.*NF+1./12.*ns
      PI=4.*ATAN(1.)
      FAC=G3**2/(8.*PI**2)
C
      F(1)=FAC*(20./3.*CH2(1)-8.*CH2(2)+6.*CH2(4)
     $         +4.*CH2(5)+2.*CH2(6))
      F(2)=FAC*(CH2(1)+2./3.*CH2(2)+2.*CH2(4)
     $         +3./2.*CH2(5)+CH2(6)+1./2.*CH2(7)
     $         -3./2.*CH2(10)-119./54.*CH2(11)
     $         +(70./27.+3./2.*NF)*CH2(12)
     $         +(3.+35./27.*NF)*CH2(13)
     $         +(-7./3.-3./2.*NF)*CH2(14)
     $         +(-2.-119./54.*NF)*CH2(15)
     $         -1./2.*CH2(17)+1./2.*CH2(19))
      F(3)=FAC*(-2.*CH2(1)+4./3.*CH2(2)+16./3.*CH2(3)
     $         -CH2(4)+CH2(6)+2.*CH2(7)+4./3.*CH2(9)
     $         +224./27.*CH2(11)+232./27.*CH2(12)
     $         +(8./27.*NF+4.*NFT)*CH2(13)
     $         -16./3.*CH2(14)
     $         +(8./27.*NF-4.*NFT)*CH2(15)
     $         +3.*CH2(16)+CH2(17)
     $         -3.*CH2(18)-CH2(19))
      F(4)=FAC*(2./3.*CH2(4)-113./36.*CH2(5)-2.*CH2(6)
     $         -113./36.*CH2(7)
     $         +2./3.*CH2(11)+4./3.*CH2(12)
     $         +2.*NF/3.*CH2(13)+2.*NF/3.*CH2(15))    
      F(5)=FAC*(2.*CH2(4)+137./18.*CH2(5)+2.*CH2(6)
     $         +89./18.*CH2(7)
     $         -4./3.*CH2(11)-8./3.*CH2(12)
     $         -4.*NF/3.*CH2(13)-4.*NF/3.*CH2(15))    
      F(6)=FAC*(-2.*CH2(4)-113./36.*CH2(5)+2./3.*CH2(6)
     $         -113./36.*CH2(7)
     $         +2./3.*CH2(11)+4./3.*CH2(12)
     $         +2.*NF/3.*CH2(13)+2.*NF/3.*CH2(15))    
      F(7)=FAC*(-2.*CH2(4)-4./3.*CH2(5)-2.*CH2(6)
     $         +4./3.*CH2(7))
      F(8)=FAC*(9./4.*CH2(5)+9./4.*CH2(7)
     $         -4.*CH2(10)-2.*CH2(11)-6.*CH2(12)
     $         +2./3.*(3.-NF)*CH2(13)-6.*CH2(14)    
     $         +2./3.*(-3.-NF)*CH2(15))     
      F(9)=0.
      F(10)=FAC*(CH2(10))
      F(11)=FAC*(-3.*CH2(10)-8.*CH2(11))
      F(12)=FAC*(-1./9.*CH2(11)-11./9.*CH2(12)
     $           +(3.-NF/9.)*CH2(13)-NF/9.*CH2(15)    
     $          -1./36.*RMIX(1)+1./36.*RMIX(2))   
      F(13)=FAC*(1./3.*CH2(11)+11./3.*CH2(12)
     $           +(NF/3.-1.)*CH2(13)+NF/3.*CH2(15)     
     $          +1./12.*RMIX(1)-1./12.*RMIX(2))   
      F(14)=FAC*(-1./9.*CH2(11)-2./9.*CH2(12)
     $           -NF/9.*CH2(13)+CH2(14)-NF/9.*CH2(15) 
     $          -1./36.*RMIX(1)+1./36.*RMIX(2))   
      F(15)=FAC*(1./3.*CH2(11)+2./3.*CH2(12)
     $           +NF/3.*CH2(13)-3.*CH2(14)
     $           +(NF/3.-8.)*CH2(15) 
     $          +1./12.*RMIX(1)-1./12.*RMIX(2))   
      F(16)=FAC*((1.-2.*BB)*CH2(16)-7.*CH2(18)-6.*CH2(19))    
      F(17)=FAC*(-3.*CH2(16)+(-8.-2.*BB)*CH2(17)
     $           -3.*CH2(18)+2.*CH2(19))    
      F(18)=FAC*(-7./3.*CH2(16)-2.*CH2(17)
     $           +(-19./3.-2.*BB)*CH2(18))   
      F(19)=FAC*(-CH2(16)+2./3.*CH2(17)
     $          +(8./3.-2.*BB)*CH2(19))
      RETURN
      END


c______________________________________________________________________
      SUBROUTINE GAMMAC1(T,CPOA,F)            
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      REAL CPOA(12),F(12)
      REAL MCHA(2),MSQU(3),MSQD(3),SMIX(6),RMIX(2),ABMIX(2),BB
      
+CDE,SUGPAS
C-FP  include 'sugpas.h'
C
      COMMON / G3/ G3
      COMMON /CHRGN/ MCHA,MSQU,MSQD,SMIX,RMIX,ABMIX             
      COMMON/SCALEQ/Q
      DATA MZ/91.17/
C
      NS=0.
      IF(MSQU(1).LT.Q) THEN
       NS=NS+1.
      ENDIF
      IF(MSQU(2).LT.Q) THEN
       NS=NS+1.
      ENDIF
      IF(MSQU(3).LT.Q) THEN
       NS=NS+10.
      ENDIF             
      IF(Q.GT.AMT) THEN 
       NF=6.
       NFT=3.-2.*3.
      ELSE
       NF=5.
       NFT=3.-2.*2.
      ENDIF
      BB=-11./2.+1./3*NF+1./12.*NS
      PI=4.*ATAN(1.)
      FAC=G3**2/(8.*PI**2)
      
C
      F(1)=FAC*(20./3.*CPOA(1)-8.*CPOA(2)+6.*CPOA(4)
     $         +4.*CPOA(5)+2.*CPOA(6))
      F(2)=FAC*(CPOA(1)+2./3.*CPOA(2)+2.*CPOA(4)
     $         +3./2.*CPOA(5)+CPOA(6)+1./2.*CPOA(7))
      F(3)=FAC*(-2.*CPOA(1)+4./3.*CPOA(2)+16./3.*CPOA(3)
     $         -CPOA(4)+CPOA(6)+2.*CPOA(7)+4./3.*CPOA(9)
     $         +3.*CPOA(11))
      F(4)=FAC*(2./3.*CPOA(4)-113./36.*CPOA(5)-2.*CPOA(6)
     $         -113./36.*CPOA(7))    
      F(5)=FAC*(2.*CPOA(4)+137./18.*CPOA(5)+2.*CPOA(6)
     $         +89./18.*CPOA(7))
      F(6)=FAC*(-2.*CPOA(4)-113./36.*CPOA(5)+2./3.*CPOA(6)
     $         -113./36.*CPOA(7))
      F(7)=FAC*(-2.*CPOA(4)-4./3.*CPOA(5)-2.*CPOA(6)
     $         +4./3.*CPOA(7))
      F(8)=FAC*(9./4.*CPOA(5)+9./4.*CPOA(7)
     $         +2.*CPOA(12))
      F(9)=0.
      F(10)=FAC*(-2.*BB*CPOA(10))
      F(11)=FAC*(16./3.-2.*BB)*CPOA(11)
      F(12)=FAC*(-2.*BB*CPOA(12))   
      RETURN
      END
c______________________________________________________________________
      SUBROUTINE GAMMAC2(T,CPOB,F)            
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      REAL CPOB(17),F(17)
      REAL MCHA(2),MSQU(3),MSQD(3),SMIX(6),RMIX(2),ABMIX(2)
+CDE,SUGPAS
C-FP  include 'sugpas.h'
C
      COMMON / G3/ G3          
      COMMON /CHRGN/ MCHA,MSQU,MSQD,SMIX,RMIX,ABMIX             
      COMMON/SCALEQ/Q
      DATA MZ/91.17/
C   
      EN=3.
      NS=0.
      IF(MSQU(1).LT.Q) THEN
       NS=NS+1.
      ENDIF
      IF(MSQU(2).LT.Q) THEN
       NS=NS+1.
      ENDIF
      IF(MSQU(3).LT.Q) THEN
       NS=NS+10.
      ENDIF             
      IF(Q.GT.AMT) THEN 
       NF=6.
       NFT=3.-2.*3.
      ELSE
       NF=5.
       NFT=3.-2.*2.
      ENDIF
      PI=4.*ATAN(1.)
      FAC=G3**2/(8.*PI**2)
C
      F(1)=FAC*(20./3.*CPOB(1)-8.*CPOB(2)+6.*CPOB(4)
     $         +4.*CPOB(5)+2.*CPOB(6))
      F(2)=FAC*(CPOB(1)+2./3.*CPOB(2)+2.*CPOB(4)
     $         +3./2.*CPOB(5)+CPOB(6)+1./2.*CPOB(7)
     $         +(EN**2-2.)/8./EN*CPOB(10)+1./4.*CPOB(11)
     $         +(EN**2-2.)/8./EN*CPOB(12)
     $         -((EN**2-2.)/16./EN+(EN**2+2.)/72./EN)*CPOB(13)
     $         -((EN**2-2.)/16./EN-(EN**2+2.)/72./EN)*CPOB(14)
     $         +1./4.*CPOB(15)-1./8.*CPOB(16)-1./8.*CPOB(17))
      F(3)=FAC*(-2.*CPOB(1)+4./3.*CPOB(2)+16./3.*CPOB(3)
     $         -CPOB(4)+CPOB(6)+2.*CPOB(7)+4./3.*CPOB(9)
     $         -2.*(EN**2-1.)/4./EN*CPOB(10)
     $         -2.*(EN**2-1.)/4./EN*CPOB(12)
     $         +10./18.*(EN**2-1.)/2./EN*CPOB(13)
     $         +8./18.*(EN**2-1.)/2./EN*CPOB(14))
      F(4)=FAC*(2./3.*CPOB(4)-113./36.*CPOB(5)-2.*CPOB(6)
     $         -113./36.*CPOB(7))    
      F(5)=FAC*(2.*CPOB(4)+137./18.*CPOB(5)+2.*CPOB(6)
     $         +89./18.*CPOB(7))
      F(6)=FAC*(-2.*CPOB(4)-113./36.*CPOB(5)+2./3.*CPOB(6)
     $         -113./36.*CPOB(7))
      F(7)=FAC*(-2.*CPOB(4)-4./3.*CPOB(5)-2.*CPOB(6)
     $         +4./3.*CPOB(7))
      F(8)=FAC*(9./4.*CPOB(5)+9./4.*CPOB(7))
      F(9)=0.
      F(10)=FAC*(1./2.*CPOB(10)+9./2.*CPOB(12)-1./2.*CPOB(13)
     $      -4.*CPOB(14)+3./2.*CPOB(16)-3./2.*CPOB(17))
      F(11)=FAC*(-3./2.*CPOB(10)-4.*CPOB(11)-3./2.*CPOB(12)
     $          +3./2.*CPOB(13)-1./2.*CPOB(16)+1./2.*CPOB(17))
      F(12)=FAC*(-4.*CPOB(12))
      F(13)=FAC*(-25./6.*CPOB(13)+1./6.*CPOB(14)
     $          +1./3.*SMIX(2)+2./3.*SMIX(3) 
     $          +NF/3.*SMIX(4)+NF/3.*SMIX(6)
     $          +1./12.*ABMIX(1)-1./12.*ABMIX(2))   
      F(14)=FAC*(-25./6.*CPOB(14)+1./6.*CPOB(13)   
     $          -1./3.*SMIX(2)-2./3.*SMIX(3) 
     $          -NF/3.*SMIX(4)-NF/3.*SMIX(6)   
     $          -1./12.*ABMIX(1)+1./12.*ABMIX(2))   
      F(15)=FAC*(-4.*CPOB(15))
      F(16)=FAC*(13./18.*CPOB(13)-13./18.*CPOB(14)
     $          -2.*CPOB(16)-2.*CPOB(17)
     $          -1./9.*SMIX(2)-2./9.*SMIX(3) 
     $          -NF/9.*SMIX(4)-NF/9.*SMIX(6)
     $          -1./36.*ABMIX(1)+1./36.*ABMIX(2))   
         F(17)=FAC*(-13./18.*CPOB(13)+13./18.*CPOB(14)
     $          -2.*CPOB(16)-2.*CPOB(17)
     $          +1./9.*SMIX(2)+2./9.*SMIX(3) 
     $          +NF/9.*SMIX(4)+NF/9.*SMIX(6)   
     $          +1./36.*ABMIX(1)-1./36.*ABMIX(2))   
      RETURN
      END
c______________________________________________________________________
      SUBROUTINE GAMMAWB1(T,CI1,F)            
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      REAL CI1(8),F(8)
      REAL NF,NU,ND,EN
+CDE,SUGPAS
C-FP  include 'sugpas.h'

      COMMON / G3/ G3
      DATA MZ/91.17/
C   
      NF=5.
      NU=2.
      ND=3.
C     
      PI=4.*ATAN(1.)
      FAC=G3**2/(16.*PI**2)
C
      F(1)=FAC*(-2.*CI1(1)+6.*CI1(2))       
      F(2)=FAC*(6.*CI1(1)-2.*CI1(2))
      F(3)=FAC*(-2./9.*CI1(2)-22./9.*CI1(3)
     $         -2./9.*NF*CI1(4)-2./9.*NF*CI1(6))
      F(4)=FAC*(2./3.*CI1(2)+22./3.*CI1(3)
     $          +(-2.+2./3.*NF)*CI1(4)+2./3.*NF*CI1(6))    
      F(5)=FAC*(-2./9.*CI1(2)-4./9.*CI1(3)
     $         -2./9.*NF*CI1(4)+2.*CI1(5)-2./9.*NF*CI1(6))
      F(6)=FAC*(2./3.*CI1(2)+4./3.*CI1(3)+2./3.*NF*CI1(4)
     $          -6.*CI1(5)+(-16.+2./3.*NF)*CI1(6))
      F(7)=FAC*(416./81.*CI1(2)-464./81.*CI1(3)
     $          +(416./81.*NU-232./81.*ND)*CI1(4)
     $          +32./9.*CI1(5)
     $          +(-448./81.*NU+200./81.*ND)*CI1(6)
     $          +32./3.*CI1(7)-32./9.*CI1(8))
      F(8)=FAC*(3.*CI1(1)+70./27.*CI1(2)
     $          +(140./27.+3.*NF)*CI1(3)
     $          +(6.+70./27.*NF)*CI1(4)
     $          +(-14./3.-3.*NF)*CI1(5)
     $          +(-4.-119./27.*NF)*CI1(6)
     $          +28./3.*CI1(8))        
      RETURN
      END
c______________________________________________________________________
      SUBROUTINE GAMMAWB2(T,CI2,F)            
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,N,O-Z)
      REAL CI2(8),F(8)
+CDE,SUGPAS
C-FP  include 'sugpas.h'
C
      COMMON / G3/ G3
C
      DATA MZ/91.17/
C   
      EN=3.
      NF=5.
      NU=2.
      ND=3.
      
      par=0.
C     
      PI=4.*ATAN(1.)
      FAC1=G3**2/(16.*PI**2)
      FAC2=G3**4/(16.*PI**2)**2
C
      F(1)=FAC1*(-2.*CI2(1)+6.*CI2(2))       
     $    +FAC2*((-22./3.-57./2./EN**2-2./3./EN*NF)*CI2(1)
     $          +(-19.*EN/6.+39./EN+2./3.*NF)*CI2(2))
      F(2)=FAC1*(6.*CI2(1)-2.*CI2(2))
     $    +FAC2*((-19.*EN/6.+39./EN+2./3.*NF)*CI2(1)
     $           +(-22./3.-57./2./EN**2-3./3./EN*NF)*CI2(2))
      F(3)=FAC1*(-2./9.*CI2(2)-22./9.*CI2(3)
     $         -2./9.*NF*CI2(4)-2./9.*NF*CI2(6))
     $    +FAC2*((3.*EN-2./3./EN)*CI2(1)
     $          +(-32./27.+86./27/EN**2)*CI2(2)
     $          +(-262./27.-1195./54./EN**2+3.*EN*NF
     $            -10./3./EN*NF)*CI2(3)
     $          +(17.*EN/6.+113./3./EN-2./27.*EN*NF
     $            +74./27./EN**2*NF)*CI2(4)
     $          +(-3.*EN*NF+20./3./EN*NF)*CI2(5)
     $          +(-56./27.*NF-178./27./EN**2*NF)*CI2(6))
      F(4)=FAC1*(2./3.*CI2(2)+22./3.*CI2(3)
     $          +(-2.+2./3.*NF)*CI2(4)+2./3.*NF*CI2(6))    
     $    +FAC2*(-7./3.*CI2(1)
     $          +(-176.*EN/27.-230./27./EN)*CI2(2)
     $          +(-533.*EN/54.+593./27./EN
     $            +1./3.*NF)*CI2(3)
     $          +(-12.-57./2./EN**2+110./27.*NF
     $            -182./27./EN*NF)*CI2(4)
     $          -11/3.*NF*CI2(5)
     $          +(-16.*EN/27.*NF+250./27./EN*NF)*CI2(6))
      F(5)=FAC1*(-2./9.*CI2(2)-4./9.*CI2(3)
     $         -2./9.*NF*CI2(4)+2.*CI2(5)-2./9.*NF*CI2(6))
     $    +FAC2*((-3.*EN+16./3./EN)*CI2(1)
     $          +(-122./27.-94./27./EN**2)*CI2(2)
     $          +(-244./27.-188./27./EN**2-3.*EN*NF
     $            +10./3./EN*NF)*CI2(3)
     $          +(-6.*EN+32./3./EN-56./27.*NF
     $            +2./27./EN**2*NF)*CI2(4)
     $          +(137/6.+15./2./EN**2+3.*EN*NF
     $            -20./3./EN*NF)*CI2(5)
     $          +(-71./2.*EN-18./EN+178./27.*NF
     $            +74./27./EN**2*NF)*CI2(6))
      F(6)=FAC1*(2./3.*CI2(2)+4./3.*CI2(3)+2./3.*NF*CI2(4)
     $          -6.*CI2(5)+(-16.+2./3.*NF)*CI2(6))
     $    +FAC2*(-7./3.*EN*CI2(1)
     $          +(86.*EN/27.+130./27./EN)*CI2(2)
     $          +(172.*EN/27.+260./27./EN-NF/3.)*CI2(3)
     $          +(-14./3.+74.*EN/27.*NF
     $            -20./27./EN*NF)*CI2(4)
     $          +(-100.*EN/3.+3./EN+11./3.*NF)*CI2(5)
     $          +(-203.*EN**2/6.+479./6.+15./2./EN**2
     $            +200.*EN/27.*NF)*CI2(6))
      F(7)=FAC1*(416./81.*CI2(2)-464./81.*CI2(3)
     $          +(416./81.*NU-232./81.*ND)*CI2(4)
     $          +32./9.*CI2(5)
     $          +(-448./81.*NU+200./81.*ND)*CI2(6)
     $          +32./3.*CI2(7)-32./9.*CI2(8))
     $    +FAC2*(4688./27.*CI2(7)-2192./81.*CI2(8)
     $           +PAR*CI2(2))
      F(8)=FAC1*(3.*CI2(1)+70./27.*CI2(2)
     $          +(140./27.+3.*NF)*CI2(3)
     $          +(6.+70./27.*NF)*CI2(4)
     $          +(-14./3.-3.*NF)*CI2(5)
     $          +(-4.-119./27.*NF)*CI2(6)
     $          +28./3.*CI2(8))        
     $    +FAC2*(4063./27.*CI2(8)
     $           -PAR*CI2(2))
      RETURN
      END

C---------------------------------------------------------------------- 
      SUBROUTINE CHARGINO(GK,HK,AMTLSS,AMTRSS,MTQ,MBQ)
C----------------------------------------------------------------------
C     DIAGONALIZE CHARGINOS AND STOPS ACCORDING TO HABER-KANE
      IMPLICIT REAL    (A-G,M,O-Z)
      IMPLICIT INTEGER (H-L,N)
      REAL     UM(2,2),VM(2,2),TM(2,2),MCHAR(2,2),
     $         MCHA(2),MSTO(2),MSQU(3),MSQD(3),
     $         GK(2,3),HK(2,3),mat(2,2),MV(2,2),
     $         MD(2,2)
      REAL     EIGV(2,2),WORK(2)
      REAL     RMIX(2),ABMIX(2),SMIX(6),MTQ,MBQ

+CDE,SUGMG
+CDE,SUGPAS
C-FP  include 'sugmg.h'
C-FP  include 'sugpas.h'
     
      COMMON / G3/ G3
      COMMON /CHRGN/ MCHA,MSQU,MSQD,SMIX,RMIX,ABMIX        
      COMMON /GGN/ M1,M2,M3,ABOT,ATOP,ATAU
      DATA MZ/91.187/,MTAU/1.784/,MB/4.8/,MW/80./,ALEM/.0078186/      
C
c      WRITE(6,*) 'MTQ,MBQ INO=',MTQ,MBQ
      ATR=ATOP 
      ABR=ABOT
      TANB=XTANB
      COTB=1./TANB
      BETA=ATAN(TANB)
      SB=SIN(BETA)
      CB=COS(BETA)       
      S2B=SIN(2.*BETA)
      C2B=COS(2.*BETA) 
      QR=AMTLSS**2
      TR=AMTRSS**2
      ALT=MTQ/(SQRT(2.)*MW*SB)
      ALB=MBQ/(SQRT(2.)*MW*CB)
      VEV=SQRT(V**2+VP**2)          
c
      MAT(1,1)= M2
      MAT(1,2)= SQRT(2.)*MW*SB
      MAT(2,1)= SQRT(2.)*MW*CB
      MAT(2,2)= MU         
C
C     DIAGONALIZE CHARGINOS AS IN H-K
C
      MCHAR(1,1)= M2**2+2.*MW**2*CB**2
      MCHAR(1,2)=M2*SQRT(2.)*MW*SB+
     $           MU*SQRT(2.)*MW*CB
      MCHAR(2,1)=M2*SQRT(2.)*MW*SB+
     $           MU*SQRT(2.)*MW*CB
      MCHAR(2,2)= MU**2+2.*MW**2*SB**2
C
c      write(6,*) 'mchar=',mchar
      CALL eisrs1(2,2,MCHAR,MCHA,EIGV,IERR,WORK)         
      MCHA(1)=SQRT(MCHA(1))
      MCHA(2)=SQRT(MCHA(2))
c      write(6,*) 'mcha=',mcha
c      write(6,*) 'eigv=',eigv
C
      DO J=1,2
      SNORM=0.
      DO I=1,2
       SNORM=SNORM+EIGV(I,J)**2
      END DO
      DO I=1,2
       VM(J,I)=EIGV(I,J)/SQRT(SNORM)
      END DO
      END DO    
c      write(6,*) m2,mu,mw,sb,cb
c      write(6,*) 'vm=',vm
C
      MCHAR(1,1)=M2**2+2.*MW**2*SB**2
      MCHAR(1,2)=M2*SQRT(2.)*MW*CB+
     $           MU*SQRT(2.)*MW*SB
      MCHAR(2,1)=M2*SQRT(2.)*MW*CB+
     $           MU*SQRT(2.)*MW*SB
      MCHAR(2,2)= MU**2+2.*MW**2*CB**2
C
      CALL eisrs1(2,2,MCHAR,MCHA,EIGV,IERR,WORK)         
      MCHA(1)=SQRT(MCHA(1))
      MCHA(2)=SQRT(MCHA(2))
C
      DO J=1,2
      SNORM=0.
      DO I=1,2
       SNORM=SNORM+EIGV(I,J)**2
      END DO
      DO I=1,2
       UM(J,I)=EIGV(I,J)/SQRT(SNORM)
      END DO
      END DO
c      write(6,*) 'um=',um
C
      DO I=1,2
      DO J=1,2
      MV(I,J)=0.
      DO K=1,2
       MV(I,J)=MV(I,J)+MAT(I,K)*VM(J,K)
      END DO
      END DO
      END DO
      DO I=1,2
      DO J=1,2
      MD(I,J)=0.
      DO K=1,2
       MD(I,J)=MD(I,J)+UM(I,K)*MV(K,J)
      END DO
C      WRITE(12,*)I,J,MD(I,J)
      END DO
      END DO                               
      IF(MD(1,1).LT.0.) THEN
       UM(1,1)=-UM(1,1)
       UM(1,2)=-UM(1,2)
      ENDIF
      IF(MD(2,2).LT.0.) THEN
       UM(2,1)=-UM(2,1)
       UM(2,2)=-UM(2,2)
      ENDIF                      
      DO I=1,2
      DO J=1,2
      MV(I,J)=0.
      DO K=1,2
       MV(I,J)=MV(I,J)+MAT(I,K)*VM(J,K)
      END DO
      END DO
      END DO
      DO I=1,2
      DO J=1,2
      MD(I,J)=0.
      DO K=1,2
       MD(I,J)=MD(I,J)+UM(I,K)*MV(K,J)
      END DO
      END DO
      END DO                               
C
C     DIAGONALIZE STOPS
C
      MCHAR(1,1)=MTQ**2+QR+(-1./6.*MZ**2+2./3.*MW**2)*C2B  
      MCHAR(1,2)=MTQ*(ATR-MU/TANB)  
      MCHAR(2,1)=MTQ*(ATR-MU/TANB)  
      MCHAR(2,2)=MTQ**2+TR+(2./3.*MZ**2-2./3.*MW**2)*C2B
c      write(11,*)'char',amt,atr,mu,tanb,qr,tr,mw,mz,c2b
C
      CALL eisrs1(2,2,MCHAR,MSTO,EIGV,IERR,WORK)         
      MSQU(1)=SQRT(MSTO(1))
      MSQU(2)=SQRT(MSTO(2))
      MSQU(1)=MSS(12)
      MSQU(2)=MSS(13)
      MSQU(3)=1./2.*(MSS(8)+MSS(9)) 
C
      DO J=1,2
      SNORM=0.
      DO I=1,2
       SNORM=SNORM+EIGV(I,J)**2
      END DO
      DO I=1,2
       TM(J,I)=EIGV(I,J)/SQRT(SNORM)
      END DO
      END DO
C
      DO I=1,2
      DO J=1,2
      MV(I,J)=0.
      DO K=1,2
       MV(I,J)=MV(I,J)+MCHAR(I,K)*TM(J,K)
      END DO
      END DO
      END DO
      DO I=1,2
      DO J=1,2
      MD(I,J)=0.
      DO K=1,2
       MD(I,J)=MD(I,J)+TM(I,K)*MV(K,J)
      END DO
C      WRITE(12,*)I,J,MD(I,J)
      END DO
      END DO                                       
      IF(MD(1,1).LT.0.) THEN
       TM(1,1)=-TM(1,1)
       TM(1,2)=-TM(1,2)
      ENDIF
      IF(MD(2,2).LT.0.) THEN
       TM(2,1)=-TM(2,1)
       TM(2,2)=-TM(2,2)
      ENDIF                      
      DO I=1,2
      DO J=1,2
      MV(I,J)=0.
      DO K=1,2
       MV(I,J)=MV(I,J)+MCHAR(I,K)*TM(J,K)
      END DO
      END DO
      END DO
      DO I=1,2
      DO J=1,2
      MD(I,J)=0.
      DO K=1,2
       MD(I,J)=MD(I,J)+TM(I,K)*MV(K,J)
      END DO
C      WRITE(12,*)I,J,MD(I,J)
      END DO
      END DO                                          
C....
c      write(6,*) 'm2,mu,=',m2,mu
c      write(6,*) vm(1,1),tm(1,1),alt,vm(1,2),tm(1,2)
c      write(6,*) alb,um(1,2)
      GK(1,1)=VM(1,1)*TM(1,1)-ALT*VM(1,2)*TM(1,2)
      GK(1,2)=VM(1,1)*TM(2,1)-ALT*VM(1,2)*TM(2,2)
      GK(1,3)=(ALT*VM(1,2))**2-(GK(1,1))**2-(GK(1,2))**2
      GK(2,1)=VM(2,1)*TM(1,1)-ALT*VM(2,2)*TM(1,2)
      GK(2,2)=VM(2,1)*TM(2,1)-ALT*VM(2,2)*TM(2,2)
      GK(2,3)=(ALT*VM(2,2))**2-(GK(2,1))**2-(GK(2,2))**2
      HK(1,1)=ALB*UM(1,2)*TM(1,1)
      HK(1,2)=ALB*UM(1,2)*TM(2,1)
      HK(1,3)=-GK(1,1)*HK(1,1)-GK(1,2)*HK(1,2)
      HK(2,1)=ALB*UM(2,2)*TM(1,1)
      HK(2,2)=ALB*UM(2,2)*TM(2,1)
      HK(2,3)=-GK(2,1)*HK(2,1)-GK(2,2)*HK(2,2)
C
      RETURN
      END
C---------------------------------------------------------------------- 
      SUBROUTINE GLUNENO(G,GAM,AGE,AHE)
C----------------------------------------------------------------------
      IMPLICIT REAL    (A-G,M,O-Z)
      IMPLICIT INTEGER (H-L,N)
      REAL     MZERO(4,4),MCH0(4)
      REAL     DM(6,6),ESQ(3,3),ESD(3,3),
     $         EMD(3,3),EAD(3,3),UNI(3,3),EDY(3,3)
      REAL     EIGV(4,4),WORK(4),G(137)
      REAL     GAM(6,6),XORK(6),MDSB(6),HELP(6,6)
      REAL     ANEU(4,4),BNEU(4,4),AGE(4,6,6),AHE(4,6,6)

+CDE,SUGPAS
C-FP  include 'sugpas.h'
C     
      COMMON /GLNN/ MCH0,MDSB
      COMMON /GGN/ M1,M2,M3,ABOT,ATOP,ATAU
      DATA MZ/91.187/,MTAU/1.784/,MB/4.8/,MW/80./,ALEM/.0078186/      
C
      TANB=XTANB
      COTB=1./TANB
      BETA=ATAN(TANB)
      SB=SIN(BETA)
      CB=COS(BETA)       
      S2B=SIN(2.*BETA)
      C2B=COS(2.*BETA) 
      VEV=SQRT(V**2+VP**2)          
      SW=SQRT(XW)      
      CW=SQRT(1.-XW)
c
      MZERO(1,1)=  M1
      MZERO(1,2)=  0.0
      MZERO(1,3)= -MZ*SW*CB
      MZERO(1,4)=  MZ*SW*SB
      MZERO(2,1)=  0.0
      MZERO(2,2)=  M2
      MZERO(2,3)=  MZ*CW*CB
      MZERO(2,4)= -MZ*CW*SB
      MZERO(3,1)= -MZ*SW*CB
      MZERO(3,2)=  MZ*CW*CB
      MZERO(3,3)=  0.0
      MZERO(3,4)= -MU
      MZERO(4,1)=  MZ*SW*SB
      MZERO(4,2)= -MZ*CW*SB
      MZERO(4,3)= -MU
      MZERO(4,4)=  0.0
c      write(11,*)'tanb=',tanb,' mu=',mu
C
      CALL eisrs1(4,4,MZERO,MCH0,EIGV,IERR,WORK)
      DO J=1,4
      ACOM=1.
      SNORM=0.
      DO I=1,4
       SNORM=SNORM+EIGV(I,J)**2
      ENDDO
      IF (MCH0(J).LT.0.) ACOM=-1.
      IF (MCH0(J).LT.0.) MCH0(J)=ABS(MCH0(J))
      DO I=1,4
       ANEU(J,I)=EIGV(I,J)/SQRT(SNORM)
       BNEU(J,I)=ACOM*EIGV(I,J)/SQRT(SNORM)
      ENDDO
      ENDDO
c....6x6 d-squark mass matrix......
       UNI(1,1)=1.
       UNI(1,2)=0.
       UNI(1,3)=0.
       UNI(2,1)=0.
       UNI(2,2)=1.
       UNI(2,3)=0.
       UNI(3,1)=0.
       UNI(3,2)=0.
       UNI(3,3)=1.
       EMD(1,1)=G(45)*VEV*CB 
       EMD(1,2)=G(46)*VEV*CB 
       EMD(1,3)=G(47)*VEV*CB 
       EMD(2,1)=G(48)*VEV*CB 
       EMD(2,2)=G(49)*VEV*CB 
       EMD(2,3)=G(50)*VEV*CB 
       EMD(3,1)=G(51)*VEV*CB 
       EMD(3,2)=G(52)*VEV*CB 
       EMD(3,3)=G(53)*VEV*CB 
       ESQ(1,1)=G(63)
       ESQ(1,2)=G(64)
       ESQ(1,3)=G(65)
       ESQ(2,1)=G(66)
       ESQ(2,2)=G(67)
       ESQ(2,3)=G(68)
       ESQ(3,1)=G(69)
       ESQ(3,2)=G(70)
       ESQ(3,3)=G(71)
       ESD(1,1)=G(81)
       ESD(1,2)=G(82)
       ESD(1,3)=G(83)
       ESD(2,1)=G(84)
       ESD(2,2)=G(85)
       ESD(2,3)=G(86)
       ESD(3,1)=G(87)
       ESD(3,2)=G(88)
       ESD(3,3)=G(89)
       EAD(1,1)=G(117)*CB*VEV
       EAD(1,2)=G(118)*CB*VEV
       EAD(1,3)=G(119)*CB*VEV
       EAD(2,1)=G(120)*CB*VEV
       EAD(2,2)=G(121)*CB*VEV
       EAD(2,3)=G(122)*CB*VEV
       EAD(3,1)=G(123)*CB*VEV
       EAD(3,2)=G(124)*CB*VEV
       EAD(3,3)=G(125)*CB*VEV       
c
       EDY(1,1)=EMD(1,1)/(SQRT(2.)*CB*MW)
       EDY(1,2)=0.
       EDY(1,3)=0.
       EDY(2,1)=0.
       EDY(2,2)=EMD(2,2)/(SQRT(2.)*CB*MW)
       EDY(2,3)=0.
       EDY(3,1)=0.
       EDY(3,2)=0.
       EDY(3,3)=EMD(3,3)/(SQRT(2.)*CB*MW)
C
       DO I=1,3
       DO J=1,3
        DM(I,J)=0.
        DO K=1,3
        DM(I,J)=DM(I,J)+ESQ(I,K)*UNI(K,J)+
     $          EMD(K,I)*EMD(K,J)-
     $          MZ**2*(1./2.-1./3.*XW)*C2B*UNI(I,K)*UNI(K,J)
        ENDDO
        DM(I,J+3)=EAD(I,J)
        DO K=1,3
        DM(I,J+3)=DM(I,J+3)-EMD(I,K)*MU*TANB*UNI(K,J)
        ENDDO
        DM(I+3,J)=EAD(J,I)
        DO K=1,3
        DM(I+3,J)=DM(I+3,J)-MU*TANB*UNI(I,K)*EMD(J,K)
        ENDDO
        DM(I+3,J+3)=0.
        DO K=1,3
        DM(I+3,J+3)=DM(I+3,J+3)+ESD(I,K)*UNI(K,J)+
     $          EMD(K,I)*EMD(K,J)+
     $          MZ**2*1./3.*XW*C2B*UNI(I,K)*UNI(K,J)
        ENDDO
       ENDDO
       ENDDO
      CALL eisrs1(6,6,DM,MDSB,GAM,IERR,XORK) 
c
c      WRITE(11,*)'U,V,T'        
C
       DO I=1,6
       DO J=1,6
       HELP(I,J)=0.
        DO K=1,6
         HELP(I,J)=HELP(I,J)+GAM(K,I)*GAM(K,J)
        ENDDO
       ENDDO
       ENDDO
       DO I=1,6
c       WRITE(12,*)I,I,' : ',MDSB(I)
       DO J=1,6
c       WRITE(12,*)I,J,' : ',DM(I,J),GAM(I,J)
       ENDDO
       ENDDO
c
       DO I=1,4
       DO J=1,3
       DO K=1,6
        AGE(I,J,K)=((-1./3.)*SW*(ANEU(I,1)*CW+ANEU(I,2)*SW)+
     $              1./CW*(-1./2.+1./3.*XW)*(-ANEU(I,1)*SW
     $               +ANEU(I,2)*CW))*GAM(J,K)
        AGE(I,J+3,K)=((-1./3.)*SW*(BNEU(I,1)*CW+BNEU(I,2)*SW)+
     $              1./CW*(1./3.*XW)*(-BNEU(I,1)*SW
     $               +BNEU(I,2)*CW))*GAM(J+3,K)
        AHE(I,J,K)=0.
        AHE(I,J+3,K)=0.
        DO L=1,3
        AHE(I,J,K)=AHE(I,J,K)+BNEU(I,3)*EDY(J,L)*GAM(L,K)
        AHE(I,J+3,K)=AHE(I,J,K)+ANEU(I,3)*EDY(J,L)*GAM(L+3,K)
        ENDDO
       ENDDO
       ENDDO
       ENDDO
       DO I=1,6
       MDSB(I)=SQRT(abs(MDSB(I)))
       ENDDO
C
      RETURN
      END
C---------------------------------------------------------------------
      SUBROUTINE FUNS(X,FN1,FN2,FN3,FN4)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
C
      IF(ABS(X-1).GT.0.01) THEN
       FN1=(X**2-5*X-2.)/12./(X-1.)**3
     $     +X*LOG(X)/2./(X-1.)**4
       FN2=(2*X**2+5*X-1.)/12./(X-1.)**3
     $    -X**2*LOG(X)/2./(X-1.)**4
       FN3=(X-3.)/2./(X-1.)**2
     $    +LOG(X)/(X-1.)**3
       FN4=(X+1.)/2./(X-1.)**2
     $    -X*LOG(X)/(X-1.)**3           
      ELSE
       FN1=1/24.-(X-1.)/40.+(X-1.)**2/60.
       FN2=1/24.-(X-1.)/60.+(X-1.)**2/120.
       FN3=1/3.-(X-1.)/4.+(X-1.)**2/5.
       FN4=1/6.-(X-1.)/12.+(X-1.)**2/20.
      ENDIF
      
C
      RETURN 
      END
C----------------------------------------------------------------------
      REAL FUNCTION BI(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
C
      BI=1./4.*(X/(1.-X)+X*LOG(X)/(X-1.)**2)
C 
      RETURN 
      END
C---------------------------------------------------------------------- 
      REAL FUNCTION CI(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)

      CI=1./8.*X*((X-6.)/(X-1.)+(3.*X+2.)/(X-1.)**2*LOG(X))
C 
      RETURN 
      END
C---------------------------------------------------------------------- 
      REAL FUNCTION DI(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)

      DI=-4./9.*LOG(X)+(-19.*X**3+25.*X**2)/36./(X-1.)**3
     $   +X**2*(5.*X**2-2.*X-6.)/18./(X-1.)**4*LOG(X)
C 
      RETURN 
      END
C---------------------------------------------------------------------- 
      REAL FUNCTION EI(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
C
      EI=-2./3.*LOG(X)+X**2*(15.-16.*X+4.*X**2)/6./(X-1.)**4*LOG(X)
     $   +X*(18.-11.*X-X**2)/12./(1.-X)**3
C 
      RETURN 
      END
C---------------------------------------------------------------------- 
      REAL FUNCTION XKARE(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
C
      PI=4.*ATAN(1.)
C
      IF(X.LT.4.) THEN
       GE=-2.*ATAN(SQRT(X/(4.-X)))**2
      ELSE
       GE=-PI**2/2.+2.*(LOG(SQRT(X)/2.+SQRT(X-4.)/2.))**2
      ENDIF
       XKARE=4.*(2.*GE+X)/X
C 
      RETURN 
      END
C---------------------------------------------------------------------- 
      FUNCTION XKAIM(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
C
      PI=4.*ATAN(1.)
C
      IF(X.LT.4.) THEN
       GE=0.
      ELSE
       GE=-2.*PI*LOG(SQRT(X)/2.+SQRT(X-4.)/2.)
      ENDIF
C 
      XKAIM=8.*GE/X
C
      RETURN 
      END
c______________________________________________________________________
      SUBROUTINE BREMS(AEMB,ASMB,MS,MC,MB,Q,CI1,GBREM)            
C-----------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      REAL CI1(8)
      EXTERNAL FNTG
C
+CDE,SUGPAS
C-FP  include 'sugpas.h'
C
      COMMON /TAUS/FAC22,FAC27,FAC28,FAC78   
C
      DATA MZ/91.17/,MW/80.1/
      PI=4.*ATAN(1.)          
C     
      FACAL=AEMB*ASMB/768./PI**5/4.
      FACBL=AEMB*ASMB/96./PI**5
      FAC22=2.*4./9.*CI1(2)**2
      FAC27=-32.*2./3.*CI1(2)*CI1(7)
      FAC28=-32.*2./3.*(-1./3.)*CI1(2)*CI1(8)
      FAC78=-128.*(-1./3.)*CI1(7)*CI1(8)
C
C      QINT=RGMLT2(INTG2,0.,1.,5,8,XI)
      RINT=TRIINT(FNTG,0,64,0.1,0.,1.,1.,0.,1.,1.)
      BREMSF=FACAL*RINT
      BREMS88=FACBL*(-1./3.*CI1(8))**2*
     $        (16./3.-4.*PI**2/3.+4.*LOG(MB/Q))
C
      GBREM=BREMSF+BREMS88
      RETURN
      END 
C---------------------------------------------------------------------- 
      REAL FUNCTION FNTG(X,Y)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      COMMON /TAUS/FAC22,FAC27,FAC28,FAC78   
      DATA MB/4.8/,MC/1.5/,MS/0.2/
C
      RHO=(MS/MB)**2
      T=X
      U=Y
      S=T+U-1.+RHO
      SC=S*(MB/MC)**2
C
      O22=(XKARE(SC)**2+XKAIM(SC)**2)*(1.-S)
      O27=1./2.*S*XKARE(SC)
      O28=1./2.*S*XKARE(SC)
      O78=1./2.*S*(1.+1./2.*T*U)/T/U
      FNTG=FAC22*O22+FAC27*O27+FAC28*O28+FAC78*O78
C
      RETURN 
      END
C---------------------------------------------------------------------- 
      REAL FUNCTION GES(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
      GES=1.-8.*X**2+8.*X**6-X**8-24.*X**4*LOG(X)
      RETURN 
      END
C---------------------------------------------------------------------- 
      REAL FUNCTION FES(X)            
C----------------------------------------------------------------------
      IMPLICIT REAL (A-H,M,O-Z)
C
      PI=4.*ATAN(1.)       
      FES=(PI**2-31./4.)*(1.-X)**2+3./2.
C 
      RETURN 
      END
+EOD
+DECK,ISARED,IF=ISATOOLS
cccccccccccccccccccccccccccccccccccccccccccccc
c      AUTHORS: Baer,Belyaev
c
c      Last modification -> 10/27/2005 A.Belyaev
c
cccccccccccccccccccccccccccccccccccccccccccccc
     
      SUBROUTINE ISARED(IPRT)
c      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      IMPLICIT NONE
      
	
c----------USER--------------------------------      
      COMMON /CTRL/
     &AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX,
     &NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP

      REAL*8 AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX
      INTEGER NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP
     

      INTEGER IPRINT
      
      DATA   AS_MAX / 3D0 /, XFINI/0.05D0/, NDIMUSER/3/, NST_MAX/10/,
     &      NPROC_MIN/1/,   NPROC_MAX/1820/, NPROC_STEP/1/, IPRINT/1/,
     &      COS_MIN / -0.999999d0 / , COS_MAX / 0.999999d0 /,
     &      CS_MIN  /0d0/, ISUM/1/, SUPPEXPMAX/2d0/
     

      common/printlevel/NPRINT
      INTEGER NPRINT
c-----------------------------------------------      
      COMMON   /GOOD/    NNOGOOD,IALLOW 
      INTEGER  NNOGOOD,IALLOW                                                                                                       
c------BASES------------------------------------\
     
      INTEGER NDIM,IG,MXDIM,NWILD,NCALL
      REAL*8 XL,XU
   
      PARAMETER (MXDIM = 50 )                                           
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,IG(MXDIM),NCALL    
      DATA NWILD/2/,NCALL/1000/      
      
      INTEGER INTV, IPNT, NLOOP, MLOOP,ITMX1,ITMX2
      REAL*8 ACC1,ACC2
      COMMON /BPARM2/ ACC1,ACC2,ITMX1,ITMX2                             
      DATA  ITMX1/5/,ITMX2/5/,ACC1/0.1d0/,ACC2/0.1d0/
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
c-----------------------------------------------
      REAL*8 xb,g,pm
      CHARACTER*6 names
      INTEGER J,idof,IPTOT
      COMMON /INPART/ xb(29),g(29),pm(29),idof(29),IPTOT
      COMMON /NAMES/ names(29)

      DATA IPTOT/29/
      DATA  (IDOF(J),J=1,29)
     _/  2,     2 ,     16,
     _   2 ,	1 ,     1,      1,      3,     3, 
     _  	1 ,     1 ,     1,      3,     3,    3,    3,
     _   2 ,    1 ,     1,      1,      3,     3,
     _  	1 ,     1 ,     1,      3,     3,    3,    3/

     
      DATA  (NAMES(J),J=1,29)
     _/'~o1',  '~o2' ,'~g',
     _  '~1-' ,'~e1' , '~e2' , '~e3' ,'~t1','~b1', 
     _         '~n1' , '~n2' , '~n3' ,'~u1','~d1','~c1','~s1',
     _  '~1+' ,'~E1' , '~E2' , '~E3' ,'~T1','~B1', 
     _         '~N1' , '~N2' , '~N3' ,'~U1','~D1','~C1','~S1'/
c-----------------------------------------------
      REAL*4 OMGH2,SIGMA,XFREEZ
      INTEGER NSTEPS
      COMMON/SUGRED/ OMGH2,SIGMA,XFREEZ,NSTEPS
c-----ISAJET-----------------------------------   
+CDE,SSLUN
+CDE,SUGXIN
+CDE,SUGMG
+CDE,SUGPAS
c----------COMPHEP------------------------------      
      COMMON/VARS/A(1800)
      REAL*8 A
c-----------------------------------------------      
c-----------------------------------------------      
      CHARACTER*6 PINF
      REAL*8 PBNTOGEV,PI,SQRT_GN,FFF,XFI,XF_OLD,SUMM,GEFF,
     &FUNC_INT,FFF_TMP,OMEGA,FFF_OLD
      
      INTEGER IPRT,NPROC_MAX_S,NPROC_MIN_S,IPM,IDEL,
     &NDIMUSER_SAVE,NST,NDIMUSER_EFF_SAVE, NCALL_SAV,I
    
      
c-----------------------------------------------      
      REAL*8 del(29)
    
      
      
      IPRINT=IPRT
      NPRINT=IPRINT
      
      XF=XFINI
      FFF=0d0
	
      SQRT_GN=dsqrt(67.07d0)/1d+20
      PBNTOGEV=1d0/0.3893796623/1d+09	
       
      Pi=DACOS(-1d0)
      
      FFF=0
      NNOGOOD=0
      
      call vini
***************************

      call isahep

*****************************
! Z1,Z2,W1, e1, e2, e3, n1,n2,n3,u1,d1,c1,s1,t1,b1,gss
****************************
	PM(1)=abs(A(93))   	!neutr1
        PM(2)=abs(A(95))   	!neutr2
        PM(3)=abs(A(131))  	!gluino
	
        PM(4)=abs(A(89))   	!charg
        PM(5)=abs(A(132))  	!sel
        PM(6)=abs(A(134))  	!smu
        PM(7)=abs(A(106))  	!sta
        PM(8)=abs(A(122))   	!stop
        PM(9)=abs(A(126))  	!sbot
	
   	
        PM(10)=abs(A(136))  	!snu_e
        PM(11)=abs(A(137))  	!snu_l
        PM(12)=abs(A(112))  	!snu_tau
        PM(13)=abs(A(138))  	!sup1
        PM(14)=abs(A(140))  	!sd_1
        PM(15)=abs(A(142))  	!sc1
        PM(16)=abs(A(144))  	!ss_1
	
        PM(17)=	PM(4)		!charg
        PM(18)=	PM(5)  		!sel
        PM(19)=	PM(6)  		!smu
        PM(20)=	PM(7)  		!sta
        PM(21)=	PM(8)		!stop
        PM(22)=	PM(9)  		!sbot
	
 
        PM(23)=	PM(10)  	!snu_e
        PM(24)=	PM(11)  	!snu_l
        PM(25)=	PM(12)  	!snu_tau
        PM(26)=	PM(13)  	!sup1
        PM(27)=	PM(14)  	!sd_1
        PM(28)=	PM(15)  	!sc1
        PM(29)=	PM(17)  	!ss_1
***********************************************      

 
      SUPPEXP=1E+20
 
      DO IPM=2,IPTOT
        if(min(pm(IPM),PM(1)).ne.pm(1).and.iallow.eq.0) then
          iallow=-11 !NEUTR IS NOT THE LIGHTEST
          if(iprt.gt.2) print *,'Z1 IS NOT LSP',IPM,PM(IPM),PM(1)
          NNOGOOD=5
          goto 555
          ENDIF 
          SUPPEXP=min(SUPPEXP,pm(IPM)/pm(1))
      ENDDO

      geff=0d0
      DO IDEL=1,IPTOT
        del(idel)=(pm(idel)-pm(1))/pm(1)
        geff=geff+ 2. * (1.+del(IDEL))**(3./2.) * Exp(-del(idel)/XF)
        if(iprint.gt.2) 
     &print *,  (1.+del(IDEL))**(3./2.) * Exp(-del(idel)/XF), del(idel)
      ENDDO
      IF(IPRINT.gt.1) print *,'GEFF=', GEFF,'   ','SUPPEXP=',SUPPEXP
      NDIMUSER_EFF=NDIMUSER
      IF(SUPPEXP.ge.SUPPEXPMAX.and.NDIMUSER.eq.3)  NDIMUSER_EFF=2 
      if(iprint.gt.2) 
     & print *, 'NDIMUSER_EFF=', NDIMUSER_EFF,SUPPEXP
     

cccccccccccccccccc    

      NST=0
      NDIMUSER_SAVE=NDIMUSER
      NDIMUSER_EFF_SAVE=NDIMUSER_EFF
c       print *,'ISARED:', NPROC_MIN,NPROC_MAX

      IF(NDIMUSER.ge.2) NDIMUSER=2
      NDIMUSER_EFF=NDIMUSER
      NCALL_SAV=NCALL
      NCALL=NCALL/2.
888   continue
      NST=NST+1
      IF(NST.GT.NST_MAX) goto 666
      
      IPRINT=IPRT
c--------------------	
      FFF_OLD=FFF  
      FFF=FUNC_INT(IPRINT)
      IF(FFF.lt.CS_MIN) GOTO  666
c--------------------	  

      IF(NDIMUSER_SAVE.eq.2) GOTO 777
      if(IPRT.gt.1) print *,'FFF0=', FFF

        
      IF(FFF.le.0) then
         FFF=0.
         goto 666
      ENDIF


       XFI=LOG(
     &     PM(1)/(2d0*Pi**3)*geff/2d0*sqrt(45d0/(2d0*81d0))/SQRT_GN
     &     *FFF*PBNTOGEV*SQRT(XF)
     &     )
       

       XF_OLD=XF
       XF=1D0/XFI
       


       IF(iprint.gt.1) then
       print *,'======================='
       print *,'XF = ',XF,1d0/XF
       print *,'CS  = ',FFF
       print *,'NST = ',NST
       print *,'======================='
       endif

       IF(XF.le.0.) then
         XF=XFINI
         FFF=0
         goto 666
       ENDIF

ccc       IF(abs(XF-XF_OLD)/XF.gt.0.01) goto 888
       IF(abs(FFF-FFF_OLD)/FFF.gt.0.03) goto 888
ccc    print *,'xxxxxxxx 3d Integration xxxxxxxxxx'
 777   CONTINUE
 666   NCALL=NCALL*2.
       NDIMUSER=NDIMUSER_SAVE
       NDIMUSER_EFF=NDIMUSER_EFF_SAVE
       IF(NDIMUSER.eq.2    ) goto 999
       IF(NDIMUSER_EFF.eq.2) NCALL=NCALL/2.

       IF(FFF.lt.CS_MIN) THEN
          FFF=1.E-20
          GOTO 999
       ENDIF


       FFF=FUNC_INT(IPRINT)
 999   continue
  
c      print *,'IPRINT=',IPRINT
       IF(IPRINT.ge.3) then
         NPROC_MAX_S=NPROC_MAX
         NPROC_MIN_S=NPROC_MIN
         SUMM=0.
         
         
         DO I =NPROC_MIN_S,NPROC_MAX_S,NPROC_STEP
           if(SUPPEXP.ge.SUPPEXPMAX.and.I.gt.26) GOTO 444
           NPROC_MIN=I
           NPROC_MAX=I
           FFF_TMP=FUNC_INT(-1)
           IF(FFF_TMP/FFF.gt.0.01) THEN
             print '(I6,A4,F6.2,A2,4A8)',
     &       I,'  ',FFF_TMP/FFF*100,' %',
     &       (PINF(I,J),J=1,4)
             SUMM=SUMM+FFF_TMP/FFF
           ENDIF
         ENDDO
 444     continue	 

         NPROC_MAX=NPROC_MAX_S
         NPROC_MIN=NPROC_MIN_S
       endif

      
 
 555   continue
       if(iprint.gt.1) then
       print *,'===========FINAL======='
       print *, 'freez out temp=',1d0/XF
       print *, 'n steps       =',NST
       print *, 'CS (fb)       =',FFF*1000d0
       print *, 'OMEGA H^2     =',OMEGA(FFF)
       print *,'======================='
       endif

       OMGH2 =OMEGA(FFF)
       SIGMA =FFF
       XFREEZ=XF
       NSTEPS =NST

       NCALL=NCALL_SAV
      
      RETURN
      END

******************************************************************
******************************************************************
******************************************************************
      FUNCTION FUNC(X)


      IMPLICIT NONE
      
      CHARACTER*6 PINF,PN1,PN2
      REAL*8 A
      COMMON/VARS/A(1800)
 
      COMMON /CTRL/
     &AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX,
     &NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP

      REAL*8 AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX
      INTEGER NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP
      
      REAL*8 X(25)
      REAL*8 P(0:3,4)

      REAL*8 RR,SN,PI,GEVTOPBN,FUNC,ds_da_dc,AS_MIN,PM,E,XMASS,Z,
     &COS1, PM1,PM2,PM3,PM4,SIN1,SFACT,CFACT,TFACT,B1,B2,FA,AS,DJACOB,
     &ECM,XFA,FA12,E1,E2,R1,R2,E3,R3,E4,R4,F_PS,FA12_integr,FUNC_TMP,
     &SQME
     
      INTEGER I
      
      RR(E,XMASS)  = SQRT(MAX(0d0,(E-XMASS)*(E+XMASS)))
      SN(Z)        = SQRT(MAX(0d0,(1-z)*(1+z)))
      
      
      PI=DACOS(-1d0)
      GEVTOPBN= 0.3893796623*1.E+09      
      
      FUNC=0.
      ds_da_dc=0.
      
      
 
      AS_MIN=2d0
      PM=abs(A(93))
C------------------------------------------ 
      COS1=1d0-2d0*X(1)


      IF(COS1.gt.COS_MAX) goto 999
      IF(COS1.lt.cos_min) goto 999
      SIN1=SN(COS1)


C------------------------------------------      
	
      DO I =NPROC_MIN,NPROC_MAX,NPROC_STEP
        
        CALL PMAS(I,1,PM1)
        CALL PMAS(I,2,PM2)
	IF(ABS(PM1/PM).gt.SUPPEXPMAX.or.ABS(PM2/PM).gt.SUPPEXPMAX) 
     >  goto 900
        CALL PMAS(I,3,PM3)
        CALL PMAS(I,4,PM4)
	
	PN1=PINF(I,1)
        PN2=PINF(I,2)
	SFACT=1.
	CFACT=1.

	IF(PN1.ne.PN2) SFACT=2.

	IF(PN1.ne.'~o1'.and.PN1.ne.'~o2'.and.PN1.ne.'~g')  CFACT=2.
	IF(PN2.ne.'~o1'.and.PN2.ne.'~o2'.and.PN2.ne.'~g')  CFACT=2.
	
	IF(PN1.eq.'~1+'.and.PN2.eq.'~1-')  CFACT=1.
	
	IF(PN1.eq.'~e1'.and.PN2.eq.'~E1')  CFACT=1.
	IF(PN1.eq.'~e2'.and.PN2.eq.'~E2')  CFACT=1.
	IF(PN1.eq.'~e3'.and.PN2.eq.'~E3')  CFACT=1.
	IF(PN1.eq.'~n1'.and.PN2.eq.'~N1')  CFACT=1.
	IF(PN1.eq.'~n2'.and.PN2.eq.'~N2')  CFACT=1.
	IF(PN1.eq.'~n3'.and.PN2.eq.'~N3')  CFACT=1.
	IF(PN1.eq.'~u1'.and.PN2.eq.'~U1')  CFACT=1.
	IF(PN1.eq.'~d1'.and.PN2.eq.'~D1')  CFACT=1.
	IF(PN1.eq.'~c1'.and.PN2.eq.'~C1')  CFACT=1.
	IF(PN1.eq.'~s1'.and.PN2.eq.'~S1')  CFACT=1.
	IF(PN1.eq.'~t1'.and.PN2.eq.'~T1')  CFACT=1.
	IF(PN1.eq.'~b1'.and.PN2.eq.'~B1')  CFACT=1.
	
	TFACT=SFACT*CFACT
	
     
      
	
	pm1=abs(pm1)
	pm2=abs(pm2)
	pm3=abs(pm3)
	pm4=abs(pm4)
	
      
	
	B1=pm1/pm
	B2=pm2/pm
        
	
     
        IF(NDIMUSER.eq.1) then
          FA=1.
          AS=AS_MAX
          DJACOB=2.
        ELSEIF(NDIMUSER.ge.2) then
	
          AS=AS_MIN+(AS_MAX-AS_MIN)*X(2)
          DJACOB=(AS_MAX-AS_MIN)*2.
	  IF(AS.le.b1+b2) goto 900
	  
	  IF(NDIMUSER.eq.2) THEN
	      FA=FA12(AS,I,XF)
	      
cc	      print *,FA
	    
	  ELSEIF(NDIMUSER.eq.3.and.NDIMUSER_EFF.eq.2) THEN
	
   	      FA=FA12_integr(AS,b1,b2,XF)*
     &        ((AS**2-b1**2-b2**2)**2-4.*b1**2*b2**2)
     &        /sqrt(AS)/(2.*sqrt(2.*pi)*b1**(3./2.)*b2**(3./2.))

         
          ELSEIF(NDIMUSER.eq.3.and.NDIMUSER_EFF.eq.3) THEN
	      XFA=X(3)
	      FA=FA12(AS,I,XFA)
	      
          ENDIF
      
        ENDIF
	
         
        ECM=AS*PM
        IF(ECM.GT.max(PM1+PM2,PM3+PM4)) then
	
	
          E1=(ECM+(PM1-PM2)*(PM1+PM2)/ECM)/2D0
          E2=(ECM+(PM2-PM1)*(PM1+PM2)/ECM)/2D0
          R1=RR(E1,PM1)
          R2=R1
 	
          P(0,1)=E1
          P(1,1)=0.
          P(2,1)=0.
          P(3,1)=-R1
          P(0,2)=E2
          P(1,2)=0.
          P(2,2)=0.
          P(3,2)=R1
	
          E3=(ECM+(PM3-PM4)*(PM3+PM4)/ECM)/2D0
          R3=RR(E3,PM3)
          E4=(ECM+(PM4-PM3)*(PM3+PM4)/ECM)/2D0
          R4=R3

          P(0,3)=E3
          P(1,3)=R3*SIN1
          P(2,3)=0.
          P(3,3)=R3*COS1
         
	  P(0,4)=E4
          P(1,4)=-P(1,3)
          P(2,4)=0.
          P(3,4)=-P(3,3)
           
c          F_PS=sqrlam(ECM,PM3,PM4)
c     &          /sqrlam(ECM,PM1,PM2)
c     &          /(32d0*Pi*ECM**2)
        
	 
	  F_PS=R3/R1/(32d0*Pi*ECM**2)
     
        
	  
	  FUNC_TMP =TFACT*SQME(I,P)*F_PS*FA*DJACOB*GEVTOPBN
	
c	  print *,pm1,pm2,pm3,pm4
	  
c	  print *,'FUNC', TFACT, SQME(I,P), F_PS, FA, DJACOB	  

c	  IF(FUNC_TMP.le.0) print *, 'FUNC',I,SQME(I,P),F_PS,FA,DJACOB
	  
          ds_da_dc=FUNC_TMP+ds_da_dc
	  IF(I.eq.26.and.NDIMUSER.eq.3.and.NDIMUSER_EFF.eq.2) goto 999
	  
	  
        ENDIF
  900   CONTINUE     

      ENDDO
  999 FUNC=ds_da_dc
       

      IF(FUNC.le.1D-16) FUNC=1D-16
 
      return
      end
      
C-------------------------------------------------------
C#######################################################
C-------------------------------------------------------

      FUNCTION SQRLAM(x,y,z) 
      IMPLICIT  NONE
      REAL*8     SQRLAM,x,y,z  
      SQRLAM=sqrt(max(1.E-06,
     &       (x+(y+z))*(x-(y+z))*(x+(y-z))*(x-(y-z))))
      return
      END

C-------------------------------------------------------
C#######################################################
C-------------------------------------------------------
C-------------------------------------------------------
      Function BesK1(z)
C-----------------------------------------------------------------------
C     The modified Bessel function of the second kind K(n, z)
C     for large arguments z.
C     These functions have a precision better then 1(.1) % for z > 1.5(3).
C     For more details see my notes on thermal average. CsB 12/2001
C-----------------------------------------------------------------------
      Implicit none
      Real*8 BesK1,BesK2,z,Pi
      Integer n
      Data Pi / 3.14159265358979323846D0 /

      BesK1 = (Sqrt(Pi/2.)*(1./z)**3.5*
     -    (105. - 120.*z + 384.*z**2 + 1024.*z**3))/(1024.)

      ENTRY BesK2(z)
      BesK2 = (Sqrt(Pi/2.)*(1./z)**3.5*
     -    (-315. + 840.*z + 1920.*z**2 + 1024.*z**3))/(1024.)

      If (z.LT.1.5) Print*, '!!! WARNING: Precision < 1% in BesK !!!'
      If (z.LT.3.) Print*,  '!!! WARNING: Precision < .1% in BesK !!!'
     
      Return
      End
cccccccccccccccccccccccc===================================cccccccccccc

      Function FA12(as,I,x)
      IMPLICIT NONE
      REAL*8 FA12
      
      REAL*8 A
      COMMON/VARS/A(1800)

      COMMON /CTRL/
     &AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX,
     &NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP

      REAL*8 AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX
      INTEGER NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP
 
      REAL*8 PI,BesK1,BesK2,bj,bi,sqrlam,as,x,gj,gi,BF
      INTEGER ip1,ip2,JSUM,I

      REAL*8 b,g,pm
      CHARACTER*6 names
      INTEGER J,idof,IPTOT
      COMMON /INPART/ b(29),g(29),pm(29),idof(29),IPTOT
      COMMON /NAMES/ names(29)
      
      CHARACTER*6 PINF1,PINF2,PINF
     
     
      Data Pi / 3.14159265358979323846D0 /

      DO J=1,IPTOT
        IF(PINF(I,1).eq.NAMES(J)) IP1=J
        IF(PINF(I,2).eq.NAMES(J)) IP2=J
      ENDDO
     
  
        BF=0d0
      
       JSUM=IPTOT
       if(NPROC_MIN.ge.1.and.NPROC_MAX.le.26.and.ISUM.eq.0) JSUM=1   
       if(NDIMUSER_EFF.eq.2) JSUM=1
       DO J=1,JSUM
        b(J)=PM(J)/PM(1)
	g(J)=IDOF(J)
 	BF=BF+b(J)**2*g(J)*BesK2(b(J)/x)*Exp((-b(J)+b(1))/x)
      ENDDO
      
C Changed from /Exp((-2d0*b(1)+as)/x) to avoid floating overflow. FEP

        FA12= 
     _ sqrlam(as,b(ip1),b(ip2))**2*
     _ g(ip1)*g(ip2)*BesK1(as/x) /4d0*Exp(-(-2d0*b(1)+as)/x)/(x*(BF)**2)

       End   

C-------------------------------------------------------
C#######################################################
C-------------------------------------------------------
      Function FA12_integr(a,b1,b2,xF)
C-----------------------------------------------------------------------
C     Function to calculate F_{12} for the velocity averaged
C     co-annihilation cross section.
C       x  = T/m is already integrated over analytically.
C       a  = Sqrt(s)/m.
C       bi = m_i/m.
C       xF is the upper limit of the x-integral.
C       m is a convenient scale (can be choosen e.g. as (m_1+m_2)/2).
C-----------------------------------------------------------------------
      Implicit none
      Real*8 FA12_integr,a,b1,b2,xF, a12,A1, Pi, dErfc
      Data Pi / 3.14159265358979323846D0 /

      a12 = a - b1 - b2
      A1  = dErfc(Sqrt(a12/xF))

      FA12_integr = A1*Sqrt(Pi/a12) + 
     -  2.*(3./(8.*a) - 15./(8.*b1) - 15./(8.*b2))*
     -   (-A1*Sqrt(a12*Pi) + Sqrt(xF)/Exp(a12/xF)) + 
     -  (2.*(-15./(128.*a**2) + 345./(128.*b1**2) - 45./(64.*a*b1) + 
     -       345./(128.*b2**2) - 45./(64.*a*b2) + 225./(64.*b1*b2))*
     -     (2.*A1*a12**1.5*Sqrt(Pi) + 
     -       (-2.*a12*Sqrt(xF) + xF**1.5)/Exp(a12/xF)))/3.
     

      Return
      End   
C-------------------------------------------------------
C#######################################################
C-------------------------------------------------------

c      SUBROUTINE SPEVNT
c      RETURN
c      END

C-------------------------------------------------------
C#######################################################
C-------------------------------------------------------
      
      SUBROUTINE CPUTIM(ISECON)
      IMPLICIT NONE
      INTEGER ISECON
      REAL*4    SEC
      ISECON=0
+SELF,IF=CERN
      CALL TIMEX( SEC)
+SELF
      ISECON = SEC 
      RETURN
      END


C-------------------------------------------------------
C#######################################################
C-------------------------------------------------------

      FUNCTION FUNC_INT(IPRINT)
      IMPLICIT NONE
C------- BASES COMMON BLOCKS ---------------------
      
      EXTERNAL FUNC
      REAL*8  FUNC_INT,FUNC
      
      INTEGER NDIM,IG,MXDIM,NWILD,NCALL
      REAL*8 XL,XU
      PARAMETER (MXDIM = 50 )                                           
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,IG(MXDIM),NCALL    
c      DATA NWILD/2/,NCALL/1000/      
      INTEGER INTV, IPNT, NLOOP, MLOOP,ITMX1,ITMX2
      REAL*8 ACC1,ACC2
      COMMON /BPARM2/ ACC1,ACC2,ITMX1,ITMX2                             
c      DATA  ITMX1/5/,ITMX2/5/,ACC1/0.1d0/,ACC2/0.1d0/
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP      
c---------------------------------------------------
      REAL*8 ESTIM, SIGMA, CTIME

     
      COMMON /CTRL/
     &AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX,
     &NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP

      REAL*8 AS_MAX,XFINI,XF,COS_MIN,COS_MAX,CS_MIN,SUPPEXP, SUPPEXPMAX
      INTEGER NDIMUSER,NDIMUSER_EFF,ISUM,NST_MAX,
     &NPROC_MIN,NPROC_MAX,NPROC_STEP
     
      INTEGER I,IPRINT,IT1,IT2
      
      CALL BSINIT 
      
      NDIM =NDIMUSER_EFF
     
      
      NWILD=NDIM
      DO 1 I=1,NDIMUSER_EFF
        XL(I)=0d0
        XU(I)=1d0
    1 CONTINUE
      IF(NDIMUSER_EFF.eq.3) XL(3)=0.000001
      IF(NDIMUSER_EFF.eq.3) XU(3)=XF
   
      ITMX1=5
      ITMX2=5
      
C-------------------------------------------------

      INTV=IPRINT
      
c       print *,'NCALLS=', NCALL,IPRINT,INTV,NPROC_MIN,NPROC_MAX
      
c      CALL BSINIT                                                  
      CALL BASES( FUNC, ESTIM, SIGMA, CTIME, IT1, IT2 )             
      
      FUNC_INT=ESTIM
      
     
      
      RETURN
      END
C-------------------------------------------------------
C#######################################################
c ==========================================================================
C   
C   ISAJET - CompHEP interface
C
      SUBROUTINE ISAHEP  
C-----------------------------------------------------------------------
C          A primitive interface between ISAJET and CompHEP generated code.
C          Fills the CompHEP common blocks from ISAJET common blocks.
C-----------------------------------------------------------------------
      IMPLICIT NONE

+CDE,WCON
+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
+CDE,SUGPAS
C          SM ident code definitions. These are standard ISAJET but
C          can be changed.
      INTEGER IDUP,IDDN,IDST,IDCH,IDBT,IDTP
      INTEGER IDNE,IDE,IDNM,IDMU,IDNT,IDTAU
      INTEGER IDGL,IDGM,IDW,IDZ,IDH
      PARAMETER (IDUP=1,IDDN=2,IDST=3,IDCH=4,IDBT=5,IDTP=6)
      PARAMETER (IDNE=11,IDE=12,IDNM=13,IDMU=14,IDNT=15,IDTAU=16)
      PARAMETER (IDGL=9,IDGM=10,IDW=80,IDZ=90,IDH=81)
C          SUSY ident code definitions. They are chosen to be similar
C          to those in versions < 6.50 but may be changed.
      INTEGER ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1
      INTEGER ISNEL,ISEL,ISNML,ISMUL,ISNTL,ISTAU1
      INTEGER ISUPR,ISDNR,ISSTR,ISCHR,ISBT2,ISTP2
      INTEGER ISNER,ISER,ISNMR,ISMUR,ISNTR,ISTAU2
      INTEGER ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,ISGL
      INTEGER ISHL,ISHH,ISHA,ISHC
      INTEGER ISGRAV
      INTEGER IDTAUL,IDTAUR
      PARAMETER (ISUPL=21,ISDNL=22,ISSTL=23,ISCHL=24,ISBT1=25,ISTP1=26)
      PARAMETER (ISNEL=31,ISEL=32,ISNML=33,ISMUL=34,ISNTL=35,ISTAU1=36)
      PARAMETER (ISUPR=41,ISDNR=42,ISSTR=43,ISCHR=44,ISBT2=45,ISTP2=46)
      PARAMETER (ISNER=51,ISER=52,ISNMR=53,ISMUR=54,ISNTR=55,ISTAU2=56)
      PARAMETER (ISGL=29)
      PARAMETER (ISZ1=30,ISZ2=40,ISZ3=50,ISZ4=60,ISW1=39,ISW2=49)
      PARAMETER (ISHL=82,ISHH=83,ISHA=84,ISHC=86)
      PARAMETER (ISGRAV=91)
      PARAMETER (IDTAUL=10016,IDTAUR=20016)

      INTEGER NOUT
      PARAMETER (NOUT=33)
      INTEGER IDOUT(NOUT)
      REAL AMASS,AMPL
      REAL AMI,SUMGAM,SUMMJ,WIDMX
      REAL QSUSY,ASMB,MBMB,ASMT,MTMT,SUALFS,GG
      DOUBLE PRECISION SSMQCD
      INTEGER I,J,K,IFL1,IFL2,IFL3,JSPIN,INDEX,IITEST
C
      DATA IDOUT/
     $IDTP,ISGL,ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1,ISUPR,ISDNR,
     $ISSTR,ISCHR,ISBT2,ISTP2,ISEL,ISMUL,ISTAU1,ISNEL,ISNML,ISNTL,
     $ISER,ISMUR,ISTAU2,ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,
     $ISHL,ISHH,ISHA,ISHC/
      
      REAL FTAMZ1,FBOMZ1,FTOMZ1,VUMZ1,VDMZ1       
      

************************
c   CompHEP common blocks
************************
      Real*8 A
      COMMON/VARS/A(1800)
      CHARACTER*6 xxxxx(146)
      DATA xxxxx/
     >'EE',	'SW',  	's12',	's23',	's13',           !1
     >'MZ',	'MH3',	'Mm',	'Mt',	'Mc',		 !2 
     >'Ms',	'Mtop',	'Mb',	'wtop',	'wZ',		 !3 
     >'wW',	'sa',	'MU',	'Zp11',	'Zp12', 	 !4 
     >'Zp21',	'Zp22',	'Zm11',	'Zm12',	'Zm21', 	 !5 
     >'Zm22',	'Zn11',	'Zn12',	'Zn13',	'Zn14', 	 !6 
     >'Zn21',	'Zn22',	'Zn23',	'Zn24',	'Zn31', 	 !7 
     >'Zn32',	'Zn33',	'Zn34',	'Zn41',	'Zn42', 	 !8 
     >'Zn43',	'Zn44',	'Atau',	'Zl33',	'Zl36', 	 !9 
     >'Zl63',	'Zl66',	'Zl11',	'Zl14',	'Zl41', 	 !10 
     >'Zl44',	'Zl22',	'Zl25',	'Zl52',	'Zl55', 	 !11 
     >'Atop',	'Abot',	'Zu33',	'Zu36',	'Zu63', 	 !12 
     >'Zu66',	'Zu11',	'Zu14',	'Zu41',	'Zu44', 	 !13 
     >'Zu22',	'Zu25',	'Zu52',	'Zu55',	'Zd33', 	 !14 
     >'Zd36',	'Zd63',	'Zd66',	'Zd11',	'Zd14', 	 !15 
     >'Zd41',	'Zd44',	'Zd22',	'Zd25',	'Zd52', 	 !16 
     >'Zd55',	'Mh',	'wh',	'MHH',	'wHh',		 !17 
     >'wH3',	'MHc',	'wHc',	'MC1',	'wC1',		 !18 
     >'MC2',	'wC2',	'MNE1',	'wNE1',	'MNE2', 	 !19 
     >'wNE2',	'MNE3',	'wNE3',	'MNE4',	'wNE4', 	 !20 
     >'wSG',	'wSe1',	'wSe2',	'wSmu1','wSmu2',	 !21 
     >'MStau1',	'wStau1','MStau2','wStau2','wSne',	 !22 
     >'wSnmu',	'MSntau','wSntau','wSu1','wSu2',	 !23 
     >'wSd1',	'wSd2',	'wSc1',	'wSc2',	'wSs1', 	 !24 
     >'wSs2',	'MStop1','wStop1','MStop2','wStop2'	 !25 
     >,'MSbot1','wSbot1','MSbot2','wSbot2','tb',	 !26
     >'MSG',	'MSe1',	'MSe2',	'MSmu1','MSmu2',	 !27
     >'MSne',	'MSnmu','MSu1',	'MSu2',	'MSd1', 	 !28 
     >'MSd2',	'MSc1',	'MSc2',	'MSs1',	'MSs2', 	 !29 
     >'GG'/						 !30 
************************
c      Bases common blocks
************************
      INTEGER NPRINT
      common/printlevel/NPRINT
******************
c   Local variables
******************
      INTEGER ii
      
      
      REAL TANB,MT,PI,GPX,THX,THY,THETAX,THETAY,GAMTOT
      PI=4.*ATAN(1.)

CsB   sin of the Weinberg angle
      GPX=SQRT(.6)*GSS(1)
      IF((GSS(2)**2+GPX**2).eq.0) THEN 
        SIN2W=SN2THW
      ELSE
        SIN2W=GPX**2/(GSS(2)**2+GPX**2)
      ENDIF

C   Set constants & EW parameters
C   This *must* be done after defining SIN2W above
      CALL SETCON
      CALL SETW
      
CsB   theta_x and theta_y in the chargino mixing matrices
      CALL THETAXY(THX,THY)
      THETAX = THX
      THETAY = THY

C     CompHEP = ISAJET              ! name
      A(1) = SQRT(4.D0*PI/128.D0)   ! SQRT(4*Pi/128)
      A(2) = SQRT(SIN2W)            ! sin of the Weinberg angle
      A(3) = 0.221                  ! CKM matrix element (= 0.221 PDG'94)
      A(4) = 0.040                  ! CKM matrix element (= 0.040 PDG'94)
      A(5) = .0035                  ! CKM matrix element (= .0035 PDG'94)
     
      A(6) = AMZ                    ! Z boson mass
      A(7) = MSS(31)                ! mass of CP-odd Higgs
      A(8) = AMMU                   ! muon mass
C---------------------------------------------------C
      A(10) = AMCH                  ! charm mass
    
      A(11) = AMST                  ! strange mass

      
c      A(9)  = FTAMZ*VDQ             ! tau mass
c      A(12) = FTMT *VUQ             ! top mass
c      A(13) = FBMA *VDQ             ! bottom mass
      A(9)  = MLQ             ! tau mass
      A(12) = MTQ             ! top mass
      A(13) = MBQ            ! bottom mass
     
      if(nprint.eq.3) then
      
 	if(nprint.ge.3) print*,'MBQ=',MBQ
	if(nprint.ge.3) print*,'MTQ=',MTQ
	if(nprint.ge.3) print*,'MLQ=',MLQ
      ENDIF
        
c      print *,'MTAZMZ1,MBMZ1,MTOMZ1',
c     $      FTAMZ1*VDMZ1, FBOMZ1*VDMZ1, FTOMZ1*VUMZ1
c      print *,'FTAZMZ1,FBOZ1,FTOMZ1',FTAMZ1,FTOMZ1,FBOMZ1
c      print *,'VDMZ1,VUMZ1',VDMZ1,VUMZ1
      
c      print *,'MLQ,MBQ,MTQ',MLQ,MBQ,MTQ
       
     
ccc      FT=MTQ/VUQ
ccc      FB=MBQ/VDQ
ccc      FL=MLQ/VDQ


C---------------------------------------------------C      
      A(14) = GAMTOT(IDTP)          ! top width
      A(15) = GAMZ                  ! Z boson width
     
      A(16) = GAMW                   ! W boson width
      A(17) = SIN(ALFAH)             ! sin(alpha) Higgs mixing angle
      A(18) = MU                     ! mu parameter
      
      A(19) = -SIN(GAMMAR)           ! chargino mixing angle
      A(20) =  COS(GAMMAR)           ! chargino mixing angle
      A(21) = -THETAY*COS(GAMMAR)    ! chargino mixing angle
      A(22) = -THETAY*SIN(GAMMAR)    ! chargino mixing angle
     
      A(23) = -SIN(GAMMAL)           ! chargino mixing angle
      A(24) = -THETAX*COS(GAMMAL)    ! chargino mixing angle
      A(25) = -COS(GAMMAL)           ! chargino mixing angle
      A(26) =  THETAX*SIN(GAMMAL)    ! chargino mixing angle
      
      A(27) =   ZMIXSS(4,1)          ! neutralino mixing angle 1,1
      A(28) =   ZMIXSS(4,2)          ! neutralino mixing angle 1,2
      A(29) =   ZMIXSS(4,3)	     ! neutralino mixing angle 1,3
      A(30) =   ZMIXSS(4,4)	     ! neutralino mixing angle 1,4

      A(31) =   ZMIXSS(3,1)          ! neutralino mixing angle
      A(32) =   ZMIXSS(3,2)          ! neutralino mixing angle
      A(33) =   ZMIXSS(3,3)	     ! neutralino mixing angle
      A(34) =   ZMIXSS(3,4)	     ! neutralino mixing angle

      A(35) =  -ZMIXSS(2,1)	    ! neutralino mixing angle
      A(36) =  -ZMIXSS(2,2)	    ! neutralino mixing angle
      A(37) =  -ZMIXSS(2,3)	  ! neutralino mixing angle
      A(38) =  -ZMIXSS(2,4)	  ! neutralino mixing angle
      
      A(39) =  -ZMIXSS(1,1)	  ! neutralino mixing angle
      A(40) =  -ZMIXSS(1,2)	  ! neutralino mixing angle
      A(41) =  -ZMIXSS(1,3)	  ! neutralino mixing angle
      A(42) =  -ZMIXSS(1,4)	  ! neutralino mixing angle
      
      A(43) = GSS(10)               ! Tau soft coupling
      
      A(44) =  COS(THETAL)          ! stau mixing angle Zl33
      A(45) =  -SIN(THETAL)          ! stau mixing angle Zl36
      A(46) =   SIN(THETAL)          ! stau mixing angle Zl63
      A(47) =  COS(THETAL)          ! stau mixing angle Zl66
     
     
      A(56) = GSS(12)               ! top tril soft coupling
      A(57) = GSS(11)               ! bottom tril  soft coupling
      
      A(58) =  COS(THETAT)           ! squark mixing angle
      A(59) =  -SIN(THETAT)          ! squark mixing angle
      A(60) =  SIN(THETAT)          ! squark mixing angle
      A(61) =  COS(THETAT)           ! squark mixing angle
     
     
     
      A(70) =  COS(THETAB)           ! squark mixing angle
      A(71) =  -SIN(THETAB)           ! squark mixing angle
      A(72) =   SIN(THETAB)          ! squark mixing angle
      A(73) =  COS(THETAB)           ! squark mixing angle
     
     
      A(82) = MSS(29)               ! Mh
      A(83) = GAMTOT(ISHL)          ! width of light Higgs
      A(84) = MSS(30)               ! MHh
      A(85) = GAMTOT(ISHH)          ! width of heavy higgs
      A(86) = GAMTOT(ISHA)          ! width of CP-odd Higgs
      A(87) = MSS(32)               ! MHC
      A(88) = GAMTOT(ISHC)          ! Width of charged Higgs
      
      A(89) = ABS(MSS(27))          ! MC1
      A(90) = GAMTOT(ISW1)          ! width of chargino 1
      A(91) = ABS(MSS(28))          ! mass of chargino 2
      A(92) = GAMTOT(ISW2)          ! width of chargino 2
      A(93) = -MSS(23)              ! MNE1
      
      A(94) = GAMTOT(ISZ1)          ! width of neutralino 1
      A(94) = abs(A(93))/100.
      
      A(95) = -MSS(24)              ! MNe2
      A(96) = GAMTOT(ISZ2)          ! width of neutralino 2
      A(97) = -MSS(25)              ! mass of neutralino 3
      A(98) = GAMTOT(ISZ3)          ! width of neutralino 3
      A(99) = -MSS(26)              ! mass of neutralino 4
      A(100) = GAMTOT(ISZ4)         ! width of neutralino 4
      A(101) = GAMTOT(ISGL)         ! gluino width
     
      A(102) = GAMTOT(ISER)         ! 1st selectron width (ISAJET: e_r)
      A(103) = GAMTOT(ISEL)         ! 2nd selectron width (ISAJET: e_l)
     
      A(104) = GAMTOT(ISMUR)        ! 1st smuon width (ISAJET: mu_r)
      A(105) = GAMTOT(ISMUL)        ! 2nd smuon width (ISAJET: mu_l)
     
      A(106) = MSS(21)              ! MSTAU1
      A(107) = GAMTOT(ISTAU1)       ! 1st stau width
      A(108) = MSS(22)              ! MSTAU2
      A(109) = GAMTOT(ISTAU2)       ! 2nd stau width
      A(110) = GAMTOT(ISNEL)        ! e-sneutrino width
      A(111) = GAMTOT(ISNML)        ! mu-sneutrino width
      A(112) = MSS(16)              ! tau-sneutrino mass
      A(113) = GAMTOT(ISNTL)        ! tau-sneutrino width
     
      A(114) = GAMTOT(ISUPL)        ! width of u-squark 1 (ISAJET: u_l)
      A(115) = GAMTOT(ISUPR)        ! width of u-squark 2 (ISAJET: u_r)
      
      
      A(116) = GAMTOT(ISDNL)        ! width of d-squark 1 (ISAJET: d_l)
      A(117) = GAMTOT(ISDNR)        ! width of d-squark 2 (ISAJET: d_r)
      A(118) = GAMTOT(ISCHL)        ! width of c-squark 1 (ISAJET: c_l)
      A(119) = GAMTOT(ISCHR)        ! width of c-squark 1 (ISAJET: c_r)
      A(120) = GAMTOT(ISSTL)        ! width of s-squark 1 (ISAJET: s_l)
      A(121) = GAMTOT(ISSTR)        ! width of s-squark 1 (ISAJET: s_r)
     
      A(122) = MSS(12)              ! MST1
      A(123) = GAMTOT(ISTP1)        ! width of t-squark 1
      A(124) = MSS(13)              ! mass of t-squark 2
      A(125) = GAMTOT(ISTP2)        ! width of t-squark 2
      A(126) = MSS(10)              ! MSB1
      A(127) = GAMTOT(ISBT1)        ! width of b-squark 1
      A(128) = MSS(11)              ! mass of b-squark 2
      A(129) = GAMTOT(ISBT2)        ! width of b-squark 2
      A(130) = XTANB                ! tan beta
      A(131) = MSS(1)               ! gluino mass
      
      

      IF(MSS(17).lt.MSS(18)) THEN
        A(132) = MSS(17)              ! MSE1
        A(133) = MSS(18)              ! MSE2
        A(48) =  1                     
        A(49) =  0                     
        A(50) =  0                     
        A(51) =  1                     
      ELSE
        A(132) = MSS(18)              
        A(133) = MSS(17)              
        A(48) =  0                     ! slepton mixing angle
        A(49) =  1                     ! slepton mixing angle
        A(50) =  -1                     ! slepton mixing angle
        A(51) =  0                     ! slepton mixing angle
      ENDIF
     
      IF(MSS(19).lt.MSS(20)) THEN
        A(134) = MSS(19)              ! MSMU1
        A(135) = MSS(20)              ! MSMU2
        A(52) =  1                     ! slepton mixing angle
        A(53) =  0                     ! slepton mixing angle
        A(54) =  0                     ! slepton mixing angle
        A(55) =  1                    ! slepton mixing angle
       ELSE
        A(134) = MSS(20)              
        A(135) = MSS(19)              
        A(52) =  0                     ! slepton mixing angle
        A(53) =  1                     ! slepton mixing angle
        A(54) =   -1                     ! slepton mixing angle
        A(55) =  0                    ! slepton mixing angle
      ENDIF
     
      A(136) = MSS(14)              ! e-sneutrino mass
      A(137) = MSS(15)              ! mu-sneutrino mass
     
             
      
      A(62) =  1                     ! squark mixing angle
      A(63) =  0                     ! squark mixing angle
      A(64) =  0                     ! squark mixing angle
      A(65) =  1                     ! squark mixing angle
      A(138) = MSS(2)               ! mass of u-squark 1 (ISAJET: u_l)
      A(139) = MSS(3)               ! mass of u-squark 2 (ISAJET: u_r)
      IF(MSS(2).gt.MSS(3)) then
       A(62) =  0                     ! squark mixing angle
       A(63) =  1                     ! squark mixing angle
       A(64) =  -1                     ! squark mixing angle
       A(65) =  0                     ! squark mixing angle
       A(138) = MSS(3)               ! mass of u-squark 1 (ISAJET: u_l)
       A(139) = MSS(2)               ! mass of u-squark 2 (ISAJET: u_r)
      ENDIF
       
      A(66) =  1                     ! squark mixing angle
      A(67) =  0                     ! squark mixing angle
      A(68) =  0                     ! squark mixing angle
      A(69) =  1                     ! squark mixing angle
      A(142) = MSS(8)               ! mass of c-squark 1 (ISAJET: c_l)
      A(143) = MSS(9)               ! mass of c-squark 1 (ISAJET: c_r)
      IF(MSS(8).gt.MSS(9)) then
      A(66) =  0                     ! squark mixing angle
      A(67) =  1                     ! squark mixing angle
      A(68) =  -1                     ! squark mixing angle
      A(69) =  0                     ! squark mixing angle
      A(142) = MSS(9)               ! mass of c-squark 1 (ISAJET: c_l)
      A(143) = MSS(8)               ! mass of c-squark 1 (ISAJET: c_r)
      ENDIF
 
      A(74) = 1                     ! squark mixing angle
      A(75) = 0                     ! squark mixing angle
      A(76) = 0                     ! squark mixing angle
      A(77) = 1                     ! squark mixing angle
      A(140) = MSS(4)               ! mass of d-squark 1 (ISAJET: d_l)
      A(141) = MSS(5)               ! mass of d-squark 2 (ISAJET: d_r)
      IF(MSS(4).gt.MSS(5)) THEN
      A(74) = 0                     ! squark mixing angle
      A(75) = 1                     ! squark mixing angle
      A(76) = -1                     ! squark mixing angle
      A(77) = 0                     ! squark mixing angle
      A(140) = MSS(5)               ! mass of d-squark 1 (ISAJET: d_l)
      A(141) = MSS(4)               ! mass of d-squark 2 (ISAJET: d_r)
      ENDIF
       
      
      
      A(78) = 1                     ! squark mixing angle
      A(79) = 0                     ! squark mixing angle
      A(80) = 0                     ! squark mixing angle
      A(81) = 1                     ! squark mixing angle
      A(144) = MSS(6)               ! mass of s-squark 1 (ISAJET: s_l)
      A(145) = MSS(7)               ! mass of s-squark 1 (ISAJET: s_r)
      IF(MSS(6).gt.MSS(7)) then
      A(78) = 0                     ! squark mixing angle
      A(79) = 1                     ! squark mixing angle
      A(80) = -1                     ! squark mixing angle
      A(81) = 0                     ! squark mixing angle
      A(144) = MSS(7)               ! mass of s-squark 1 (ISAJET: s_l)
      A(145) = MSS(6)               ! mass of s-squark 1 (ISAJET: s_r)
      ENDIF
      
      
      
      A(146) = GSS(3)               ! g_strong(M_Z) in CompHEP, g_strong(Q) in ISAJET
      

      IF(NPRINT.ge.2) then
      
        Do ii=1,144,3
	  Print '(3(I6,E16.3))', 
     &     ii,A(ii),ii+1,A(ii+1),ii+2,A(ii+2)
        End do
        Do ii=145,146,2   
	  Print '(2(I6,E16.3))', 
     &     ii,A(ii),ii+1,A(ii+1)
        End do
	
!      Print*, GAMTOT(IDW), GAMTOT(IDZ)
!      Stop
      ENDIF

      RETURN
      END
 
      FUNCTION GAMTOT(ID)
C-----------------------------------------------------------------------
C          Calculate total width (in GeV) for ID
C-----------------------------------------------------------------------
      IMPLICIT NONE
      
+CDE,SSMODE
+CDE,SSLUN
C
      INTEGER ID,I
      REAL GAMTOT
C
      GAMTOT=0
      DO 100 I=1,NSSMOD
        IF(ISSMOD(I).EQ.ID) GAMTOT=GAMTOT+GSSMOD(I)
100   CONTINUE
      RETURN
      END 

      SUBROUTINE THETAXY(THX,THY)
C-----------------------------------------------------------------------
C          Calculate theta_x and theta_y in the chargino mixing matrices.
C-----------------------------------------------------------------------
      IMPLICIT NONE

+CDE,SSSM
+CDE,SSPAR
+CDE,SUGMG
CsB
      REAL MU2,AL,SINA,COSA,SIN2A,COS2A,ZETA,ZETAS,XM,YM,THX,THY

      REAL SR2
      SR2=SQRT(2.)

CsB   M_2(M_weak)
      MU2 = GSS(8)

      AL=ATAN(RV2V1)
      SINA=SIN(AL)
      COSA=COS(AL)
      SIN2A=SIN(2.*AL)
      COS2A=COS(2.*AL)
      ZETAS=(TWOM1**2-MU2**2)**2
     $+4*AMW**2*(AMW**2*COS2A**2+TWOM1**2+MU2**2+2*TWOM1*MU2*SIN2A)
      ZETA=SQRT(ZETAS)
      XM=-(TWOM1**2-MU2**2-2*AMW**2*COS2A-ZETA)
     $/(2*SR2*AMW*(MU2*SINA+TWOM1*COSA))
      YM=-(TWOM1**2-MU2**2+2*AMW**2*COS2A-ZETA)
     $/(2*SR2*AMW*(MU2*COSA+TWOM1*SINA))
      THX=SIGN(1.,XM)
      THY=SIGN(1.,YM)

      RETURN
      END
      
c####################################################################
********************************************************************
c####################################################################
      REAL*8 FUNCTION omega(FF)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

*----------------------------------------------------
*OMEH2=CISLO*PLANCK*VOLNO*TEMP*(TGAMMA**3)/SJINT/CRIT

	CISLO=1.66
	VOLNO=9.

*PLANCK=0.818933748
* MP     = 2.1767E-08      kg  
* 1  eV  = 1.782661731E-36 kg
* 1 GeV  = 1.782661731E-27 kg
* MP     = 2.1767/1.782661731 *1.E+19 GeV
	PLANCK=1.782661731/2.1767    
*1.E-19 left

*TEMP=(T_x/T_gamma)^3=2./(2.+7./8.*(6.*2.+5.*3.*2.))
	TEMP=2./(2.+7./8.*(6.*2.+5.*3.*2.))

 

* k boltz= 1.3806503E-23 J/K
*        = 8.617342E-05 ev/K
*        = 8.617342E-14 GeV/K
* T_gamma^3 = (2.726*0.8617342)^3  ! 10^(-39) left
	TG3=(2.726*0.8617342)**3     
* 10^(-39) left

* ro_crit= 8.0992E-47 GeV^(4)
	CRIT = 8.0992                
* 10^47 left

*CS: GeV^(-2) =0.3893796623  *1.E+09 pb
*    1pb      =1./0.3893796623*1.E-09 GeV^2
*    1fb      =1./0.3893796623*1.E-12 GeV^2
*

	CSCONV = 3.893796623               
* 10^11 left
 
*  -19-39+47+11  =0 

        omega=10000
        IF(FF.ne.0.) then
	  omega=CISLO*PLANCK*VOLNO*TEMP*TG3/CRIT*CSCONV/1000./FF
	endif
      
      return
      
*------------------------------------------------------
      END
c####################################################################
************************************************************************
*	BASES/SPRING library                                           *      
************************************************************************
*    ====================================================              *
      SUBROUTINE BASES( FXN, S, SIGMA, CTIME, IT1, IT2 )                
*    ====================================================              *
*      Subroutine BASES for the Numerical integration.                 *
*      In terms of this program Integration can be done, furthermore   *
*      a probability distribution can be made for the event generation.*
*      The event with weight one is generated by program SPRING.       *
* ((Input))                                                            *
*    from the arguement                                                *
*      FXN    : Name of function program                               *
*    from the labeled common /BASE1/                                   *
*      XL(50) : Lower limits of the integration variabels              *
*      XU(50) : upper limits of the integration variabels              *
*      NDIM   : Dimension of the integration                           *
*      NCALL  : Number of sampling points per iteration                *
*    from the lebeled common /BASE2/                                   *
*      ITMX*  : Number of iteration                                    *
*      ACC*   : Required accuracies                                    *
* ((Output))                                                           *
*      S      : Estimate of the integral                               *
*      SIGMA  : Standard deviation of the estimate                     *
*      CTIME  : Computing time required for integration                *
*      IT1    : Number of iterations for the grid defining step        *
*      IT2    : Number of iterations for the integration step          *
C*                                                                     *
C*       Coded by S.Kawabata         April '94                         *
C*                                                                     *
C***********************************************************************
C                                                                       
C                                                                       
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      EXTERNAL FXN                                                      
      PARAMETER (MXDIM = 50)                                            
*                                                                       
*     JFLAG =  0 : First trial for defining grids.                      
*     JFLAG =  1 : First trial for event accumulation.                  
*     JFLAG =  2 : Second or more trial for defining grids.             
*     JFLAG =  3 : Second or more trial for accumulation.               
*                                                                      *
      COMMON /BASE0/ JFLAG,IBASES                                       
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE2/ ACC1,ACC2,ITMX1,ITMX2                              
      REAL*4 STIME                                                      
      COMMON /BSRSLT/AVGI,SD,CHI2A,STIME,ITG,ITF                        
      CHARACTER*80 ERROR                                                
      COMMON /BWARN1/ NERROR                                            
      COMMON /BWARN2/ ERROR(3,3)                                        
*        INTV = ( 0 / 1 / any ) = ( Batch / Batch(Unix) / Interactive ) 
*        IPNT = ( 0 / any ) = ( IBM Type / Ascii printer )              
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
       COMMON/NINFO/ NODEID, NUMNOD                                     
       COMMON /BDATE/ IDATE(3),ITIME(2)                                 
*            IDATE(1) : year        ITIME(1) : hour                     
*            IDATE(2) : month       ITIME(2) : minute                   
*            IDATE(3) : day                                             
      REAL*4 TIMEBS,TIMINT,TIMESP,TIME0,RTIME,TIMEB1,TIMEB2,TIMES1      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
                                                                        
*-------------------------------------------------                      
*     Check the parameters defined by user                              
*------------------------------------------------------                 
                                                                        
      CALL BSCHCK                                                       
                                                                        
* ---------------------------------------------------------------       
*          Initialize timer                                             
* ---------------------------------------------------------------       
                                                                        
       CALL BSDATE                                                      
                                                                        
       JFLAG  = 0                                                       
       LU     = 6                                                       
       IF( INTV .GT. 1 ) THEN                                           
           CALL BSPRNT( LU, 1, IDUM1, IDUM2 )                           
       ENDIF                                                            
                                                                        
C  -----------------------------------------------------                
C     Defining grids                                                    
C  -----------------------------------------------------                
*                                                                       
       DO 100 I = 1, NWILD                                              
          IG(I) = 1                                                     
  100  CONTINUE                                                         
                                                                        
       CALL BSETGU                                                      
                                                                        
       IF( INTV .GT. 1 ) THEN                                           
           CALL BSPRNT( LU, 4, IDUM1, IDUM2 )                           
       ENDIF                                                            
                                                                        
       CALL BSUTIM( 0, 2 )                                              
                                                                        
*     ===================                                               
       CALL BSINTG( FXN )                                               
*     ===================        For a parallel computer                
C                                      CALL BSCAST( JFLAG, 1 )          
                                                                        
*  ----------------------------------------------------                 
*     Accumulation to make probability distribution                     
*  ----------------------------------------------------                 
*     ===================                                               
       CALL BSINTG( FXN )                                               
*     ===================        For a parallel computer                
C                                      CALL BSCAST( JFLAG, 1 )          
       S     = AVGI                                                     
       SIGMA = SD                                                       
       CTIME = STIME                                                    
       IT1   = ITG                                                      
       IT2   = ITF                                                      
                                                                        
       CALL BSUTIM( 0, 2 )                                              
       TIMEB2 = RTIME                                                   
                                                                        
       IF( NERROR .GT. 0.and. INTV.ge.3 ) THEN                                         
CAB       IF( NERROR .GT. 0. ) THEN                                         
           WRITE(6,9900)                                                
 9900      FORMAT(1X,'****************************************',        
     .               '***************************************',         
     .           /1X,'* (((( Warning in the integration step ',         
     .               '))))                                   *',        
     .           /1X,'*                                      ',         
     .               '                                       *')        
           DO 990 J = 1,NERROR                                          
           DO 990 I = 1,3                                               
              WRITE(6,9901) ERROR(I,J)                                  
 9901         FORMAT(1X,A79)                                            
  990      CONTINUE                                                     
           WRITE(6,9902)                                                
 9902      FORMAT(1X,'*                                      ',         
     .               '                                       *',        
     .           /1X,'*(( Suggestion ))                      ',         
     .               '                                       *',        
     .           /1X,'* (1) Try integration again with larger ',        
     .               'number of sample points than this job.*',         
     .           /1X,'* or                                   ',         
     .               '                                       *',        
     .           /1X,'* (2) The integral variables are not sui',        
     .               'ted for the function.                 *',         
     .           /1X,'*     Take another integral variables !!',        
     .               '                                      *',         
     .           /1X,'*                                       ',        
     .               '                                      *',         
     .           /1X,'****************************************',        
     .               '***************************************')         
       ENDIF                                                            
                                                                        
       IF( INTV .GT. 1 ) THEN                                           
           CALL BSPRNT( LU, 2, IDUM1, IDUM2 )                           
       ENDIF                                                            
                                                                        
       RETURN                                                           
       END                                                              
************************************************************************
*     ==========================                                       *
       SUBROUTINE BHINIT( LUN )                                         
*     ==========================                                       *
*                                                                      *
* ((Purpose))                                                          *
*    Initialization program for  histograms and scatter plots.         *
*    This program is called by USERIN.                                 *
* ((Arguments))                                                        *
*    LUN    : logical unit number for message print                    *
* !! Caution!!                                                         *
*    When LUN is set equal to 0, the message print is suppressed.      *
* (( Common /PLOTH/ ))                                                 *
*                                                                      *
*    NW                     : Total number of words of used buffer     *
*                                                                      *
*    NHIST                  : Number of Histograms                     *
*    NSCAT                  : Number of Scat_Plots                     *
*                                                                      *
*   -----------------                                                  *
*     Hashing Table                                                    *
*   -----------------                                                  *
*                                                                      *
*     XHASH(   1,i)      : NH Number of histograms for the i-th class  *
*     XHASH(   2,i) = K  : Serial number of histograms                 *
*              :                     :                                 *
*     XHASH(NH+1,i) = K  : Serial number of histograms                 *
*                     |                                                *
*              MAPL(1,K) = ID  : Histogram ID                          *
*              MAPL(2,K) = IP1 : the 1st pointer to the K-th buffer    *
*              MAPL(3,K) = IP2 : the 2nd pointer to the K-th buffer    *
*              MAPL(4,K) = IP3 : the 3rd pointer to the K-th buffer    *
*                                                                      *
* (( Common /PLOTB/ ))                                                 *
*                                                                      *
*   --------------------                                               *
*     Histogram buffer                                                 *
*   --------------------                                               *
*                                                                      *
*    IP1  = NW + 1                                                     *
*           NW = NW + 281    : Updated NW                              *
*       BUFF( IP1 )          = Xmin                                    *
*       BUFF( IP1 + 1 )      = Xmax                                    *
*       IBUF( IP1 + 2 )      = No. of bins                             *
*       BUFF( IP1 + 3 )      = Bin width                               *
*    IP2  = IP1 + 4                                                    *
*       IBUF(   IP2       )                                            *
*          => IBUF( +  51 )  = No. of sampling points                  *
*       BUFF(   IP2 +  52)                                             *
*          => BUFF( + 103 )  = Sum of Fi for the current IT            *
*       BUFF(   IP2 + 104)                                             *
*          => BUFF( + 155 )  = Sum of Fi**2 for the current IT         *
*       BUFF(   IP2 + 156)                                             *
*          => BUFF( + 207 )  = Sum of Fi for total                     *
*       BUFF(   IP2 + 208)                                             *
*          => BUFF( + 259 )  = Sum of Fi**2 for total                  *
*    IP3  = IP1 + 264                                                  *
*       IBUF( IP3 )          = Tag for spring                          *
*       IBUF( IP3   +  1 )                                             *
*          => IBUF( + 16 )   = Title of this histogram                 *
*                                                                      *
*   --------------------                                               *
*     Scat_Plot buffer                                                 *
*   --------------------                                               *
*                                                                      *
* IP1   = NW + 1                                                       *
*         NW  = NW + 2527                                              *
*       BUFF( IP1 )          = Xmin                                    *
*       BUFF( IP1 + 1 )      = Xmax                                    *
*       IBUF( IP1 + 2 )      = No. of bins for X                       *
*       BUFF( IP1 + 3 )      = Bin width for X                         *
*       BUFF( IP1 + 4 )      = Ymin                                    *
*       BUFF( IP1 + 5 )      = Ymax                                    *
*       IBUF( IP1 + 6 )      = No. of bins for Y                       *
*       BUFF( IP1 + 7 )      = Bin width for Y                         *
* IP2   = IP1 + 8                                                      *
*       BUFF(   IP2       )  = No. of sampling points                  *
*       BUFF(   IP2 +   1 )                                            *
*          => BUFF( +2500 )  = Sum of Fi                               *
* IP3   = IP1 + 2509                                                   *
*       IBUF( IP3 )          = X-Tag for spring                        *
*       IBUF( IP3   +  1 )   = Y-Tag for spring                        *
*       IBUF( IP3   +  2 )                                             *
*          => IBUF( + 17 )   = Title of this histogram                 *
*                                                                      *
*  ((Author))                                                          *
*    S.Kawabata    June '90 at KEK                                     *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      COMMON/PLOTLU/ LU                                                 
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                      *
         LU   = LUN                                                     
                                                                        
         NW     = 0                                                     
                                                                        
         DO 50 I = 1, 13                                                
           XHASH(1,I) = 0                                               
           DHASH(1,I) = 0                                               
   50    CONTINUE                                                       
         NHIST    = 0                                                   
         NSCAT    = 0                                                   
         DO 100 I = 1, NHS                                              
           MAPL(1,I)= 0                                                 
  100    CONTINUE                                                       
         DO 200 I = 1, NSC                                              
           MAPD(1,I)= 0                                                 
  200    CONTINUE                                                       
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*     =========================                                        *
       SUBROUTINE BHPLOT( LU )                                          
*     =========================                                        *
* ((Purpose))                                                          *
*     Interface routine to print histograms and scatter plots.         *
*     Routines XHPLOT and DHPLOT are called to print them.             *
* ((Author))                                                           *
*     S.Kawabata  June '90  at KEK                                     *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      REAL*8 AVGI,SD,CHI2A                                              
      COMMON /BSRSLT/AVGI,SD,CHI2A,STIME,ITG,ITF                        
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                       
      IF( ITF .LE. 0 ) RETURN                                           
*    ===================                                               *
      CALL XHCHCK( LU )                                                 
*    ===================                                                
                                                                        
      IF( NHIST .LE. 0 ) THEN                                           
         WRITE(LU,9000)                                                 
 9000    FORMAT(1X,'No Histogram')                                      
      ELSE                                                              
         DO 500 J = 1, NHIST                                            
            IFBASE(J) = 1                                               
*          =====================                                        
            CALL XHPLOT(LU, 0, J )                                      
*          =====================                                        
  500    CONTINUE                                                       
      ENDIF                                                             
                                                                        
*    ===================                                                
      CALL DHPLOT( LU )                                                 
*    ===================                                                
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    ====================                                              *
      SUBROUTINE BHRSET                                                 
*    ====================                                              *
* ((Purpose))                                                          *
*     To reset contents of histograms and scatter plots.               *
* ((Author))                                                           *
*     S.Kawabata  June '90 at KEK                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                      *
*-------------------------- Clear Histograms --------------------------*
*                                                                      *
         DO 200 J    = 1, NHIST                                         
           IP2       = MAPL(3,J)                                        
           DO 100 I  = IP2,IP2+259                                      
             IBUF(I) = 0                                                
  100      CONTINUE                                                     
           IFBASE(J) = 0                                                
  200    CONTINUE                                                       
*                                                                      *
*-------------------------- Clear Scat. Plots -------------------------*
*                                                                      *
         DO 500  J   = 1, NSCAT                                         
           IP2       = MAPD(3,J)                                        
           DO 400  I = IP2,IP2+2500                                     
             IBUF(I) = 0.0                                              
  400      CONTINUE                                                     
  500    CONTINUE                                                       
*                                                                      *
      RETURN                                                            
      END                                                               
************************************************************************
*     ====================                                             *
       SUBROUTINE BHSAVE                                                
*     ====================                                             *
* ((Purpose))                                                          *
*     To save contents of temporary buffers to the histogram buffers,  *
*     in order to avoid the precision problem.                         *
* ((Author))                                                           *
*     S.Kawabata  June '90 at KEK                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                      *
      DO 200 J = 1, NHIST                                               
         IP2   = MAPL(3,J)                                              
         NC    = IBUF( MAPL(2,J)+2 ) + 1                                
         IB1   = IP2 + 52                                               
         IB2   = IB1 + 52                                               
         DO 100 I = 0,NC                                                
            I1    = I + IB1                                             
            I2    = I1 + 104                                            
            BUFF(I2)  = BUFF(I2) + BUFF(I1)                             
            BUFF(I1)  = 0.0                                             
            I1    = I + IB2                                             
            I2    = I1 + 104                                            
            BUFF(I2)  = BUFF(I2) + BUFF(I1)                             
            BUFF(I1)  = 0.0                                             
  100    CONTINUE                                                       
  200 CONTINUE                                                          
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ===================                                               *
      SUBROUTINE BSCHCK                                                 
*    ===================                                               *
* ((Purpose))                                                          *
*     To check user's initialization parameters.                       *
*                                                                      *
*        Coded by S.Kawabata        Oct. '85                           *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER ( MXDIM = 50)                                           
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                   
     .               IG(MXDIM),NCALL                                    
      COMMON /BPARM2/ ACC1,ACC2,ITMX1,ITMX2                             
                                                                        
      COMMON /BASE0/ JFLAG,IBASES                                       
      COMMON /BASE1/ XLT(MXDIM),XUT(MXDIM),NDIMT,NWILDT,                
     .               IGT(MXDIM),NCALLT                                  
      COMMON /BASE2/ ACC1T,ACC2T,ITMX1T,ITMX2T                          
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
      COMMON /XHCNTL/ LOCK                                              
                                                                        
      LOCK  = 1                                                         
                                                                        
      IF( IBASES .NE.  1 ) THEN                                         
          WRITE(6,9000)                                                 
 9000     FORMAT(                                                       
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   BSINIT was not called before calling BASES  *',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Process was terminated due to this error.   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
          STOP                                                          
      ENDIF                                                             
                                                                        
                                                                        
      IF( NDIM .LT. 1) THEN                                             
          WRITE(6,9100)                                                 
 9100     FORMAT(                                                       
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   NDIM was not set before calling BASES.      *',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Process was terminated due to this error.   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
          STOP                                                          
      ENDIF                                                             
                                                                        
      NDIMT = NDIM                                                      
                                                                        
      DO 200 I = 1,NDIM     
         IF( XU(I) .LE. -1.0D37) THEN                                   
             WRITE(6,9200) I,I                                          
 9200        FORMAT(                                                    
     .        5X,'*************************************************',   
     .       /5X,'*                                               *',   
     .       /5X,'*   XL(',I6,' ).  XU(',I6,' ) were not set      *',   
     .       /5X,'*    before calling BASES.                      *',   
     .       /5X,'*   Process was terminated due to this error.   *',   
     .       /5X,'*                                               *',   
     .       /5X,'*************************************************')   
             STOP                                                       
         ENDIF                                                          
                                                                        
         IGT(I)  = IG(I)                                                
         XLT(I)  = XL(I)                                                
         XUT(I)  = XU(I)                                                
                                                                        
  200 CONTINUE                                                          
C                                                                       
C  Change the maximum number of the wild variables                      
C 10 ===> 15                                                            
      IF( NWILD .LT.  0) THEN                                           
          NWILD = MIN( NDIM, 15)                                        
          WRITE(6,9300) NWILD                                           
 9300     FORMAT(                                                       
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   NWILD was not set before calling BASES.     *',      
     .    /5X,'*                                               *',      
     .    /5X,'*   NWILD is set equal to the value(',I6,' ).   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
      ELSE                                                              
     .IF( NWILD .GT. 15) THEN                                           
          NWILDO = NWILD                                                
          NWILD  = MIN( NDIM, 15)                                       
          WRITE(6,9400) NWILDO, NWILD                                   
 9400     FORMAT(                                                       
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   NWILD(',I6,' ) was too large number.        *',      
     .    /5X,'*                                               *',      
     .    /5X,'*   NWILD is set equal to the value(',I6,' ).   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
      ENDIF                                                             
                                                                        
      NWILDT = NWILD                                                    
      NCALLT = NCALL                                                    
                                                                        
      ITMX1T = ITMX1                                                    
      ITMX2T = ITMX2                                                    
      ACC1T  = ACC1                                                     
      ACC2T  = ACC2                                                     
C                                                                       
      RETURN                                                            
      END                                                               
C***********************************************************************
C*=======================                                              *
       SUBROUTINE BSDATE                                                
C*=======================                                              *
C*((Purpose))                                                          *
C*    Changethe format of the time stamp.                              *
C*    This program should be modified according to the machine.        *
C*((Author))                                                           *
C*    S.Kawabata  Nov. '91 at KEK                                      *
C*    For HP      Jul. '92 at KEK                                      *
C***********************************************************************
       COMMON /BDATE/ IDATE(3),ITIME(2)                                 
       COMMON /SLATE/ IS(40)                                            
*            IDATE(1) : year        ITIME(1) : hour                     
*            IDATE(2) : month       ITIME(2) : minute                   
*            IDATE(3) : day                                             
                                                                        
*      CALL UXDATE(IY,IM,ID,IHH,IMM)                                    
+SELF,IF=CERN
       CALL DATIME(ID,IT)
       CALL UCOPY(IS(1),IDATE(1),5)                                     
+SELF
       IDATE(1) = MOD(IDATE(1),1900)                                    
*      IDATE(1) = IY                                                    
*      IDATE(2) = IM                                                    
*      IDATE(3) = ID                                                    
*      ITIME(1) = IHH                                                   
*      ITIME(2) = IMM                                                   
       RETURN                                                           
       END                                                              
************************************************************************
*    ===========================================                       *
      SUBROUTINE BSDIMS( MDIM, MWILD, XLL, XUU )                        
*    ===========================================                       *
* ((Purpose))                                                          *
*     To set the BASES parameters.                                     *
* ((Input))                                                            *
*     MDIM   : The number of dimension of integral                     *
*     MWILD  : The number of wild variables                            *
*     XLL(i) : The lower value of the i-th integral variable           *
*     XUU(i) : The upper value of the i-th integral variable           *
* ((Output))                                                           *
*     These parameters are to be set in the labeled common /BPARM1/    *
* (Caution)                                                            *
*     The parameter IG(i) is not able to set by this routine.          *
*     If some of parameters IG(i) are required to be changed,          *
*     it is done by calling the subroutine BSGRID.                     *
*                                                                      *
*        Coded by S.Kawabata         August '94                        *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50 )                                
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                   
     .               IG(MXDIM),NCALL                                    
                                                                        
      DIMENSION XLL(MDIM), XUU(MDIM)                                    
                                                                        
*=========================================================              
                                                                        
      NDIM   = MDIM                                                     
      NWILD  = MWILD                                                    
      DO 100 I= 1, NDIM                                                 
         XL(I) = XLL(I)                                                 
         XU(I) = XUU(I)                                                 
  100 CONTINUE                                                          
                                                                        
       RETURN                                                           
       END                                                              
C***********************************************************************
C*                                                                     *
C*========================                                             *
C*    SUBROUTINE BSETGU                                                *
C*========================                                             *
C*((Function))                                                         *
C*     Initialization of Bases progam                                  *
C*     This is called only when IFLAG=0.                               *
C*     ( IFLAG = 0 ; First Trial of Defining Grid step )               *
C*                                                                     *
C*    Changed by S.Kawabata    Aug. 1984 at Nagoya Univ.               *
C*    Last update              Oct. 1985 at KEK                        *
C*                                                                     *
C***********************************************************************
C                                                                       
      SUBROUTINE BSETGU                                                 
C                                                                       
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
     .               ND,NG,NPG,MA(MXDIM)                                
      COMMON /BASE6/ D(NDMX,MXDIM),                                     
     .               ALPH,XSAVE(NDMX,MXDIM),XTI,XTSI,XACC,ITSX          
                                                                        
      DIMENSION  XIN(NDMX)                                              
      DATA  ONE/ 1.0D0/                                                 
C                                                                       
C---------------------------------------------------------------        
C           Define the number of grids and sub-regions                  
C---------------------------------------------------------------        
C==> Determine NG : Number of grids                                     
          NG    = (NCALL/2.)**(1./NWILD)                                
         IF(NG .GT. 25) NG  = 25                                        
  100    IF(NG .LT.  2) NG  =  1                                        
         IF(NG**NWILD .GT. LENG) THEN                                   
            NG  = NG - 1                                                
            GO TO 100                                                   
         ENDIF                                                          
C                                                                       
C==> Determine ND : Number of sub-regions                               
          M     = NDMX/NG                                               
          ND    = M*NG                                                  
C                                                                       
C==> Determine NPG: Number of sampling points per subhypercube          
          NSP   = NG**NWILD                                             
          NPG   = NCALL/NSP                                             
                                                                        
          XI(1,1)= ONE                                                  
          MA(1)  = 1                                                    
          DX(1)  = XU(1)-XL(1)                                          
                                                                        
          IF( NDIM .GT. 1 ) THEN                                        
              DO 130 J = 2,NDIM                                         
                 XI(1,J)= ONE                                           
                 DX(J)  = XU(J)-XL(J)                                   
                 IF( J .LE. NWILD ) THEN                                
                    MA(J)  = NG*MA(J-1)                                 
                 ENDIF                                                  
  130         CONTINUE                                                  
          ENDIF                                                         
C                                                                       
C---------------------------------------------------------------        
C           Set size of subregions uniform                              
C---------------------------------------------------------------        
          NDM   = ND-1                                                  
          RC    = ONE/ND                                                
          DO 155 J =1,NDIM                                              
             K     = 0                                                  
             XN    = 0.D0                                               
             DR    = XN                                                 
             I     = K                                                  
  140        K     = K+1                                                
             DR    = DR+ONE                                             
             XO    = XN                                                 
             XN    = XI(K,J)                                            
  145       IF(RC .GT. DR) GO TO 140                                    
             I     = I+1                                                
             DR    = DR-RC                                              
             XIN(I)= XN-(XN-XO)*DR                                      
            IF(I .LT. NDM) GO TO 145                                    
             DO 150 I  = 1,NDM                                          
                XI(I,J)= XIN(I)                                         
  150        CONTINUE                                                   
             XI(ND,J)  = ONE                                            
  155     CONTINUE                                                      
********************************************* Updated Feb.08 '94        
          IF( ITSX .GT. 0 ) THEN                                        
              IPSAVE = 1                                                
              XACC    = 1.0D37                                          
              XTI     = 0.0D0                                           
              XTSI    = XACC                                            
              ITSX    = 1                                               
              DO 200 J = 1, NDIM                                        
              DO 200 I = 1, ND                                          
                 XSAVE(I,J) = XI(I,J)                                   
  200         CONTINUE                                                  
          ENDIF                                                         
C                                                                       
      RETURN                                                            
      END                                                               
C***********************************************************************
C*                                                                     *
C*========================                                             *
C*    SUBROUTINE BSETGV( IFLAG )                                       *
C*========================                                             *
C*((Function))                                                         *
C*    Refine the grid sizes                                            *
C*                                                                     *
C*    Coded   by S.Kawabata    Aug. 1984 at Nagoya Univ.               *
C*    Last update              Oct. 1985 at KEK                        *
C*                                                                     *
C***********************************************************************
C                                                                       
      SUBROUTINE BSETGV( IFLAG )                                        
C                                                                       
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
     .               ND,NG,NPG,MA(MXDIM)                                
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
      COMMON /BASE6/ D(NDMX,MXDIM),                                     
     .               ALPH,XSAVE(NDMX,MXDIM),XTI,XTSI,XACC,ITSX          
      REAL*4 STIME                                                      
      COMMON /BSRSLT/AVGI,SD,CHI2A,STIME,ITG,ITF                        
*                                                                       
                                                                        
      DIMENSION  XIN(NDMX),R(NDMX),DT(MXDIM),DDX(NDMX)                  
      DATA  ONE/1.0D0/,ZERO/0.0D0/,N0/0/,N1/1/                          
*                                                                       
*========= Save the grid information for the best accuracy ===========  
*                                                                       
      IF( ITSX .GT. 0 ) THEN                                            
          IF( IFLAG .EQ. 0 ) THEN                                       
              IF( IT .GE. 5 ) THEN                                      
                  IF( ( TI .GT. AVGI+SD) .AND. TSI .LT. XTSI ) THEN     
                      DO 400 J = 1, NDIM                                
                      DO 400 I = 1, ND                                  
                         XSAVE(I,J) = XI(I,J)                           
  400                 CONTINUE                                          
                      XACC         = TACC                               
                      ITSX         = IT                                 
                      XTI          = TI                                 
                      XTSI         = TSI                                
                  ENDIF                                                 
              ENDIF                                                     
          ELSE                                                          
              IF( ( XTI .GT. TI) .AND. XTSI .LT. TSI ) THEN             
                  DO 500 J = 1, NDIM                                    
                  DO 500 I = 1, ND                                      
                     XI(I,J) = XSAVE(I,J)                               
  500             CONTINUE                                              
*                ==========                                             
                   RETURN                                               
*                ==========                                             
              ENDIF                                                     
          ENDIF                                                         
      ENDIF                                                             
                                                                        
C======= SMOOTHING THE FUNCTION D(I,J)                                  
C                                                                       
        CLOGE   = 1.0D0/LOG(10.0D0)                                     
                                                                        
        NDM     = ND-1                                                  
        DO 780 J= N1,NDIM                                               
         IF( IG(J) .EQ. 1 ) THEN                                        
          DDX(1)= 0.5D0*(D(1,J) + D(2,J))                               
          DO 710 I=2,NDM                                                
            DDX(I)= (D(I+1,J) + D(I,J) + D(I-1,J))/3.D0                 
  710     CONTINUE                                                      
          DDX(ND) = 0.5D0*(D(NDM,J) + D(ND,J))                          
          DT(J) = 0.D0                                                  
          DO 720 I = 1, ND                                              
             D(I,J) = DDX(I)                                            
             DT(J)  = DT(J)+D(I,J)                                      
  720     CONTINUE                                                      
C                                                                       
C=========== REDEFINE THE GRID                                          
C                                                                       
                                                                        
          DTLOG   = LOG(DT(J))                                          
          DT10    = CLOGE*DTLOG                                         
          RC    = ZERO                                                  
          DO 730 I= N1,ND                                               
            R(I)  = ZERO                                                
            IF(D(I,J) .GT. ZERO) THEN                                   
               DILOG = LOG(D(I,J))                                      
               IF( DT10 - CLOGE*DILOG  .LE. 70.0D0 ) THEN               
                   XO    = DT(J)/D(I,J)                                 
                   R(I)  = ((XO-ONE)/(XO*(DTLOG-DILOG)))**ALPH          
               ELSE                                                     
C                  XO    = DT(J)/D(I,J)                                 
                   R(I)  = (DTLOG-DILOG)**(-ALPH)                       
               ENDIF                                                    
            ENDIF                                                       
            RC    = RC+R(I)                                             
  730     CONTINUE                                                      
          RC    = RC/ND                                                 
          K     = N0                                                    
          XN    = N0                                                    
          DR    = XN                                                    
          I     = K                                                     
  740  K     = K + N1                                                   
          DR    = DR+R(K)                                               
          XO    = XN                                                    
          XN    = XI(K,J)                                               
  750 IF(RC.GT.DR)GO TO 740                                             
          I     = I + N1                                                
          DR    = DR-RC                                                 
          XIN(I)= XN-(XN-XO)*DR/R(K)                                    
      IF(I.LT.NDM)GO TO 750                                             
          DO 760 I= N1,NDM                                              
            XI(I,J)= XIN(I)                                             
  760     CONTINUE                                                      
          XI(ND,J)= ONE                                                 
         ENDIF                                                          
  780   CONTINUE                                                        
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ==================================                                *
      SUBROUTINE BSGRID( MDIM, IGG )                                    
*    ==================================                                *
* ((Purpose))                                                          *
*     To change the grid optimizing flag.                              *
* ((Input))                                                            *
*     MDIM   : The number of dimension of integral                     *
*     IGG(i) : The flag switches whether the grid of i-th variable     *
*              is to be optimized ( 1 ) or kept uniform ( 0 ).         *
* ((Output))                                                           *
*     These parameters are to be set in the labeled common /BPARM1/    *
*                                                                      *
*        Coded by S.Kawabata         August '94                        *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50 )                                
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                   
     .               IG(MXDIM),NCALL                                    
                                                                        
      DIMENSION IGG(MDIM)                                               
                                                                        
*=========================================================              
                                                                        
      NDIM   = MDIM                                                     
      DO 100 I= 1, NDIM                                                 
         IG(I) = IGG(I)                                                 
  100 CONTINUE                                                          
                                                                        
       RETURN                                                           
       END                                                              
*********************************************************************** 
*============================                                         * 
      SUBROUTINE BSINFO( LU )                                           
*============================                                         * 
*((Purpose))                                                          * 
*    Print the information for                                        * 
*        (1) BASES parameters                                         * 
*        (2) Computer time information                                * 
*        (3) Convergency behavior of the Grid optimization step       * 
*        (4) Convergency behavior of the integration step             * 
*(( Input ))                                                          * 
*    LU  :  Logical unit number of printer                            * 
*                                                                     * 
*           by S.Kawabata    March 1994 at KEK                          
*                                                                     * 
*********************************************************************** 
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      REAL*4 STIME                                                      
      COMMON /BSRSLT/AVGI,SD,CHI2A,STIME,ITG,ITF                        
                                                                        
*  Print Title                                                          
                                                                        
      CALL BSPRNT( LU, 1, IDUM1, IDUM2 )                                
                                                                        
*  Print Bases parameters                                               
                                                                        
      CALL BSPRNT( LU, 4, IDUM1, IDUM2 )                                
                                                                        
*  Print Computing time information                                     
                                                                        
      CALL BSPRNT( LU, 3, IDUM1, IDUM2 )                                
                                                                        
*  Print Convergency Behaviors                                          
                                                                        
      DO 100 ISTEP = 0, 1                                               
         ITX  = ITG                                                     
         IF( ISTEP .EQ. 1 ) ITX = ITF                                   
                                                                        
      IF( ITX .GT. 0 ) THEN                                             
                                                                        
         CALL BSPRNT( LU, 8, ITX, ISTEP )
	                                                                
                                                                        
      ENDIF                                                             
  100 CONTINUE                                                          
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    ===================                                               *
      SUBROUTINE BSINIT                                                 
*    ===================                                               *
* ((Purpose))                                                          *
*     Initialization of BASE50/SPRING50.                               *
*     Function of this routine is                                      *
*       (0) Set the size of histogram and scatter plot buffers         *
*       (1) Set the parameters INTV and IPNT                           *
*             INTV = ( 0 / 1 / any )                                   *
*                  = ( Batch / Batch(Unix) / Interactive )             *
*             IPNT = ( 0 / any )                                       *
*                  = ( IBM Type / Ascii printer )                      *
*       (2) Set the acceleration factor ALPHA by 1.5                   *
*            The range of this value is from 0.0 to 2.0.               *
*            ALPHA = 0.0 results in no grid-optimization.              *
*       (3) Set the grid-optimization flag IGOPT ( Default value 0 )   *
*             IGOPT = 0  :  The grid is optimized by VEGAS algorithm   *
*             IGOPT = 1  :  The grid is optimized so that the accuracy *
*                           of each iteration be minimized.            *
*       (4) Set Node-ID number NODEID and the number of nodes NUMNOD   *
*       (5) Set seed of radom number                                   *
*       (6) Set the values of BASES paremeters with default ones.      *
*       (7) Set the values of parameters with non-sense values,        *
*            which should be set again with the true values by User    *
*            before running BASES.                                     *
*                                                                      *
*        Coded by S.Kawabata         March '94                         *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50 )                                
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                   
     .               IG(MXDIM),NCALL                                    
      COMMON /BPARM2/ ACC1,ACC2,ITMX1,ITMX2                             
                                                                        
      COMMON /BASE0/ JFLAG,IBASES                                       
      COMMON /BASE6/ D(NDMX,MXDIM),                                     
     .               ALPH,XSAVE(NDMX,MXDIM),XTI,XTSI,XACC,IGOPT         
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
       COMMON/NINFO/ NODEID, NUMNOD                                     
       COMMON /BDATE/ IDATE(3),ITIME(2)                                 
*            IDATE(1) : year        ITIME(1) : hour                     
*            IDATE(2) : month       ITIME(2) : minute                   
*            IDATE(3) : day                                             
      REAL*4 TIMEBS,TIMINT,TIMESP,TIME0,RTIME,TIMEB1,TIMEB2,TIMES1      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
*=========================================================              
* (0) Initialization of timer and Histogram buffer                      
*     Timer initialization                                              
       CALL BSTIME( TIME0, 0 )                                          
       TIMEB1 = TIME0                                                   
       TIMINT = 0                                                       
                                                                        
*     Histogram buffer initialization                                   
       LU  = 6                                                          
       CALL BHINIT( LU )                                                
                                                                        
*=========================================================              
                                                                        
* (1) Set the parameters INTV and IPNT                                  
       INTV  = 0                                                        
       IPNT  = 1                                                        
* (2) Set the acceleration factor ALPHA by 1.5                          
       ALPH  = 1.5D0                                                    
* (3) Set the grid-optimization flag IGOPT                              
       IGOPT = 0                                                        
* (4) Set Node-ID number NODEID and the number of nodes NUMNOD          
*      IF( INTV .EQ. 0 ) THEN                                           
           NODEID = 0                                                   
           NUMNOD = 1                                                   
*      ELSE                                                             
*          NODEID = 0                                                   
*          NUMNOD = 1                                                   
*      ENDIF                                                            
                                                                        
C---------------------------------------------------------------        
C (5)  Set initial seeds of random number generator                     
C---------------------------------------------------------------        
       ISEED = 12345                                                    
C                                                                       
       CALL DRNSET( ISEED )                                             
C ---------------------------------------------------------------       
C (6),(7)  Set BASES parameters equal to default values                 
C ---------------------------------------------------------------       
C                                                                       
cccAB       NDIM   = -1                                                      
cccAB        NWILD  =  1                                                      
cccAB        ITMX1  = 15                                                      
cccAB        ITMX2  = 100                                                     
cccAB        NCALL  = 1000                                                    
cccAB        ACC1   = 0.2D0                                                   
cccAB        ACC2   = 0.01D0                                                  
       DO 100 I = 1,MXDIM                                               
          IG(I) = 1                                                     
          XU(I)  = -1.0D37                                              
  100  CONTINUE                                                         
                                                                        
*    Initialization of computing time table of BASES                    
       DO 200 I = 0, 2                                                  
          TIMEBS(I) = 0.0                                               
  200  CONTINUE                                                         
                                                                        
*-------------------------------------------                            
*      Don't change IBASES from this value                              
*-------------------------------------------                            
       IBASES =  1                                                      
                                                                        
       RETURN                                                           
       END                                                              
*********************************************************************** 
*                                                                     * 
*    ==========================                                       * 
      SUBROUTINE BSINTG( FXN )                                          
*    ==========================                                       * 
*((Function))                                                         * 
*    Subroutine performs N-dimensional Monte Carlo integration        * 
*    for four vector generation of simulated events                   * 
*                                                                     * 
*       JFLAG = 0 ; First Trial of Defining Grid                      * 
*       JFLAG = 1 ; First Trial of Data Accumulation                  * 
*       JFLAG = 2 ; Second Trial of Defining Grid                     * 
*       JFLAG = 3 ; Second Trial of Data Accumulation                 * 
*                                                                     * 
*    Coded   by S.Kawabata    July 1980 at DESY, Hamburg              * 
*    Last update              March 1994                              * 
*                                                                     * 
*********************************************************************** 
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
                                                                        
      EXTERNAL FXN                                                      
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE0/ JFLAG,IBASES                                       
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE2/ ACC1,ACC2,ITMX1,ITMX2                              
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
      COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
     .               ND,NG,NPG,MA(MXDIM)                                
      PARAMETER (ITM = 50)                                              
      REAL*4 TIME, EFF, WRONG, TRSLT, TSTD, PCNT                        
      COMMON /BASE5/ ITRAT(ITM,0:1),TIME(ITM,0:2),EFF(ITM,0:1),         
     .               WRONG(ITM,0:1),RESLT(ITM,0:1),ACSTD(ITM,0:1),      
     .               TRSLT(ITM,0:1),TSTD(ITM,0:1),PCNT(ITM,0:1)         
      COMMON /BASE6/ D(NDMX,MXDIM),                                     
     .               ALPH,XSAVE(NDMX,MXDIM),XTI,XTSI,XACC,ITSX          
      REAL*4 STIME                                                      
      COMMON /BSRSLT/AVGI,SD,CHI2A,STIME,ITG,ITF                        
      CHARACTER*80 ERROR                                                
      COMMON /BWARN1/ NERROR                                            
      COMMON /BWARN2/ ERROR(3,3)                                        
*                                                                       
*        INTV = ( 0 / 1 / any ) = ( Batch / Batch(Unix) / Interactive ) 
*        IPNT = ( 0 / any ) = ( IBM Type / Ascii printer )              
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      REAL*8  X(MXDIM)                                                  
      INTEGER KG(MXDIM),IA(MXDIM)                                       
                                                                        
      COMMON/NINFO/ NODEID, NUMNOD                                      
      REAL*4 TIMEBS,TIMINT,TIMESP,TIME0,RTIME,TIMEB1,TIMEB2,TIMES1      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
*                                                                       
*     Parameters for checking convergency                               
*                                                                       
      DATA ACLMT,FC / 25.0D0, 5.0D0 /                                   
                                                                        
C     REAL*8  TX(2)                                                     
      INTEGER NCNODE(2,512),NPNODE(2,512)                               
C     INTEGER NEFF(2)                                                   
                                                                        
      DATA  ONE/ 1.0D0/, ZERO/0.0D0/, LU / 6/                           
      DATA  N0/0/, N1/1/, HUNDRT/100.0D0/                               
                                                                        
************************************************************************
*                       Initialization Part                             
************************************************************************
*=======================================================================
*          Determine the number of hypercubes NSP                       
*=======================================================================
                                                                        
      XND     = ND                                                      
      NSP     = NG**NWILD                                               
      XJAC    = 1.0D0                                                   
      DO  5 I = 1, NDIM                                                 
         XJAC = XJAC*DX(I)                                              
    5 CONTINUE                                                          
      CALLS   = NSP*NPG                                                 
      DXG     = 1.0D0/NG                                                
      DV2G    = DXG**(2*NWILD)/NPG/NPG/(NPG-1)                          
      DXG     = DXG*XND                                                 
                                                                        
      IF( NSP .EQ. 1 ) THEN                                             
*=======================================================================
*           Determination of the number of sampling points              
*               per node in the single hypercube case                   
*=======================================================================
          MEX     = MOD(NPG,NUMNOD)                                     
          NPERCP  = NPG/NUMNOD                                          
          NPGT    = 0                                                   
          DO  12 NODEX = 1,NUMNOD                                       
             NPGS  = NPGT + 1                                           
             NPGT  = NPGT + NPERCP                                      
             IF( NODEX .LE. MEX ) NPGT = NPGT + 1                       
             NCNODE(1,NODEX) = 1                                        
             NCNODE(2,NODEX) = 1                                        
             NPNODE(1,NODEX) = NPGS                                     
             NPNODE(2,NODEX) = NPGT                                     
   12     CONTINUE                                                      
      ELSE                                                              
*=======================================================================
*          Determination of the number of hypercubes                    
*              per node in many hypercubes case                         
*=======================================================================
          MEX     = MOD(NSP,NUMNOD)                                     
          NPERCP  = NSP/NUMNOD                                          
          NSPT    = 0                                                   
          DO  15 NODEX = 1,NUMNOD                                       
             NSPS  = NSPT + 1                                           
             NSPT  = NSPT + NPERCP                                      
             IF( NODEX .LE. MEX ) NSPT = NSPT + 1                       
             NCNODE(1,NODEX) = NSPS                                     
             NCNODE(2,NODEX) = NSPT                                     
             NPNODE(1,NODEX) = 1                                        
             NPNODE(2,NODEX) = NPG                                      
   15     CONTINUE                                                      
      ENDIF                                                             
*=======================================================================
      NEND    = N0                                                      
      ATACC   = ZERO                                                    
      NERROR  = N0                                                      
      NER1    = N0                                                      
      NER2    = N0                                                      
      NER3    = N0                                                      
      SUMTI   = ZERO                                                    
      SUMTSI  = ZERO                                                    
                                                                        
      IF(JFLAG .EQ. N0 .OR. JFLAG .EQ. N1 ) THEN                        
*-----------------------------------------------------------------------
*        JFLAG = 0  : The first trial of the grid optim. step           
*        JFLAG = 1  : The first trial of the integration step           
*-----------------------------------------------------------------------
         DO 10 J  = N1,NSP                                              
           DXD(J) = ZERO                                                
           DXP(J) = ZERO                                                
   10    CONTINUE                                                       
*       -----------------                                               
         ISTEP   = JFLAG                                                
*       -----------------                                               
         IT1   = N1                                                     
         SI    = ZERO                                                   
         SI2   = ZERO                                                   
         SWGT  = ZERO                                                   
         SCHI  = ZERO                                                   
*       =============                                                   
         CALL BHRSET                                                    
*       =============                                                   
         NSU     = N0                                                   
         SCALLS= ZERO                                                   
      ELSE                                                              
*-----------------------------------------------------------------------
*        JFLAG = 2  : The continuation of the grid optim. step          
*        JFLAG = 3  : The continuation of the integration step          
*-----------------------------------------------------------------------
C        IF( JFLAG .EQ. 2 ) THEN                                        
*           -------------                                               
C            ISTEP  = N0                                                
*           -------------                                               
C        ELSE                                                           
C    .   IF( JFLAG .EQ. 3 ) THEN                                        
*           -------------                                               
C            ISTEP  = N1                                                
*           -------------                                               
C        ELSE                                                           
C                *****************                                      
C                      STOP                                             
C                *****************                                      
C         ENDIF                                                         
C                                                                       
C         IT1   = IT + 1                                                
      ENDIF                                                             
                                                                        
*------- Set the expected accuracy and the max. iteration number -------
                                                                        
      ITMX   = ITMX1                                                    
      ACC    = ACC1*0.01D0                                              
      IF( ISTEP .EQ. N1 ) THEN                                          
         ITMX = ITMX2                                                   
         ACC  = ACC2*0.01D0                                             
      ENDIF                                                             
                                                                        
*-------- Print the title of the convergency behavior table ----------- 
*                  in the interactive mode                              
      IF( INTV .GT. 1 ) THEN                                            
*         -----------------------------------                           
           CALL BSPRNT( LU, 5, ISTEP, IDUM2 )                           
*         -----------------------------------                           
      ENDIF                                                             
      NEGFLG     = 0                                                    
                                                                        
*    =====================                                              
      CALL BSUTIM( 0, 2 )                                               
*    =====================                                              
                                                                        
*********************************************************************   
*               Main Integration Loop                                   
*********************************************************************   
*    ========                                                           
      DO 500  IT = IT1,ITMX                                             
*    ========                                                           
*=======================================================================
*                 Initialization for the iteration                      
*=======================================================================
                                                                        
         SCALLS  = SCALLS + CALLS                                       
         NGOOD   = N0                                                   
         NEGTIV  = N0                                                   
         TI      = ZERO                                                 
         TSI     = TI                                                   
                                                                        
         IF( ISTEP .EQ. N0 ) THEN                                       
             DO 200 J= N1,NDIM                                          
             DO 200 I=1,ND                                              
                D(I,J)= TI                                              
  200        CONTINUE                                                   
         ENDIF                                                          
                                                                        
         NODEX  = NODEID                                                
         IF( NODEID .EQ. 0 )  NODEX = NUMNOD                            
                                                                        
*---------------------------------------------------------------------  
*        Distributing hyper cubes to NumNode nodes                      
*           NCNODE(1,NODEX)   : 1st cube number for the node NODEX      
*           NCNODE(2,NODEX)   : Last cube number for the node NODEX     
*                    NODEX    : node number 1 => NumNode(=0)            
*                    NODEX    : node number 1 => NumNode(=0)            
*---------------------------------------------------------------------  
                                                                        
         NSP1  = NCNODE(1,NODEX)                                        
         NSP2  = NCNODE(2,NODEX)                                        
*                                 Dummy loopfor a parallel processor    
C                                 IF( NSP1 .GT. 1 ) THEN                
C                                     CALL DRLOOP( NDIM*NPG*(NSP1-1) )  
C                                 ENDIF                                 
                                                                        
*=====================================================================  
*      Loop for hypercube from NSP1 to NSP2 in the NodeX-th node        
*=====================================================================  
*       ========                                                        
         DO 400 NCB = NSP1, NSP2                                        
*       ========                                                        
            FB      = 0.0                                               
            F2B     = 0.0                                               
            NP      = NCB - 1                                           
            IF( NWILD .GT. 1 ) THEN                                     
                DO 210 J = 1,NWILD-1                                    
                   NUM   = MOD(NP,MA(J+1))                              
                   KG(J) = NUM/MA(J) + 1                                
  210           CONTINUE                                                
            ENDIF                                                       
            KG(NWILD)     = NP/MA(NWILD) + 1                            
                                                                        
*---------------------------------------------------------------------  
*       If number of hypercubes is only one,                            
*        Distributing sampling points to NumNode nodes                  
*           NPNODE(1,NODEX)   : 1st sample point for the node NODEX     
*           NPNODE(2,NODEX)   : Last sample point for the node NODEX    
*                    NODEX    : node number 1 => NumNode(=0)            
*---------------------------------------------------------------------  
                                                                        
            NPG1  = NPNODE(1,NODEX)                                     
            NPG2  = NPNODE(2,NODEX)                                     
*                                 Dummy loop for a parallel processor   
C                                 IF( NPG1 .GT. 1 ) THEN                
C                                     CALL DRLOOP( NDIM*(NPG1-1) )      
C                                 ENDIF                                 
                                                                        
*=====================================================================  
*          Loop for sampling points from NPG1 to NPG2                   
*                in the single hypercube case                           
*=====================================================================  
*          ========                                                     
            DO 300 NTY = NPG1,NPG2                                      
*          ========                                                     
*---------------------------------------------------------------------  
*        Determine the integration variables by random numbers          
*---------------------------------------------------------------------  
                                                                        
               WGT   = XJAC                                             
               DO 250 J= 1,NDIM                                         
                  IF( J .LE. NWILD ) THEN                               
                      XN  = (KG(J)-DRN(IDUMY))*DXG+1.D0                 
                  ELSE                                                  
                      XN  = ND*DRN(IDUMY)+1.D0                           
                  ENDIF                                                 
                  IA(J)   = XN                                          
                  IAJ     = IA(J)                                       
                  IF( IAJ .EQ. 1) THEN                                  
                      XO  = XI(IAJ,J)                                   
                      RC  = (XN-IA(J))*XO                               
                  ELSE                                                  
                      XO  = XI(IAJ,J)-XI(IAJ-1,J)                       
                      RC  = XI(IAJ-1,J)+(XN-IAJ)*XO                     
                  ENDIF                                                 
                  X(J)    = XL(J)+RC*DX(J)                              
                  WGT     = WGT*XO*XND                                  
  250          CONTINUE                                                 
*-----------------------------------------------------------------------
*                     =======                                           
               FXG  =  FXN(X)*WGT                                       
*                     =======                                           
*-----------------------------------------------------------------------
*             Check the value of the integrand                          
*-----------------------------------------------------------------------
                                                                        
               IF( FXG .NE. 0.0 ) THEN                                  
                   NGOOD = NGOOD + 1                                    
                   IF( ISTEP .EQ. 1 ) THEN                              
                       DXD(NCB) = DXD(NCB) + FXG                        
                       IF( FXG .GT. DXP(NCB) ) DXP(NCB) = FXG           
                   ENDIF                                                
                   IF( FXG .LT. 0.0 ) THEN                              
                       NEGTIV= NEGTIV+ 1                                
                       IF( NEGFLG .EQ. 0 ) THEN                         
                          WRITE(6,9200) IT,NODEID                       
 9200                     FORMAT(1X,                                    
     .                       '******* WARNING FROM BASES ********',     
     .                       '***********',                             
     .                       /1X,'*  Negative FUNCTION at IT =',I3,1X,  
     .                       ', node = ',I3,1X,'*',                     
     .                       /1X,'***********************************', 
     .                       '***********')                             
                          NEGFLG  = 1                                   
                       ENDIF                                            
                   ENDIF                                                
               ENDIF                                                    
                                                                        
*-----------------------------------------------------------------------
*              Accumulation of FXG and FXG*FXG                          
*-----------------------------------------------------------------------
                                                                        
               F2    = FXG*FXG                                          
               FB    = FB + FXG                                         
               F2B   = F2B + F2                                         
                                                                        
               IF( ISTEP .EQ. 0 ) THEN                                  
                   DO 260  J = 1,NDIM                                   
                      D(IA(J),J)= D(IA(J),J)+F2                         
  260              CONTINUE                                             
               ENDIF                                                    
*======                                                                 
  300       CONTINUE                                                    
*======                                                                 
*------------------------------------------- for a parallel processor   
*                                 Dummy loop for a parallel processor   
C                                 IF( NPG2 .LT. NPG ) THEN              
C                                     CALL DRLOOP(NDIM*(NPG-NPG1))      
C                                 ENDIF                                 
*                                 Global sum of FB and F2B              
C                                 IF( NSP .EQ. 1 ) THEN                 
C                                     CALL BSDSUM(  FB, 1 )             
C                                     CALL BSDSUM( F2B, 1 )             
C                                 ENDIF                                 
*-----------------------------------------------------------------------
                                                                        
*-----------------------------------------------------------------------
*         Calculate the estimate and variance in the hypercube          
*-----------------------------------------------------------------------
                                                                        
            F2B   = DSQRT(F2B*NPG)                                      
            F2S   = (F2B-FB)*(F2B+FB)                                   
            TI    = TI+FB                                               
            TSI   = TSI + F2S                                           
                                                                        
*======                                                                 
  400    CONTINUE                                                       
*======                                                                 
*------------------------------------------- for a parallel processor   
*                                 Dummy loop                            
C                                 IF( NSP2 .LT. NSP ) THEN              
C                                     CALL DRLOOP(NDIM*NPG*(NSP-NSP2))  
C                                 ENDIF                                 
                                                                        
*                                 Global sum of efficiency and frequency
*                                     of negative valued function       
C                                 NEFF(1) = NGOOD                       
C                                 NEFF(2) = NEGTIV                      
C                                 CALL BSISUM( NEFF, 2 )                
                                                                        
C                                 TX(1) = TI                            
C                                 TX(2) = TSI                           
C                                 IF( NSP .EQ. 1 ) THEN                 
C                                     CALL BSDSUM(   TX, 2 )            
C                                 ENDIF                                 
                                                                        
*                                 Global sum of grid information        
C                                 IF( ISTEP .EQ. 0 ) THEN               
C                                     NOWORK = NDMX*NDIM                
C                                     CALL BSDSUM(    D, NOWORK )       
C                                 ENDIF                                 
                                                                        
*=====================================================================  
*           Compute Result of this Iteration                            
*=====================================================================  
*--------------------------------------------------------------------   
*           Accumulate the histogram entries                            
*--------------------------------------------------------------------   
*       -------------                                                   
         CALL BHSAVE                                                    
*       -------------                                                   
*--------------------------------------------------------------------   
                                                                        
C        TI     = TX(1)                                                 
C        TSI    = TX(2)                                                 
C        NGOOD  = NEFF(1)                                               
C        NEGTIV = NEFF(2)                                               
                                                                        
         TI    = TI/CALLS                                               
         TSI   = TSI*DV2G                                               
**                                                                      
         IF( TSI .LE. 1.0D-37 ) TSI = 1.0D-37                           
**                                                                      
         TI2   = TI*TI                                                  
                                                                        
         IF( NGOOD .LE. 10 ) THEN                                       
*           --------------------------------                            
             CALL BSPRNT( LU, 9, IDUM1, IDUM2 )                         
*           --------------------------------                            
*            *****************                                          
                   STOP                                                 
*            *****************                                          
                                                                        
         ENDIF                                                          
                                                                        
*--------------------------------------------------------------------   
*               Calculate the cumulative result                         
*--------------------------------------------------------------------   
                                                                        
         WGT   = ONE/TSI                                                
         SI    = SI+TI*WGT                                              
         SWGT  = SWGT+WGT                                               
         SCHI  = SCHI+TI2*WGT                                           
         AVGI  = SI/SWGT                                                
         CHI2A = ZERO                                                   
         IF(IT .GT. N1 ) CHI2A = (SCHI - SI*AVGI)/(IT-.999D0)           
         SD    = DSQRT(ONE/SWGT)                                        
                                                                        
*---------------------------------------------------------------------  
*             Save the results in the buffer                            
*---------------------------------------------------------------------  
                                                                        
         TSI   = DSQRT(TSI)                                             
         ITX         = MOD( IT, ITM)                                    
         IF( ITX .EQ. 0 ) ITX = ITM                                     
         ITRAT(ITX,ISTEP)  = IT                                         
         EFF  (ITX,ISTEP)  = NGOOD/CALLS*HUNDRT                         
         WRONG(ITX,ISTEP)  = NEGTIV/CALLS*HUNDRT                        
         RESLT(ITX,ISTEP)  = AVGI                                       
         ACSTD(ITX,ISTEP)  = SD                                         
         TRSLT(ITX,ISTEP)  = TI                                         
         TACC              = ABS(TSI/TI*HUNDRT)                         
         TSTD (ITX,ISTEP)  = TACC                                       
         PCNT (ITX,ISTEP)  = ABS(SD/AVGI*HUNDRT)                        
                                                                        
*---------------------------------------------------------------------- 
*                  Check cumulative accuracy                            
*---------------------------------------------------------------------- 
                                                                        
         IF( NODEID .EQ. 0 ) THEN                                       
                                                                        
*-------------------  Check cumulative accuracy ----------------------- 
                                                                        
             SDAV  = SD/AVGI                                            
             IF((ABS(SDAV) .LE. ACC)) NEND = N1                         
                                                                        
             IF( ISTEP .EQ. N1 ) THEN                                   
                 IF( TACC .GT. ACLMT ) THEN                             
                     IF( NER1 .EQ. 0 ) THEN                             
                         NERROR = NERROR + 1                            
                         WRITE(ERROR(1,NERROR),9900) NERROR,IT,ACLMT    
 9900                    FORMAT('* (',I1,') Temp. accuracy of it-#',    
     .                         I3,' is too large comparing to',         
     .                         F6.2,' percent.',6X,'*')                 
                         WRITE(ERROR(2,NERROR),9901) TACC,ACLMT         
 9901                    FORMAT('*',8X,'Temp. accuracy (',              
     .                         F7.4,' % )  >>   (',                     
     .                         F7.4,' % )',23X,'*')                     
                         WRITE(ERROR(3,NERROR),9902)                    
 9902                    FORMAT('*',77X,'*')                            
                         NER1  = 1                                      
                     ENDIF                                              
                 ENDIF                                                  
                 IF( IT .GT. 1 ) THEN                                   
                     IF(( TI .GT. AVTI+FDEVI ) .OR.                     
     .                  ( TI .LT. AVTI-FDEVI )      ) THEN              
                          IF( NER2 .EQ. 0 ) THEN                        
                              NERROR = NERROR + 1                       
                              WRITE(ERROR(1,NERROR),9910) NERROR,IT,FC  
 9910                         FORMAT('* (',I1,') Temp. estimate of ',   
     .                        'it-#',I3,' fluctuates more than ',       
     .                               F4.1,'*average-sigma.',6X,'*')     
                              RE = TI                                   
                              CALL BSORDR( RE, FX2, ORDER, IORDR )      
                              RE = TI/ORDER                             
                              RE1 = AVTI                                
                              AC  = FDEVI                               
                              IF( RE1 .GE. AC ) THEN                    
                                  CALL BSORDR( RE1, FX2, ORDR1, IORDR1) 
                              ELSE                                      
                                  CALL BSORDR( AC, FX2, ORDR1, IORDR1)  
                              ENDIF                                     
                              RE1 = AVTI/ORDR1                          
                              AC  = AC/ORDR1                            
                              WRITE(ERROR(2,NERROR),9911) RE,IORDR,     
     .                                          RE1,AC,IORDR1           
 9911                         FORMAT('*        Temp. Estimate (',       
     .                         F10.6,' E',I3,')  >  (',F10.6,'+',F8.6,  
     .                         ' ) E',I3,', or',1X,'*')                 
                              WRITE(ERROR(3,NERROR),9912) RE,IORDR,     
     .                                          RE1,AC,IORDR1           
 9912                         FORMAT('*        Temp. Estimate (',       
     .                         F10.6,' E',I3,')  <  (',F10.6,'-',F8.6,  
     .                         ' ) E',I3,5X,'*')                        
                              NER2 = 1                                  
                          ENDIF                                         
                     ENDIF                                              
                     IF( TSI .GT. FDEVI ) THEN                          
                         IF( NER3 .EQ. 0 ) THEN                         
                             NERROR = NERROR + 1                        
                             WRITE(ERROR(1,NERROR),9920) NERROR,IT,FC   
 9920                        FORMAT('* (',I1,') Error of it-#',         
     .                              I3,' fluctuates more than',F4.1,    
     .                              '*average-sigma.',16X,'*')          
                             RE1 = TSI                                  
                             CALL BSORDR( RE1, FX2, ORDER, IORDR)       
                             RE1 = TSI/ORDER                            
                             AC  = FDEVI                                
                             CALL BSORDR( AC, FX2, ORDR1, IORDR1)       
                             AC  = AC/ORDR1                             
                             WRITE(ERROR(2,NERROR),9921) RE1,IORDR,     
     .                                         AC,IORDR1                
 9921                        FORMAT('*        Temp. Error (',           
     .                         F10.6,' E',I3,')  >  (',F10.6,           
     .                         ' E',I3,')',18X,'*')                     
                             WRITE(ERROR(3,NERROR),9902)                
                             NER3  = 1                                  
                         ENDIF                                          
                     ENDIF                                              
                 ENDIF                                                  
                 SUMTSI = SUMTSI + TSI                                  
                 SUMTI  = SUMTI  + TI                                   
                 AVTSI  = SUMTSI/FLOAT(IT)                              
                 AVTI   = SUMTI/FLOAT(IT)                               
                 FDEVI  = FC*AVTSI                                      
             ENDIF                                                      
         ENDIF                                                          
                                                                        
*------------------------------------------- for a parallel processor   
                                                                        
*                                  Broadcast                            
C                                  CALL BSCAST( NEND, 1 )               
                                                                        
*---------------------------------------------------------------------- 
*        Smoothing the Distribution D(I,J) and refine the grids         
*---------------------------------------------------------------------- 
                                                                        
         IF( ISTEP .LE. N0 ) THEN                                       
             IF( IT .EQ. ITMX ) NEND = N1                               
*           ---------------------                                       
             CALL BSETGV( NEND )                                        
*           ---------------------                                       
         ENDIF                                                          
*       ==========================                                      
         CALL BSUTIM( 0, ISTEP )                                        
*       ==========================                                      
                                                                        
         TIME (ITX,ISTEP)  = TIMINT                                     
         STIME             = TIMINT                                     
                                                                        
*---- Print the convergency behavior table in the interactive mode ---- 
         IF( INTV .GT. 1 ) THEN                                         
*            ---------------------------------                          
              CALL BSPRNT ( LU, 6, ISTEP, IDUM2 )                       
*            ---------------------------------                          
         ENDIF                                                          
                                                                        
         IF( NEND .EQ. N1 ) GO TO 600                                   
                                                                        
*       ======================                                          
         CALL BSUTIM( 0, 2 )                                            
*       ======================                                          
*======                                                                 
  500 CONTINUE                                                          
*======                                                                 
      IT    = IT - N1                                                   
      NEND  = N1                                                        
                                                                        
*********************************************************************** 
*                   Termination of BASES                                
*********************************************************************** 
*======                                                                 
  600 CONTINUE                                                          
*======                                                                 
*---------------------------------------------- For a parallel computer 
                                                                        
*                                 Global sum of histograms              
C                                 CALL BHSUM                            
*                                 Global sum of probabilities           
C                                 CALL BSDSUM(  DXD, NSP )              
*                                 Global sum of the max.value in each HC
C                                 CALL BSDSUM(  DXP, NSP )              
                                                                        
                                                                        
*======================= End of the step ? ============================ 
                                                                        
      IF( NEND .EQ. N1 ) THEN                                           
          IF( INTV .GT. 1 ) THEN                                        
*            ---------------------------------                          
              CALL BSPRNT ( LU, 7, IDUM1, IDUM2 )                       
*            ---------------------------------                          
          ENDIF                                                         
          IF( ISTEP .EQ. N0) THEN                                       
              JFLAG   = N1                                              
              ITG     = IT                                              
          ELSE                                                          
              JFLAG   = N0                                              
              ITF     = IT                                              
          ENDIF                                                         
      ENDIF                                                             
*    ======================                                             
       CALL BSUTIM( 0, 2 )                                              
*    ======================                                             
                                                                        
      RETURN                                                            
      END                                                               
*********************************************************************** 
*    ===================================                              * 
      SUBROUTINE BSLIST( LU, I, ISTEP )                                 
*    ===================================                              * 
* ((purpose))                                                         * 
*     Print out results of each iteration and cumulative result       * 
* ((Argument))                                                        * 
*  (Input)                                                            * 
*     LU      : Logical unit number for the printer                   * 
*     I       : Address in the arrays of common /BASE5/               * 
*     ISTEP   : The Set-Identifier                                    * 
*               ISTEP = ( 0 / 1 ) = ( Grid opt. / Integration step )  * 
*                                                                     * 
*     S. Kawabata   March '94                                         * 
*********************************************************************** 
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (ITM = 50)                                              
      REAL*4 TIME, EFF, WRONG, TRSLT, TSTD, PCNT                        
      COMMON /BASE5/ ITRAT(ITM,0:1),TIME(ITM,0:2),EFF(ITM,0:1),         
     .               WRONG(ITM,0:1),RESLT(ITM,0:1),ACSTD(ITM,0:1),      
     .               TRSLT(ITM,0:1),TSTD(ITM,0:1),PCNT(ITM,0:1)         
                                                                        
      CALL BSTCNV( TIME(I,ISTEP), IH, MN, IS1, IS2 )                    
                                                                        
      RE  = RESLT(I,ISTEP)                                              
      AC  = ABS(ACSTD(I,ISTEP))                                         
      ARE = ABS(RE)                                                     
      IF( ARE .GE. AC) THEN                                             
          CALL BSORDR( ARE, F2, ORDER, IORDR)                           
      ELSE                                                              
          CALL BSORDR(  AC, F2, ORDER, IORDR )                          
      ENDIF                                                             
      RE  = RE/ORDER                                                    
      AC  = AC/ORDER                                                    
      IEFF = EFF(I,ISTEP)                                               
      WRITE(LU,9631) ITRAT(I,ISTEP),IEFF,WRONG(I,ISTEP),                
     .              TRSLT(I,ISTEP),TSTD(I,ISTEP),                       
     .              RE,AC,IORDR,PCNT(I,ISTEP),IH,MN,IS1,IS2             
 9631 FORMAT(I4,I4,F6.2,1P,E11.3, 0P,1X,F6.3,                           
     .              F10.6,'(+-',F8.6,')E',I3.2,1X,F6.3,                 
     .          1X,I3,':',I2,':',I2,'.',I2.2)                           
                                                                        
                                                                        
      RETURN                                                            
      END                                                               
C***********************************************************************
C*                                                                     *
C*=============================================                        *
C*    SUBROUTINE BSORDR( VAL, F2, ORDER, IORDR)                        *
C*=============================================                        *
C*((Function))                                                         *
C*    To resolve the real number VAL into mantester and exponent parts.*
C*  When VAL = 1230.0 is given, output are                             *
C*        F2 = 1.2  and ORDER = 4.0.                                   *
C*((Input))                                                            *
C*  VAL  : Real*8 value                                                *
C*((Output))                                                           *
C*  F2   : The upper two digits is given                               *
C*  ORDER: Order is given                                              *
C*  IORDR: Exponent is given                                           *
C*((Author))                                                           *
C*  S.Kawabata                                                         *
C*                                                                     *
C***********************************************************************
                                                                        
      SUBROUTINE BSORDR(VAL, F2, ORDER, IORDR)                          
      IMPLICIT REAL*8 (A-H,O-Z)                                         
                                                                        
      IF( VAL .NE. 0.0 ) THEN                                           
          ORDER    =  LOG10( VAL )                                      
          IORDR    =  INT( ORDER )                                      
          IF( ORDER .LT. 0.0D0 ) IORDR = IORDR - 1                      
          ORDER  = 10.D0**IORDR                                         
          F2     = VAL/ORDER                                            
      ELSE                                                              
          IORDR  = 0                                                    
          ORDER  = 1.0D0                                                
          F2    = 0.0D0                                                 
      ENDIF                                                             
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    ================================================                  *
      SUBROUTINE BSPARM( MCALL, AC1, AC2, IT1, IT2 )                    
*    ================================================                  *
* ((Purpose))                                                          *
*     To set the BASES parameters.                                     *
* ((Input))                                                            *
*     MCALL  : The number of sample points per iteration.              *
*              This actual number is to be determined by taking the    *
*              number of dimensions into account.                      *
*     AC1 %  : The required accuracy at the grid optimization step     *
*     AC2 %  : The required accuracy at the integration step.          *
*     IT1    : The max. number of iteration at the grid opt. step.     *
*     IT2    : Thr max. number of iteration at the integration step.   *
* ((Output))                                                           *
*     These parameters are set in the labeled common /BPARM1/ and      *
*     /BPARM2/.                                                         
*                                                                      *
*        Coded by S.Kawabata         August '94                        *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50 )                                
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                   
     .               IG(MXDIM),NCALL                                    
      COMMON /BPARM2/ ACC1,ACC2,ITMX1,ITMX2                             
                                                                        
      INTEGER MCALL, IT1, IT2                                           
      REAL*8 AC1, AC2                                                   
                                                                        
      NCALL = MCALL                                                     
      ACC1  = AC1                                                       
      ACC2  = AC2                                                       
      ITMX1 = IT1                                                       
      ITMX2 = IT2                                                       
                                                                        
      RETURN                                                            
      END                                                               
*********************************************************************** 
*    =======================================                          * 
      SUBROUTINE BSPRNT( LU, ID, IP1, IP2 )                             
*    =======================================                          * 
* ((purpose))                                                         * 
*     Print out routine of BASES.                                     * 
*  (Argument)                                                         * 
*     ID  : Identity number of printouts.                             * 
*     IP1... IP2 : Integer                                            * 
*  (Author)                                                           * 
*     S. Kawabata   May 1992                                          * 
*     Last update   March 1994                                        * 
*********************************************************************** 
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE0/ JFLAG,IBASES                                       
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE2/ ACC1,ACC2,ITMX1,ITMX2                              
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
      COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
     .               ND,NG,NPG,MA(MXDIM)                                
      PARAMETER (ITM = 50)                                              
      REAL*4 TIME, EFF, WRONG, TRSLT, TSTD, PCNT                        
      COMMON /BASE5/ ITRAT(ITM,0:1),TIME(ITM,0:2),EFF(ITM,0:1),         
     .               WRONG(ITM,0:1),RESLT(ITM,0:1),ACSTD(ITM,0:1),      
     .               TRSLT(ITM,0:1),TSTD(ITM,0:1),PCNT(ITM,0:1)         
      REAL*4 STIME                                                      
      COMMON /BSRSLT/AVGI,SD,CHI2A,STIME,IT1,ITF                        
      CHARACTER*51 ICH(0:1)                                             
      CHARACTER*1 CN                                                    
*        INTV = ( 0 / 1 / any ) = ( Batch / Batch(Unix) / Interactive ) 
*        IPNT = ( 0 / any ) = ( IBM Type / Ascii printer )              
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
*                                                                       
       COMMON /BDATE/ IDATE(3),ITIME(2)                                 
*            IDATE(1) : year        ITIME(1) : hour                     
*            IDATE(2) : month       ITIME(2) : minute                   
*            IDATE(3) : day                                             
      REAL*4 TIMEBS,TIMINT,TIMESP,TIME0,RTIME,TIMEB1,TIMEB2,TIMES1      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
      REAL*4 XTIME                                                      
*                                                                       
       COMMON/NINFO/ NODEID, NUMNOD                                     
*                                                                       
      DATA  ICH / 'Convergency Behavior for the Grid Optimization Step',
     .            'Convergency Behavior for the Integration Step      '/
                                                                        
      IF( NODEID .NE. 0 ) RETURN                                        
      CN = CHAR(12)                                                     
                                                                        
      GO TO ( 100, 200, 300, 400, 500, 600, 700, 800, 900, 1000 ), ID   
C----------------------------------------------------------- BSMAIN     
                                                                        
  100 IF( IPNT .EQ. 0 ) THEN                                            
          WRITE(LU,9600)                                                
 9600     FORMAT(/1H1,/1H )                                             
      ELSE                                                              
          WRITE(LU,9610) CN                                             
 9610     FORMAT(A1)                                                    
      ENDIF                                                             
      WRITE(LU,9620) (IDATE(I),I=1,3),(ITIME(J),J=1,2)                  
 9620 FORMAT(55X,'Date: ',I2,'/',I2,'/',I2,2X,I2.2,':',I2.2)            
      WRITE(LU,9050)                                                    
 9050 FORMAT(                                                           
     . 8X,'**********************************************************', 
     ./8X,'*                                                        *', 
     ./8X,'*     BBBBBBB     AAAA     SSSSSS   EEEEEE   SSSSSS      *', 
     ./8X,'*     BB    BB   AA  AA   SS    SS  EE      SS    SS     *', 
     ./8X,'*     BB    BB  AA    AA  SS        EE      SS           *', 
     ./8X,'*     BBBBBBB   AAAAAAAA   SSSSSS   EEEEEE   SSSSSS      *', 
     ./8X,'*     BB    BB  AA    AA        SS  EE            SS     *', 
     ./8X,'*     BB    BB  AA    AA  SS    SS  EE      SS    SS     *', 
     ./8X,'*     BBBB BB   AA    AA   SSSSSS   EEEEEE   SSSSSS      *', 
     ./8X,'*                                                        *', 
     ./8X,'*                   BASES Version 5.1                    *', 
     ./8X,'*           coded by S.Kawabata KEK, March 1994          *', 
     ./8X,'**********************************************************') 
                                                                        
          RETURN                                                        
C----------------------------------------------------------- BSMAIN     
                                                                        
  200     IF( IPNT .EQ. 0 ) THEN                                        
              WRITE(LU,9600)                                            
          ELSE                                                          
              WRITE(LU,9610) CN                                         
          ENDIF                                                         
          WRITE(LU,9300)                                                
 9300     FORMAT(20X,                                                   
     .         '****** END OF BASES *********')                         
                                                                        
C----------------------------------------------------------- BSMAIN     
                                                                        
  300 CONTINUE                                                          
      WRITE(LU,9305)                                                    
 9305 FORMAT(                                                           
     .//5X,'<<   Computing Time Information   >>')                      
                                                                        
*     WRITE(LU,9310) (IDATE(I),I=1,3),(ITIME(J),J=1,2)                  
*9310 FORMAT(/15X,'Start at: ',I2,'/',I2,'/',I2,2X,I2.2,':',I2.2)       
*     CALL BSDATE                                                       
*     WRITE(LU,9320) (IDATE(I),I=1,3),(ITIME(J),J=1,2)                  
*9320 FORMAT(15X,'End   at: ',I2,'/',I2,'/',I2,2X,I2.2,':',I2.2)        
      WRITE(LU,9330)                                                    
 9330 FORMAT(/15X,'(1) For BASES              H: M:  Sec')              
      CALL BSTCNV(TIMEBS(2),IH,MN,IS1,IS2)                              
      WRITE(LU,9340) IH, MN, IS1, IS2                                   
 9340 FORMAT(19X,'Overhead           : ',I3,':',I2,':',I2,'.',I2.2)     
      CALL BSTCNV(TIMEBS(0),IH,MN,IS1,IS2)                              
      WRITE(LU,9350) IH, MN, IS1, IS2                                   
 9350 FORMAT(19X,'Grid Optim. Step   : ',I3,':',I2,':',I2,'.',I2.2)     
      CALL BSTCNV(TIMEBS(1),IH,MN,IS1,IS2)                              
      WRITE(LU,9360) IH, MN, IS1, IS2                                   
 9360 FORMAT(19X,'Integration Step   : ',I3,':',I2,':',I2,'.',I2.2)     
      XTIME = TIMEB2 - TIMEB1                                           
      CALL BSTCNV(XTIME,IH,MN,IS1,IS2)                                  
      WRITE(LU,9365) IH, MN, IS1, IS2                                   
 9365 FORMAT(19X,'Go time for all    : ',I3,':',I2,':',I2,'.',I2.2)     
      EXTIM  = TIMEBS(1)*1000.0/SCALLS/0.7                              
      WRITE(LU,9375)                                                    
 9375 FORMAT(/15X,'(2) Expected event generation time')                 
      WRITE(LU,9376) EXTIM                                              
 9376 FORMAT(19X,'Expected time for 1000 events :',F10.2,' Sec')        
      RETURN                                                            
                                                                        
C----------------------------------------------------------- BASES      
                                                                        
  400 NSP   = NG**NWILD                                                 
      MCALL = NSP*NPG                                                   
      WRITE(LU,9400) NDIM,NWILD,MCALL,NCALL,ND,NG,NSP                   
 9400 FORMAT(                                                           
     .//5X,'<<   Parameters for BASES    >>',                           
     .//5X,' (1) Dimensions of integration etc.',                       
     . /5X,'     # of dimensions :    Ndim    =',I9,3X,'( 50 at max.)', 
     . /5X,'     # of Wilds      :    Nwild   =',I9,3X,'( 15 at max.)', 
     . /5X,'     # of sample points : Ncall   =',I9,'(real)',           
     .                                         I9,'(given)',            
     . /5X,'     # of subregions    : Ng      =',I9,' / variable',      
     . /5X,'     # of regions       : Nregion =',I9,' / variable',      
     . /5X,'     # of Hypercubes    : Ncube   =',I9,                    
     .//5X,' (2) About the integration variables')                      
      WRITE(LU,9405)                                                    
 9405 FORMAT(10X,'------',2('+---------------'),'+-------+-------')     
      WRITE(LU,9410)                                                    
 9410 FORMAT(10X,'    i       XL(i)           XU(i)     ',              
     .           '  IG(i)   Wild')                                      
      WRITE(LU,9405)                                                    
       DO 450 I = 1,NDIM                                                
          IF( I .LE. NWILD ) THEN                                       
          WRITE(LU,9420) I,XL(I),XU(I),IG(I)                            
 9420     FORMAT(10X,I5,1P,2('  ',E14.6),'  ',3X,0P,I1,3X,              
     .                       '   yes')                                  
          ELSE                                                          
          WRITE(LU,9421) I,XL(I),XU(I),IG(I)                            
 9421     FORMAT(10X,I5,1P,2('  ',E14.6),'  ',3X,0P,I1,3X,              
     .                        '    no')                                 
          ENDIF                                                         
  450  CONTINUE                                                         
       WRITE(LU,9405)                                                   
       WRITE(LU,9450) ITMX1,ACC1,ITMX2,ACC2                             
 9450  FORMAT(                                                          
     . /5X,' (3) Parameters for the grid optimization step',            
     . /5X,'     Max.# of iterations: ITMX1 =',I9,                      
     . /5X,'     Expected accuracy  : Acc1  =',F9.4,' %',               
     .//5X,' (4) Parameters for the integration step',                  
     . /5X,'     Max.# of iterations: ITMX2 =',I9,                      
     . /5X,'     Expected accuracy  : Acc2  =',F9.4,' %')               
                                                                        
          RETURN                                                        
C----------------------------------------------------------- BASES      
                                                                        
  500    IF( INTV .LE. 1 )    RETURN                                    
         ISTEP  = IP1                                                   
         IF( IPNT .EQ. 0 ) THEN                                         
             WRITE(LU,9600)                                             
         ELSE                                                           
             WRITE(LU,9610) CN                                          
         ENDIF                                                          
         WRITE(LU,9620) (IDATE(I),I=1,3),(ITIME(J),J=1,2)               
         WRITE(LU,9500) ICH(ISTEP)                                      
 9500    FORMAT(15X,A)                                                  
         WRITE(LU,9570)                                                 
         WRITE(LU,9550)                                                 
 9550    FORMAT(1X,'<- Result of  each iteration ->',                   
     .          2X,'<-     Cumulative Result     ->',                   
     .          1X,'< CPU  time >',                                     
     .         /1X,' IT Eff R_Neg   Estimate  Acc %',                   
     .          2X,'Estimate(+- Error )order  Acc %',                   
     .          1X,'( H: M: Sec )')                                     
         WRITE(LU,9570)                                                 
 9570    FORMAT(1X,7('----------'),'--------')                          
         RETURN                                                         
                                                                        
C----------------------------------------------------------- BASES      
                                                                        
  600    IF( INTV .LE. 1 ) RETURN                                       
         ISTEP  = IP1                                                   
         ITX = MOD( IT, ITM)                                            
         IF( ITX .EQ. 0 ) ITX = ITM                                     
                                                                        
         CALL BSLIST( LU, ITX, ISTEP )                                  
                                                                        
         RETURN                                                         
                                                                        
  700    IF( INTV .LE. 1 ) RETURN                                       
         WRITE(LU,9570)                                                 
                                                                        
         RETURN                                                         
C----------------------------------------------------------- BASES      
                                                                        
  800    ITJ    = IP1                                                   
         ISTEP  = IP2                                                   
         ITX  = MOD( ITJ, ITM )                                         
         IF( ITX .EQ. 0 ) ITX = ITM                                     
                                                                        
         IF( ITRAT(1,ISTEP) .EQ. 1 ) THEN                               
             NDEV   = 1                                                 
         ELSE                                                           
             NDEV   = 2                                                 
             ITFN   = ITM                                               
             ITMN   = 10000                                             
             DO 610 I = 1,ITM                                           
                IF( ITRAT(I,ISTEP) .LT. ITMN ) THEN                     
                    ITST = I                                            
                    ITMN = ITRAT(I,ISTEP)                               
                ENDIF                                                   
  610        CONTINUE                                                   
             IF( ITST .EQ. 1 ) NDEV = 1                                 
         ENDIF                                                          
                                                                        
         IF( IPNT .EQ. 0 ) THEN                                         
             WRITE(LU,9600)                                             
         ELSE                                                           
             WRITE(LU,9610) CN                                          
         ENDIF                                                          
         WRITE(LU,9620) (IDATE(I),I=1,3),(ITIME(J),J=1,2)               
         WRITE(LU,9500) ICH(ISTEP)                                      
         WRITE(LU,9570)                                                 
         WRITE(LU,9550)                                                 
         WRITE(LU,9570)                                                 
                                                                        
  625    IF( NDEV .EQ. 1 ) THEN                                         
             ITST = 1                                                   
             ITFN = ITX                                                 
         ENDIF                                                          
                                                                        
         DO 650 I = ITST, ITFN                                          
                                                                        
            CALL BSLIST( LU, I, ISTEP )                                 
                                                                        
  650    CONTINUE                                                       
         NDEV  = NDEV - 1                                               
         IF( NDEV .GT. 0 ) GO TO 625                                    
         WRITE(LU,9570)                                                 
                                                                        
      RETURN                                                            
                                                                        
C----------------------------------------------------------- BASES      
                                                                        
  900 WRITE(LU,9950)                                                    
 9950 FORMAT(1X,'******** FATAL ERROR IN BASES **************',         
     .      /1X,'There are no enough good points in this iteration.',   
     .      /1X,'Process was terminated due to this error.')            
                                                                        
      RETURN                                                            
                                                                        
C-----------------------------------------------------------------      
 1000 LOOP = IP1                                                        
      IF( IP2 .NE. 0 ) THEN                                             
          IF( IPNT .EQ. 0 ) THEN                                        
              WRITE(LU,9600)                                            
           ELSE                                                         
              WRITE(LU,9610) CN                                         
           ENDIF                                                        
           WRITE(LU,9620) (IDATE(I),I=1,3),(ITIME(J),J=1,2)             
           WRITE(LU,9650)                                               
 9650      FORMAT(                                                      
     .      20X,'Results of Integration',                               
     .     /10X,5('----------'),'------',                               
     .     /10X,' Loop#  Estimate(+- Error )order',                     
     .                     '  It1  It2 ( H: M: Sec )',                  
     .     /10X,5('----------'),'------')                               
      ENDIF                                                             
                                                                        
      RE  = AVGI                                                        
      AC  = ABS(SD)                                                     
      ARE = ABS(RE)                                                     
      IF( ARE .GE. AC) THEN                                             
          CALL BSORDR( ARE, F2, ORDER, IORDR)                           
      ELSE                                                              
          CALL BSORDR(  AC, F2, ORDER, IORDR )                          
      ENDIF                                                             
      RE  = RE/ORDER                                                    
      AC  = AC/ORDER                                                    
      CALL BSTCNV( STIME, IH, MN, IS1, IS2)                             
      WRITE(LU,9660) LOOP,RE,AC,IORDR,IT1,IT,IH,MN,IS1,IS2              
 9660 FORMAT(10X,I6,F10.6,'(+-',F8.6,')E',I3.2,2I5,                     
     .        1X,I3,':',I2,':',I2,'.',I2.2,                             
     .      /10X,5('----------'),'------')                              
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*                                                                      *
*    ==========================                                        *
      SUBROUTINE BSREAD( LUN )                                          
*    ==========================                                        *
* ((Function))                                                         *
*     Read temporary result from the logocal unit LUN                  *
* ((Auther))                                                           *
*     S.Kawabata    June '90 at KEK                                    *
*                                                                      *
************************************************************************
                                                                        
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE1/ ND1(5*MXDIM+3)                                     
*     COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
*    .               IG(MXDIM),NCALL                                    
C     COMMON /BASE2/ ND2(6)                                             
*     COMMON /BASE2/ ACC1,ACC2,ITMX1,ITMX2                              
      COMMON /BASE3/ ND3(11)                                            
*     COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
      COMMON /BASE4/ ND4(2*MXDIM*(NDMX+1)+4*LENG+MXDIM+3)               
*     COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
*    .               ND,NG,NPG,MA(MXDIM)                                
      PARAMETER (ITM  = 50 )                                            
*     COMMON /BASE5/ ND5(22*ITM)                                        
      COMMON /BASE5/ ND5(23*ITM)                                        
*     REAL*4 TIME, EFF, WRONG, TRSLT, TSTD, PCNT                        
*     COMMON /BASE5/ ITRAT(ITM,0:1),TIME(ITM,0:2),EFF(ITM,0:1),         
*    .               WRONG(ITM,0:1),RESLT(ITM,0:1),ACSTD(ITM,0:1),      
*    .               TRSLT(ITM,0:1),TSTD(ITM,0:1),PCNT(ITM,0:1)         
      COMMON /RANDM/ ND6(45)                                            
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      COMMON /PLOTH/ NPH(18*(NHS+NSC)+29),NW                            
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
*     INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
*     COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
*    .              NHIST, MAPL(4,NHS),                                 
*    .              NSCAT, MAPD(4,NSC),                                 
*    .              NW                                                  
                                                                        
      COMMON/NINFO/ NODEID, NUMNOD                                      
                                                                        
      IF( NODEID .NE. 0 ) RETURN                                        
                                                                        
      REWIND LUN                                                        
      READ(LUN) ND1,ND3,ND4,ND5,ND6,NPH                                 
C     READ(LUN) ND1,ND2,ND3,ND4,ND5,ND6,NPH                             
                                                                        
      READ(LUN) NW,(IBUF(I),I=1,NW)                                     
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*=================================================                      
      SUBROUTINE BSTCNV( TIME, IH, MN, IS1, IS2 )                       
*=================================================                      
* (Purpose)                                                             
*    Resolve TIME in second into IH, MN, IS1, IS2                       
* (Input)                                                               
*    TIME : in the unit of second                                       
* (Output)                                                              
*    IH   : Hours                                                       
*    MN   : Minute                                                      
*    IS1  : Second                                                      
*    IS2  : 0.xx Second                                                 
* (Author)                                                              
*    S.Kawabata 1992 June 15                                            
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      REAL*4 TIME                                                       
      INTEGER  HOUR                                                     
      DATA HOUR, MINUT, N100/ 360000, 6000, 100 /                       
                                                                        
      ISEC  = TIME*N100                                                 
      IH    = 0                                                         
      MN    = IH                                                        
      IF( ISEC .GE. MINUT ) THEN                                        
          ITIME = ISEC                                                  
          IF( ISEC .GE. HOUR ) THEN                                     
              IH    = ITIME/HOUR                                        
              IHX   = IH*HOUR                                           
              ITIME = ITIME - IHX                                       
              ISEC  = ISEC - IHX                                        
          ENDIF                                                         
          MN    = ITIME/MINUT                                           
          ISEC  = ISEC - MN*MINUT                                       
      ENDIF                                                             
      IS1  = ISEC/N100                                                  
      IS2  = MOD( ISEC, N100)                                           
                                                                        
      RETURN                                                            
      END                                                               
*CMZ :          24/06/94  10.51.47  by  Unknown                         
*-- Author :                                                            
C                                                                       
C***********************************************************************
C*=================================                                    *
C* SUBROUTINE BSTIME( TIME, IFLG )                                     *
C*=================================                                    *
C*((Purpose))                                                          *
C*        Interface routine to get used CPU time from FORTRAN          *
C*        Library routine CLOCK etc.                                   *
C*((Input))                                                            *
C*        IFLG  : Flag                                                 *
C*          IFLG = 0 : Initialization of clock routine.                *
C*          IFLG = 1 : Get used CPU time.                              *
C*((Output))                                                           *
C*        TIME  : Used CPU time in second.                             *
C*                                                                     *
C*       Coded by S.Kawabata        Oct. '85                           *
C*                                                                     *
C***********************************************************************
C                                                                       
      SUBROUTINE BSTIME( TIME, IFLG )                                   
C                                                                       
*     save time_init                                                    
C                                                                       
                                                                        
      IF( IFLG .NE. 0 ) THEN                                            
C                                                                       
C         iutime.c should be compiled.                                  
C                                                                       
*         TIME = uxtime() - time_init                                   
          TIME=0
+SELF,IF=CERN
          CALL TIMEX(TIME)                                              
+SELF
C                                                                       
      ELSE                                                              
                                                                        
*         time_init = uxtime()                                          
+SELF,IF=CERN
          CALL TIMEST(999.)                                             
+SELF
          TIME      = 0.0                                               
                                                                        
      ENDIF                                                             
C                                                                       
      RETURN                                                            
      END   

      SUBROUTINE BSUTIM( JOB, ID )                                      
                                                                        
C     COMMON/NINFO/ NODEID, NUMNOD                                      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
                                                                        
*  Prior to call thisroutine, BSTIME( TIME0, 1 ) should be called       
*  for initialize the time offset TIME0.                                
*                                                                       
*     print *,'bsutim .. job, id ',job,id                               
      CALL BSTIME( RTIME, 1)                                            
      DTIME      = RTIME - TIME0                                        
                                                                        
      IF( JOB .EQ. 0 ) THEN                                             
*       For BASES computing time                                        
*         ID  = 0  : Grid defining step                                 
*               1  : Integration step                                   
*               2  : Others                                             
                                                                        
          TIMEBS(ID) = TIMEBS(ID) + DTIME                               
                                                                        
          IF( ID .LE. 1 ) THEN                                          
              TIMINT = TIMINT + DTIME                                   
          ENDIF                                                         
      ELSE                                                              
*       For SPRING computing time                                       
*         ID  = 0  : Event generation                                   
*               1  : Overhead                                           
*               2  : Others                                             
                                                                        
          TIMESP(ID) = TIMESP(ID) + DTIME                               
                                                                        
      ENDIF                                                             
                                                                        
      TIME0      = RTIME                                                
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*                                                                      *
*    ==========================                                        *
      SUBROUTINE BSWRIT( LUN )                                          
*    =====================                                             *
* ((Purpose))                                                          *
*     Read temporary result from disk file.                            *
* ((Auther))                                                           *
*     S.Kawabata  June '90 at KEK                                      *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE1/ ND1(5*MXDIM+3)                                     
*     COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
*    .               IG(MXDIM),NCALL                                    
C     COMMON /BASE2/ ND2(6)                                             
*     COMMON /BASE2/ ACC1,ACC2,ITMX1,ITMX2                              
      COMMON /BASE3/ ND3(11)                                            
*     COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
      COMMON /BASE4/ ND4(2*MXDIM*(NDMX+1)+4*LENG+MXDIM+3)               
*     COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
*    .               ND,NG,NPG,MA(MXDIM)                                
      PARAMETER (ITM  = 50 )                                            
*     COMMON /BASE5/ ND5(22*ITM)                                        
      COMMON /BASE5/ ND5(23*ITM)                                        
*     REAL*4 TIME, EFF, WRONG, TRSLT, TSTD, PCNT                        
*     COMMON /BASE5/ ITRAT(ITM,0:1),TIME(ITM,0:2),EFF(ITM,0:1),         
*    .               WRONG(ITM,0:1),RESLT(ITM,0:1),ACSTD(ITM,0:1),      
*    .               TRSLT(ITM,0:1),TSTD(ITM,0:1),PCNT(ITM,0:1)         
      COMMON /RANDM/ ND6(45)                                            
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      COMMON /PLOTH/ NPH(18*(NHS+NSC)+29),NW                            
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
*     INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
*     COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
*    .              NHIST, MAPL(4,NHS),                                 
*    .              NSCAT, MAPD(4,NSC),                                 
*    .              NW                                                  
                                                                        
      COMMON/NINFO/ NODEID, NUMNOD                                      
                                                                        
      IF( NODEID .NE. 0 ) RETURN                                        
                                                                        
      REWIND LUN                                                        
      WRITE(LUN) ND1,ND3,ND4,ND5,ND6,NPH                                
C     WRITE(LUN) ND1,ND2,ND3,ND4,ND5,ND6,NPH                            
      IF(NW .EQ. 0 ) NW = 281                                           
      WRITE(LUN) NW,(IBUF(I),I=1,NW)                                    
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    =======================================                           *
       SUBROUTINE DHFILL( ID, DX, DY, FX )                              
*    =======================================                           *
* ((Function))                                                         *
*     To fill scatter plot                                             *
*   This routine identifies the bin number which is to be updated      *
*   with weight FX*WGT.  Up to five points per plot are able to        *
*   be stacked before calling BHUPDT or SHUPDT.                        *
* ((Input))                                                            *
*   ID    : Histogram identification number                            *
*   DX    : Input x value                                              *
*   DY    : Input y value                                              *
*   FX    : Input value of the function                                *
* ((Author))                                                           *
*   S.Kawabata         June '90 at KEK                                 *
*                                                                      *
************************************************************************
                                                                        
      REAL*8 DX, DY, FX                                                 
      COMMON /BASE0/ IFLAG,IBASES                                       
      REAL*8 SCALLS,WGT,TI,TSI,TACC                                     
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
C     COMMON /PLOTLU/ LU                                                
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                      *
*======================================================================*
*               Find the scatter plot ID in the table                  *
*======================================================================*
*                                                                      *
      IF( NSCAT .GT. 0 ) THEN                                           
          I  = IABS(MOD( ID, 13 )) + 1                                  
          IF( DHASH(1, I) .EQ. 1 ) THEN                                 
            IF( ID .EQ. MAPD( 1, DHASH(2,I))) THEN                      
                ISCAT = DHASH(2,I)                                      
                GO TO 200                                               
            ENDIF                                                       
          ELSEIF( DHASH(1, I) .GT. 1 ) THEN                             
            DO 100 K = 2, DHASH(1,I)+1                                  
               IF( ID .EQ. MAPD( 1, DHASH(K,I))) THEN                   
                   ISCAT = DHASH(K,I)                                   
                   GO TO 200                                            
               ENDIF                                                    
  100       CONTINUE                                                    
          ENDIF                                                         
      ENDIF                                                             
C     IF( LU .GT. 0 ) THEN                                              
C         WRITE(LU,9000) ID                                             
C9000     FORMAT(1X,'No Scat_Plot corresponds to ID =',I5,              
C    .          /1X,' This call is neglected ]]]')                      
C     ENDIF                                                             
      RETURN                                                            
                                                                        
*                                                                      *
*======================================================================*
*               Determine the bin numbers for x and y                  *
*======================================================================*
*                                                                      *
  200 X     = DX*1.0                                                    
      Y     = DY*1.0                                                    
                                                                        
          IP1   = MAPD(2,ISCAT)                                         
          XMIN  = BUFF(IP1)                                             
          XMAX  = BUFF(IP1+1)                                           
          MXBIN = IBUF(IP1+2)                                           
          DEV   = BUFF(IP1+3)                                           
          IX    =   0                                                   
          IY    =   0                                                   
          IF( X .GE. XMIN .AND. X .LE. XMAX ) THEN                      
              IX   = INT( (X - XMIN)/DEV+ 1.0 )                         
              IF( IX .GT. MXBIN ) IX =   0                              
          ENDIF                                                         
C                                                                       
          IF( IX .GT. 0 ) THEN                                          
              YMIN  = BUFF(IP1+4)                                       
              YMAX  = BUFF(IP1+5)                                       
              MYBIN = IBUF(IP1+6)                                       
              DEV   = BUFF(IP1+7)                                       
              IF( Y .GE. YMIN .AND. Y .LE. YMAX ) THEN                  
                  IY   = INT((Y - YMIN)/DEV + 1.0)                      
                 IF( IY .GT. MYBIN ) THEN                               
                     IX  =  0                                           
                     IY  =  0                                           
                 ENDIF                                                  
              ENDIF                                                     
          ENDIF                                                         
*                                                                      *
*======================================================================*
*               Fill the scatter plot ID                               *
*======================================================================*
*----------------------------------------------------------------------*
*               For BASES                                              *
*----------------------------------------------------------------------*
*                                                                      *
      IF( IBASES .EQ. 1 ) THEN                                          
          IF( IY .GT. 0 ) THEN                                          
                                                                        
              IP2       = MAPD(3,ISCAT)                                 
              IBUF(IP2) = SCALLS                                        
              IP2       = IX + MXBIN*(IY - 1) + IP2                     
              BUFF(IP2) = BUFF(IP2) + FX*WGT                            
                                                                        
          ENDIF                                                         
                                                                        
*----------------------------------------------------------------------*
*               For SPRING                                             *
*----------------------------------------------------------------------*
*                                                                      *
      ELSE                                                              
                                                                        
          IP3         = MAPD(4,ISCAT)                                   
          IBUF(IP3)   = IX                                              
          IBUF(IP3+1) = IY                                              
                                                                        
      ENDIF                                                             
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*  =================================================================== *
      SUBROUTINE DHINIT(ID,DXMIN,DXMAX,NXBIN,DYMIN,DYMAX,NYBIN,TNAME)   
*  =================================================================== *
* ((Function))                                                         *
*     To define a scatter plot                                         *
* ((Input))                                                            *
*    ID   : scatter plot identification number                         *
*    DXMIN: Lower limit of X for the scatter plot                      *
*    DXMAX: Upper limit of X for the scatter plot                      *
*    NXBIN: Number of bins of X for the plot (Max. is 50 )             *
*    DYMIN: Lower limit of Y for the scatter plot                      *
*    DYMAX: Upper limit of Y for the scatter plot                      *
*    NYBIN: Number of bins of Y for the plot (Max. is 50 )             *
*    TNAME: Title of the plot in the character string (upto 64         *
*            characters)                                               *
* ((Author))                                                           *
*    S.Kawabata     June '90 at KEK                                    *
*                                                                      *
************************************************************************
                                                                        
      REAL*8 DXMIN,DXMAX,DYMIN,DYMAX                                    
      CHARACTER*(*) TNAME                                               
      CHARACTER*64 NAME                                                 
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
*     COMMON/XHCNTL/ LOCK                                               
      COMMON/PLOTLU/ LU                                                 
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                      *
*======================================================================*
*               Find the scatter plot ID in the table                  *
*======================================================================*
*                                                                      *
      IF( NSCAT .GE. NSC ) THEN                                         
*         IF( LOCK .NE. 0 ) RETURN                                      
          IF( LU .GT. 0 ) THEN                                          
            WRITE(LU,9000) NSCAT,ID                                     
 9000       FORMAT(1X,'Numberof Scat_plots exceeds ',I3,' at ID = ',I3, 
     .            /1X,'This call is neglected.')                        
          ENDIF                                                         
          RETURN                                                        
      ENDIF                                                             
                                                                        
      IEXIST = 0                                                        
      I  = IABS(MOD( ID, 13 )) + 1                                      
      NS     = DHASH(1, I)                                              
                                                                        
      IF( NS .EQ. 1 ) THEN                                              
            IF( ID .EQ. MAPD( 1, DHASH(2,I))) THEN                      
*               IF( LOCK .NE. 0 ) RETURN                                
                IEXIST = DHASH(2,I)                                     
            ENDIF                                                       
      ELSEIF( NS .GT. 1 ) THEN                                          
          DO 100 K = 2, DHASH(1,I)+1                                    
            IF( ID .EQ. MAPD( 1, DHASH(K,I))) THEN                      
*               IF( LOCK .NE. 0 ) RETURN                                
                IEXIST = DHASH(K,I)                                     
                GO TO 110                                               
            ENDIF                                                       
  100    CONTINUE                                                       
  110    CONTINUE                                                       
      ENDIF                                                             
      XMIN  = DXMIN*1.0                                                 
      XMAX  = DXMAX*1.0                                                 
      YMIN  = DYMIN*1.0                                                 
      YMAX  = DYMAX*1.0                                                 
                                                                        
      IF( IEXIST .GT. 0 ) THEN                                          
          IF( LU .GT. 0 ) THEN                                          
            WRITE(LU,9100) ID                                           
          ENDIF                                                         
 9100     FORMAT(1X,'Scat_Plot ID (',I3,' ) exists already.')           
          IP1    =  MAPD(2,IEXIST)                                      
          IF(( XMIN .EQ. BUFF(IP1))   .AND.                             
     .       ( XMAX .EQ. BUFF(IP1+1)) .AND.                             
     .       ( NXBIN .EQ. IBUF(IP1+2)) )    THEN                        
             IF(( YMIN .EQ. BUFF(IP1+4))   .AND.                        
     .          ( YMAX .EQ. BUFF(IP1+5)) .AND.                          
     .          ( NYBIN .EQ. IBUF(IP1+6)) )    THEN                     
                  IF( LU .GT. 0 ) THEN                                  
                      WRITE(LU,9110)                                    
                  ENDIF                                                 
 9110             FORMAT(1X,' This call is neglected.')                 
                  RETURN                                                
             ENDIF                                                      
          ENDIF                                                         
          IF( LU .GT. 0 ) THEN                                          
              WRITE(LU,9120) ID,XMIN,XMAX,NXBIN,YMIN,YMAX,NYBIN         
          ENDIF                                                         
 9120     FORMAT(1X,'Scat_Plot ( ID =',I3,' ) parameters are replaced', 
     .          /1X,'by the following new parameters :',                
     .          /1X,' XMIN(',E12.5,')  XMAX(',E12.5,' )  XBIN(',I4,' )',
     .          /1X,' YMIN(',E12.5,')  YMAX(',E12.5,' )  YBIN(',I4,' )')
      ENDIF                                                             
      IF(NXBIN .GT. 50 .OR. NYBIN .GT. 50 ) THEN                        
         IF( LU .GT. 0 ) THEN                                           
             WRITE(LU,9300) NXBIN,NYBIN,ID                              
         ENDIF                                                          
 9300    FORMAT(1X,'Bin size (',2I3,' )  exceeds 50 at ID =',I5,        
     .         /1X,' This call is neglected .')                         
         RETURN                                                         
      ELSEIF((XMIN .GE. XMAX) .OR. (YMIN .GE. YMAX)) THEN               
         IF( LU .GT. 0 ) THEN                                           
             WRITE(LU,9400) ID,XMIN,XMAX,YMIN,YMAX                      
         ENDIF                                                          
 9400    FORMAT(1X,'Lower limit is larger than upper at SC_PL ID =',I5, 
     .         /1X,' This call is neglected .',                         
     .         /1X,' XMIN =',G13.4,' XMAX =',G13.4,                     
     .         /1X,' YMIN =',G13.4,' YMAX =',G13.4)                     
         RETURN                                                         
      ENDIF                                                             
      IF(DHASH(1,I) .GE. NSC ) THEN                                     
         IF( LU .GT. 0 ) THEN                                           
             WRITE(LU,9500) I                                           
         ENDIF                                                          
 9500    FORMAT(1X,I5,'-th Hash table overflow',                        
     .         /1X,' This call is neglected.')                          
         RETURN                                                         
      ENDIF                                                             
                                                                        
      IF( IEXIST .GT. 0 ) THEN                                          
          NSCT     = IEXIST                                             
      ELSE                                                              
          NSCAT        = NSCAT + 1                                      
          DHASH(1,I)   = DHASH(1,I) + 1                                 
          K            = DHASH(1,I) + 1                                 
          DHASH(K,I)   = NSCAT                                          
          NSCT         = NSCAT                                          
          IP1    = NW + 1                                               
          NW  = NW + 2527                                               
          MAPD(1,NSCT)  = ID                                            
          MAPD(2,NSCT)  = IP1                                           
      ENDIF                                                             
                                                                        
         BUFF(IP1     ) = XMIN                                          
         BUFF(IP1 +  1) = XMAX                                          
         IBUF(IP1 +  2) = NXBIN                                         
         DEV            = XMAX - XMIN                                   
         BUFF(IP1 +  3) = DEV/NXBIN                                     
         BUFF(IP1 +  4) = YMIN                                          
         BUFF(IP1 +  5) = YMAX                                          
         IBUF(IP1 +  6) = NYBIN                                         
         DEV            = YMAX - YMIN                                   
         BUFF(IP1 +  7) = DEV/NYBIN                                     
      IP2   = IP1 + 8                                                   
         MAPD(3,NSCT)  = IP2                                            
         IBUF(IP2     ) = 0                                             
      IP3   = IP1 + 2509                                                
         MAPD(4,NSCT)  = IP3                                            
         IBUF(IP3     ) =  0                                            
         IBUF(IP3 +  1) =  0                                            
                                                                        
         I1   = IP3 + 2                                                 
         I2   = I1 + 15                                                 
         NAME = TNAME                                                   
         READ(NAME,9800) (BUFF(I),I=I1,I2)                              
 9800    FORMAT(16A4)                                                   
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*     =========================                                        *
       SUBROUTINE DHPLOT( LU )                                          
*     =========================                                        *
* ((Purpose))                                                          *
*      To print scatter plots for BASES and SPRING                     *
*                                                                      *
* ((Author))                                                           *
*       S.Kawabata    June '90                                         *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      CHARACTER*1  PLUS,MINUS,BLNK,STAR,NUM(0:9),NEG(0:9),SHARP,PNT     
      REAL*4       X(50)                                                
      CHARACTER*1 CHARR(50), CN                                         
      CHARACTER*80 FORM1,FORM                                           
      DATA  PLUS /'+'/, MINUS /'-'/, BLNK /' '/, STAR /'*'/             
      DATA  SHARP /'#'/,  PNT /'.'/                                     
      DATA  NUM  / '0','1','2','3','4','5','6','7','8','9'/             
      DATA  NEG  / '-','a','b','c','d','e','f','g','h','i'/             
*                                                                      *
*--------------------------- Entry point ------------------------------*
*                                                                      *
      CN   = CHAR(12)                                                   
                                                                        
      IF( NSCAT .GT. 0 ) THEN                                           
         DO 900 ISCAT = 1, NSCAT                                        
            IP3   = MAPD(4,ISCAT)                                       
            IF( IPNT .EQ. 0 ) THEN                                      
                WRITE(LU,9010)                                          
            ELSE                                                        
                WRITE(LU,9020) CN                                       
            ENDIF                                                       
 9010       FORMAT(/1H1)                                                
 9020       FORMAT(A1)                                                  
            WRITE(LU,9100) MAPD(1,ISCAT),(BUFF(I), I=IP3+2,IP3+17)      
 9100       FORMAT(/5X,'Scat_Plot (ID =',I3,' ) for ',16A4,/)           
                                                                        
            IP1   = MAPD(2,ISCAT)                                       
            XL    = BUFF(IP1)                                           
            XU    = BUFF(IP1+1)                                         
            NX    = IBUF(IP1+2)                                         
            DX    = BUFF(IP1+3)                                         
            XM    = ABS(XU)                                             
            XX    = ABS(XL)                                             
            IF( XX .GT. XM ) XM = XX                                    
            CALL XHORDR( XU, FX, XORD, IXORD)                           
            YL    = BUFF(IP1+4)                                         
            YU    = BUFF(IP1+5)                                         
            NY    = IBUF(IP1+6)                                         
            DY    = BUFF(IP1+7)                                         
            MIDY  = NY/2                                                
            IF( MIDY .EQ. 0 ) MIDY = 1                                  
            YM    = ABS(YU)                                             
            YY    = ABS(YL)                                             
            IF( YY .GT. YM ) YM = YY                                    
            CALL XHORDR( YM, FY, YORD, IYORD)                           
            IP2   = MAPD(3,ISCAT)                                       
            NTOTAL= IBUF(IP2)                                           
            VMAX  = BUFF(IP2+1)                                         
            VMIN  = VMAX                                                
            DO 100 J = 0,NY-1                                           
               IB    = NX*J + IP2                                       
               DO 100 I = 1,NX                                          
                  VLS    = BUFF( I + IB )                               
                  IF( VLS .GT. VMAX ) VMAX = VLS                        
                  IF( VLS .LT. VMIN ) VMIN = VLS                        
  100       CONTINUE                                                    
***                                                                     
            IF( VMAX .EQ. 0.0 .AND. VMIN .EQ. 0.0 ) THEN                
                VMAX  = 10.0                                            
                VMIN  = 0.0                                             
            ENDIF                                                       
***                                                                     
            IF( VMAX .GT. -VMIN ) THEN                                  
                UNIT = ABS(VMAX)/11.0                                   
            ELSE                                                        
                UNIT = ABS(VMIN)/11.0                                   
            ENDIF                                                       
            WRITE(FORM1,9200) NX                                        
*9200       FORMAT('(7X,''E'',I3,3X,''+'',',I2,'(''--''),''-+'')')      
 9200       FORMAT('(7X,''E'',I3,3X,''+'',',I2,'(''-''),''+'')')        
            WRITE(LU,FORM1) IYORD                                       
            DO 300 L = NY-1,0,-1                                        
               IB     = NX*L + IP2                                      
               DO 200 I = 1,NX                                          
                 XNUM   = BUFF( I + IB )/UNIT                           
                 IF( XNUM .LT. 0 0 ) THEN                               
                     NUMB   = XNUM - 1.0                                
                     IF(     NUMB .GE. -1 )THEN                         
                             CHARR(I) = MINUS                           
                     ELSEIF( NUMB .GE. -10 ) THEN                       
                            CHARR(I) = NEG(-NUMB-1)                     
                     ELSE                                               
                            CHARR(I) = SHARP                            
                     ENDIF                                              
                 ELSE                                                   
                     NUMB   = XNUM + 1.0                                
                     IF(     XNUM .EQ. 0.0 ) THEN                       
                             CHARR(I) = BLNK                            
                     ELSEIF( NUMB .LE.  1 ) THEN                        
                             CHARR(I) = PLUS                            
                             IF( VMIN .GE. 0.0 ) CHARR(I) = PNT         
                     ELSEIF( NUMB .LE. 10 ) THEN                        
                             CHARR(I) = NUM(NUMB-1)                     
                     ELSE                                               
                             CHARR(I) = STAR                            
                     ENDIF                                              
                 ENDIF                                                  
  200          CONTINUE                                                 
                                                                        
               Y   = (L*DY + YL)/YORD                                   
               IF( L .EQ. MIDY ) THEN                                   
                   WRITE(FORM,9300) NX                                  
*9300              FORMAT('(5X,F6.3,'' Y I'',',I2,'(1X,A1),'' I'')')    
 9300              FORMAT('(5X,F6.3,'' Y I'',',I2,'A1,''I'')')          
               ELSE                                                     
                   WRITE(FORM,9310) NX                                  
*9310              FORMAT('(5X,F6.3,''   I'',',I2,'(1X,A1),'' I'')')    
 9310              FORMAT('(5X,F6.3,''   I'',',I2,'A1,''I'')')          
               ENDIF                                                    
               WRITE(LU,FORM) Y,(CHARR(M),M=1,NX)                       
                                                                        
  300       CONTINUE                                                    
                                                                        
            WRITE(LU,FORM1) IYORD                                       
                                                                        
            NXH   = NX/2                                                
            IF( NXH .EQ. 0 ) NXH = 1                                    
            WRITE(FORM,9400) NXH                                        
                                                                        
*           WRITE(FORM,9400) NX                                         
 9400       FORMAT('(6X,''Low-'',5X,',I2,'X,''X'')')                    
            WRITE(LU,FORM)                                              
                                                                        
            XORD     = XORD*10.                                         
            DO 400 I = 1, NX                                            
               X(I)  = ((I-1)*DX + XL)/XORD                             
               IF( X(I) .LT. 0.0 ) THEN                                 
                   CHARR(I)  = MINUS                                    
                   X(I)      = -X(I)                                    
               ELSE                                                     
                   CHARR(I)  = BLNK                                     
               ENDIF                                                    
  400       CONTINUE                                                    
            WRITE(FORM1,9500) NX                                        
*9500       FORMAT('(6X,''Edge'',5X,',I2,'(1X,A1))')                    
 9500       FORMAT('(6X,''Edge'',5X,',I2,'A1)')                         
            WRITE(LU,FORM1) (CHARR(M),M=1,NX)                           
                                                                        
            XORD      = 1.0                                             
            DO 600 I  = 1,5                                             
               IF( I .EQ. 2 ) THEN                                      
                   WRITE(FORM,9602) NX                                  
 9602              FORMAT('(7X,''E'',I3,4X',I2,                         
     .                    '(''.''))')                                   
                   WRITE(LU,FORM) IXORD                                 
               ELSE                                                     
                   DO 500 J = 1, NX                                     
                      XX        = X(J)*10.0                             
                      NUMB      = XX                                    
                      CHARR(J)  = NUM(NUMB)                             
                      X(J)      = XX - FLOAT(NUMB)                      
  500              CONTINUE                                             
                   IF(     I .EQ. 4 ) THEN                              
                           WRITE(FORM,9604) NX                          
 9604                      FORMAT('(7X,''Low-'',4X,',I2,                
     .                            'A1)')                                
                   ELSEIF( I .EQ. 5 ) THEN                              
                           WRITE(FORM,9605) NX                          
 9605                      FORMAT('(7X,''Edge'',4X,',I2,                
     .                            'A1)')                                
                   ELSE                                                 
                           WRITE(FORM,9601) NX                          
 9601                      FORMAT('(15X,',I2,                           
     .                            'A1)')                                
                   ENDIF                                                
                   WRITE(LU,FORM) (CHARR(M),M=1,NX)                     
               ENDIF                                                    
  600       CONTINUE                                                    
                                                                        
  900    CONTINUE                                                       
      ENDIF                                                             
C                                                                       
      RETURN                                                            
      END                                                               
C********************************************************************** 
C*======================                                              * 
C* FUNCTION DRN( ISEED)                                               * 
C*======================                                              * 
C*  Machine-independent Random number generator                       * 
C*     General purpose Version,  OK as long as >= 32 bits             * 
C*((Arguement))                                                       * 
C*  ISEED: Seed                                                       * 
C*                                                                    * 
C********************************************************************** 
                                                                        
      REAL*8 FUNCTION DRN(ISEED)                                        
                                                                        
      COMMON/RANDM/RDM(31),RM1,RM2,IA1,IC1,M1,IX1,                      
     .                             IA2,IC2,M2,IX2,                      
     .                             IA3,IC3,M3,IX3                       
                                                                        
C Generate Next number in sequence                                      
                                                                        
      IX1    = MOD( IA1*IX1+IC1, M1 )                                   
      IX2    = MOD( IA2*IX2+IC2, M2 )                                   
      IX3    = MOD( IA3*IX3+IC3, M3 )                                   
      J      = 1 + (31*IX3)/M3                                          
      DRN    = RDM(J)                                                   
      RDM(J) = ( FLOAT(IX1)+FLOAT(IX2)*RM2 )*RM1                        
                                                                        
C Omit following statement if function arguement passed by value:       
                                                                        
      ISEED = IX1                                                       
      RETURN                                                            
      END                                                               
C********************************************************************** 
C*============================                                        * 
C* Subroutine DRNSET( ISEED )                                         * 
C*============================                                        * 
C*((Purpose))                                                         * 
C*  Initialization routine of                                         * 
C*         Machine-independent Random number generator                * 
C*         General purpose Version,  OK as long as >= 32 bits         * 
C*((Arguement))                                                       * 
C*  ISEED: SEED                                                       * 
C*                                                                    * 
C********************************************************************** 
                                                                        
      SUBROUTINE DRNSET( ISEED )                                        
                                                                        
      COMMON/RANDM/RDM(31),RM1,RM2,IA1,IC1,M1,IX1,                      
     .                             IA2,IC2,M2,IX2,                      
     .                             IA3,IC3,M3,IX3                       
                                                                        
      IA1 =    1279                                                     
      IC1 =  351762                                                     
      M1  = 1664557                                                     
      IA2 =    2011                                                     
      IC2 =  221592                                                     
      M2  = 1048583                                                     
      IA3 =   15091                                                     
      IC3 =    6171                                                     
      M3  =   29201                                                     
                                                                        
C Initialization                                                        
                                                                        
      IX1  = MOD( ISEED, M1 )                                           
      IX1  = MOD( IA1*IX1+IC1, M1 )                                     
      IX2  = MOD( IX1, M2 )                                             
      IX1  = MOD( IA1*IX1+IC1, M1 )                                     
      IX3  = MOD( IX1,M3)                                               
      RM1  = 1./FLOAT(M1)                                               
      RM2  = 1./FLOAT(M2)                                               
      DO 100 J = 1,31                                                   
         IX1   = MOD( IA1*IX1+IC1, M1 )                                 
         IX2   = MOD( IA2*IX2+IC2, M2 )                                 
         RDM(J)= ( FLOAT(IX1)+FLOAT(IX2)*RM2 )*RM1                      
  100 CONTINUE                                                          
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    ===================                                               *
      SUBROUTINE SHCLER                                                 
*    ===================                                               *
* ((FUNCTION))                                                         *
*     To cancel the update of histograms and scatter plots in case     *
*   of the trial was rejected.                                         *
* ((Author))                                                           *
*     S.Kawabata June '90 at KEK                                       *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      IF( NHIST .GT. 0 ) THEN                                           
         DO 200  J   = 1, NHIST                                         
           IP3       = MAPL(3,J)                                        
           IBUF(IP3) = -1                                               
  200    CONTINUE                                                       
      ENDIF                                                             
C                                                                       
      IF( NSCAT .GT. 0 ) THEN                                           
         DO 500   K    = 1, NSCAT                                       
           IP3         = MAPD(4,K)                                      
           IBUF(IP3)   =  0                                             
           IBUF(IP3+1) =  0                                             
  500    CONTINUE                                                       
      ENDIF                                                             
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ===========================                                       *
      SUBROUTINE SHFILL( NTRY )                                         
*    ===========================                                       *
* ((Function))                                                         *
*     To fill the number of trials for a event generation              *
* ((Input))                                                            *
*    NTYR : the number of trials for the current event                 *
* ((Author))                                                           *
*    S.Kawabata    April 1994                                          *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( MXBIN = 51 )                                          
      COMMON/PLOTSP/ NBIN,IBUFSP( MXBIN )                               
                                                                        
      IF( NTRY .LE. NBIN ) THEN                                         
          IBUFSP( NTRY ) = IBUFSP( NTRY ) + 1                           
      ELSE                                                              
          IBUFSP( NBIN+1 ) = IBUFSP( NBIN+1 ) + 1                       
      ENDIF                                                             
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    ============================                                      *
      SUBROUTINE SHINIT( MXTRY )                                        
*    ============================                                      *
* ((Function))                                                         *
*     To clear the histogram buffer for generation efficiency          *
* ((Input))                                                            *
*    MXTRY: Maximum number of trials for one event generation          *
* ((Author))                                                           *
*    S.Kawabata    April 1994                                          *
*                                                                      *
************************************************************************
                                                                        
      INTEGER MXTRY                                                     
      PARAMETER ( MXBIN = 51 )                                          
      COMMON/PLOTSP/ NBIN,IBUFSP( MXBIN )                               
                                                                        
      IF( MXTRY .GT. 50 ) THEN                                          
          NBIN  = 50                                                    
      ELSE                                                              
          NBIN  = MXTRY                                                 
      ENDIF                                                             
                                                                        
      DO 100 I = 1,NBIN+1                                               
         IBUFSP(I) = 0                                                  
  100 CONTINUE                                                          
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    =========================                                         *
      SUBROUTINE SHPLOT( LU )                                           
*    =========================                                         *
C*((Function))                                                         *
C*    To print histograms and scatter plots defined by XHINIT and      *
C*  DHINIT.                                                            *
C*    For the original histograms, a special histograms are printd     *
C*  by this routine. For the additional histograms and scatter plots   *
C*  routines XHPLOT and DHPLOT are called.                             *
C*((Author))                                                           *
C*    S.Kawabata   June '90 at KEK                                     *
C*                                                                     *
C***********************************************************************
                                                                        
      REAL*8         SCALLS,WGT,TI,TSI,TACC                             
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      CHARACTER*50 CHARR,CHR1                                           
      CHARACTER*52 SCALE                                                
      REAL  VAL(0:51),VLOG(0:51)                                        
      REAL  VERR(0:51)                                                  
      CHARACTER*1  BLNK,STAR,CROS,AI,CN                                 
      DATA  YMAX / 50/, BLNK /' '/, STAR /'*'/, CROS /'O'/              
      DATA  AI /'I'/                                                    
                                                                        
      CN  = CHAR(12)                                                    
                                                                        
      CALL XHCHCK( LU )                                                 
                                                                        
      IF( NHIST .GT. 0 ) THEN                                           
*                 add March 1994                                        
         CALL SHUPDT                                                    
*                                                                       
C        NTOTAL= SCALLS                                                 
         DO 500 IHIST = 1, NHIST                                        
          IF(IFBASE(IHIST) .EQ. 1 ) THEN                                
            IP3  = MAPL(4,IHIST)                                        
            IF( IPNT .EQ. 0 ) THEN                                      
                WRITE(LU,9010)                                          
            ELSE                                                        
                WRITE(LU,9020) CN                                       
            ENDIF                                                       
 9010       FORMAT(/1H1)                                                
 9020       FORMAT(A1)                                                  
            WRITE(LU,9050) MAPL(1,IHIST),(BUFF(I), I=IP3+1,IP3+15)      
 9050       FORMAT(1X,'Original Histogram (ID =',I3,' ) for ',15A4)     
                                                                        
            IP1   = MAPL(2,IHIST)                                       
            XMIN  = BUFF(IP1)                                           
            XMAX  = BUFF(IP1+1)                                         
            NXBIN = IBUF(IP1+2) + 1                                     
            DEV   = BUFF(IP1+3)                                         
            VMAX  = 0.0                                                 
            VORG  = 0.0                                                 
            VEVT  = 0.0                                                 
C           FACT       = 1./(NTOTAL*DEV)                                
            FACT       = 1./(SCALLS*DEV)                                
            IP2   = MAPL(3,IHIST)                                       
            IPX   = IP2 + 52                                            
            IPF   = IP2 + 156                                           
            IPF2  = IPF + 52                                            
C           VAL(0)     = BUFF(IPF)/NTOTAL                               
            VAL(0)     = BUFF(IPF)/SCALLS                               
C           VAL(NXBIN) = BUFF(IPF+NXBIN)/NTOTAL                         
            VAL(NXBIN) = BUFF(IPF+NXBIN)/SCALLS                         
            VEVT1 = BUFF(IPX) + BUFF(IPX+NXBIN)                         
            DO  50 I   = 1,NXBIN-1                                      
                TX     = BUFF(I+IPF)                                    
                NX     = IBUF(I+IP2)                                    
                VLS    = TX*FACT                                        
                IF( VMAX .LT. VLS ) VMAX = VLS                          
                VAL(I) = VLS                                            
                IF( NX .GT. 1 ) THEN                                    
                  DEV2   =  NX*BUFF(I+IPF2)-TX*TX                       
                  IF( DEV2 .LE. 0.0 ) THEN                              
                      VERR(I)= 0.0                                      
                  ELSE                                                  
                      VERR(I)= FACT*SQRT( DEV2/( NX-1 ))                
                  ENDIF                                                 
                ELSEIF( NX .EQ. 1 ) THEN                                
                  VERR(I)= VLS                                          
                ELSE                                                    
                  VERR(I)= 0.0                                          
                ENDIF                                                   
                VORG   = VLS + VORG                                     
                VEVT   = BUFF(I+IPX) + VEVT                             
   50       CONTINUE                                                    
            NTOT   = INT(VEVT+VEVT1)                                    
            IF( VMAX .LE. 0.0 .AND. VEVT .GT. 0.0 ) THEN                
                  WRITE(LU,9060) MAPL(1,IHIST)                          
 9060             FORMAT(/5X,'***************************************', 
     .                   /5X,'* Since BASES has no entry            *', 
     .                   /5X,'*     in the histogram ID(',I6,' ),   *', 
     .                   /5X,'*  an additional hist. is given       *', 
     .                   /5X,'*     in the next page in stead.      *', 
     .                   /5X,'***************************************') 
C                                                                       
                  CALL XHPLOT( LU, 1, IHIST )                           
C                                                                       
                  GO TO 500                                             
            ELSEIF( VEVT .LE. 0) THEN                                   
                  WRITE(LU,9070) IHIST                                  
 9070             FORMAT(/5X,'***************************************', 
     .                   /5X,'*    SPRING has no entry              *', 
     .                   /5X,'*     in the histogram ID(',I6,' )    *', 
     .                   /5X,'***************************************') 
                  GO TO 500                                             
            ENDIF                                                       
            VNORM = VORG/VEVT                                           
            XNORM = VNORM*DEV                                           
            VLMAX = ALOG10(VMAX)                                        
            VLMIN = VLMAX                                               
            DO  60 I = 0,NXBIN                                          
              IF( VAL(I) .GT. 0.0 ) THEN                                
                  VLS   = ALOG10( VAL(I) )                              
                 IF( I .GT. 0 .AND. I .LT. NXBIN ) THEN                 
                    IF( VLS .LT. VLMIN ) VLMIN = VLS                    
                 ENDIF                                                  
                 VLOG(I)  = VLS                                         
              ELSE                                                      
                 VLOG(I)  = 0.0                                         
              ENDIF                                                     
   60       CONTINUE                                                    
C                                                                       
             VXMAX = VLMAX                                              
             IF( VLMIN .LT. 0.0) THEN                                   
                VXMIN = IFIX(VLMIN) - 1.0                               
             ELSE                                                       
                VXMIN = IFIX(VLMIN)                                     
             ENDIF                                                      
             CALL XHRNGE( 1, VXMIN, VXMAX, VLMIN, VLMAX, VLSTP)         
             UNITL = (VLMAX-VLMIN)/YMAX                                 
C                                                                       
             CALL XHSCLE( 1, VLMIN, VLMAX, VLSTP, UNITL, SCALE, CHR1)   
C                                                                       
C                                                                       
             WRITE(LU,9150) NTOT                                        
 9150        FORMAT(1X,'Total =',I10,' events',                         
     .              3X,'"*" : Orig. Dist. in Log Scale.')               
             VXMIN = 10.0**VLMIN                                        
             WRITE(LU,9200) SCALE                                       
 9200        FORMAT(1X,'   x      d(Sig/dx)  dN/dx',A52)                
             WRITE(LU,9250) CHR1                                        
 9250        FORMAT(1X,                                                 
     .             '+-------+----------+-------+',                      
     .       A50 )                                                      
C                                                                       
                                                                        
            VX    = ABS(XMAX)                                           
            XM    = ABS(XMIN)                                           
            IF( XM .GT. VX ) VX = XM                                    
                                                                        
            CALL XHORDR( VX, F2, ORD, IORD )                            
                                                                        
            DO 200 I = 0,NXBIN                                          
              RNORM = VNORM                                             
              IF( I .EQ. 0 .OR. I .EQ. NXBIN ) RNORM = XNORM            
              VX    = VAL(I)                                            
              XL     = BUFF( I + IPX )                                  
              NX     = XL                                               
              IF( VX .GT. 0.0 ) THEN                                    
                 NUMBL  = (VLOG(I) - VLMIN)/UNITL + 1.0                 
              ELSE                                                      
                 NUMBL  = 0                                             
              ENDIF                                                     
              IF( NX .GT. 0 ) THEN                                      
                 NUMB   = ( LOG10( XL*RNORM ) - VLMIN)/UNITL + 1.0      
                 ERL    = SQRT(XL)                                      
                 DERL   = (XL + ERL)*RNORM                              
                 NERUP  = ( LOG10( DERL ) - VLMIN)/UNITL + 1.0          
                 DERL   = (XL - ERL)*RNORM                              
                 IF( DERL .GT. 0.0 ) THEN                               
                     NERLW  = ( LOG10( DERL ) - VLMIN)/UNITL + 1.0      
                 ELSE                                                   
                     NERLW  = 0                                         
                 ENDIF                                                  
              ELSE                                                      
                 NUMB   = 0                                             
                 NERUP  = 0                                             
                 NERLW  = 0                                             
              ENDIF                                                     
              IF( NUMB  .GT. 50 ) NUMB = 50                             
              IF( NUMBL .GT. 50 ) NUMBL= 50                             
              DO 100 K = 1,50                                           
                IF( K .LE. NUMBL) THEN                                  
                  CHARR(K:K) = STAR                                     
                ELSE                                                    
                  IF( K .EQ. 50 ) THEN                                  
                    CHARR(K:K) = AI                                     
                  ELSE                                                  
                    CHARR(K:K) = BLNK                                   
                  ENDIF                                                 
                ENDIF                                                   
C                                                                       
                IF(     K .EQ. NUMB ) THEN                              
                        CHARR(K:K) = CROS                               
                        IF( K .EQ. NERUP .AND. K .EQ. NERLW ) GO TO 100 
                ENDIF                                                   
                IF(     K .EQ. NERUP ) THEN                             
                        CHARR(K:K) = '>'                                
                ELSEIF( K .EQ. NERLW ) THEN                             
                        CHARR(K:K) = '<'                                
                ENDIF                                                   
                                                                        
  100         CONTINUE                                                  
                                                                        
              CALL XHORDR( VX, F2, ORDER, IORDR )                       
                                                                        
             IF( I .EQ. 0 .OR. I .EQ. NXBIN ) THEN                      
                 WRITE(LU,9300) IORD,F2,IORDR,NX,CHARR                  
 9300            FORMAT(1X,'I  E',I3,' I',F6.3,'E',I3,'I',              
     .                                            I7,'I',A50)           
             ELSE                                                       
                   XM    = (XMIN + DEV*(I-1))/ORD                       
                   WRITE(LU,9340) XM,F2,IORDR,NX,CHARR                  
 9340              FORMAT(1X,'I',F6.3,' I',F6.3,'E',I3,'I',             
     .                                        I7,'I',A50)               
             ENDIF                                                      
  200       CONTINUE                                                    
             WRITE(LU,9250) CHR1                                        
             WRITE(LU,9260)                                             
 9260    FORMAT(1X,                                                     
     .       '   x      d(Sig/dx)  dN/dx',4X,                           
     .       '"O" : Generated Events.',                                 
     .       '( Arbitrary unit in Log )')                               
C                                                                       
           ELSE                                                         
C                                                                       
              CALL XHPLOT( LU, 1, IHIST )                               
C                                                                       
           ENDIF                                                        
  500    CONTINUE                                                       
      ENDIF                                                             
C                                                                       
      CALL DHPLOT( LU )                                                 
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ====================                                              *
      SUBROUTINE SHRSET                                                 
*    ====================                                              *
* ((Function))                                                         *
*     To reset the content of histograms and scatter plots.            *
* ((Author))                                                           *
*     S.Kawabata   June '90 at KEK                                     *
*                                                                      *
* **********************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      IF( NHIST .GT. 0 ) THEN                                           
         DO 100 IHIST = 1, NHIST                                        
            IP2       = MAPL(3,IHIST) + 52                              
            IP3       = MAPL(4,IHIST)                                   
            IBUF(IP3) = -1                                              
            DO 100 I = 0,51                                             
               BUFF(I+IP2) = 0.0                                        
  100      CONTINUE                                                     
      ENDIF                                                             
C                                                                       
      IF( NSCAT .GT. 0 ) THEN                                           
         DO 400   ISCAT = 1, NSCAT                                      
            IP3         = MAPD(4,ISCAT)                                 
            IBUF(IP3)   = 0                                             
            IBUF(IP3+1) = 0                                             
            IP2         = MAPD(3,ISCAT)                                 
            IBUF(IP2)   = 0                                             
            DO 400   I  = IP2+1,IP2+2500                                
               BUFF(I)  = 0.0                                           
  400      CONTINUE                                                     
      ENDIF                                                             
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ====================                                              *
      SUBROUTINE SHUPDT                                                 
*    ====================                                              *
* ((Function))                                                         *
*     To update histograms and scatter plots with unit weight.         *
*   The bin number to be updated is marked by XHFILL and DHFILL.       *
* ((Author))                                                           *
*     S.Kawabata  June '90 at KEK                                      *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      IF( NHIST .GT. 0 ) THEN                                           
         DO 150   IHIST   = 1, NHIST                                    
            IP3       = MAPL(4,IHIST)                                   
            IX        = IBUF(IP3)                                       
            IF( IX .GE. 0 ) THEN                                        
                IP       = IX + MAPL(3,IHIST) + 52                      
                BUFF(IP) = BUFF(IP) + 1.                                
                                                                        
                IBUF(IP3)  = -1                                         
            ENDIF                                                       
  150    CONTINUE                                                       
      ENDIF                                                             
C                                                                       
      IF( NSCAT .GT. 0 ) THEN                                           
         DO 250   ISCAT   = 1, NSCAT                                    
            IP3         = MAPD(4,ISCAT)                                 
            IX          = IBUF(IP3)                                     
            IF( IX .GT. 0 ) THEN                                        
                IP1   = MAPD(2,ISCAT)                                   
                MXBIN = IBUF(IP1+2)                                     
                MYBIN = IBUF(IP1+6)                                     
                IP2       = MAPD(3,ISCAT)                               
                IBUF(IP2) = IBUF(IP2) + 1                               
                IY        = IBUF(IP3+1)                                 
                IF( IX .GT. 0 .AND. IX .LE. MXBIN .AND.                 
     .              IY .GT. 0 .AND. IY .LE. MYBIN ) THEN                
                    IP       = IX + MXBIN*(IY-1) + IP2                  
                    BUFF(IP) = BUFF(IP) + 1.0                           
                ENDIF                                                   
                IBUF(IP3)   =  0                                        
                IBUF(IP3+1) =  0                                        
           ENDIF                                                        
C                                                                       
  250    CONTINUE                                                       
      ENDIF                                                             
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ===================                                               *
      SUBROUTINE SPCHCK                                                 
*    ===================                                               *
* ((Purpose))                                                          *
*     To check user's initialization parameters.                       *
*                                                                      *
*        Coded by S.Kawabata      April  '94                           *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      PARAMETER ( MXDIM = 50)                                           
      COMMON /BPARM1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                   
     .               IG(MXDIM),NCALL                                    
      COMMON /BPARM2/ ACC1,ACC2,ITMX1,ITMX2                             
                                                                        
      COMMON /BASE0/ JFLAG,IBASES                                       
      COMMON /BASE1/ XLT(MXDIM),XUT(MXDIM),NDIMT,NWILDT,                
     .               IGT(MXDIM),NCALLT                                  
      COMMON /BASE2/ ACC1T,ACC2T,ITMX1T,ITMX2T                          
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      IF( NDIM .NE. NDIMT ) THEN                                        
          WRITE(6,9100) NDIM,NDIMT                                      
 9100     FORMAT(                                                       
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Given NDIM(',I6,' ) does not match          *',      
     .    /5X,'*      to NDIM(',I6,' ) in BASES.               *',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Process was terminated due to this error.   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
          STOP                                                          
      ENDIF                                                             
                                                                        
      IF( NWILD .NE. NWILDT ) THEN                                      
          WRITE(6,9110) NWILD,NWILDT                                    
 9110     FORMAT(                                                       
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Given NWILD(',I6,' ) does not match         *',      
     .    /5X,'*      to NWILD(',I6,' ) in BASES.              *',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Process was terminated due to this error.   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
          STOP                                                          
      ENDIF                                                             
                                                                        
      DO 200 I = 1,NDIM                                                 
         IF( XL(I) .NE. XLT(I) ) THEN                                   
             WRITE(6,9200) I,XL(I),I,XLT(I)                             
 9200        FORMAT(                                                    
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Given XL(',I3,' ) = ',D15.8,'            *',         
     .    /5X,'*      does not match to                        *',      
     .    /5X,'*      to XL(',I3,' ) = ',D15.8,' in BASES   *',         
     .    /5X,'*                                               *',      
     .    /5X,'*   Process was terminated due to this error.   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
             STOP                                                       
         ENDIF                                                          
         IF( XU(I) .NE. XUT(I) ) THEN                                   
             WRITE(6,9210) I,XU(I),I,XUT(I)                             
 9210        FORMAT(                                                    
     .     5X,'*************************************************',      
     .    /5X,'*                                               *',      
     .    /5X,'*   Given XU(',I3,' ) = ',D15.8,'            *',         
     .    /5X,'*      does not match to                        *',      
     .    /5X,'*      to XU(',I3,' ) = ',D15.8,' in BASES   *',         
     .    /5X,'*                                               *',      
     .    /5X,'*   Process was terminated due to this error.   *',      
     .    /5X,'*                                               *',      
     .    /5X,'*************************************************')      
             STOP                                                       
         ENDIF                                                          
  200 CONTINUE                                                          
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    =========================                                         *
      SUBROUTINE SPHIST( LU )                                           
*    =========================                                         *
* ((Purpose))                                                          *
*      To print the histogram for event generation                     *
* ((Input))                                                            *
*      LU   : logical unit number for the printer to be printed        *
*                                                                      *
* ((Author))                                                           *
*       S.Kawabata    April 1994                                       *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( MXBIN = 51 )                                          
      COMMON/PLOTSP/ NBIN,IBUFSP( MXBIN )                               
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      REAL  VAL(MXBIN),VLOG(MXBIN)                                      
      CHARACTER*50 CHARR,CHAR1                                          
      CHARACTER*52 SCALE                                                
      CHARACTER*1  BLNK,STAR,OO,AI,CN                                   
      DATA  YMAX / 50/                                                  
      DATA  BLNK /' '/, STAR /'*'/, OO /'O'/, AI /'I'/                  
                                                                        
      CN    = CHAR(12)                                                  
      IF( IPNT .EQ. 0 ) THEN                                            
          WRITE(LU,9000)                                                
 9000     FORMAT(/1H1,/1H )                                             
      ELSE                                                              
          WRITE(LU,9005) CN                                             
 9005     FORMAT(A1)                                                    
      ENDIF                                                             
          WRITE(LU,9102)                                                
 9102     FORMAT(5X,                                                    
     .  '************* Number of trials to get an event *************') 
                                                                        
      XMIN  = 1.0                                                       
      XMAX  = NBIN                                                      
      DEV   = 1.0                                                       
      NBIN1 = NBIN + 1                                                  
                                                                        
          NTOTAL     = IBUFSP(NBIN1)                                    
          VAL(NBIN1) = FLOAT(NTOTAL)                                    
          VMIN       = 0.0                                              
          VMAX       = VMIN                                             
          DO  55 I   = 1,NBIN                                           
              NTR    = IBUFSP(I)                                        
              VLS    = FLOAT( NTR )                                     
              NTOTAL = NTR + NTOTAL                                     
              IF( VMAX .LT. VLS ) VMAX = VLS                            
              VAL(I) = VLS                                              
   55     CONTINUE                                                      
                                                                        
          VLMAX = LOG10(VMAX)                                           
          VLMIN = VLMAX                                                 
                                                                        
           DO  60 I = 1,NBIN1                                           
               IF( VAL(I) .GT. 0.0 ) THEN                               
                   VLS   = LOG10( VAL(I) )                              
                   IF( I .LE. NBIN ) THEN                               
                       IF( VLS .LT. VLMIN ) VLMIN = VLS                 
                   ENDIF                                                
                   VLOG(I)  = VLS                                       
               ENDIF                                                    
   60      CONTINUE                                                     
                                                                        
           IF( VLMIN .LT. 0.0) THEN                                     
               VXMIN = IFIX(VLMIN) - 1.0                                
           ELSE                                                         
               VXMIN = IFIX(VLMIN)                                      
           ENDIF                                                        
           VXMAX = VLMAX                                                
           IFLG  = 1                                                    
           CALL XHRNGE( IFLG, VXMIN, VXMAX, VLMIN, VLMAX, VLSTP )       
           UNITL = (VLMAX-VLMIN)/YMAX                                   
                                                                        
       IFLG   = 0                                                       
           IF( VMIN .GE. 0.0 ) THEN                                     
               VXMAX  = 1.2*VMAX                                        
               VXMIN  = 0.0                                             
               CALL XHRNGE( IFLG, VXMIN, VXMAX, VMIN, VMAX, VSTP )      
           ELSE                                                         
               VXMAX  = 1.1*VMAX                                        
               VXMIN  = 1.1*VMIN                                        
               CALL XHRNGE( IFLG, VXMIN, VXMAX, VMIN, VMAX, VSTP )      
           ENDIF                                                        
                                                                        
       UNIT  = (VMAX-VMIN)/YMAX                                         
                                                                        
       CALL XHSCLE( IFLG, VMIN, VMAX, VSTP, UNIT, SCALE, CHAR1 )        
                                                                        
             WRITE(LU,9210) NTOTAL                                      
 9210        FORMAT(1X,'Total =',I10,' events',                         
     .        3X,'"*" : No. of events in Linear scale.')                
             WRITE(LU,9205) SCALE                                       
 9205        FORMAT(1X,'   x      Lg(dN/dx)  dN/dx',A52)                
             WRITE(LU,9251) CHAR1                                       
 9251        FORMAT(1X,                                                 
     .             '+-------+----------+-------+',                      
     .       A50 )                                                      
                                                                        
       VX    = ABS(XMAX)                                                
       XM    = ABS(XMIN)                                                
       IF( XM .GT. VX ) VX = XM                                         
                                                                        
       CALL XHORDR( VX, F2, ORD, IORD )                                 
                                                                        
       IF( VMIN .LT. 0.0 ) THEN                                         
           V1    = VMIN                                                 
           NUMBL = 1                                                    
           DO 150 I = 1, 80                                             
              V2    = V1 + UNIT                                         
              IF( V1 .LE. 0.0 .AND. V2 .GE. 0.0 ) THEN                  
                  NUMBL  = I                                            
                  GO TO 180                                             
              ENDIF                                                     
              V1    = V2                                                
  150      CONTINUE                                                     
       ENDIF                                                            
                                                                        
  180  DO 300 I = 1,NBIN1                                               
          VX   = VAL(I)                                                 
          IF( VMIN .GE. 0.0 ) THEN                                      
              IF( VX .GT. 0.0 ) THEN                                    
                  NUMBL  = (VLOG(I) - VLMIN)/UNITL + 1.0                
                  NUMB   = VX/UNIT + 1.0                                
              ELSE                                                      
                  NUMBL  = 0                                            
                  NUMB   = 0                                            
              ENDIF                                                     
              IF( NUMB .GT. 50 ) NUMB = 50                              
              IF( NUMBL.GT. 50 ) NUMBL= 50                              
              DO 200 K = 1,50                                           
                 IF(     ( K .GT. NUMBL) .AND. (K .GT. NUMB ) ) THEN    
                           IF( K .EQ. 50 ) THEN                         
                               CHARR(K:K) = AI                          
                           ELSE                                         
                               CHARR(K:K) = BLNK                        
                           ENDIF                                        
                 ELSEIF( ( K .LE. NUMBL) .AND. (K .GT. NUMB )) THEN     
                           CHARR(K:K) = OO                              
                 ELSEIF( ( K .GT. NUMBL) .AND. (K .LE. NUMB )) THEN     
                           CHARR(K:K) = STAR                            
                 ELSEIF( ( K .LE. NUMBL) .AND. (K .LE. NUMB)) THEN      
                           IF( NUMB .GE. NUMBL ) THEN                   
                               CHARR(K:K) = OO                          
                           ELSE                                         
                               CHARR(K:K) = STAR                        
                           ENDIF                                        
                 ENDIF                                                  
  200         CONTINUE                                                  
          ELSE                                                          
                                                                        
              V1          = VMIN                                        
              NHIG        = 1                                           
              DO 220  J = 1, 50                                         
                 V2     = V1 + UNIT                                     
                 IF( VX .GE. V1 .AND. VX .LT. V2 ) THEN                 
                     NHIG   = J                                         
                     GO TO 240                                          
                 ENDIF                                                  
                 V1    = V2                                             
  220         CONTINUE                                                  
  240         NLOW   = NUMBL                                            
              IF( NHIG .LT. NLOW) THEN                                  
                  NX    = NHIG                                          
                  NHIG  = NLOW                                          
                  NLOW  = NX                                            
              ENDIF                                                     
                                                                        
              DO 250 K = 1, 49                                          
                 IF(     K .EQ. NUMBL ) THEN                            
                         CHARR(K:K) = AI                                
                 ELSEIF( K .GT. NHIG ) THEN                             
                         CHARR(K:K) = BLNK                              
                 ELSEIF( K .LT. NLOW ) THEN                             
                         CHARR(K:K) = BLNK                              
                 ELSE                                                   
                     IF( K .EQ. NHIG .AND. K .EQ. NLOW) THEN            
                         CHARR(K:K) = AI                                
                     ELSE                                               
                         CHARR(K:K) = STAR                              
                     ENDIF                                              
                 ENDIF                                                  
  250         CONTINUE                                                  
              CHARR(50:50) = AI                                         
          ENDIF                                                         
                                                                        
             NX  = VAL(I)                                               
             VX     = VAL(I)                                            
             VX1    = VX                                                
             IF( VX .LT. 0.0 ) VX1 = -VX                                
             CALL XHORDR( VX1, F2, ORDER, IORDR )                       
             F2     = VX/ORDER                                          
             IF( I .EQ. NBIN1 ) THEN                                    
                 WRITE(LU,9400) IORD,F2,IORDR,NX,CHARR                  
 9400            FORMAT(1X,'I  E',I3,' I',F6.3,'E',I3,'I',              
     .                                            I7,'I',A50)           
             ELSE                                                       
                   XM  = (XMIN + DEV*(I - 1))/ORD                       
                   WRITE(LU,9440) XM,F2,IORDR,NX,CHARR                  
 9440              FORMAT(1X,'I',F6.3,' I',F6.3,'E',I3,'I',             
     .                                        I7,'I',A50)               
             ENDIF                                                      
                                                                        
  300  CONTINUE                                                         
                                                                        
       IF( VMIN .GE. 0.0 ) THEN                                         
           CALL XHSCLE( 1, VLMIN, VLMAX, VLSTP, UNITL, SCALE, CHAR1)    
           VXMIN  = 10**VLMIN                                           
       ENDIF                                                            
                                                                        
           WRITE(LU,9251) CHAR1                                         
           WRITE(LU,9205) SCALE                                         
           WRITE(LU,9360)                                               
 9360      FORMAT(30X,'"O" : No. of Events in Log. scale.')             
                                                                        
C                                                                       
                                                                        
      RETURN                                                            
      END                                                               
*********************************************************************** 
*============================                                         * 
      SUBROUTINE SPINFO( LU )                                           
*============================                                         * 
*((Purpose))                                                          * 
*    Print the information for                                        * 
*        (1) BASES parameters                                         * 
*        (2) Computer time information                                * 
*        (3) Convergency behavior of the Grid optimization step       * 
*        (4) Convergency behavior of the integration step             * 
*(( Input ))                                                          * 
*    LU  :  Logical unit number of printer                            * 
*                                                                     * 
*           by S.Kawabata    March 1994 at KEK                          
*                                                                     * 
*********************************************************************** 
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      COMMON /BDATE/ IDATE(3),ITIME(2)                                  
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      COMMON /SPRNG2/ MXTRY,NEVENT, NTRIAL, MISS                        
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
*     COMMON/PLOTH/ XHASH(ILH,13),DHASH(IDH,14),IFBASE(ILH),            
*    .              MAXL, NHIST, MAPL(4,ILH),                           
*    .              MAXD, NSCAT, MAPD(4,IDH),                           
*    .              NW                                                  
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
                                                                        
      REAL*4 TIMEBS,TIMINT,TIMESP,TIME0,RTIME,TIMEB1,TIMEB2,TIMES1      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
      REAL*4 XTIME                                                      
                                                                        
      CHARACTER*1 CN                                                    
                                                                        
       IF( IPNT .EQ. 0 ) THEN                                           
           WRITE(LU,9300)                                               
       ELSE                                                             
           CN     = CHAR(12)                                            
           WRITE(LU,9350) CN                                            
       ENDIF                                                            
 9300  FORMAT(/1H1,////1H )                                             
 9350  FORMAT(A1,////1X)                                                
       WRITE(LU,9360) (IDATE(I),I=1,3),(ITIME(J),J=1,2)                 
 9360  FORMAT(55X,'Date: ',I2,'/',I2,'/',I2,2X,I2.2,':',I2.2)           
       WRITE(LU,9400)                                                   
 9400 FORMAT(                                                           
     . 8X,'**********************************************************', 
     ./8X,'*                                                        *', 
     ./8X,'*    SSSSS   PPPPPP   RRRRRR   IIIII  N    NN   GGGGG    *', 
     ./8X,'*   SS   SS  PP   PP  RR   RR   III   NN   NN  GG   GG   *', 
     ./8X,'*   SS       PP   PP  RR   RR   III   NNN  NN  GG        *', 
     ./8X,'*    SSSSS   PPPPPP   RRRRR     III   NNNN NN  GG  GGGG  *', 
     ./8X,'*        SS  PP       RR  RR    III   NN NNNN  GG   GG   *', 
     ./8X,'*   SS   SS  PP       RR   RR   III   NN  NNN  GG   GG   *', 
     ./8X,'*    SSSSS   PP       RR    RR IIIII  NN   NN   GGGGG    *', 
     ./8X,'*                                                        *', 
     ./8X,'*                  SPRING Version 5.1                    *', 
     ./8X,'*           coded by S.Kawabata KEK, March 1994          *', 
     ./8X,'**********************************************************') 
*                                                                      *
          EFF   = FLOAT(NEVENT)/FLOAT(NTRIAL)*100.D0                    
          CALL BSTIME( RTIME, 1 )                                       
          XTIME = RTIME - TIMES1                                        
          WRITE(LU,9500) NEVENT,EFF,(TIMESP(I),I=0,2),XTIME,MXTRY,MISS  
 9500     FORMAT(/5X,'Number of generated events    =',I10,             
     .         /5X,'Generation efficiency         =',F10.3,' Percent',  
     .         /5X,'Computing time for generation =',F10.3,' Seconds',  
     .         /5X,'               for Overhead   =',F10.3,' Seconds',  
     .         /5X,'               for Others     =',F10.3,' Seconds',  
     .         /5X,'GO time for event generation  =',F10.3,' Seconds',  
     .         /5X,'Max. number of trials MXTRY   =',I10,' per event',  
     .         /5X,'Number of miss-generation     =',I10,' times')      
                                                                        
      CALL SPHIST( LU )                                                 
                                                                        
      RETURN                                                            
      END                                                               
C***********************************************************************
C*====================================                                 *
C* SUBROUTINE SPRGEN( F, MXTRY, NTRY )                                 *
C*====================================                                 *
C*                                                                     *
C*     Generation of events according to the probability density       *
C*     which is stored in a disk file.                                 *
C*                                                                     *
C*    Coded   by S.Kawabata   at July,1980                             *
C*    Update     S.Kawabata   September '84                            *
C*                                                                     *
C***********************************************************************
C                                                                       
       SUBROUTINE SPRGEN(F,MXTRY,NTRY)                                  
C                                                                       
      IMPLICIT REAL*8 (A-H,O-Z)                                         
C                                                                       
      EXTERNAL F                                                        
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
     .               ND,NG,NPG,MA(MXDIM)                                
                                                                        
      COMMON /SPRNG1/ XND, DXG, XJAC, DXMAX, NSP                        
                                                                        
      DIMENSION Y(MXDIM),KG(MXDIM)                                      
      DATA ONE/1.0D0/                                                   
C                                                                       
C                                                                       
      RX    = DRN(IDUMY)*DXMAX                                           
C                                                                       
C  -------------- Binary Search  --------------------------------       
C                                                                       
      IPMIN = 1                                                         
      IPMAX = NSP                                                       
C                                                                       
 300  IC    = (IPMIN+IPMAX)/2                                           
        IF(RX .LT. DXD(IC)) THEN                                        
          IPMAX = IC                                                    
        ELSE                                                            
          IPMIN = IC                                                    
        ENDIF                                                           
      IF(IPMAX-IPMIN .GT.  2) GO TO 300                                 
C                                                                       
      IC    = IPMIN-1                                                   
 350  IC    = IC+1                                                      
      IF(DXD(IC) .LT. RX) GO TO 350                                     
C                                                                       
C --------------------------------------------------------------------  
C      Identify the hypecube number from sequential number IC           
C --------------------------------------------------------------------  
C                                                                       
       FMAX  = DXP(IC)                                                  
C                                                                       
       IX    = IC-1                                                     
                                                                        
       KG(NWILD) = IX/MA(NWILD) + 1                                     
       IF( NWILD .GT. 1 ) THEN                                          
           DO 400 J = 1,NWILD-1                                         
              NUM   = MOD(IX,MA(J+1))                                   
              KG(J) = NUM/MA(J) + 1                                     
  400      CONTINUE                                                     
       ENDIF                                                            
C                                                                       
C  ------------------------------------------------------------------   
C                     Sample and test a event                           
C  ------------------------------------------------------------------   
C                                                                       
      DO 600 NTRY = 1,MXTRY                                             
        WGT   = XJAC                                                    
        DO 550 J=1,NDIM                                                 
          IF( J .LE. NWILD) THEN                                        
             XN    = (KG(J)-DRN(IDUMY))*DXG+ONE                          
          ELSE                                                          
             XN    = ND*DRN(IDUMY) + ONE                                 
          ENDIF                                                         
          IAJ   = XN                                                    
          IF(IAJ .EQ. 1) THEN                                           
            XO    = XI(IAJ,J)                                           
            RC    = (XN-IAJ)*XO                                         
          ELSE                                                          
            XO    = XI(IAJ,J)-XI(IAJ-1,J)                               
            RC    = XI(IAJ-1,J)+(XN-IAJ)*XO                             
          ENDIF                                                         
          Y(J)  = XL(J) + RC*DX(J)                                      
          WGT   = WGT*XO*XND                                            
  550   CONTINUE                                                        
C                                                                       
*       FX    = F(Y)*WGT                                                
        FF    = F(Y)                                                    
        FX    = FF*WGT                                                  
        FUNCT = FX/FMAX                                                 
C                                                                       
        IF( FX .GT. 0.0D0 ) THEN                                        
*           IF( DRN(IDUMY) .LE. FUNCT ) GO TO 700                        
            XJ = DRN(IDUMY)                                              
            IF( XJ .LE. FUNCT ) GO TO 700                               
*           IF( XJ .LE. FUNCT ) THEN                                    
*               WRITE(6,9999) NTRY,IC,FF,WGT,XJ,FUNCT                   
*9999           FORMAT(1X,'NTRY,IC,FF,WGT,XJ,FUNCT = ',2I5,4E12.4)      
*               GO TO 700                                               
*           ENDIF                                                       
        ELSE                                                            
     .  IF( FX .LT. 0.0D0 ) THEN                                        
            WRITE(6,9100) IC                                            
 9100       FORMAT(                                                     
     .      /5X,'********** FATAL ERROR IN SPRING **********',          
     .      /5X,'* A negative value of function was found  *',          
     .      /5X,'*        in the ',I6,'-th Hypercube.      *',          
     .      /5X,'*******************************************')          
            WRITE(6,9405)                                               
 9405       FORMAT(5X,'------',3('+---------------'),'+')               
            WRITE(6,9410)                                               
 9410       FORMAT(5X,'    i       XL(i)             X       ',         
     .                '     XU(i)')                                     
            WRITE(6,9405)                                               
            DO 450 I = 1,NDIM                                           
                WRITE(6,9420) I,XL(I),Y(I),XU(I)                        
 9420           FORMAT(5X,I5,1P,3('  ',E14.6))                          
  450       CONTINUE                                                    
            WRITE(6,9405)                                               
            STOP                                                        
        ENDIF                                                           
C                                                                       
        CALL SHCLER                                                     
C                                                                       
  600 CONTINUE                                                          
                                                                        
      NTRY  = MXTRY + 1                                                 
                                                                        
  700 RETURN                                                            
      END                                                               
************************************************************************
*    ==================================                                *
      SUBROUTINE SPRING(FUNC, MXTRY )                                   
*    ==================================                                *
*         Main Program for the Event generation program SPRING.        *
*                                                                      *
*        Coded by S.Kawabata        September '84                      *
*                                                                      *
************************************************************************
                                                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                         
      EXTERNAL FUNC                                                     
      COMMON /BASE0/ NDUM,IBASES                                        
      PARAMETER (MXDIM = 50, NDMX = 50, LENG = 32768)                   
      COMMON /BASE1/ XL(MXDIM),XU(MXDIM),NDIM,NWILD,                    
     .               IG(MXDIM),NCALL                                    
      COMMON /BASE4/ XI(NDMX,MXDIM),DX(MXDIM),DXD(LENG),DXP(LENG),      
     .               ND,NG,NPG,MA(MXDIM)                                
      COMMON /BDATE/ IDATE(3),ITIME(2)                                  
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      COMMON /SPRNG1/ XND, DXG, XJAC, DXMAX, NSP                        
      COMMON /SPRNG2/ MXTRYP,NEVENT, NTRIAL,MISS                        
                                                                        
      REAL*4 TIMEBS,TIMINT,TIMESP,TIME0,RTIME,TIMEB1,TIMEB2,TIMES1      
      COMMON /BTIME1/ TIME0,RTIME,TIMEB1,TIMEB2,TIMES1                  
      COMMON /BTIME2/ TIMEBS(0:2),TIMINT,TIMESP(0:2)                    
*                                                                      *
*----------------------------- Entry point ----------------------------*
*                                                                      *
*======================================================================*
*                  Initialization of the program                       *
*======================================================================*
*----------------------------------------------------------------------*
*                     initialize timer etc.                            *
*----------------------------------------------------------------------*
*                                                                      *
       IF( IBASES .GT. 0 ) THEN                                         
                                                                        
           CALL SPCHCK                                                  
                                                                        
           CALL BSTIME( TIME0, 0 )                                      
           TIMES1 = TIME0                                               
                                                                        
           MXTRYP = MXTRY                                               
           INTV   = 0                                                   
           IBASES = 0                                                   
           MISFLG = 0                                                   
                                                                        
           CALL BSDATE                                                  
                                                                        
           DO 10 I = 0,2                                                
              TIMESP(I) = 0.0                                           
   10      CONTINUE                                                     
*                                                                      *
            IF( MXTRY .LT. 10 ) MXTRY = 50                              
            NBIN    = MXTRY                                             
            IF( MXTRY .GT. 50) NBIN = 50                                
            MXTRY1  = MXTRY + 1                                         
            MISS    = 0                                                 
            NEVENT  = 0                                                 
            NTRIAL  = 0                                                 
                                                                        
            CALL SHINIT( MXTRY1 )                                       
                                                                        
*           -------------                                               
             CALL SHRSET                                                
*            -------------                                              
*----------------------------------------------------------------------*
*             Make the cumulative probability distribution             *
*----------------------------------------------------------------------*
*                                                                      *
            XND     = ND                                                
            DXG     = XND/NG                                            
            NSP     = NG**NWILD                                         
                                                                        
*///// DEBUG                                                            
*       MCALL   = NSP*NPG                                               
*       CALL BSPRNT( 4, MCALL, IDUM2, IDUM3, IDUM4 )                    
*                                                                       
            XJAC    = 1.0                                               
            DO 50 I = 1, NDIM                                           
               XJAC = XJAC*DX(I)                                        
   50       CONTINUE                                                    
            DXMAX   = 0.0D0                                             
            DO 100  I = 1,NSP                                           
               IF( DXD( I ) .LT. 0.0D0 ) THEN                           
                   WRITE(6,9100) I                                      
 9100              FORMAT(                                              
     .             /5X,'********** FATAL ERROR IN SPRING **********',   
     .             /5X,'*     Negative probability was found      *',   
     .             /5X,'*        in the ',I6,'-th Hypercube.      *',   
     .             /5X,'*******************************************')   
                   STOP                                                 
               ENDIF                                                    
                                                                        
               DXMAX    = DXMAX + DXD( I )                              
               DXD(I)   = DXMAX                                         
  100       CONTINUE                                                    
*        =====================                                          
          CALL BSUTIM( 1, 1 )                                           
*        =====================                                          
      ENDIF                                                             
*     =====================                                             
       CALL BSUTIM( 1, 2 )                                              
*     =====================                                             
      IF( IBASES .EQ. 1 ) THEN                                          
          WRITE(6,9000)                                                 
 9000     FORMAT(                                                       
     .      1X,'**************************************************',    
     .     /1X,'*    Flag IBASES was not equal to "0".           *',    
     .     /1X,'*                                                *',    
     .     /1X,'*   Process was terminated by this error.        *',    
     .     /1X,'*   Call S.Kawabata.                             *',    
     .     /1X,'**************************************************')    
           STOP                                                         
       ENDIF                                                            
*                                                                      *
*======================================================================*
*                       Event generation                               *
*======================================================================*
*     =====================                                             
  500  CALL BSUTIM( 1, 1 )                                              
*     =====================                                             
                                                                        
*     ==================================                                
        CALL SPRGEN( FUNC, MXTRY, IRET)                                 
*     ==================================                                
                                                                        
*     =====================                                             
       CALL BSUTIM( 1, 0 )                                              
*     =====================                                             
                                                                        
      CALL SHFILL( IRET )                                               
                                                                        
      IF( IRET .LE. MXTRY ) THEN                                        
          NTRIAL =NTRIAL + IRET                                         
          NEVENT = NEVENT + 1                                           
          CALL SHUPDT                                                   
      ELSE                                                              
          NTRIAL =NTRIAL + IRET - 1                                     
          MISS = MISS + 1                                               
          IF( MISFLG .EQ. 0 .AND. MISS .GT. MXTRY ) THEN                
              WRITE(6,9600) MXTRY                                       
 9600         FORMAT(1X,'****************************************',     
     .                  '****************************************',     
     .              /1X,'* (((( Warning ))))                     ',     
     .                  '                                       *',     
     .              /1X,'*                                       ',     
     .                  '                                       *',     
     .              /1X,'*  The number of mis-generations is foun',     
     .                  'd more than',I3,' times.                  *')  
              WRITE(6,9610)                                             
 9610         FORMAT(1X,'*                                       ',     
     .                  '                                       *',     
     .              /1X,'*(( Suggestion ))                       ',     
     .                  '                                       *',     
     .              /1X,'* (1) Try integration again with larger ',     
     .                  'number of sample points than this job. *',     
     .              /1X,'* or                                    ',     
     .                  '                                       *',     
     .              /1X,'* (2) The integral variables are not sui',     
     .                  'ted for the function.                  *',     
     .              /1X,'*     Take another integral variables !!',     
     .                  '                                       *',     
     .              /1X,'*                                       ',     
     .                  '                                       *',     
     .              /1X,'****************************************',     
     .                  '****************************************')     
            MISFLG = 1                                                  
          ENDIF                                                         
          GO TO 500                                                     
      ENDIF                                                             
*     =====================                                             
  600  CALL BSUTIM( 1, 1 )                                              
*     =====================                                             
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    =======================                                           *
      SUBROUTINE XHCHCK(LU)                                             
*    =======================                                           *
* ((Purpose))                                                          *
*      To check the contents of the histogram table                    *
*                                                                      *
* ((Author))                                                           *
*       S.Kawabata    June '90                                         *
*                                                                      *
************************************************************************
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
      CHARACTER*1 CN                                                    
                                                                        
      CN  = CHAR(12)                                                    
                                                                        
      IF( IPNT .EQ. 0 ) THEN                                            
          WRITE(LU,9000)                                                
      ELSE                                                              
          WRITE(LU,9010) CN                                             
      ENDIF                                                             
 9000 FORMAT(/1H1)                                                      
 9010 FORMAT(A1)                                                        
                                                                        
      WRITE(LU,9050) NW                                                 
 9050 FORMAT(                                                           
     . //5X,'*********  Contents of the histogram Header *********',    
     .     //1X,'(1) Actual Buffer size     = ',I6,' Words')            
      WRITE(LU,9100) NHS,NHIST                                          
 9100 FORMAT(1X,'(2) Contents of Histograms ',                          
     .      /1X,'    Max. No. of Histograms = ',I6,                     
     .      /1X,'    Number   of Histograms = ',I6)                     
                                                                        
      IF( NHIST .GT. 0 ) THEN                                           
          WRITE(LU,9200)                                                
 9200     FORMAT(1X,'   ID     X_min        X_max    X_bin',            
     .              ' Hash Hst#')                                       
          DO 200 I = 1, 13                                              
             NT    = XHASH(1,I)                                         
             IF( NT .GT. 0 ) THEN                                       
                 DO 100 J = 2, NT+1                                     
                    K     = XHASH(J,I)                                  
                    IP1   = MAPL(2,K)                                   
                    IP3   = MAPL(4,K)                                   
                    XMIN  = BUFF(IP1)                                   
                    XMAX  = BUFF(IP1+1)                                 
                    NBIN  = IBUF(IP1+2)                                 
                    WRITE(LU,9300) MAPL(1,K),XMIN,XMAX,NBIN,I,NT,K      
 9300               FORMAT(1X,I5,1X,1PE12.4,1X,E12.4,I5,2I3,I5)         
  100            CONTINUE                                               
             ENDIF                                                      
  200     CONTINUE                                                      
      ENDIF                                                             
                                                                        
      WRITE(LU,9400) NSC,NSCAT                                          
 9400 FORMAT(1X,'(3) Contents of Scatter Plots',                        
     .      /1X,'    Max. No. of Scat_Plots = ',I6,                     
     .      /1X,'    Number   of Scat_Plots = ',I6)                     
                                                                        
      IF( NSCAT .GT. 0 ) THEN                                           
          WRITE(LU,9500)                                                
 9500     FORMAT(1X,'   ID      X_min   ',                              
     .              '     X_max   X-Bin    Y_min   ',                   
     .              '     Y_max   Y_Bin Hash Hst#')                     
          DO 400 I = 1, 13                                              
             NT    = DHASH(1,I)                                         
             IF( NT .GT. 0 ) THEN                                       
                 DO 300 J = 2, NT+1                                     
                    K     = DHASH(J,I)                                  
                    IP1   = MAPD(2,K)                                   
                    IP3   = MAPD(4,K)                                   
                    XMIN  = BUFF(IP1)                                   
                    XMAX  = BUFF(IP1+1)                                 
                    NXBN  = IBUF(IP1+2)                                 
                    YMIN  = BUFF(IP1+4)                                 
                    YMAX  = BUFF(IP1+5)                                 
                    NYBN  = IBUF(IP1+6)                                 
                    WRITE(LU,9600) MAPD(1,K),XMIN,XMAX,NXBN,            
     .                            YMIN,YMAX,NYBN,I,NT,K                 
 9600               FORMAT(1X,I5,1X,1PE12.4,1X,E12.4,I5,                
     .                                 E12.4,1X,E12.4,I5,2I3,I5)        
  300            CONTINUE                                               
             ENDIF                                                      
  400     CONTINUE                                                      
      ENDIF                                                             
      RETURN                                                            
      END                                                               
************************************************************************
*    ==============================                                    *
      SUBROUTINE XHFILL(ID, DX, FX )                                    
*    ==============================                                    *
* ((Function))                                                         *
*     To fill histograms.                                              *
*   This routine identifies the bin number which is to be updated      *
*   with weight FX*WGT.  Up to five points per histogram are able      *
*   to be stacked before calling BHUPDT or SHUPDT.                     *
* ((Input))                                                            *
*   ID    : Histogram identification number                            *
*   DX    : Input value                                                *
*   FX    : Input value of the function                                *
* ((Author))                                                           *
*   S.Kawabata         June '90 at KEK                                 *
*                                                                      *
************************************************************************
                                                                        
      REAL*8 DX,FX                                                      
      COMMON /BASE0/ IFLAG,IBASES                                       
      REAL*8         SCALLS,WGT,TI,TSI,TACC                             
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
C     COMMON/PLOTLU/ LU                                                 
C                                                                       
      IF( NHIST .GT. 0 ) THEN                                           
C                                                                       
          I  = IABS(MOD( ID, 13 )) + 1                                  
          IF( XHASH(1, I) .EQ. 1 ) THEN                                 
            IF( ID .EQ. MAPL( 1, XHASH(2,I))) THEN                      
                IHIST = XHASH(2,I)                                      
                GO TO 200                                               
            ENDIF                                                       
          ELSEIF( XHASH(1, I) .GT. 1 ) THEN                             
            DO 100 K = 2, XHASH(1,I)+1                                  
               IF( ID .EQ. MAPL( 1, XHASH(K,I))) THEN                   
                   IHIST = XHASH(K,I)                                   
                   GO TO 200                                            
               ENDIF                                                    
  100       CONTINUE                                                    
          ENDIF                                                         
      ENDIF                                                             
C     IF( LU .GT. 0 ) THEN                                              
C         WRITE(LU,9000) ID                                             
C     ENDIF                                                             
C9000 FORMAT(1X,'No Histogram corresponds to ID =',I5,                  
C    .      /1X,' This call is neglected.')                             
      RETURN                                                            
C                                                                       
                                                                        
  200 X     = DX*1.0                                                    
                                                                        
          IX    = -1                                                    
          IP1   = MAPL(2,IHIST)                                         
          XMIN  = BUFF(IP1)                                             
          XMAX  = BUFF(IP1+1)                                           
          NXBIN = IBUF(IP1+2)                                           
          DEV   = BUFF(IP1+3)                                           
          IF(     X .LT. XMIN ) THEN                                    
                  IX   = 0                                              
          ELSEIF( X .GT. XMAX ) THEN                                    
                 IX   = NXBIN + 1                                       
          ELSE                                                          
                 IX   = INT((X - XMIN)/DEV + 1.0)                       
                 IF( IX .GT. NXBIN ) IX = NXBIN                         
          ENDIF                                                         
C        PRINT*,'ID, IHIST, IFBASE =',ID,IHIST,(IFBASE(I),I=1,NHIST)    
                                                                        
      IF( IBASES .EQ. 1 ) THEN                                          
                                                                        
          IP2       = MAPL(3,IHIST) + IX                                
          IBUF(IP2) = IBUF(IP2) + 1                                     
          FXWGT     = FX*WGT                                            
          IP2       = IP2 + 52                                          
          BUFF(IP2) = BUFF(IP2) + FXWGT                                 
          IP2       = IP2 + 52                                          
          BUFF(IP2) = BUFF(IP2) + FXWGT*FXWGT                           
*   Add March 1994                                                      
          IFBASE(IHIST) = 1                                             
                                                                        
      ELSE                                                              
C        PRINT*,'ID, IHIST, IFBASE =',ID,IHIST,(IFBASE(I),I=1,NHIST)    
                                                                        
         IP3        =  MAPL(4,IHIST)                                    
         IBUF(IP3)  = IX                                                
                                                                        
      ENDIF                                                             
                                                                        
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    ============================================                      *
      SUBROUTINE XHINIT(ID,DXMIN,DXMAX,NBIN,TNAME)                      
*    ============================================                      *
* ((Function))                                                         *
*     To define a histogram.                                           *
* ((Input))                                                            *
*    ID   : Histogram identification number                            *
*    DXMIN: Lower limit of the histogram                               *
*    DXMAX: Upper limit of the histogram                               *
*    NBIN : Number of bins for the histogram (Max. is 50 )             *
*    TNAME: Title of the histogram in the character string (upto 64    *
*            characters)                                               *
* ((Author))                                                           *
*    S.Kawabata    June '90                                            *
*                                                                      *
************************************************************************
                                                                        
      REAL*8 DXMIN, DXMAX                                               
      CHARACTER*(*) TNAME                                               
      CHARACTER*68  NAME                                                
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
*     COMMON/XHCNTL/ LOCK                                               
      COMMON/PLOTLU/ LU                                                 
                                                                        
      IF( NHIST .GE. NHS ) THEN                                         
*         IF( LOCK .NE. 0 ) RETURN                                      
          IF( LU .GT. 0 ) THEN                                          
              WRITE(LU,9000) NHIST,ID                                   
          ENDIF                                                         
 9000     FORMAT(1X,'Number of Histograms exceeds ',I3,' at ID = ',I3,  
     .            /1X,'This call is neglected.')                        
          RETURN                                                        
      ENDIF                                                             
                                                                        
      IEXIST = 0                                                        
      I  = IABS(MOD( ID, 13 )) + 1                                      
      NH = XHASH(1,I)                                                   
                                                                        
      IF( NH .EQ. 1 ) THEN                                              
            IF( ID .EQ. MAPL( 1, XHASH(2,I))) THEN                      
*               IF( LOCK .NE. 0 ) RETURN                                
                IEXIST = XHASH(2,I)                                     
            ENDIF                                                       
      ELSEIF( NH .GT. 1 ) THEN                                          
          DO 100 K = 2, NH+1                                            
            IF( ID .EQ. MAPL( 1, XHASH(K,I))) THEN                      
*               IF( LOCK .NE. 0 ) RETURN                                
                IEXIST = XHASH(K,I)                                     
                GO TO 110                                               
            ENDIF                                                       
  100    CONTINUE                                                       
  110    CONTINUE                                                       
      ENDIF                                                             
      XMIN  = DXMIN*1.0                                                 
      XMAX  = DXMAX*1.0                                                 
                                                                        
      IF( IEXIST .GT. 0 ) THEN                                          
          IF( LU .GT. 0 ) THEN                                          
              WRITE(LU,9100) ID                                         
          ENDIF                                                         
 9100     FORMAT(1X,'Histogram ID (',I3,' ) exists already.')           
          IP1    =  MAPL(2,IEXIST)                                      
          IF(( XMIN .EQ. BUFF(IP1))   .AND.                             
     .       ( XMAX .EQ. BUFF(IP1+1)) .AND.                             
     .       ( NBIN .EQ. IBUF(IP1+2)) )    THEN                         
               IF( LU .GT. 0 ) THEN                                     
                   WRITE(LU,9110)                                       
               ENDIF                                                    
 9110          FORMAT(1X,' This call is neglected.')                    
               RETURN                                                   
          ENDIF                                                         
          IF( LU .GT. 0 ) THEN                                          
              WRITE(LU,9120) ID,XMIN,XMAX,NBIN                          
          ENDIF                                                         
 9120     FORMAT(1X,'Histogram ( ID =',I3,' ) parameters are replaced', 
     .          /1X,'by the following new parameters :',                
     .          /1X,' XMIN(',E12.5,')  XMAX(',E12.5,' )  NBIN(',I4,' )')
      ENDIF                                                             
                                                                        
      IF((NHIST .GE. NHS) .AND. (ID .GT. 0) ) THEN                      
*         IF( LOCK .NE. 0 ) RETURN                                      
          IF( LU .GT. 0 ) THEN                                          
              WRITE(LU,9000) NHS,ID                                     
          ENDIF                                                         
         RETURN                                                         
      ENDIF                                                             
                                                                        
      IF(NBIN  .GT. 50 ) THEN                                           
         IF( LU .GT. 0 ) THEN                                           
             WRITE(LU,9200) NBIN,ID                                     
         ENDIF                                                          
 9200    FORMAT(1X,'Bin size (',I3,' )  exceeds 50 at ID =',I5,         
     .         /1X,' This call is neglected.')                          
         RETURN                                                         
      ENDIF                                                             
      IF(XMIN  .GE. XMAX ) THEN                                         
         IF( LU .GT. 0 ) THEN                                           
             WRITE(LU,9300) ID                                          
         ENDIF                                                          
 9300    FORMAT(1X,'Lower limit is larger than upper at ID =',I5,       
     .         /1X,' This call is neglected.')                          
         RETURN                                                         
      ENDIF                                                             
      IF(XHASH(1,I) .GE. NHS) THEN                                      
         IF( LU .GT. 0 ) THEN                                           
             WRITE(LU,9400) I                                           
         ENDIF                                                          
 9400    FORMAT(1X,I5,'-th Hash table overflow',                        
     .         /1X,' This call is neglected.')                          
         RETURN                                                         
      ENDIF                                                             
                                                                        
      IF( IEXIST .GT. 0 ) THEN                                          
          NHST     = IEXIST                                             
      ELSE                                                              
          NHIST        = NHIST + 1                                      
          XHASH(1,I)   = XHASH(1,I) + 1                                 
          K            = XHASH(1,I) + 1                                 
          XHASH(K,I)   = NHIST                                          
          NHST         = NHIST                                          
          IP1    = NW + 1                                               
          NW  = NW + 281                                                
          MAPL(1,NHST)  = ID                                            
          MAPL(2,NHST)  = IP1                                           
      ENDIF                                                             
         BUFF(IP1     ) = XMIN                                          
         BUFF(IP1 +  1) = XMAX                                          
         IBUF(IP1 +  2) = NBIN                                          
         DEV            = XMAX - XMIN                                   
         BUFF(IP1 +  3) = DEV/NBIN                                      
      IP2   = IP1 + 4                                                   
         MAPL(3,NHST)  = IP2                                            
      IP3   = IP1 + 264                                                 
         MAPL(4,NHST)  = IP3                                            
         IBUF(IP3)     = -1                                             
                                                                        
         I1   = IP3 + 1                                                 
         I2   = I1 + 15                                                 
         NAME = TNAME                                                   
         READ(NAME,9800) (BUFF(I),I=I1,I2)                              
 9800    FORMAT(16A4)                                                   
                                                                        
C                                                                       
 1000 CONTINUE                                                          
      RETURN                                                            
      END                                                               
C***********************************************************************
C*                                                                     *
C*=============================================                        *
C*    SUBROUTINE XHORDR( VAL, F2, ORDER, IORDR)                        *
C*=============================================                        *
C*((Function))                                                         *
C*    To resolve the real number VAL into mantester and exponent parts.*
C*  When VAL = 1230.0 is given, output are                             *
C*        F2 = 1.2  and ORDER = 4.0.                                   *
C*((Input))                                                            *
C*  VAL  : Real*4 value                                                *
C*((Output))                                                           *
C*  F2   : The upper two digits is given                               *
C*  ORDER: Order is given                                              *
C*  IORDR: Exponent is given                                           *
C*((Author))                                                           *
C*  S.Kawabata                                                         *
C*                                                                     *
C***********************************************************************
                                                                        
      SUBROUTINE XHORDR(VAL, F2, ORDER, IORDR)                          
                                                                        
      IF( VAL .NE. 0.0 ) THEN                                           
          ORDER    =  LOG10( VAL )                                      
          IORDR    =  INT( ORDER )                                      
          IF( ORDER .LT. 0.0 ) IORDR = IORDR - 1                        
          ORDER  = 10.0**IORDR                                          
          F2     = VAL/ORDER                                            
      ELSE                                                              
          IORDR  = 0                                                    
          ORDER  = 1.0                                                  
          F2    = 0.0                                                   
      ENDIF                                                             
                                                                        
      RETURN                                                            
      END                                                               
************************************************************************
*    =====================================                             *
      SUBROUTINE XHPLOT( LU, IFG, IHIST )                               
*    =====================================                             *
* ((Purpose))                                                          *
*      To print histograms for BASES and SPRING.                       *
* ((Input))                                                            *
*      IFG  : Flag which indicats whether this is called by BASES      *
*             or SPRING.  IFG = ( 0 / anyother) = ( By BASES/ SPRING)  *
*      IHIST: Serial number of the histogram                           *
*                                                                      *
* ((Author))                                                           *
*       S.Kawabata    June '90 at KEK                                  *
*     Last update     March '94                                        *
*                                                                      *
************************************************************************
                                                                        
      REAL*8         SCALLS,WGT,TI,TSI,TACC                             
      COMMON /BASE3/ SCALLS,WGT,TI,TSI,TACC,IT                          
                                                                        
      PARAMETER ( NHS = 50, NSC = 50 )                                  
      INTEGER*4 XHASH,DHASH,NHIST,MAPL,IFBASE,NSCAT,MAPD                
      COMMON/PLOTH/ XHASH(NHS+1,13),DHASH(NSC+1,14),IFBASE(NHS),        
     .              NHIST, MAPL(4,NHS),                                 
     .              NSCAT, MAPD(4,NSC),                                 
     .              NW                                                  
      COMMON /PLOTB/ IBUF( 281*NHS + 2527*NSC )                         
      REAL*4         BUFF( 281*NHS + 2527*NSC )                         
      EQUIVALENCE (IBUF(1),BUFF(1))                                     
                                                                        
      COMMON /BSCNTL/ INTV, IPNT, NLOOP, MLOOP                          
                                                                        
      REAL  VAL(0:51),VLOG(0:51),VERR(0:51)                             
      CHARACTER*50 CHARR,CHAR1                                          
      CHARACTER*52 SCALE                                                
      CHARACTER*1  BLNK,STAR,OO,AI,CN                                   
      DATA  YMAX / 50/                                                  
      DATA  BLNK /' '/, STAR /'*'/, OO /'O'/, AI /'I'/                  
                                                                        
      CN    = CHAR(12)                                                  
      IP3   = MAPL(4,IHIST)                                             
      IF(     IFG .EQ. 0 ) THEN                                         
            IF( IPNT .EQ. 0 ) THEN                                      
                WRITE(LU,9000)                                          
            ELSE                                                        
                WRITE(LU,9005) CN                                       
            ENDIF                                                       
 9000       FORMAT(/1H1)                                                
 9005       FORMAT(A1)                                                  
            WRITE(LU,9100) MAPL(1,IHIST),(BUFF(I),I=IP3+1,IP3+16)       
 9100       FORMAT(1X,'Histogram (ID =',I3,' ) for ',16A4)              
      ELSEIF( IFG .EQ. -10 ) THEN                                       
            IF( IPNT .EQ. 0 ) THEN                                      
                WRITE(LU,9000)                                          
            ELSE                                                        
                WRITE(LU,9005) CN                                       
            ENDIF                                                       
            WRITE(LU,9102) (BUFF(I),I=IP3+1,IP3+16)                     
 9102       FORMAT(5X,16A4)                                             
      ELSE                                                              
            IF( IPNT .EQ. 0 ) THEN                                      
                WRITE(LU,9000)                                          
            ELSE                                                        
                WRITE(LU,9005) CN                                       
            ENDIF                                                       
            WRITE(LU,9105) MAPL(1,IHIST),(BUFF(I),I=IP3+1,IP3+16)       
 9105       FORMAT(                                                     
     .      1X,'Additional Histogram (ID =',I3,' ) for ',16A4)          
      ENDIF                                                             
                                                                        
      IP1   = MAPL(2,IHIST)                                             
      XMIN  = BUFF(IP1)                                                 
      XMAX  = BUFF(IP1+1)                                               
      NXBIN = IBUF(IP1+2) + 1                                           
      DEV   = BUFF(IP1+3)                                               
      IP2   = MAPL(3,IHIST)                                             
                                                                        
      IF( IFG .EQ. 0 ) THEN                                             
C         NTOTAL     = SCALLS                                           
          FACT       = 1./(SCALLS*DEV)                                  
          IPF   = IP2 + 156                                             
          IPF2  = IPF + 52                                              
          VAL(0)     = BUFF(IPF)/SCALLS                                 
          VAL(NXBIN) = BUFF(IPF+NXBIN)/SCALLS                           
          VMAX       = FACT*BUFF(IPF+1)                                 
          VMIN       = VMAX                                             
          DO  50 I   = 1,NXBIN-1                                        
              TX     = BUFF(I+IPF)                                      
              NX     = IBUF(I+IP2)                                      
              VLS    = TX*FACT                                          
              IF( VMAX .LT. VLS ) VMAX = VLS                            
              IF( VMIN .GT. VLS ) VMIN = VLS                            
              VAL(I) = VLS                                              
              IF( NX .GT. 1 ) THEN                                      
                  DEV2   =  NX*BUFF(I+IPF2)-TX*TX                       
                  IF( DEV2 .LE. 0.0 ) THEN                              
                      VERR(I)= 0.0                                      
                  ELSE                                                  
                      VERR(I)= FACT*SQRT( DEV2/( NX-1 ))                
                  ENDIF                                                 
              ELSEIF( NX .EQ. 1 ) THEN                                  
                  VERR(I)= VLS                                          
              ELSE                                                      
                  VERR(I)= 0.0                                          
              ENDIF                                                     
                                                                        
   50     CONTINUE                                                      
      ELSE                                                              
          IPX   = IP2 + 52                                              
          VAL(0)     = BUFF(IPX)                                        
          VAL(NXBIN) = BUFF(IPX+NXBIN)                                  
          NTOTAL     = INT(VAL(0)) + INT(VAL(NXBIN))                    
          VMIN       = 0.0                                              
          VMAX       = VMIN                                             
          DO  55 I   = 1,NXBIN-1                                        
              VLS    = BUFF(I+IPX)                                      
              NTOTAL = INT(VLS) + NTOTAL                                
              IF( VMAX .LT. VLS ) VMAX = VLS                            
              VAL(I) = VLS                                              
              IF( VLS .GT. 0.0 ) THEN                                   
                  VERR(I) = SQRT(VLS)                                   
              ELSE                                                      
                  VERR(I) = 0.0                                         
              ENDIF                                                     
   55     CONTINUE                                                      
       ENDIF                                                            
***                                                                     
       IF( VMAX .EQ. 0.0 .AND. VMIN .EQ. 0.0) THEN                      
           V0 = VAL(0)                                                  
           VM = VAL(NXBIN)                                              
           IF( V0 .GE. 0.0 .AND. VM .GE. 0.0 ) THEN                     
               VMIN  = 0.0                                              
               IF( V0 .GT. VM  ) THEN                                   
                   VMAX = V0                                            
               ELSE                                                     
                   VMAX = VM                                            
               ENDIF                                                    
           ELSEIF( V0 .LT. 0.0 .AND. VM .LT. 0.0 ) THEN                 
               VMAX  = 0.0                                              
               IF( V0 .LT. VM ) THEN                                    
                   VMIN  = V0                                           
               ELSE                                                     
                   VMIN  = VM                                           
               ENDIF                                                    
           ELSEIF( V0 .GT. VM ) THEN                                    
               VMAX  = V0                                               
               VMIN  = VM                                               
           ELSE                                                         
               VMAX  = VM                                               
               VMIN  = V0                                               
           ENDIF                                                        
       ENDIF                                                            
***                                                                     
       IF( VMIN .GE. 0.0 ) THEN                                         
C//VV                                                                   
           IF( VMAX .GT. 0.0 ) THEN                                     
               VLMAX = LOG10(VMAX)                                      
           ELSE                                                         
               VLMAX = 2.0                                              
           ENDIF                                                        
C//                                                                     
           VLMIN = VLMAX                                                
           DO  60 I = 0,NXBIN                                           
               IF( VAL(I) .GT. 0.0 ) THEN                               
                   VLS   = LOG10( VAL(I) )                              
                   IF( I .GT. 0 .AND. I .LT. NXBIN ) THEN               
                       IF( VLS .LT. VLMIN ) VLMIN = VLS                 
                   ENDIF                                                
                   VLOG(I)  = VLS                                       
C//VV                                                                   
C              ELSE                                                     
C                  VLOG(I)  = 0.0                                       
               ENDIF                                                    
   60      CONTINUE                                                     
                                                                        
           IF( VLMIN .LT. 0.0) THEN                                     
               VXMIN = IFIX(VLMIN) - 1.0                                
           ELSE                                                         
               VXMIN = IFIX(VLMIN)                                      
           ENDIF                                                        
           VXMAX = VLMAX                                                
           IFLG  = 1                                                    
           CALL XHRNGE( IFLG, VXMIN, VXMAX, VLMIN, VLMAX, VLSTP )       
           UNITL = (VLMAX-VLMIN)/YMAX                                   
                                                                        
       ENDIF                                                            
                                                                        
       IFLG   = 0                                                       
       IF( VMAX .GT. 0.0 ) THEN                                         
           IF( VMIN .GE. 0.0 ) THEN                                     
               VXMAX  = 1.2*VMAX                                        
               VXMIN  = 0.0                                             
               CALL XHRNGE( IFLG, VXMIN, VXMAX, VMIN, VMAX, VSTP )      
           ELSE                                                         
               VXMAX  = 1.1*VMAX                                        
               VXMIN  = 1.1*VMIN                                        
               CALL XHRNGE( IFLG, VXMIN, VXMAX, VMIN, VMAX, VSTP )      
           ENDIF                                                        
       ELSE                                                             
          VXMAX  = 0.0                                                  
          VXMIN  = 1.1*VMIN                                             
          CALL XHRNGE( IFLG, VXMIN, VXMAX, VMIN, VMAX, VSTP )           
       ENDIF                                                            
                                                                        
       UNIT  = (VMAX-VMIN)/YMAX                                         
                                                                        
       CALL XHSCLE( IFLG, VMIN, VMAX, VSTP, UNIT, SCALE, CHAR1 )        
C                                                                       
C                                                                       
       IF( IFG .EQ. 0 ) THEN                                            
           WRITE(LU,9150)                                               
 9150      FORMAT(30X,'Linear Scale indicated by "*"')                  
           WRITE(LU,9200) SCALE                                         
 9200      FORMAT(1X,'    x      d(Sigma)/dx    ',A52)                  
           WRITE(LU,9250) CHAR1                                         
 9250      FORMAT(1X,                                                   
     .                '+-------+------------------+',                   
     .           A50 )                                                  
       ELSE                                                             
             WRITE(LU,9210) NTOTAL                                      
 9210        FORMAT(1X,'Total =',I10,' events',                         
     .        3X,'"*" : No. of events in Linear scale.')                
             WRITE(LU,9205) SCALE                                       
 9205        FORMAT(1X,'   x      Lg(dN/dx)  dN/dx',A52)                
             WRITE(LU,9251) CHAR1                                       
 9251        FORMAT(1X,                                                 
     .             '+-------+----------+-------+',                      
     .       A50 )                                                      
       ENDIF                                                            
                                                                        
       VX    = ABS(XMAX)                                                
       XM    = ABS(XMIN)                                                
       IF( XM .GT. VX ) VX = XM                                         
                                                                        
       CALL XHORDR( VX, F2, ORD, IORD )                                 
                                                                        
       IF( VMIN .LT. 0.0 ) THEN                                         
           V1    = VMIN                                                 
           NUMBL = 1                                                    
           DO 150 I = 1, 80                                             
              V2    = V1 + UNIT                                         
              IF( V1 .LE. 0.0 .AND. V2 .GE. 0.0 ) THEN                  
                  NUMBL  = I                                            
                  GO TO 180                                             
              ENDIF                                                     
              V1    = V2                                                
  150      CONTINUE                                                     
       ENDIF                                                            
                                                                        
  180  DO 300 I = 0,NXBIN                                               
          VX   = VAL(I)                                                 
          IF( VMIN .GE. 0.0 ) THEN                                      
              IF( VX .GT. 0.0 ) THEN                                    
                  NUMBL  = (VLOG(I) - VLMIN)/UNITL + 1.0                
                  NUMB   = VX/UNIT + 1.0                                
              ELSE                                                      
                  NUMBL  = 0                                            
                  NUMB   = 0                                            
              ENDIF                                                     
              IF( NUMB .GT. 50 ) NUMB = 50                              
              IF( NUMBL.GT. 50 ) NUMBL= 50                              
              DO 200 K = 1,50                                           
                 IF(     ( K .GT. NUMBL) .AND. (K .GT. NUMB ) ) THEN    
                           IF( K .EQ. 50 ) THEN                         
                               CHARR(K:K) = AI                          
                           ELSE                                         
                               CHARR(K:K) = BLNK                        
                           ENDIF                                        
                 ELSEIF( ( K .LE. NUMBL) .AND. (K .GT. NUMB )) THEN     
                           CHARR(K:K) = OO                              
                 ELSEIF( ( K .GT. NUMBL) .AND. (K .LE. NUMB )) THEN     
                           CHARR(K:K) = STAR                            
                 ELSEIF( ( K .LE. NUMBL) .AND. (K .LE. NUMB)) THEN      
                           IF( NUMB .GE. NUMBL ) THEN                   
                               CHARR(K:K) = OO                          
                           ELSE                                         
                               CHARR(K:K) = STAR                        
                           ENDIF                                        
                 ENDIF                                                  
  200         CONTINUE                                                  
          ELSE                                                          
                                                                        
              V1          = VMIN                                        
              NHIG        = 1                                           
              DO 220  J = 1, 50                                         
                 V2     = V1 + UNIT                                     
                 IF( VX .GE. V1 .AND. VX .LT. V2 ) THEN                 
                     NHIG   = J                                         
                     GO TO 240                                          
                 ENDIF                                                  
                 V1    = V2                                             
  220         CONTINUE                                                  
  240         NLOW   = NUMBL                                            
              IF( NHIG .LT. NLOW) THEN                                  
                  NX    = NHIG                                          
                  NHIG  = NLOW                                          
                  NLOW  = NX                                            
              ENDIF                                                     
                                                                        
              DO 250 K = 1, 49                                          
                 IF(     K .EQ. NUMBL ) THEN                            
                         CHARR(K:K) = AI                                
                 ELSEIF( K .GT. NHIG ) THEN                             
                         CHARR(K:K) = BLNK                              
                 ELSEIF( K .LT. NLOW ) THEN                             
                         CHARR(K:K) = BLNK                              
                 ELSE                                                   
                     IF( K .EQ. NHIG .AND. K .EQ. NLOW) THEN            
                         CHARR(K:K) = AI                                
                     ELSE                                               
                         CHARR(K:K) = STAR                              
                     ENDIF                                              
                 ENDIF                                                  
  250         CONTINUE                                                  
              CHARR(50:50) = AI                                         
          ENDIF                                                         
                                                                        
          IF( IFG .EQ. 0 ) THEN                                         
                                                                        
              NX     = IBUF(I+IP2)                                      
              VX     = VAL(I)                                           
              VX1    = VX                                               
              IF( VX .LT. 0.0 ) VX1 = -VX                               
                                                                        
                                                                        
              IF( I .EQ. 0 .OR. I. EQ. NXBIN ) THEN                     
                  CALL XHORDR( VX1, F2, ORDER, IORDR )                  
                  F2     = VX/ORDER                                     
                  WRITE(LU,9300) IORD,F2,IORDR,CHARR                    
 9300             FORMAT(1X,'I  E',I3,' I',F6.3,8X,'E',I3,              
     .                                     'I',A50)                     
              ELSE                                                      
                  XM    = (XMIN + DEV*(I-1))/ORD                        
                  VE     = VERR(I)                                      
                  IF( VE .GT. VX1 ) THEN                                
                      CALL XHORDR(  VE, F2, ORDER, IORDR )              
                  ELSE                                                  
                      CALL XHORDR( VX1, F2, ORDER, IORDR )              
                  ENDIF                                                 
                  F2   = VX/ORDER                                       
                  VE   = VE/ORDER                                       
                  WRITE(LU,9340) XM,F2,VE,IORDR,CHARR                   
 9340             FORMAT(1X,'I', F6.3,' I',F6.3,'+-',F5.3,' E',I3,      
     .                                    'I',A50)                      
             ENDIF                                                      
          ELSE                                                          
             NX  = VAL(I)                                               
             VX     = VAL(I)                                            
             VX1    = VX                                                
             IF( VX .LT. 0.0 ) VX1 = -VX                                
             CALL XHORDR( VX1, F2, ORDER, IORDR )                       
             F2     = VX/ORDER                                          
             IF( I .EQ. 0 .OR. I .EQ. NXBIN ) THEN                      
                 WRITE(LU,9400) IORD,F2,IORDR,NX,CHARR                  
 9400            FORMAT(1X,'I  E',I3,' I',F6.3,'E',I3,'I',              
     .                                            I7,'I',A50)           
             ELSE                                                       
                   XM  = (XMIN + DEV*(I - 1))/ORD                       
                   WRITE(LU,9440) XM,F2,IORDR,NX,CHARR                  
 9440              FORMAT(1X,'I',F6.3,' I',F6.3,'E',I3,'I',             
     .                                        I7,'I',A50)               
             ENDIF                                                      
          ENDIF                                                         
  300  CONTINUE                                                         
                                                                        
       IF( VMIN .GE. 0.0 ) THEN                                         
           CALL XHSCLE( 1, VLMIN, VLMAX, VLSTP, UNITL, SCALE, CHAR1)    
           VXMIN  = 10**VLMIN                                           
       ENDIF                                                            
                                                                        
       IF( IFG .EQ. 0 ) THEN                                            
           WRITE(LU,9250) CHAR1                                         
           IF( VMIN .GE. 0.0 ) THEN                                     
               WRITE(LU,9200) SCALE                                     
               WRITE(LU,9260)                                           
 9260          FORMAT(30X,'Logarithmic Scale indicated by "O"')         
           ELSE                                                         
               WRITE(LU,9200) SCALE                                     
           ENDIF                                                        
       ELSE                                                             
           WRITE(LU,9251) CHAR1                                         
           WRITE(LU,9205) SCALE                                         
           WRITE(LU,9360)                                               
 9360      FORMAT(30X,'"O" : No. of Events in Log. scale.')             
       ENDIF                                                            
                                                                        
C                                                                       
  500  CONTINUE                                                         
                                                                        
      RETURN                                                            
      END                                                               
C***********************************************************************
C*                                                                     *
C*============================================================         *
C*  SUBROUTINE XHRNGE( IFLG, VMIN, VMAX, VTMIN, VTMAX, STEP)           *
C*============================================================         *
C*((Function))                                                         *
C*    Determine the vertical range of the histogram.                   *
C*((Input))                                                            *
C*    IFLG   : Flag which indicates whether logarithmic or linear      *
C*             scale.  IFLG = ( 1 / any other ) = ( log / linear )     *
C*    VMIN,VMAX : Minimum and maximum values of vertical window.       *
C*((Output))                                                           *
C*    VTMIN,VTMAX : Minimum and maxmum values of optimized vertical    *
C*                  window.                                            *
C*    STEP   : step of scale for the optimized vertical window         *
C*((Author))                                                           *
C*    S.Kawabata    Oct '85  at KEK                                    *
C*                                                                     *
C***********************************************************************
C                                                                       
      SUBROUTINE XHRNGE( IFLG, VMIN, VMAX, VTMIN, VTMAX, STEP)          
C                                                                       
C     IFLG =    1 : Log scale                                           
C            other: Linear scale                                        
C                                                                       
      PARAMETER ( NBIN  = 25 )                                          
      REAL    WIND(NBIN),STP1(NBIN),STP2(NBIN)                          
C                                                                       
      DATA WIND/                                                        
     .   1.00, 1.10, 1.20, 1.30, 1.40, 1.50, 1.60, 1.80, 2.00,  2.20,   
     .   2.50, 2.70, 3.00, 3.30, 3.60, 4.00, 4.50, 5.00, 5.50,  6.00,   
     .   6.50, 7.00, 8.00, 9.00, 10.0/                                  
*     DATA STP1/                                                        
*    .   0.20, 0.22, 0.30, 0.26, 0.28, 0.30, 0.32, 0.36, 0.40,  0.44,   
*    .   0.50, 0.54, 0.60, 0.66, 0.60, 0.80, 0.90, 1.00, 1.10,  1.00,   
*    .   1.30, 1.00, 1.60, 1.80, 2.00/                                  
      DATA STP1/                                                        
     .   0.250,0.275,0.300,0.325,0.350,0.375,0.400,0.450,0.500,0.550,   
     .   0.625,0.675,0.750,0.825,0.900,1.000,1.125,1.250,1.375,1.500,   
     .   1.625,1.750,2.000,2.250,2.500/                                 
      DATA STP2/                                                        
     .   1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00,  1.00,   
     .   1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00,  2.00,   
     .   2.00, 2.00, 2.00, 2.00, 2.00/                                  
C                                                                       
          XMAX   = VMAX                                                 
          XMIN   = VMIN                                                 
          IFLAG  = IFLG                                                 
          IF( IFLG .NE. 1 .AND. VMIN .LT. 0.0 ) THEN                    
              IF( VMAX .LE. 0.0 )THEN                                   
                  IFLAG  = 2                                            
                  XMAX  = - VMIN                                        
                  XMIN  =  0.0                                          
              ELSE                                                      
                  AVMIN  = - VMIN                                       
                  XMIN  =0.0                                            
                  IF( VMAX .GE. AVMIN ) THEN                            
                      IFLAG  = 3                                        
                      XMAX  = VMAX                                      
                      XMIN1 = AVMIN                                     
                  ELSE                                                  
                      IFLAG  = 4                                        
                      XMAX  = AVMIN                                     
                      XMIN1 = VMAX                                      
                  ENDIF                                                 
              ENDIF                                                     
          ENDIF                                                         
          DSCALE = XMAX - XMIN                                          
          CALL XHORDR( DSCALE, DSF2, DSORDR, IORD)                      
                                                                        
          DO 100 I = 2, 25                                              
             IF( DSF2 .GE. WIND(I-1) .AND.                              
     .           DSF2 .LE. WIND( I )       ) GO TO 200                  
 100      CONTINUE                                                      
          I = 25                                                        
C                                                                       
 200      CONTINUE                                                      
                                                                        
          XMAX = WIND(I)*DSORDR + XMIN                                  
          IF(     DSORDR .GE. 10.0 .OR. IFLG .NE. 1 ) THEN              
                  STEP1  = STP1(I)                                      
                  STEP   = STEP1*DSORDR                                 
          ELSE                                                          
                  STEP1  = STP2(I)                                      
                  STEP   = STEP1                                        
          ENDIF                                                         
                                                                        
          IF(     IFLAG .LE. 1 ) THEN                                   
                  VTMAX  = XMAX                                         
                  VTMIN  = XMIN                                         
          ELSEIF( IFLAG .EQ. 2 ) THEN                                   
                  VTMAX  = XMIN                                         
                  VTMIN  = -XMAX                                        
          ELSE                                                          
                                                                        
                  XPLUS   = 0.0                                         
                  DO 300 J = 1, 10                                      
                     XPLUS = XPLUS + STEP                               
                     IF( XPLUS .GT. XMIN1 ) GO TO 400                   
 300              CONTINUE                                              
 400              XMIN = XPLUS                                          
                  XMAX = XMAX                                           
                  IF( IFIX((WIND(I)+0.1)/STEP1)+J .GT. 7 ) THEN         
                      STEP = 2.0*STEP                                   
                  ENDIF                                                 
                  IF( IFLAG .EQ. 3 ) THEN                               
                      VTMAX  = XMAX                                     
                      VTMIN  = -XMIN                                    
                  ELSE                                                  
                      VTMAX  = XMIN                                     
                      VTMIN  = -XMAX                                    
                  ENDIF                                                 
          ENDIF                                                         
C                                                                       
      RETURN                                                            
      END                                                               
************************************************************************
*    =========================================================         *
      SUBROUTINE XHSCLE( IFLG,VMIN,VMAX,VSTP,UNIT,SCALE,CHAR)           
*    =========================================================         *
* ((Function))                                                         *
*     Determine the vertical scale and make it's format                *
* ((Input))                                                            *
*     IFLG   : Flag which indicates whether logarithmic or linear      *
*              scale.  IFLG = ( 1 / any other ) = ( log / linear )     *
*     VMIN,VMAX : Minimum and maximum values of vertical window.       *
*     VSTEP  : Step of unit scale                                      *
*     UNIT   : Unit of one mark *(or o)                                *
* ((Output))                                                           *
*     NSCL   : Number of scale mark                                    *
*     NBLK   : Number of blanks between scale marks                    *
*     CHAR   : Format of scale                                         *
* ((Author))                                                           *
*     S.Kawabata    Oct '85  at KEK                                    *
*                                                                      *
************************************************************************
                                                                        
      CHARACTER*50 CHAR                                                 
      CHARACTER*52 SCALE                                                
      CHARACTER*1 PLUS,MINUS                                            
      DATA PLUS /'+'/, MINUS /'-'/                                      
                                                                        
C     IFLG =    1 : Log scale                                           
C            other: Linear scale                                        
      WRITE(SCALE,9000)                                                 
 9000 FORMAT(5('          '))                                           
      IF( IFLG .EQ. 1 ) THEN                                            
          SC  = 10.**VMIN                                               
      ELSE                                                              
          SC  = VMIN                                                    
      ENDIF                                                             
                                                                        
      WRITE(SCALE(1:8),9100) SC                                         
 9100 FORMAT(1P,E8.1)                                                   
      I2    = 8                                                         
      STV   = VSTP + VMIN                                               
      STV1  = STV                                                       
      VAL1  = VMIN                                                      
      CHAR(50:50) = PLUS                                                
      DO  100   I = 1, 49                                               
          VAL2    = VAL1 + UNIT                                         
          IF( STV .GE. VAL1 .AND. STV .LT. VAL2 ) THEN                  
              CHAR(I:I)  = PLUS                                         
              NSCL       = NSCL + 1                                     
              IF( IFLG .EQ. 1 ) THEN                                    
                 SC          = 10.0**STV                                
              ELSE                                                      
                 IF(     STV1 .EQ. 0.0 ) THEN                           
                         SC           = STV                             
                 ELSEIF( ABS(STV/STV1) .LT. 1.E-2 ) THEN                
                         SC           = 0.0                             
                 ELSE                                                   
                         SC          = STV                              
                 ENDIF                                                  
                 STV1       = STV                                       
              ENDIF                                                     
              STV  = STV + VSTP                                         
              IF( I2 .LT. I-1 ) THEN                                    
                  I2   = I + 8                                          
                  IF( I2 .LE. 52 ) THEN                                 
                      WRITE(SCALE(I+1:I2),9100) SC                      
                  ENDIF                                                 
              ENDIF                                                     
          ELSE                                                          
              CHAR(I:I) = MINUS                                         
          ENDIF                                                         
          VAL1      = VAL2                                              
  100 CONTINUE                                                          
C                                                                       
      IF( NSCL .EQ. 0 ) THEN                                            
          IF( IFLG .EQ. 1 ) THEN                                        
             SC       = 10.0**VMAX                                      
          ELSE                                                          
             SC       = VMAX                                            
          ENDIF                                                         
          WRITE(SCALE(44:52),9100) SC                                   
      ENDIF                                                             
C                                                                       
      RETURN                                                            
      END                                                               
+EOD
+DECK,ISARES,IF=ISATOOLS      
      SUBROUTINE ISARES(IPRT)

      IMPLICIT NONE
      REAL*8 AQI(2,6),BQI(2,6),MI(2,2,6),NL(4),NLP(2),T3Q(6),EQ(6),MQ(6)
      REAL*8 FQQ(6),FQH(6),msq(2,6),cz(2),cq(2,6),rq(2,6),rq1(2,6)
      REAL*8 FNTQ(2,3),GQ(6),CSQ(2,2,6),THETAQ(6),SJ(2),ATQ(6)
      REAL*8 MH(2),DQ(6),delq(2,3),PDF(2,-5:5),mnucl(2),mrnucl(2)
      REAL*8 FNUCL(6,2),FNTG(2)
     
      
      REAL*8 SIN2W,PI,ALPE,SW,CW,MW,MZ,E,G,G1,MNE,SA,CA,BETA,SB,
     $       CB,CAPB,SAPB,MU,MSUSY,QR,ALPS,GEVTOPBN,TQT,BD,B1D,
     $       BS,B1S,B2S,BGLU,ap,an,XMIN,XMAX,XD,Ctq5Pdf,X,
     $       SIGMA0PROT,SIGMA0NEUT,SSALFS,CMD,XJ,
     $       SIGMASPROT,SIGMASNEUT,thetaw,GPX

      INTEGER I,II,IQ,IX,JH,IN,J,kk
      
      INTEGER IPRT
      
      

      common/check/p1,p2
      real*8 p1,p2
C     include 'sugmg.h'
C     include 'sspar.h' 
C     include 'sssm.h' 
+CDE,SUGMG
+CDE,SSPAR
+CDE,SSSM

c-----ISARES OUTPUT---------------------------
      
      COMMON/SUGRES/SIGMA0PROT,SIGMA0NEUT,SIGMASPROT,SIGMASNEUT
       
      save/SUGRES/
c----------------------------------------------
ccccccccccccccccccc CONSTANTS ccccccccccccccccccccccccccccc
   
      PI=DACOS(-1d0)
       
      GPX=SQRT(0.6)*GSS(1)
      SIN2W=GPX**2/(GSS(2)**2+GPX**2)
      thetaw=asin(sqrt(SIN2W))
      ALPE=1d0/(4d0*PI/GSS(2)**2/SIN2W)
      
      
      SW=SQRT(SIN2W)
      CW=sqrt(1d0-SW**2)
      MW=80.419d0
      MZ=MW/CW
  
c      print *, SIN2W, ALPE,MW,MZ
       
      E=SQRT(4*PI*ALPE)
      G =E/SW
      G1=E/CW
      MNE=ABS(MSS(23))
      SA=SIN(-ALFAH)
      CA=COS(-ALFAH)
      MH(2)=MSS(29)
      MH(1)=MSS(30)
      BETA=ATAN(1d0/RV2V1)
      SB=SIN(BETA)
      CB=COS(BETA)
      CAPB=COS(-alfah+beta)
      SAPB=SIN(-alfah+beta)
      MU=GSS(25)
 
      mnucl(1)=0.938d0
      mnucl(2)=0.930d0
      mrnucl(1)=mnucl(1)*mne/(mne+mnucl(1))
      mrnucl(2)=mnucl(2)*mne/(mne+mnucl(2))
      
      
      MSUSY=(MSS(2)+MSS(3)+MSS(4)+MSS(5)
     $       +MSS(10)+MSS(11)+MSS(12)+MSS(13))/8d0

      QR=sqrt(MSUSY**2-MSS(23)**2)
    
      ALPS=SSALFS(QR**2)
      
      GEVTOPBN= 0.3893796623*1.E+09      

c-------------------------------------------------------------c

      FNTQ(1,1)=0.020
      FNTQ(1,2)=0.026
      FNTQ(1,3)=0.118
      
      FNTQ(2,1)=0.014
      FNTQ(2,2)=0.036
      FNTQ(2,3)=0.118
      
      FNTG(1)=1d0-FNTQ(1,1)-FNTQ(1,2)-FNTQ(1,3)
      FNTG(2)=1d0-FNTQ(2,1)-FNTQ(2,2)-FNTQ(2,3)
      
      delq(1,1)= 0.78
      delq(1,2)=-0.48
      delq(1,3)=-0.15
      
      delq(2,1)=-0.48
      delq(2,2)= 0.78
      delq(2,3)=-0.15
 
cccccccccccccccccc QUARK MASS           ccccccccccccccccccccccc
      mq(1)=AMUP
      mq(2)=AMDN
      mq(3)=AMST
      mq(4)=AMCH
      mq(5)=MBQ
      mq(6)=MTQ
c      print *,'QUARK MASSES:',(mq(kk),kk=1,6)
c-------------------------------------------------------------c

cccccccccccccccccc SQUARK MASS           ccccccccccccccccccccccc
      DO I=1,6
        msq(1,I)=mss(2*I  )
        msq(2,I)=mss(2*I+1)
      ENDDO
c-------------------------------------------------------------c

     
cccccccccccccccccc SQUARK MIXING ANGLE ccccccccccccccccccccccc
      DO I=1,4       ! u d s c b t
        MI(1,1,I)=1
        MI(1,2,I)=0
        MI(2,1,I)=0
        MI(2,2,I)=1
	THETAQ(I)=0
	ATQ(I)=0
      ENDDO
      ATQ(5)=AAB
      ATQ(6)=AAT
      THETAQ(5)=-THETAB
      THETAQ(6)=-THETAT
      MI(1,1,5)=  COS(THETAB)
      MI(1,2,5)=  SIN(THETAB)
      MI(2,1,5)= -SIN(THETAB)
      MI(2,2,5)=  COS(THETAB)
      MI(1,1,6)=  COS(THETAT)
      MI(1,2,6)=  SIN(THETAT)
      MI(2,1,6)= -SIN(THETAT)
      MI(2,2,6)=  COS(THETAT)
c-------------------------------------------------------------c
cccccccccccccccc NEUTRALINO MIXING MATRIX, CZ ccccccccccccccccccccc
     
      NL(1)=  ZMIXSS(4,1)
      NL(2)=  ZMIXSS(3,1)
      NL(3)= -ZMIXSS(2,1)
      NL(4)= -ZMIXSS(1,1)
           
      NLP(1) = NL(1)*CW+NL(2)*SW
      NLP(2) =-NL(1)*SW+NL(2)*CW
      
      CZ(2)= 1./2.*(G*NL(2)-G1*NL(1))*(NL(3)*SA+NL(4)*CA)
      CZ(1)= 1./2.*(G*NL(2)-G1*NL(1))*(NL(4)*SA-NL(3)*CA)
c      print *,'line 130:',CZ(1),CZ(2)
      
c------------------------------------------------------------c

ccccccccccccccccc T3Q, CQ      ccccccccccccccccccccccccccccccccccc
       
      DO I=1,6
        IF((2*(I/2).eq.I.or.I.eq.1).and.I.ne.2) THEN 
	  T3Q(I)= 1d0/2d0
	  EQ(I) = 2d0/3d0
	  RQ(1,I)= -sa/sb
	  RQ(2,I)= -ca/sb
	  RQ1(1,I)=-CA/SB
	  RQ1(2,I)= SA/SB
	ELSE
	  T3Q(I)= -1d0/2d0
	  EQ(I) = -1d0/3d0
	  RQ(1,I)= -ca/cb
	  RQ(2,I)=  sa/cb
	  RQ1(1,I)=-SA/CB
	  RQ1(2,I)=-CA/CB
	ENDIF
	
	CQ(1,I)=g/2d0/MW*RQ(1,I)
	CQ(2,I)=g/2d0/MW*RQ(2,I)
c        print *,'line 156:',CQ(1,I),CQ(2,I)
	
	SJ(1)=-CAPB
	SJ(2)= SAPB
	
	DO J=1,2
	  CSQ(J,1,I)=
     $    G*MZ/CW*SJ(J)*(T3Q(I)*cos(thetaq(I))**2
     $    -eq(i)*sw**2*cos(2.*thetaq(I)))
     $    +G*mq(I)**2/MW*RQ(J,I)
     $    -G*MQ(I)*SIN(2.*THETAQ(I))/2./MW*(mu*RQ1(J,I)-ATQ(I)*RQ(J,I))

	  CSQ(J,2,I)=
     $    G*MZ/CW*SJ(J)*(T3Q(I)*sin(thetaq(I))**2
     $    +eq(i)*sw**2*cos(2.*thetaq(I)))
     $    +G*mq(I)**2/MW*RQ(J,I)
     $    +G*MQ(I)*SIN(2.*THETAQ(I))/2./MW*(mu*RQ1(J,I)-ATQ(I)*RQ(J,I))
        ENDDO
	
	
      ENDDO
c------------------------------------------------------------c

ccccccccccccccccc AQI , BQI , FQQ, FQH , GQ  ccccccccccccccccccccccccccccccccccc
      DO IQ=1,6
        FQQ(IQ)=0d0
	FQH(IQ)=0d0
	GQ (IQ)=0d0
	DQ(IQ) =0d0
 
        DO II=1,2
 
        IX=3
        IF((2*(IQ/2).eq.IQ.or.IQ.eq.1).and.IQ.ne.2) IX=4
      
      AQI(II,IQ)  =1d0/sqrt(2d0)*(
     $   -MI(II,1,IQ)*(
     $               E*EQ(IQ)*NLP(1)+G/CW*NLP(2)*(T3Q(IQ)-EQ(IQ)*SW**2) 
     $               +G*MQ(IQ)/2./MW*NL(IX) )
     $   +MI(II,2,IQ)*(
     $               E*EQ(IQ)*NLP(1)-G/CW*NLP(2)*eq(IQ)*SW**2
     $               -G*MQ(IQ)/2./MW*NL(IX)
     $                )
     $                          )
     
c      print *,'aqi', II,IQ,AQI(II,IQ),MI(II,2,IQ),
c     $   -MI(II,1,IQ)*(
c     $               E*EQ(IQ)*NLP(1)+G/CW*NLP(2)*(T3Q(IQ)-EQ(IQ)*SW**2) 
c     $               +G*MQ(IQ)/2./MW*NL(IX) ),
c     $    MI(II,2,IQ)*(
c     $               E*EQ(IQ)*NLP(1)-G/CW*NLP(2)*eq(IQ)*SW**2
c     $               -G*MQ(IQ)/2./MW*NL(IX)
c     $                )
     
     
      BQI(II,IQ)  =1./sqrt(2.)*(
     $   -MI(II,1,IQ)*(
     $               E*EQ(IQ)*NLP(1)+G/CW*NLP(2)*(T3Q(IQ)-EQ(IQ)*SW**2) 
     $               -G*MQ(IQ)/2./MW*NL(IX) )
     $   +MI(II,2,IQ)*(
     $               -E*EQ(IQ)*NLP(1)+G/CW*NLP(2)*eq(IQ)*SW**2
     $               -G*MQ(IQ)/2./MW*NL(IX)
     $                )
     $                          )
        
	
        FQQ(IQ)=FQQ(IQ)+ 
     $     (-1d0/4d0)*(AQI(II,IQ)**2-BQI(II,IQ)**2)/
     $                  (msq(II,IQ)**2-(mne+mq(iq))**2)
  
c       PRINT *,'FQQ',(-1d0/4d0)*(AQI(II,IQ)**2-BQI(II,IQ)**2)/
c     $  		(msq(II,IQ)**2-(mne+mq(iq))**2),
c     $  	       AQI(II,IQ),BQI(II,IQ),IQ,II

c  c     print *,'line 214', AQI(II,IQ),BQI(II,IQ),
c  c   $        msq(II,IQ)**2-(mne+mq(iq))**2,msq(II,IQ),mq(iq), II,IQ
     
         FQH(IQ)=FQH(IQ)+
     $    MQ(IQ)*CZ(II)*CQ(II,IQ)/MH(II)**2
c      print *,'FQH',FQH(IQ),MQ(IQ),CZ(II),CQ(II,IQ),MH(II)
     
     
        GQ(IQ)=GQ(IQ)+ 
     $     (-1d0/4d0)*(AQI(II,IQ)**2+BQI(II,IQ)**2)/
     $                  (msq(II,IQ)**2-(mne+mq(iq))**2)**2
     
        DQ(IQ)=DQ(IQ)+
     $     (1d0/4d0)*(AQI(II,IQ)**2+BQI(II,IQ)**2)/
     $                  (msq(II,IQ)**2-(mne+mq(iq))**2)
       
       
c	if(IQ.le.3)   print *,'aq,bq', II,IQ,aqi(II,IQ),bqi(II,IQ)
	ENDDO
	DQ(IQ)=DQ(IQ)-G**2/4d0/MW**2*(NL(4)**2-NL(3)**2)/2d0*T3Q(IQ)
c	if(IQ.le.3)   print *,'IQ,DQ',IQ,DQ(IQ)	
      ENDDO
c------------------------------------------------------------c

cccccccccccccccccccccc gluon partccccccccccccccccccccccccccccccccccc      
       TQT=0d0
       BD =0d0
       BS=0d0
       B1D=0d0
       B1S=0d0
       B2S=0d0
c          print *,B1S

c      print *,((AQI(II,IQ),II=1,2),IQ=1,6)
    
       DO IQ=1,6
	DO II=1,2
          
	  DO JH=1,2
	    TQT=TQT+CZ(JH)/MH(JH)**2*
     $              CSQ(JH,II,IQ)/MSQ(II,IQ)**2/96d0/PI
          ENDDO
	  
	  BD =BD+(AQI(II,IQ)**2-BQI(II,IQ)**2)*MQ(IQ)*
     $            CMD(1,MSQ(II,IQ),MQ(IQ),MNE)/32d0/PI	  
	  BS =BS+(AQI(II,IQ)**2+BQI(II,IQ)**2)*MNE*
     $            CMD(2,MSQ(II,IQ),MQ(IQ),MNE)/32d0/PI
     
     
     	  
	  B1D=B1D+(AQI(II,IQ)**2-BQI(II,IQ)**2)*MQ(IQ)*
     $            CMD(3,MSQ(II,IQ),MQ(IQ),MNE)/12d0/PI	  
	    
         	
     
	  B1S=B1S+(AQI(II,IQ)**2+BQI(II,IQ)**2)*MNE*
     $             CMD(4,MSQ(II,IQ),MQ(IQ),MNE)/12d0/PI	
     
c       print *,'b1s',
c     $ II,IQ,CMD(4,MSQ(II,IQ),MQ(IQ),MNE) ,p1,p2

     

       
	  B2S=B2S+(AQI(II,IQ)**2+BQI(II,IQ)**2)*
     $             CMD(5,MSQ(II,IQ),MQ(IQ),MNE)/48d0/PI
          
        ENDDO
      ENDDO
      	
      
      BGLU=-TQT+BD+BS-MNE/2d0*B2S-MNE**2/4d0*(B1D+B1S)
      
c      print *,'BGLU',TQT
       
      ap=0d0
      an=0d0
      DO IQ=1,3
        AP=AP+DQ(IQ)*delq(1,IQ)/sqrt(2d0)
        AN=AN+DQ(IQ)*delq(2,IQ)/sqrt(2d0)
c 	print *,DQ(IQ),delq(1,IQ),delq(2,IQ),ap,an,IQ
      ENDDO
c------------------------------------------------------------c
      
ccccccccccccccccccccc STRUCTURE FUNCTION ccccccccccccccccccccccccccc
CC      Call SetCtq5(3)
      XMIN=1.5d-05
      XMAX=0.999d0
      XD  =(XMAX-XMIN)/10000d0
      DO IQ=-5,5,1
        PDF(1,IQ)=0d0
        PDF(2,IQ)=0d0
        DO I=1,10001
	  X=XMIN+XD*(I-1d0)
          PDF(1,IQ)=PDF(1,IQ)+X*Ctq5Pdf(IQ, X, QR,IPRT)*XD
	ENDDO
        PDF(2,IQ)=PDF(1,IQ)
      ENDDO   
      PDF(2,1) =PDF(1,2)
      PDF(2,2) =PDF(1,1)
      PDF(2,-1)=PDF(1,-2)
      PDF(2,-2)=PDF(1,-1)
c------------------------------------------------------------c

cccccccccccccccccccccc  PARTS OF FN  ccccccccccccccccccccccccccccccc      
      DO IN=1,2
      FNUCL(1,IN)=0.
      FNUCL(2,IN)=0.
      FNUCL(3,IN)=0.
      FNUCL(4,IN)=0.
      FNUCL(5,IN)=0.
        DO IQ=1,3
          FNUCL(1,IN)=FNUCL(1,IN)+ FNTQ(IN,IQ)/MQ(IQ)*
     $         (FQQ(IQ)+FQH(IQ)-mq(IQ)*mne*GQ(IQ)/2d0)
c          print *, 'FQQ', IN,IQ, FNTQ(IN,IQ), FQQ(IQ),FQH(IQ), GQ(IQ)
        ENDDO
	
c	print *,'part1',FNUCL(1,IN)
	DO  IQ=4,6
          FNUCL(2,IN)=FNUCL(2,IN)+2./27.*FNTG(IN)*FQH(IQ)/MQ(IQ)
	ENDDO
c	print *,'part2',FNUCL(2,IN)
	
	DO IQ=1,5
	  FNUCL(3,IN)=FNUCL(3,IN) -3./2.*MNE*GQ(IQ)*
     $    (PDF(IN,IQ)+PDF(IN,-IQ))
c          print *,'GQ(IQ)',GQ(IQ),IQ
        ENDDO
c	print *,'part3',FNUCL(3,IN)
	
	FNUCL(4,IN)= -8d0*PI/9d0*BGLU*FNTG(IN)
c	print *,'part4',FNUCL(4,IN),BGLU,FNTG(IN),IN
	
	FNUCL(5,IN)=  3d0/2d0*ALPS*MNE*
     $    (B2S+1d0/2d0*MNE*(B1D+B1S))*PDF(IN,0)
c 	print *,'part5',FNUCL(5,IN),IN,ALPS,
c     $  B2S,b1d,b1s,PDF(IN,0)
    
     
	
c        print *,'***** FNUCL**',IN,'******'
c        print *,(FNUCL(kk,IN),KK=1,5)
c        print *,'**************************'
	
      ENDDO
      
     
      DO IN=1,2
        FNUCL(6,IN)=0.
        DO I=1,5
	  FNUCL(6,IN)=FNUCL(6,IN)+MNUCL(IN)*FNUCL(I,IN)
c	  print *, FNUCL(6,IN),MNUCL(IN),FNUCL(I,IN),I,IN
	  
	ENDDO
      ENDDO
c------------------------------------------------------------c
	 
       
cccccccccccccccccccccc  THE FINAL ANSWER ccccccccccccccccccccccccccccccc      
 
        
 
        SIGMA0PROT=4d0*MRNUCL(1)**2/PI*FNUCL(6,1)**2*GEVTOPBN
        SIGMA0NEUT=4d0*MRNUCL(2)**2/PI*FNUCL(6,2)**2*GEVTOPBN

        XJ=1d0/2d0
	
        SIGMASPROT=32d0*MRNUCL(1)**2/PI*AP**2*(XJ+1d0)*XJ*GEVTOPBN
        SIGMASNEUT=32d0*MRNUCL(2)**2/PI*AN**2*(XJ+1d0)*XJ*GEVTOPBN
	
c	print *, SIGMA0PROT,SIGMA0NEUT,SIGMASPROT,SIGMASNEUT


	RETURN
	END     
      
c------------------------------------------------------------c
c------------------------------------------------------------c
c------------------------------------------------------------c
      
ccccccccccccccccccccccccccc FUNCTION CMD CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC      
      REAL*8 FUNCTION CMD(I,MSQ,MQ,MNE)
      IMPLICIT DOUBLE PRECISION (A-H,M,O-Z)
      REAL*8 LAM
      
      common/check/p1,p2

      DSQN=MSQ**2-MNE**2
      DQN =MQ**2 -MNE**2
      DSQQ=MSQ**2-MQ**2
      
      D3M=  msq**2+mq**2-MNE**2
      D3M1= msq**2-mq**2-MNE**2
      
      R1  =DSQQ/MNE**2
      R2  =DQN /MSQ**2
      R3  =DSQN/MQ**2
      
      DEL =2d0*MNE**2*(MQ**2+MSQ**2)-MNE**4-(MSQ**2-MQ**2)**2
      ADE =abs(DEL)
      IF(ADE.lt.1E-20)PRINT *,'DEL=0(!!!)'
      LAM=0d0
      IF(DEL.GE.0)LAM=2d0*ATAN(sqrt(ADE)/D3M)/sqrt(ADE)
      IF(DEL.LT.0)LAM=LOG((D3M+sqrt(ADE))/(D3M-sqrt(ADE)))/sqrt(ADE)

      CMD=0d0
      
      IF    (I.eq.1) THEN
        
	CMD=1d0/DEL*(R2/3d0 - 2d0/3d0*R3-5d0/3d0+
     $              (2d0*msq**2-2d0/3d0*mne**2)*LAM)
c       print *,'CI1:',DEL, R2/3d0,- 2d0/3d0*R3, 5d0/3d0,
c     $                (2d0*msq**2-2d0/3d0*mne**2)*LAM
	
      ELSEIF(I.eq.2) THEN
      
        CMD=(LOG(MSQ**2/MQ**2)-D3M1*LAM)/2d0/MNE**4+
     $ (((mq**4-mq**2*msq**2)/mne**2-7./3.*mq**2-2./3.*DSQN)*LAM+
     $ R2/3.+R1+2./3.)/DEL
      
      ELSEIF(I.eq.3) THEN
      
        CMD=-3d0/DEL**2*D3M+LAM/DEL*(-1d0+6d0*mq**2*msq**2/del)
	
      ELSEIF(I.eq.4) THEN
      
        CMD=
     $   ((2d0*log(msq/mq) - D3M1*LAM)/2d0/mne**2
     $   -1d0/msq**2
     $   -mq**2*d3m1/DEL*LAM)/mne**4
     $ +((mq**2/mne**4-(1d0-mq**2/mne**2)**2/msq**2+1d0/2d0/mne**2)
     $   +3d0*mq**2/DEL*
     $   (1d0 +  R1 + (-R1*mq**2-2d0*mq**2-msq**2+mne**2)*LAM))/DEL
     
c      p1=del*lam
           
c      p2=(-mq**2*d3m1)/mne**4

      
      ELSEIF(I.eq.5) THEN
    	
         CMD=1d0/2d0/mne**4*(log(msq**2/mq**2)-D3M1*LAM)-
     $      1d0/DEL*(LAM*(2d0*DSQN+3d0*MQ**2+R1*mq**2)-3d0-R1)
     
      ELSE
      
      print *,'wrong "I" IN CMD(I,...) !!!! check I:=',I
     
      ENDIF
      
      RETURN
      END
c------------------------------------------------------------c
C============================================================================
C Interface to CTEQ5L parton distribution
C Uses CTEQ5L from main ISAJET
C============================================================================
      DOUBLE PRECISION FUNCTION CTQ5PDF (IPARTON, X, Q, IPRT)
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER IPARTON,IPRT,IFL
      DOUBLE PRECISION X,Q,CTEQ5L,SUM5L,RAT5L
      IFL=IPARTON
      IF(IFL.GE.3) IFL=-IFL
      IF(IFL.EQ.-1) THEN
        SUM5L=CTEQ5L(-1,X,Q)
        RAT5L=CTEQ5L(-2,X,Q)
        CTQ5PDF=SUM5L/(1.D0+RAT5L)
      ELSEIF(IFL.EQ.-2) THEN
        SUM5L=CTEQ5L(-1,X,Q)
        RAT5L=CTEQ5L(-2,X,Q)
        CTQ5PDF=SUM5L*RAT5L/(1.D0+RAT5L)
      ELSEIF(IFL.GE.-5.AND.IFL.LE.5) THEN
        CTQ5PDF=CTEQ5L(IFL,X,Q)
      ELSE
        CTQ5PDF=0
      ENDIF
      RETURN
      END
+PATCH,ISATAPE.
+EOD
+DECK,BUFIN.
      SUBROUTINE BUFIN(IL,IFLAG)
C
C          INVERSE OF BUFOUT.
C          IF CDCPACK IS USED, READ INPUT RECORD INTO ZVOUT AND
C          UNPACK EACH ZVOUT WORD INTO TWO ZEVEL WORDS BY CALL EXPAIR.
C          OTHERWISE, READ ONE INPUT RECORD INTO ZEVEL.
C
+CDE,ITAPES
+CDE,ITA
+CDE,ZEVEL
+CDE,ZVOUT
      DIMENSION W(2),IW(2)
      EQUIVALENCE(W(1),IW(1))
      DATA NPARR/0/
    1 CONTINUE
+SELF,IF=CDCPACK.
C          USE CDC BUFFER IN TO READ PACKED RECORD.
      BUFFER IN(ITB,1) (ZVOUT(1),ZVOUT(512))
      IF(UNIT(ITB,ZVOUT(1),ZVOUT(512))) 300,200,100
+SELF,IF=STDIO.
C          STANDARD FORTRAN 77 READ.
      CALL ZEROL(ZEVEL,MAXLEN)
      READ(ITB,ERR=100,END=200) IZVL1,IZVL2,(ZEVEL(JJ),JJ=3,IZVL2)
      GO TO 300
+SELF.
C            TAPE READ ERROR
  100 WRITE(ITLIS,10) ITB
      NPARR=NPARR+1
   10 FORMAT(1X,' TAPE READ ERROR ON TAPE',I3)
      IFLAG=1
      IF(NPARR.LT.20) GOTO 1
C            END OF FILE
  200 IFLAG=-1
      RETURN
C            GOOD RECORD
  300 IFLAG=0
+SELF,IF=CDCPACK.
C          USE CDC ASSEMBLY LANGUAGE ROUTINE EXPAIR TO UNPACK 1 ZVOUT
C          WORDS INTO 2 ZEVEL WORDS.
      WOUT=ZVOUT(1)
      CALL EXPAIR(W(1),W(2),WOUT,IFL)
      IZEVEL(1)=IW(1)
      IZEVEL(2)=IW(2)
      IL=IW(2)
      NW=IL/2+MOD(IL,2)
      DO 310 I=2,NW
      WOUT=ZVOUT(I)
      II=2*I-1
      CALL EXPAIR(W(1),W(2),WOUT,IFL)
      CALL MOVLEV(W,IZEVEL(II),2)
  310 CONTINUE
+SELF.
      IL=3
      RETURN
      END
+EOD
+DECK,BUFOUT.
      SUBROUTINE BUFOUT(IL)
C
C          INVERSE OF BUFIN.
C          IF CDCPACK IS USED, PACK TWO ZEVEL WORDS INTO EACH ZVOUT WORD
C          BY CALL PAIRPAK AND BUFFER OUT ZVOUT ARRAY.
C          OTHERWISE WRITE OUT ZEVEL.
C
C          NRECS INCREMENTED BY 1
C          IL SET TO 3


+CDE,ITAPES
+CDE,FINAL
+CDE,IDRUN
+CDE,ZEVEL
+CDE,ZVOUT
      DIMENSION W(2),IW(2)
      EQUIVALENCE(W(1),IW(1))
C          THESE ARE NOW INITIALIZED IN BLOCK DATA
      ITA=IABS(ITEVT)
+SELF,IF=CDCPACK.
C          USE CDC ASSEMBLY LANGUAGE ROUTINE PAIRPAK TO PACK 2 ZEVEL
C          WORDS INTO 1 ZVOUT WORD AND THEN CALL CDC BUFFER OUT.
      IW(1)=IZEVEL(1)
      IZEVEL(2)=IL
      IW(2)=IL
      CALL PAIRPAK(W(1),W(2),WOUT,IFL)
      ZVOUT(1)=WOUT
      NW=IL/2+MOD(IL,2)
      DO 1 I=2,NW
      II=2*I-1
      CALL MOVLEV(IZEVEL(II),W,2)
      CALL PAIRPAK(W(1),W(2),WOUT,IFL)
      ZVOUT(I)=WOUT
    1 CONTINUE
      IL=3
      NRECS=NRECS+1
      BUFFER OUT(ITA,1) (ZVOUT(1),ZVOUT(NW))
      IF(UNIT(ITA,ZVOUT(1),ZVOUT(NW))) 10,10,11
+SELF,IF=STDIO.
C          STANDARD FORTRAN 77 WRITE.
      IZEVEL(2)=IL
      WRITE(ITA,ERR=11) (ZEVEL(I),I=1,IL)
      IL=3
      NRECS=NRECS+1
+SELF.
   10 RETURN
   11 WRITE(ITLIS,200) IEVT,IDG
  200 FORMAT(//'  BAD WRITE, EVENT NO.',I10,5X,'EVENT ID',2I10)
      RETURN
      END
+EOD
+DECK,EDIT.
      LOGICAL FUNCTION EDIT(I)
C          DUMMY ROUTINE FOR USER DEFINED LOGICAL FUNCTION
C          EDIT=.TRUE. TO WRITE EVENT ON TAPE
C          EDIT=.FALSE. TO SUPPRESS WRITING
      EDIT=.TRUE.
      RETURN
      END
+EOD
+DECK,EXPAIR,IF=CDCPACK.
          IDENT  EXPAIR
* 7/7/75  COMMENT LINE THAT FOLLOWS EXPAND HAS BEEN CORRECTED IN LIGHT
* OF INSIGHT GAINED IN FIXING A BUG IN PAIRPAK.  HOWEVER, THE ARITHMETIC
* PERFORMED IS UNCHANGED, SO THIS VERSION OF EXPAIR IS COMPATIBLE WITH
* BOTH PREVIOUS AND NEW VERSIONS OF PAIRPAK.
* VERSION OF 25 MARCH 75, PRESERVES DISTINCTION BETWEEN +ZERO AND -ZERO
*
* CALL EXPAIR(W1,W2,OUTW,IALARM) UNPACKS W1, W2 FROM LEFT, RIGHT HALVES
* OF OUTW, RESPECTIVELY.
* RETURNS IALARM=0 IF W1 AND W2 ARE INTEGER OR FINITE, DEFINITE REAL.
* RETURNS IALARM=1 IF W1 IS INFINITE OR INDEFINITE, 2 IF W2 IS SO,
* 3 IF BOTH W1 AND W2 ARE SO.
* CAUTION * REQUIRES DATA IN FORMAT PRODUCED BY PAIRPAK
* WORKS WITH RUN OR FTN CALLING SEQ. IF ASSEMBLED UNDER APPROPRIATE
* COMPILER.
* J. KOPP, BROOKHAVEN NATIONAL LABORATORY, 22 MARCH 1975
          ENTRY  EXPAIR
+         VFD    36/6HEXPAIR,24/4
EXPAIR    DATA   0
          IFLE   *F,1
          SA5    B3
          ELSE
          SA3    A1+2
          SA5    X3
          ENDIF
          SB6    1            ALARM BIT FOR ARG1 = INFINITE
          MX2    0            TOTAL OF ALARMS TO DATE
          RJ     EXPAND       UNPACK LEFT HALF OUTW
          BX6    X5           W1
          SA5    A5+B0
          SB6    B6+B6        ALARM BIT FOR ARG2 = INFINITE
          LX5    30
          RJ     EXPAND       UNPACK RIGHT HALF
          BX7    X5           W2
          IFLE   *F,1
          SA6   B1
          SA7   B2
          BX6    X2           ALARM
          SA6    B4
          ELSE
          SA4    A1+1
          SA5    A3+1         FETCH LOC ALARM
          SA6    X1
          SA7    X4
          BX6    X2
          SA6    X5
          ENDIF
          JP     EXPAIR
* ANALYZE NUMBER IN LEFT 30 BITS OF X5, RETURN IN X5 AS PROPERLY
* POSITIONED INTEGER, REAL OR INFINITY.
* USES X0,X3,X4
EXP4      AX3    30                SHIFT INTEGER TO LOW END
EXP1      PL     X5,EXP2           IF ORIG. SIGN BIT ON, COMPLEMENT ANS.
          BX3    -X3
EXP2      BX5    X3
EXPAND    DATA   0
          MX0    29                DROP LOW 30 BITS + OUR SIGN BIT
          LX0    59
          BX3    X5*X0
          MX0    6
          LX0    59                MAKE EXPONENT-BIT MASK FOR LATER
          BX4    X3*X0             TEST FOR INTEGER
          ZR     X4,EXP4           IF EXPONENT BITS 0, RETURN INTEGER
          BX4    X4-X0             REAL, TEST FOR DUMMY EXPONENT 63
          ZR     X4,EXP3           YES, OUT-OF-RANGE REAL PACKED BELOW
          AX3    5                 NO, SPECIALLY BIASSED IN-RANGE EXP.
          UX4    B4,X3
* NOW B4=OUR EXPONENT-1023 = TRUE EXPONENT+77-1023 = TRUE -946
* (1023, NOT 1024, BECAUSE EXP. ARITHMETIC IS 1-S COMPLEMENT, 11 BITS)
          SB4    B4+946            RESTORE TRUE EXPONENT
          EQ     B0,B0,EXP5        DO STANDARD PROCESSING FOR BOTH TYPES
* OUT-OF-RANGE REAL PACKED BELOW DUMMY EXPONENT
EXP3      BX3    -X0*X3            DROP DUMMY EXPONENT
          LX3    6
          UX4    B4,X3
* REAL IN B4 AND X4. NOW RESTORE NORMALIZE BIT IN CHARACTERISTIC
EXP5      AX4    1
          MX0    1
          LX0    48
          BX4    X4+X0
          PX3    B4,X4
          OR     X3,EXP6           CHECK FOR INFINITE OR INDEFINITE
          DF     X3,EXP1           FINITE + DEFINITE, CHECK SIGN
EXP6      SX2    B6+X2             SET ALARM BIT FOR THIS ARG
          JP     EXP1
          END
+EOD
+DECK,ISAHEP
      SUBROUTINE ISAHEP(MCONV)
C
C...Purpose: to convert ISAJET event record contents to or from
C...the standard event record common block.
C
C   Thanks to Lynn Garren, Fermilab.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,HEPEVT
C
C...for event number
+CDE,IDRUN
C...initial partons
+CDE,PJETS
+CDE,PRIMAR
C...partons created during decay
+CDE,JETSET
C...particles created in the decay, including final state particles
+CDE,PARTCL
C
      INTEGER MCONV
      INTEGER ITRANS
      INTEGER I1,IHP,MPART,JET,NPOFF,NJHEP,NWHEP,IMO,IJT
      INTEGER JPMO(2,MXJSET),JPDA(2,MXJSET),JMX(MXJSET),JMN(MXJSET)
      INTEGER JTMO(2,MXPTCL),JTDA(2,MXPTCL)
      INTEGER IP,IJ3,IJ2,IJ1,NSUM2,NSUM1,IPT,I,J,KST,KND,K
C
C
C...Conversion from ISAJET to standard
C
      IF(MCONV.EQ.1) THEN
        NEVHEP = IEVT
C...initial jets
        NHEP = 0
C... W or Z
        IF(IDENTW.NE.0)THEN
          NHEP = NHEP + 1
          ISTHEP(NHEP)=12
          JMOHEP(1,NHEP)=0
          JMOHEP(2,NHEP)=0
          JDAHEP(1,NHEP)= 2
          JDAHEP(2,NHEP)= NJET + 1
          IDHEP(NHEP) = ITRANS(IDENTW,1)
          DO 100 J=1,5
 100        PHEP(J,NHEP) = QWJET(J)
        ENDIF
        NWHEP = NHEP
C... jets
        IF(NJET.GT.0)THEN
          DO 120 I=1,NJET
            NHEP = NHEP + 1
            ISTHEP(NHEP)=11
            JMOHEP(1,NHEP)=0
            IF(IDENTW.NE.0) JMOHEP(1,NHEP) = 1
            JMOHEP(2,NHEP)= I
            JDAHEP(1,NHEP)=0
            JDAHEP(2,NHEP)=0
            IDHEP(NHEP) = ITRANS(IDJETS(I),1)
            DO 110 J=1,5
 110          PHEP(J,NHEP) = PJETS(J,I)
 120      CONTINUE
        ENDIF
        NJHEP = NHEP
C... pairs
        IF(NPAIR.GT.0)THEN
          DO 150 I=1,NPAIR
            NHEP = NHEP + 1
            ISTHEP(NHEP)=13
            JMOHEP(1,NHEP)= JPAIR(I) + NWHEP
            JMOHEP(2,NHEP)= JPAIR(I)
            JDAHEP(1,NHEP)=0
            JDAHEP(2,NHEP)=0
            IDHEP(NHEP) = ITRANS(IDPAIR(I),1)
            DO 140 J=1,5
 140          PHEP(J,NHEP) = PPAIR(J,I)
 150      CONTINUE
        ENDIF
        DO 160 I=1,NHEP
          DO 160 J=1,4
 160        VHEP(J,I) = 0.
C...save offset into hep list
        NPOFF = NHEP
C...partons
        DO 200 I=1,NJSET
          IHP = NHEP + I
C...use JMX and JMN to find daughters in hadron list
          JMX(I) = 0
          JMN(I) = NHEP + NPTCL + 1
          IDHEP(IHP) = ITRANS(JTYPE(I),1)
          MPART=MOD(JORIG(I),JPACK)
          JMOHEP(1,IHP)=0
          IJT = JORIG(I)/JPACK
          IF(MPART.NE.0)THEN
            JMOHEP(1,IHP)=MPART+NHEP
          ELSEIF(MPART.EQ.0 .AND. IJT.LT.10)THEN
C...find mother in jet/pair list
            IMO = IJT + NWHEP
            IF(NJHEP.LT.NPOFF)THEN
              KST = NJHEP + 1
              DO 170 K=KST,NPOFF
                IF(IDHEP(K).EQ.IDHEP(IHP)) IMO=K
 170          CONTINUE
            ENDIF
            JMOHEP(1,IHP)= IMO
            IF(JDAHEP(1,IMO).EQ.0) JDAHEP(1,IMO)=IHP
            JDAHEP(1,IMO) = MIN(IHP,JDAHEP(1,IMO))
            JDAHEP(2,IMO) = MAX(IHP,JDAHEP(2,IMO))
C...amend information if a parton thinks this is it's daughter
            KND = IHP-1
            DO 175 K=NPOFF,KND
              IF(IHP.GE.JDAHEP(1,K) .AND. IHP.LE.JDAHEP(2,K))
     1             JMOHEP(1,IHP)=K
 175        CONTINUE
          ENDIF
          JMOHEP(2,IHP)= IJT
          IF(JDCAY(I).EQ.0)THEN
            ISTHEP(IHP) = 21
            JDAHEP(1,IHP)=0
            JDAHEP(2,IHP)=0
          ELSE
            ISTHEP(IHP) = 22
            JDAHEP(1,IHP) = JDCAY(I)/JPACK + NHEP
            JDAHEP(2,IHP) = MOD(JDCAY(I),JPACK) + NHEP
          ENDIF
          DO 180 J=1,5
 180        PHEP(J,IHP) = PJSET(J,I)
          DO 190 J=1,4
 190        VHEP(J,IHP) = 0.
 200    CONTINUE
        NHEP = NHEP + NJSET
C...hadrons
        DO 250 I=1,NPTCL
          IHP = NHEP + I
          IDHEP(IHP) = ITRANS(IDENT(I),1)
          I1 = MOD(IABS(IORIG(I)),IPACK)
          JMOHEP(1,IHP)=0
          JMOHEP(2,IHP)=IABS(IORIG(I))/IPACK
C...mother is pomeron
          IF(I1.EQ.0)THEN
C...mother is in parton list
          ELSEIF(IORIG(I).LT.0)THEN
            JMOHEP(1,IHP) = I1 + NPOFF
            JMN(I1) = MIN(JMN(I1),I)
            JMX(I1) = MAX(JMX(I1),I)
C...mother is in hadron list
          ELSEIF(IORIG(I).GT.0)THEN
            JMOHEP(1,IHP) = I1 + NHEP
          ENDIF
          IF(IDCAY(I).EQ.0)THEN
            ISTHEP(IHP) = 1
            JDAHEP(1,IHP)=0
            JDAHEP(2,IHP)=0
          ELSE
            ISTHEP(IHP) = 2
            JDAHEP(1,IHP) = IDCAY(I)/IPACK + NHEP
            JDAHEP(2,IHP) = MOD(IDCAY(I),IPACK) + NHEP
          ENDIF
          DO 210 J=1,5
 210        PHEP(J,IHP) = PPTCL(J,I)
          DO 220 J=1,4
 220        VHEP(J,IHP) = 0.
 250    CONTINUE
        NHEP = NHEP + NPTCL
C...fill in missing daughter info for partons
        DO 270 I=1,NJSET
          IF(JMX(I).NE.0)THEN
            JDAHEP(1,I+NPOFF) = JMN(I) + NPOFF + NJSET
            JDAHEP(2,I+NPOFF) = JMX(I) + NPOFF + NJSET
          ENDIF
 270    CONTINUE
C
C...Conversion from standard to ISAJET
C
      ELSEIF(MCONV.EQ.2)THEN
        IEVT = NEVHEP
C...        missing information
        IDENTW = 0
        NPAIR = 0
        DO 330 I=1,5
          QWJET(I) = 0.
          DO 330 J=1,4
            PPAIR(I,J) = 0.
 330    CONTINUE
        DO 340 I=1,4
          IDPAIR(I) = 0
 340      JPAIR(I) = 0
C...zero counters
        IJ1 = 0
        IJ2 = 0
        IJ3 = 0
        IP = 0
        IPT = 0
        DO 500 I=1,NHEP
C...initial jets
C... jets
          IF(ISTHEP(I).EQ.11)THEN
            IJ1 = IJ1 + 1
            IDJETS(IJ1) = ITRANS(IDHEP(I),2)
            DO 410 J=1,5
 410          PJETS(J,IJ1) = PHEP(J,I)
C... W
          ELSEIF(ISTHEP(I).EQ.12)THEN
            IJ2 = IJ2 + 1
            IDENTW = ITRANS(IDHEP(I),2)
            DO 420 J=1,5
 420          QWJET(J) = PHEP(J,I)
C... pairs
          ELSEIF(ISTHEP(I).EQ.13)THEN
            IJ3 = IJ3 + 1
            IDPAIR(IJ3) = ITRANS(IDHEP(I),2)
            JPAIR(IJ3) = JMOHEP(2,I)
            DO 430 J=1,5
 430          PPAIR(J,IJ3) = PHEP(J,I)
C...partons
          ELSEIF(ISTHEP(I).EQ.21 .OR. ISTHEP(I).EQ.22)THEN
            IP = IP + 1
            JTYPE(IP) = ITRANS(IDHEP(I),2)
            DO 440 J=1,5
 440          PJSET(J,IP) = PHEP(J,I)
C...      temporary storage until have counts
            JPMO(1,IP) = JMOHEP(1,I)
            JPMO(2,IP) = JMOHEP(2,I)
            JPDA(1,IP) = JDAHEP(1,I)
            JPDA(2,IP) = JDAHEP(2,I)
C...hadrons
          ELSE
            IPT = IPT + 1
            IDENT(IPT) = ITRANS(IDHEP(I),2)
            DO 450 J=1,5
 450          PPTCL(J,IPT) = PHEP(J,I)
C...      temporary storage until have counts
            JTMO(1,IPT) = JMOHEP(1,I)
            JTMO(2,IPT) = JMOHEP(2,I)
            JTDA(1,IPT) = JDAHEP(1,I)
            JTDA(2,IPT) = JDAHEP(2,I)
          ENDIF
 500    CONTINUE
C...completed counts
        NJET = IJ1
        NPAIR = IJ3
        NJSET = IP
        NPTCL = IPT
C...get mother/daughter information
        NSUM1 = NJET + IJ2 + NPAIR
        NSUM2 = NSUM1 + NJSET
        DO 520 I=1,NJSET
          IF(JPDA(1,I).EQ.0)THEN
            JDCAY(I) = 0
          ELSEIF(JPDA(1,I).GT.NSUM2)THEN
            JDCAY(I) = 0
          ELSE
            JDCAY(I) = JPACK*(JPDA(1,I)-NSUM1) + JPDA(2,I)-NSUM1
          ENDIF
          IF(JPMO(1,I).LE.NSUM1)THEN
            JORIG(I) = JPACK*JPMO(2,I)
          ELSE
            JORIG(I) = JPACK*JPMO(2,I) + JPMO(1,I)-NSUM1
          ENDIF
 520    CONTINUE
        DO 550 I=1,NPTCL
          IF(JTDA(1,I).EQ.0)THEN
            IDCAY(I) = 0
          ELSE
            IDCAY(I) = IPACK*(JTDA(1,I)-NSUM2) + JTDA(2,I)-NSUM2
          ENDIF
          IF(JTMO(1,I).LE.NSUM1)THEN
            IORIG(I) = JTMO(2,I)*IPACK + 0
          ELSEIF(JTMO(1,I).LE.NSUM2)THEN
            IORIG(I) = -(JTMO(2,I)*IPACK + JTMO(1,I)-NSUM1)
          ELSE
            IORIG(I) = JTMO(2,I)*IPACK + JTMO(1,I)-NSUM2
          ENDIF
 550    CONTINUE
      ENDIF
      RETURN
      END
+EOD
+DECK,ISAWBG.
      SUBROUTINE ISAWBG
C
C          Write initial record (type 200)
C          Inverse of RDBEG
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,DYLIM
+CDE,FRGPAR
+CDE,IDRUN
+CDE,JETLIM
+CDE,KEYS
+CDE,PRIMAR
+CDE,QCDPAR
+CDE,QLMASS
+CDE,Q1Q2
+CDE,TYPES
+CDE,XMSSM
C
+CDE,ZVOUT
+CDE,ZEVEL
+CDE,FINAL
C
      INTEGER NL,IL,ITA
C
C       Keep entry point WRBEG for backward compatibility
      ENTRY WRBEG
C
      ITA=IABS(ITEVT)
      NKINF=0
      SIGF=0.
      ALUM=0.
      ACCEPT=0.
      NRECS=0
+SELF,IF=CDCPACK.
      CALL ZEROL(ZVOUT,512)
+SELF.
      CALL ZEROL(ZEVEL,MAXLEN)
      IL=3
      CALL MOVLEI(IDVER,IZEVEL(IL),4)
      IL=IL+4
      CALL MOVLEI(NJET,IZEVEL(IL),7)
      IL=IL+7
      NL=NJET*MXGOQ
      IF(NJET.NE.0) CALL MOVLEL(GOQ(1,1),LZEVEL(IL),NL)
      IL=IL+NL
      CALL MOVLEL(KEYS(1),LZEVEL(IL),10)
      IL=IL+10
      CALL MOVLEV(PMIN(1),ZEVEL(IL),36)
      IL=IL+36
      IF(.NOT.KEYS(3)) GOTO 11
      CALL MOVLEV(QMIN,ZEVEL(IL),12)
      IL=IL+12
   11 CONTINUE
      CALL MOVLEL(GODY(1),LZEVEL(IL),5)
      IL=IL+5
      CALL MOVLEV(PUD,ZEVEL(IL),22)
      IL=IL+22
      CALL MOVLEV(ALAM,ZEVEL(IL),4)
      IL=IL+4
      CALL MOVLEV(AMLEP(6),ZEVEL(IL),3)
      IL=IL+3
      CALL MOVLEI(LOC(1),IZEVEL(IL),100)
      IL=IL+100
      CALL MOVLEL(GOMSSM,LZEVEL(IL),1)
      IL=IL+1
      CALL MOVLEV(XGLSS,ZEVEL(IL),11)
      IL=IL+11
      CALL MOVLEL(GOSUG,LZEVEL(IL),1)
      IL=IL+1
      CALL MOVLEV(XM0SU,ZEVEL(IL),5)
      IL=IL+5
C
      IZEVEL(1)=200
      IZEVEL(2)=1
      CALL BUFOUT(IL)
      RETURN
      END
+EOD
+DECK,ISAWEV.
      SUBROUTINE ISAWEV
C
C          WRITE OUT MONTECARLO DATA IF EDIT IS TRUE
C
      LOGICAL EDIT
C
C        keep entry point WRTAPE for backward compatibility
      ENTRY WRTAPE
      IF(.NOT.EDIT(I)) RETURN
      CALL WGENS
      RETURN
      END
+EOD
+DECK,ISAWND
      SUBROUTINE ISAWND
C
C          WRITE END RECORD, TYPE 300
C          CONTAINS CROSS SECTIONS AND LUMINOSITY
C
+CDE,ITAPES
+CDE,FINAL
+CDE,TOTALS
+CDE,ZEVEL
+CDE,JETLIM
+CDE,DYLIM
+CDE,KEYS
C
C       keep entry point WREND for backward compatibility
      ENTRY WREND
      ITA=IABS(ITEVT)
      IZEVEL(1)=300
      IZEVEL(2)=1
      IZEVEL(3)=NKINF
      ZEVEL(4)=SIGF
      ZEVEL(5)=ALUM
      ZEVEL(6)=ACCEPT
      IZEVEL(7)=NRECS
      IL=7
      CALL BUFOUT(IL)
      WRITE(ITLIS,1010) NRECS,ITA
1010  FORMAT(////' THIS RUN WROTE',I10,
     1' PHYSICAL RECORDS ON TAPE',I3)
      RETURN
      END
+EOD
+DECK,ITRANS
      INTEGER FUNCTION ITRANS(ID,MCONV)
C
C          Convert (MCONV=1) from ISAJET numbering to PDG numbering
C               or (MCONV=2) from PDG numbering to ISAJET numbering
C
C          --- Begin Table of ISAJET/PDG particle codes ---
C
C          NAME      ISAJET    PDG
C          UP        1         2
C          DN        2         1
C          ST        3         3
C          CH        4         4
C          BT        5         5
C          TP        6         6
C          Y         7         7
C          X         8         8
C          GL        9         21
C          GM        10        22
C
C          NUE       11        12
C          E-        12        11
C          NUMU      13        14
C          MU-       14        13
C          NUTAU     15        14
C          TAU-      16        15
C          KS        20        310
C
C          UPLSS     21        1000002
C          DNLSS     22        1000001
C          STLSS     23        1000003
C          CHLSS     24        1000004
C          BT1SS     25        1000005
C          TP1SS     26        1000006
C          GLSS      29        1000021
C          Z1SS      30        1000022
C
C          NUEL      31        1000012
C          EL-       32        1000011
C          NUML      33        1000014
C          MUL-      34        1000013
C          NUTL      35        1000016
C          TAU1-     36        1000015
C          W1SS+     39        1000024
C          Z2SS      40        1000023
C
C          UPRSS     41        2000002
C          DNRSS     42        2000001
C          STRSS     43        2000003
C          CHRSS     44        2000004
C          BT2SS     45        2000005
C          TP2SS     46        2000006
C          W2SS+     49        1000037
C          Z3SS      50        1000025
C
C          NUER      51        2000012
C          ER-       52        2000011
C          NUMR      53        2000014
C          MUR-      54        2000013
C          NUTR      55        2000016
C          TAU2-     56        2000015
C          Z4SS      60        1000035
C
C          W+        80        24
C          HIGGS     81        25
C          HL0       82        51
C          HH0       83        35
C          HA0       84        36
C          H+        86        37
C          Z0        90        23
C
C          GVSS      91        1000039
C          GRAV      92        39
C
C          --- End Table of ISAJET/PDG particle codes ---
C
C          Ver 7.21: add extra mesons with IABS(ID) > 10000; these only 
C          occur in a few B decays.
C          Ver 7.52: Fix bug in special mesons
C          Ver 7.55: Update for new PDG numbering scheme.
C
C     Thanks to Lynn Garren, Fermilab.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+SEQ,ITAPES
C
      INTEGER ID,MCONV
      INTEGER I2,I3,J,IDA,IF1,IF2,IND,ITMP,IF3,JS,J1,IS1,IS2,IS3,I4,I1
C
C... ITABI(I) converts miscellaneous ISAJET particle ID's to standard 
C... scheme
C
      INTEGER ITABI(99,2), NOANT(15)
      SAVE ITABI,NOANT
C
      DATA ITABI/2,1,3,4,5,6,7,8,21,22,
     1 12,11,14,13,16,15,0,0,0,310,
     2 1000002,1000001,1000003,1000004,1000005,1000006,0,0,1000021,
     2 1000022,
     3 1000012,1000011,1000014,1000013,1000016,1000015,0,0,1000024,
     3 1000023,
     4 2000002,2000001,2000003,2000004,2000005,2000006,0,0,1000037,
     4 1000025,
     5 2000012,2000011,2000014,2000013,2000016,2000015,0,0,0,1000035,
     6 0,0,0,0,0,0,0,0,0,0,             0,0,0,0,0,0,0,0,0,24,    
     8 25,51,35,36,55,37,53,52,54,23,   1000039,39,0,0,0,0,0,0,0,
     * 2,1,3,4,5,6,7,8,0,0,             12,11,14,13,16,15,0,0,0,0, 
     2 9,10,90,80,81,0,0,0,0,0,         0,0,0,0,83,84,86,0,92,0,
     4 0,0,0,0,0,0,0,0,0,0,             82,88,87,89,85,0,0,0,0,0,  
     6 0,0,0,0,0,0,0,0,0,0,             0,0,0,0,0,0,0,0,0,0,
     8 0,0,0,0,0,0,0,0,0,0,             0,0,0,0,0,0,0,0,0/
C
      DATA NOANT/-21,-22,-23,-25,-30,-35,-47,-48,-57,-58,-59,
     1 -67,-68,-69,-70/
C
C          Entry
C
      IDA=IABS(ID)
      ITRANS=0
      IF(MCONV.NE.1) GO TO 200
C
C          Convert ISAJET to PDG
C
      CALL FLAVOR(ID,IF1,IF2,IF3,JS,IND)
      IF(IDA.EQ.0) THEN
        WRITE(ITLIS,*) ' ITRANS: particle ID is zero'
      ELSEIF(IDA.LT.100) THEN
        ITRANS=ISIGN(ITABI(IDA,1),ID)
        IF(ID.EQ.-20) ITRANS=130
C...check for illegal antiparticles
        ITMP=ITRANS
        IF(ITMP.LT.0) THEN
          DO 101 J=1,15
            IF(ITMP.EQ.NOANT(J)) ITRANS=0
 101      CONTINUE
        ENDIF
      ELSEIF(IND.NE.0.AND.IDA.LT.10000) THEN
        IS1=IABS(IF1)
        IS2=IABS(IF2)
        IS3=IABS(IF3)
C...mesons
        IF(IS1.EQ.0) THEN
          IF(IS2.LE.2 .AND. IS3.LE.2) THEN
C...         don't change
          ELSE
C...         u and d have opposite definitions
            IF(IS2.LE.2) IS2=ITABI(IS2,1)
            IF(IS3.LE.2) IS3=ITABI(IS3,1)
          ENDIF
          ITRANS=IS3*100 + IS2*10 + 2*JS+1
          ITRANS=ISIGN(ITRANS,ID)
C...         charmed and top mesons have wrong sign
          IF(IS3.EQ.4 .AND. IS2.NE.4) ITRANS=-ITRANS
          IF(IS3.EQ.6 .AND. IS2.NE.6 .AND. IS2.NE.4) ITRANS=-ITRANS
C...check for illegal antiparticles
          IF(IS2.EQ.IS3 .AND. ID.LT.0) ITRANS=0
C...diquarks
        ELSEIF(IS3.EQ.0) THEN
C...         u and d have opposite definitions
          IF(IS1.LE.2) IS1=ITABI(IS1,1)
          IF(IS2.LE.2) IS2=ITABI(IS2,1)
          IF(IS2.LT.IS1) THEN
            ITRANS=IS1*1000 + IS2*100 + 2*JS+1
          ELSE
            ITRANS=IS2*1000 + IS1*100 + 2*JS+1
          ENDIF
          ITRANS=ISIGN(ITRANS,ID)
C...         charmed and top mesons have wrong sign
          IF(IS2.EQ.4 .AND. IS1.NE.4) ITRANS=-ITRANS
          IF(IS2.EQ.6 .AND. IS1.NE.6 .AND. IS1.NE.4) ITRANS=-ITRANS
C...baryons
        ELSE
C...         u and d have opposite definitions
          IF(IS1.LE.2) IS1=ITABI(IS1,1)
          IF(IS2.LE.2) IS2=ITABI(IS2,1)
          IF(IS3.LE.2) IS3=ITABI(IS3,1)
          IF(IS3.LE.2) THEN
            ITRANS=IS1*1000 + IS2*100 + IS3*10 + 2*JS+2
          ELSEIF(IS1.LE.2 .AND. IS2.LE.2) THEN
            ITRANS=IS3*1000 + IS1*100 + IS2*10 + 2*JS+2
          ELSE
            ITRANS=IS3*1000 + IS2*100 + IS1*10 + 2*JS+2
          ENDIF
          ITRANS=ISIGN(ITRANS,ID)
        ENDIF
      ELSEIF(IND.GT.0.AND.IDA.GT.10000) THEN
C...Special mesons. 
        IF(IDA.EQ.10121) THEN
          ITRANS=ISIGN(20213,ID)
        ELSEIF(IDA.EQ.10111) THEN
          ITRANS=ISIGN(20113,ID)
        ELSEIF(IDA.EQ.10131) THEN
          ITRANS=ISIGN(10323,ID)
        ELSEIF(IDA.EQ.10231) THEN
          ITRANS=ISIGN(10313,ID)
        ELSEIF(IDA.EQ.30131) THEN
          ITRANS=ISIGN(30323,ID)
        ELSEIF(IDA.EQ.30231) THEN
          ITRANS=ISIGN(30313,ID)
        ELSEIF(IDA.EQ.10110) THEN
          ITRANS=ISIGN(10221,ID)
        ELSEIF(IDA.EQ.10441) THEN
          ITRANS=ISIGN(20443,ID)
        ELSEIF(IDA.EQ.20440) THEN
          ITRANS=ISIGN(10441,ID)
        ELSEIF(IDA.EQ.20441) THEN
          ITRANS=ISIGN(10443,ID)
        ELSEIF(IDA.EQ.20442) THEN
          ITRANS=ISIGN(445,ID)
        ELSE
          ITRANS=ID
        ENDIF
      ENDIF
      GO TO 300
C
C          Convert PDG to ISAJET
C
 200  IF(MCONV.NE.2) GO TO 300
      J1=MOD(IDA,10)
      I1=MOD(IDA/10,10)
      I2=MOD(IDA/100,10)
      I3=MOD(IDA/1000,10)
      I4=MOD(IDA/10000,10)
      IF(IDA.EQ.0) THEN
        WRITE(ITLIS,*) ' ITRANS: particle ID is zero'
C...elementary particles
      ELSEIF(IDA.LT.100) THEN
        ITRANS=ISIGN(ITABI(IDA,2),ID)
C...check for illegal antiparticles
        IF(ID.LT.0) THEN
          DO 201 J=1,15
            IF(ID.EQ.NOANT(J)) ITRANS=0
 201      CONTINUE
        ENDIF
C...K short and K long
      ELSEIF(ID.EQ.130) THEN
        ITRANS=-20
      ELSEIF(ID.EQ.310) THEN
        ITRANS=20
C...mesons
      ELSEIF(I3.EQ.0) THEN
          IF(I1.LE.2 .AND. I2.LE.2) THEN
C...         don't change
          ELSE
C...         u and d have opposite definitions
            IF(I1.LE.2) I1=ITABI(I1,2)
            IF(I2.LE.2) I2=ITABI(I2,2)
          ENDIF
          ITRANS=I1*100 + I2*10 + (J1-1)/2
          ITRANS=ISIGN(ITRANS,ID)
C...         charmed and top mesons have wrong sign
          IF(I2.EQ.4 .AND. I1.NE.4) ITRANS=-ITRANS
          IF(I2.EQ.6 .AND. I1.NE.6 .AND. I1.NE.4) ITRANS=-ITRANS
C...check for illegal antiparticles
          IF(I2.EQ.I1 .AND. ID.LT.0) ITRANS=0
C...diquarks
      ELSEIF(I1.EQ.0) THEN
C...         u and d have opposite definitions
          IF(I3.LE.2) I3=ITABI(I3,2)
          IF(I2.LE.2) I2=ITABI(I2,2)
          IF(I3.LT.I2) THEN
            ITRANS=I3*1000 + I2*100 + (J1-1)/2
          ELSE
            ITRANS=I2*1000 + I3*100 + (J1-1)/2
          ENDIF
          ITRANS=ISIGN(ITRANS,ID)
C...         charmed and top mesons have wrong sign
          IF(I2.EQ.4 .AND. I3.NE.4) ITRANS=-ITRANS
          IF(I2.EQ.6 .AND. I3.NE.6 .AND. I3.NE.4) ITRANS=-ITRANS
C...baryons
      ELSE
C...         u and d have opposite definitions
          IF(I3.LE.2) I3=ITABI(I3,2)
          IF(I2.LE.2) I2=ITABI(I2,2)
          IF(I1.LE.2) I1=ITABI(I1,2)
          IF(I3.LE.2) THEN
            ITRANS=I3*1000 + I2*100 + I1*10 + (J1-2)/2
          ELSEIF(I1.LE.2 .AND. I2.LE.2) THEN
            ITRANS=I2*1000 + I1*100 + I3*10 + (J1-2)/2
          ELSE
            ITRANS=I1*1000 + I2*100 + I3*10 + (J1-2)/2
          ENDIF
          ITRANS=ISIGN(ITRANS,ID)
      ENDIF

 300  RETURN
      END
+EOD
+DECK,MOVLEV,IF=MOVEFTN.
      SUBROUTINE MOVLEV(A,B,N)
C
C          Replacement for CDC system routine.
C          Move N consecutive locations from A to B.
C          Ver. 7.02: Separate entry points for real, integer, logical
C                     to comply with strict Fortran standard.
C                     Hence incompatible with CDC -- CDC version is 
C                     therefore obsolete, like the computer.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
      INTEGER N,I
      REAL A(N),B(N)
      INTEGER IA(N),IB(N)
      LOGICAL LA(N),LB(N)
C          Reals
      DO 100 I=1,N
        B(I)=A(I)
100   CONTINUE
      RETURN
C          Integers
      ENTRY MOVLEI(IA,IB,N)
      DO 200 I=1,N
        IB(I)=IA(I)
200   CONTINUE
      RETURN
C          Logicals
      ENTRY MOVLEL(LA,LB,N)
      DO 300 I=1,N
        LB(I)=LA(I)
300   CONTINUE
      RETURN
      END
+EOD
+DECK,PAIRPAK,IF=CDCPACK.
          IDENT  PAIRPAK
* 7/7/75  FIXED BUG THAT CAUSED NUMBERS OF FORM  N*2**-31 (1.LE.N.LT.2)
* TO BE PACKED WITH ZERO EXPONENT BITS, HENCE TO BE INCORRECTLY CALLED
* INTEGERS BY EXPAIR.  AT THE EXPENSE OF SHIFTING RANGE OF 23-BIT
* PRECISION PACKING TO 2**32 TO 2**-30 (WHERE IT WAS INTENDED TO BE
* FROM 2**31 TO 2**-31), FIX KEEPS FORMAT COMPATIBLE WITH PREVIOUS
* VERSION OF PAIRPAK, AND EXPAIR DOES NOT NEED TO BE CHANGED.
* VERSION OF 25 MARCH 75, PRESERVES DISTINCTION BETWEEN +ZERO AND -ZERO
* CALL PAIRPAK(W1,W2,OUTW,IALARM) PACKS W1, W2 IN LEFT, RIGHT HALVES OF
* OUTW, RESPECTIVELY.
* ALSO SETS IALARM = 0 IF W1, W2 WERE BOTH OKAY, MEANING EITHER
* INTEGERS OR DEFINITE AND FINITE REALS. SETS IALARM = 1 IF W1 WAS
* INFINITE OR INDEFINITE, IALARM = 2 IF W2 WAS SO, IALARM = 3 IF BOTH
* W1 AND W2 WERE SO.
*
* IF EXPONENT BITS ARE ALL 0 (OR ALL 1 IF NUMBER IS NEGATIVE), IT IS
* CALLED AN INTEGER AND CHOPPED TO ITS LOWEST 23 BITS (PLUS SIGN)
* REALS IN RANGE 2**-31 TO 2**31 IN MAGNITUDE ARE COMPRESSED TO GIVE 24
* BITS SIGNIFICANCE.  REALS OUTSIDE THIS RANGE HAVE 13 SIGNIFICANT BITS.
* ZEROES, INFINITIES AND INDEFINITES ARE PRESERVED WITH PROPER SIGN.
*
* WORKS FOR RUN OR FTN CALLING SEQ. IF ASSEMBLED UNDER CORRESPONDING
* COMPILER
*
* J. KOPP, BROOKHAVEN NATIONAL LABORATORY, 22 MARCH 1975
*
          ENTRY  PAIRPAK
+         VFD    42/7HPAIRPAK,18/4
PAIRPAK   DATA   0
          IFLE   *F,1
          SA1   B1            FETCH FIRST ARG. = W1
          ELSE
          SA2    A1+1         GET LOC W2 TO X2
          SA3    A1+2         LOC OUTW
          SA1    X1           FETCH FIRST ARG = W1
          ENDIF
          SB6    1            ALARM BIT FOR ARG1
          MX6    0            TOTAL ALARMS TO DATE
          RJ     TRIMUP       TEST W1 FOR REAL OR INTEGER AND NEATEN UP
          BX7    X1           W1 TO GO IN LEFT HALF
          IFLE   *F,1
          SA1    B2           FETCH SECOND ARG = W2
          ELSE
          SA1    X2           FETCH SECOND ARG = W2
          ENDIF
          SB6    B6+B6        ALARM BIT FOR ARG2
          RJ     TRIMUP       PERFORM THE TESTING AND PURIFICATION
          LX1    30           MOVE FROM LEFT HALF TO RIGHT HALF
          BX7    X7+X1
          IFLE   *F,1
          SA6    B4
          SA7   B3
          ELSE
          SA1    A3+1         FETCH LOC IALARM
          SA7    X3
          SA6    X1           DELIVER ALARM
          ENDIF
          JP     PAIRPAK
*
* TEST WORD IN X1 FOR REAL OR INTEGER, CHOP SUITABLY, RETURN IN LEFT
* HALF X1. ASSUMES FLOATING-POINT ARGUMENTS ARE NORMALIZED
* USES X0,X4,X6
TRIM2     MX0    29                REMOVE LOW 30 BITS AND CLEAR SIGN BIT
          LX0    59
          BX1    X1*X0
TRIM1     BX1    X1+X5             ATTACH SIGN BIT
TRIMUP    DATA   0
          MX5    0                 PREPARE + SIGN BIT IN X5
          PL     X1,TRIM3
          BX1    -X1               WORK WITH ABSOLUTE VALUE
          MX5    1                 SET SIGN BIT
TRIM3     OR      X1,TRIM3A        IF INFINITE, SET ALARM BIT + PROCEED
          DF     X1,TRIM3B         SAME IF INDEFINITE
TRIM3A    SX6     B6+X6            SET ALARM BIT, INPUT INF. OR INDEF.
TRIM3B    MX0    12                LOOK AT EXPONENT FIELD
          BX4    X1*X0
          ZR     X4,TRIM4          IF EXP. FIELD ZERO HAVE AN INTEGER
          UX4    B5,X1             UNPACK
          LX4    1                 SQUEEZE NORMALIZE BIT OUT OF CHAR.
          BX4    -X0*X4
* (7/7/75 - CONSTANT ADDED BELOW CHANGED TO 77 FROM 78.  THIS KEEPS THE
* FORMAT SAME AS BEFORE, WHERE WE ADDED 78 BUT A BUG CAUSED PACKED
* RESULT TO HAVE EXPONENT 1 LESS THAN INTENDED)
          SB5    B5+77             ADD OUR OWN BIAS
          GE     B0,B5,TRIM7
          SB7    63
          GE     B5,B7,TRIM7       SAME IF OVERFLOW, INFINITE, INDEF.
          PX1    B5,X4             REPACK WITH OUR OWN EXPONENT BIAS
* THE FOLLOWING LEFT SHIFT WILL PUT 6600 EXPONENT BIAS BIT IN LOW END
* WHERE IT WILL BE TRIMMED OFF.
          LX1    5     IDEA IS TO SHORTEN EXP. FIELD TO 6 BITS (WITH...
          JP  TRIM2    RESTRICTION OF ALLOWED RANGE) TO GAIN 6 SIGNIF
*                      BITS TOTAL
TRIM4     LX1    30                INTEGER
          MX0    7                 CHOP LEFT 7 BITS, MAX INTEGER 23 BITS
          BX1    -X0*X1
          JP     TRIM2             ATTACH SIGN
* REAL OUT OF ALLOWED RANGE FOR SPECIAL EXPONENT BIAS WHICH ALLOWS
* SAVING EXTRA SIGNIFICANT BITS.  PACK BELOW DUMMY EXPONENT 63 WHICH
* SERVES AS A FLAG FOR OUT-OF-RANGE (INCLUDING INFINITE AND INDEF) REALS
TRIM7     UX1    B5,X1             GET BACK ORIGINAL 6600 EXPONENT
          PX1    B5,X4             PACK WITH LOPPED CHARACTERISTIC
          AX1    6            PACK BELOW DUMMY EXPONENT 63
          MX0    7
          BX1    X1+X0
          JP     TRIM2
          END
+EOD
+DECK,PRTLST.
      SUBROUTINE PRTLST(JTLIS,AMY,AMX)
C
C          List defined particles. AMY, AMX are the masses of the 
C          fourth generation quarks. If a negative mass is given,
C          then these are not listed.
C          This must be linked with ISAJET, including ALDATA.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,QLMASS
+CDE,WCON
      INTEGER JTLIS
      REAL AMY,AMX
      INTEGER IFL1,IFL2,IFL3,JSPIN,INDEX,I,ID
      REAL AM,CG,AMASS,CHARGE
      CHARACTER*8 LB,LABEL
C
C          Initialize SUSY masses to 0. Remember offset of 1 from KL.
C
      DO 100 I=22,NQLEP
        AMLEP(I)=0.
100   CONTINUE
      AMLEP(7)=AMY
      AMLEP(8)=AMX
      CALL FLAVOR(80,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=WMASS(2)
      CALL FLAVOR(90,IFL1,IFL2,IFL3,JSPIN,INDEX)
      AMLEP(INDEX)=WMASS(4)
      WRITE(JTLIS,101) AMY,AMX
C
C          Loop over IDENT's
C
      DO 200 I=1,40000
        ID = I
        CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX)
        IF(AMX.LT.0..OR.AMY.LT.0.) THEN
          IF(IABS(IFL1).GT.6.OR.IABS(IFL2).GT.6.OR.IABS(IFL3).GT.6)
     $    GO TO 200
        ENDIF
        IF(INDEX.GT.0) THEN
          LB = LABEL(ID)
          IF(LB.NE.'ERR') THEN
            AM = AMASS(ID)
            CG = CHARGE(ID)
            WRITE(JTLIS,102) ID,LB,AM,CG,IFL1,IFL2,IFL3,JSPIN,INDEX
          ENDIF
        ENDIF
        ID = -I
        CALL FLAVOR(ID,IFL1,IFL2,IFL3,JSPIN,INDEX)
C          Eliminate bad ID's:
        IF(INDEX.GT.0) THEN
          LB = LABEL(ID)
          IF(LB.NE.'ERR') THEN
            AM = AMASS(ID)
            CG = CHARGE(ID)
            WRITE(JTLIS,102) ID,LB,AM,CG,IFL1,IFL2,IFL3,JSPIN,INDEX
          ENDIF
        ENDIF
 200  CONTINUE
      RETURN
 101  FORMAT(10X,'ISAJET PARTICLES, M(Y) =',F10.3,'  M(X) =',F10.3//
     1 5X,'ID',4X,'PARTICLE',8X,'MASS',4X,'CHARGE',
     2 4X,'---FLAVOR---',4X,'SPIN',4X,'INDEX')
 102  FORMAT(1X,I6,4X,A8,F12.6,F10.2,4X,3I4,I8,I9)
      END
+EOD
+DECK,RDBEG.
      SUBROUTINE RDBEG
C
C          Read first record (type 200)
C          Inverse of WRBEG
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,DYLIM
+CDE,FRGPAR
+CDE,IDRUN
+CDE,JETLIM
+CDE,KEYS
+CDE,PRIMAR
+CDE,QCDPAR
+CDE,QLMASS
+CDE,Q1Q2
+CDE,TYPES
+CDE,XMSSM
C
+CDE,ZEVEL
C
      INTEGER NL,IDSAVE,IL
C
      IL=3
      IDSAVE=IDVER
      CALL MOVLEI(IZEVEL(IL),IDVER,4)
      IF(IDVER.NE.IDSAVE) WRITE(ITLIS,1777) IDVER,IDSAVE
1777  FORMAT(///,
     $' WARNING:  DATA WERE GENERATED WITH VERSION',I5,/,
     $'           DATA ARE BEING READ WITH VERSION',I5,/,
     $' RESULTS CANNOT BE PREDICTED.'///)
      IL=IL+4
      CALL MOVLEI(IZEVEL(IL),NJET,7)
      IL=IL+7
      NL=NJET*MXGOQ
      IF(NJET.NE.0) CALL MOVLEL(LZEVEL(IL),GOQ(1,1),NL)
      IL=14+NL
      CALL MOVLEL(LZEVEL(IL),KEYS(1),10)
      IL=IL+10
      CALL MOVLEV(ZEVEL(IL),PMIN(1),36)
      IL=IL+36
      IF(.NOT.KEYS(3)) GO TO 11
      CALL MOVLEV(ZEVEL(IL),QMIN,12)
      IL=IL+12
11    CONTINUE
      CALL MOVLEL(LZEVEL(IL),GODY(1),5)
      IL=IL+5
      CALL MOVLEV(ZEVEL(IL),PUD,22)
      IL=IL+22
      CALL MOVLEV(ZEVEL(IL),ALAM,4)
      IL=IL+4
      CALL MOVLEV(ZEVEL(IL),AMLEP(6),3)
      IL=IL+3
      CALL MOVLEI(IZEVEL(IL),LOC(1),100)
      IL=IL+100
      CALL MOVLEL(LZEVEL(IL),GOMSSM,1)
      IL=IL+1
      CALL MOVLEV(ZEVEL(IL),XGLSS,11)
      IL=IL+11
      CALL MOVLEL(LZEVEL(IL),GOSUG,1)
      IL=IL+1
      CALL MOVLEV(ZEVEL(IL),XM0SU,5)
      IL=IL+5
C
      RETURN
      END
+EOD
+DECK,RDTAPE.
      SUBROUTINE RDTAPE(IDEV,IFL)
C
C          CALL ROUTINES TO READ AND UNPACK ISAJET DATA
C          RGENS FOR EVENTS
C          RDBEG FOR BEGINNING RECORD
C          REND FOR END RECORD
C
+CDE,ITAPES
+CDE,ITA
+CDE,RECTP
+CDE,ZEVEL
      ITB=IABS(IDEV)
      CALL RGENS(IFL)
      IF(IFL.NE.0) RETURN
      IF(IRECTP.EQ.200) CALL RDBEG
      IF(IRECTP.EQ.300) CALL REND
      RETURN
      END
+EOD
+DECK,REND.
      SUBROUTINE REND
C
C          INVERSE OF WREND
C          READ END RECORD (TYPE 300)
C
+CDE,ITAPES
+CDE,FINAL
+CDE,ZEVEL
      NKINF=IZEVEL(3)
      SIGF=ZEVEL(4)
      ALUM=ZEVEL(5)
      ACCEPT=ZEVEL(6)
      NRECS=IZEVEL(7)
      RETURN
      END
+EOD
+DECK,RGENS.
      SUBROUTINE RGENS(IFLAG)
C
C          Inverse of WRGEN
C          Read a record by a call BUFIN
C          If record type is not event type return.
C          If RGENS called with IFLAG=10 return without unpacking.
C          Unpack ZEVEL into appropriate common blocks.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,MBGEN
+CDE,KEYS
+CDE,RECTP
+CDE,IDRUN
+CDE,JETPAR
+CDE,JETSET
+CDE,JETSIG
+CDE,PARTCL
+CDE,PJETS
+CDE,PINITS
+CDE,PRIMAR
+CDE,ZEVEL
+CDE,TOTALS
+CDE,WSIG
+CDE,FINAL
C
      INTEGER IFLAG
      INTEGER I,IEX,IZ5,K,IFL,ISAV,IL
C
      IFL=IFLAG
      CALL BUFIN(IL,IFLAG)
      IF(IFLAG.NE.0) RETURN
      ISAV=IZEVEL(1)/100
      IRECTP=ISAV*100
      IREC=MOD(IZEVEL(1),100)
      IF(IRECTP.EQ.200) RETURN
      IF(IRECTP.EQ.300) RETURN
      IF(IFL.EQ.10) RETURN
      IL=3
      CALL MOVLEI(IZEVEL(IL),IDVER,4)
      IL=IL+4
      CALL MOVLEL(LZEVEL(IL),KEYS(1),MXKEYS)
      IL=IL+MXKEYS
      NJET=IZEVEL(IL)
      IL=IL+1
      CALL MOVLEV(ZEVEL(IL),P(1),59)
      IL=IL+59
      CALL MOVLEV(ZEVEL(IL),SIGF,1)
      IL=IL+1
      IF(.NOT.KEYS(4)) THEN
        SIGMA=ZEVEL(IL)
        SIGEVT=ZEVEL(IL+1)
        WT=ZEVEL(IL+2)
        IL=IL+3
      ENDIF
      NPTCL=IZEVEL(IL)
      IL=IL+1
      IF(NJET.GT.0) THEN
        IEX=NJET*5
        CALL MOVLEV(ZEVEL(IL),PJETS(1,1),IEX)
        IL=IL+IEX
        CALL MOVLEI(IZEVEL(IL),IDJETS(1),NJET)
        IL=IL+NJET
      ENDIF
      IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN
        CALL MOVLEV(ZEVEL(IL),QWJET(1),6)
        IL=IL+6
        CALL MOVLEV(ZEVEL(IL),QMW,16)
        IL=IL+16
        SIGLLQ=ZEVEL(IL)
        IL=IL+1
      ENDIF
      IF(KEYS(6).OR.KEYS(7)) THEN
        NPAIR=IZEVEL(IL)
        IL=IL+1
        IF(NPAIR.NE.0) THEN
          CALL MOVLEV(ZEVEL(IL),PPAIR(1,1),5*NPAIR)
          IL=IL+5*NPAIR
          CALL MOVLEI(IZEVEL(IL),IDPAIR(1),NPAIR)
          IL=IL+NPAIR
          CALL MOVLEI(IZEVEL(IL),JPAIR(1),NPAIR)
          IL=IL+NPAIR
        ENDIF
      ENDIF
      NJSET=IZEVEL(IL)
      IL=IL+1
      CALL MOVLEI(IZEVEL(IL),NKINPT,5)
      IL=IL+5
      CALL MOVLEI(IZEVEL(IL),NPOM,1)
      IL=IL+1
C
C          /JETSET/ COMMON BLOCK
      IF(NJSET.LT.1) GOTO 12
      DO 50 I=1,NJSET
      CALL MOVLEV(ZEVEL(IL),PJSET(1,I),5)
      IL=IL+5
      JORIG(I)=IZEVEL(IL)
      JTYPE(I)=IZEVEL(IL+1)
      JDCAY(I)=IZEVEL(IL+2)
      IL=IL+3
      IF(IL.LE.MAXLEN-9) GO TO 50
      IF(I.EQ.NJSET.AND.NPTCL.EQ.0) GO TO 12
      CALL BUFIN(IL,IFLAG)
      IF(IFLAG.NE.0) RETURN
50    CONTINUE
C
C          /PARTCL/ COMMON BLOCK
C          NPTCL.LT.0 IMPLIES ONLY STABLE PARTICLES ON THIS FILE
C          ORIGIN AND DECAY INFORMATION SUPPRESSED
12    IF(NPTCL.EQ.0) GOTO 999
      IF(NPTCL.GT.0) GOTO 997
C          ONLY STABLE PARTICLES
      NPTCL=-NPTCL
      DO 992 K=1,NPTCL
      CALL MOVLEV(ZEVEL(IL),PPTCL(1,K),5)
      IZ5=IABS(IZEVEL(IL+5))
      IORIG(K)=(IZ5/10000)*1000
      IDENT(K)=MOD(IZ5,10000)*ISIGN(1,IZEVEL(IL+5))
      IDCAY(K)=0
      IL=IL+6
      IF(IL.LE.MAXLEN-6) GOTO 992
      IF(K.EQ.NPTCL) RETURN
      CALL BUFIN(IL,IFLAG)
      IF(IFLAG.NE.0) RETURN
  992 CONTINUE
      RETURN
C          ALL PARTICLES
C          NOTE THAT IDCAY CAN EXCEED 2**24 LIMIT OF PAIRPAK
  997 CONTINUE
      DO 998 K=1,NPTCL
      CALL MOVLEV(ZEVEL(IL),PPTCL(1,K),5)
      IORIG(K)=IZEVEL(IL+5)
      IDENT(K)=IZEVEL(IL+6)
      IDCAY(K)=IZEVEL(IL+7)*IPACK+IZEVEL(IL+8)
      IL=IL+9
      IF(IL.LE.MAXLEN-9) GOTO 998
      IF(K.EQ.NPTCL) RETURN
      CALL BUFIN(IL,IFLAG)
      IF(IFLAG.NE.0) RETURN
  998 CONTINUE
  999 CONTINUE
      RETURN
      END
+EOD
+DECK,WGENS.
      SUBROUTINE WGENS
C
C          Copy event information into ZEVEL and call BUFOUT.
C          If number of words required exceeds MAXLEN-8, the number
C          of records written=no. of words/(MAXLEN-8)+1
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,MBGEN
+CDE,KEYS
+CDE,IDRUN
+CDE,JETPAR
+CDE,JETSET
+CDE,JETSIG
+CDE,PARTCL
+CDE,PJETS
+CDE,PINITS
+CDE,PRIMAR
+CDE,ZEVEL
+CDE,FINAL
+CDE,TOTALS
+CDE,WSIG
C
      INTEGER I2,I1,JET,K,IEX,IL,ITA,I,NPSTA
C
      ITA=IABS(ITEVT)
      IZEVEL(1)=100
      IZEVEL(2)=1
      IL=3
      CALL MOVLEI(IDVER,IZEVEL(IL),4)
      IL=IL+4
      CALL MOVLEL(KEYS(1),LZEVEL(IL),MXKEYS)
      IL=IL+MXKEYS
      IZEVEL(IL)=NJET
      IL=IL+1
      CALL MOVLEV(P(1),ZEVEL(IL),59)
      IL=IL+59
      CALL MOVLEV(SIGF,ZEVEL(IL),1)
      IL=IL+1
      IF(.NOT.KEYS(4)) THEN
        ZEVEL(IL)=SIGMA
        ZEVEL(IL+1)=SIGEVT
        ZEVEL(IL+2)=WT
        IL=IL+3
      ENDIF
C          IF ITEVT.LT.0 WRITE ONLY STABLE PARTICLES AND FLAG
C          BY NPTCL=-(NO. OF STABLE PARTICLES)
      IF(ITEVT.GT.0) THEN
        IZEVEL(IL)=NPTCL
      ELSE
        NPSTA=0
        DO 990 I=1,NPTCL
990     IF(IDCAY(I).EQ.0) NPSTA=NPSTA+1
        IZEVEL(IL)=-NPSTA
      ENDIF
      IL=IL+1
      IF(NJET.GT.0) THEN
        IEX=NJET*5
        CALL MOVLEV(PJETS(1,1),ZEVEL(IL),IEX)
        IL=IL+IEX
        CALL MOVLEI(IDJETS(1),IZEVEL(IL),NJET)
        IL=IL+NJET
      ENDIF
      IF(KEYS(3).OR.KEYS(7).OR.KEYS(11)) THEN
        CALL MOVLEV(QWJET(1),ZEVEL(IL),6)
        IL=IL+6
        CALL MOVLEV(QMW,ZEVEL(IL),16)
        IL=IL+16
        I1=JWTYP
        I2=JETTYP(3)
        IZEVEL(IL)=SIGLLQ
        IL=IL+1
      ENDIF
      IF(KEYS(6).OR.KEYS(7)) THEN
        IZEVEL(IL)=NPAIR
        IL=IL+1
        IF(NPAIR.NE.0) THEN
          CALL MOVLEV(PPAIR(1,1),ZEVEL(IL),5*NPAIR)
          IL=IL+5*NPAIR
          CALL MOVLEI(IDPAIR(1),IZEVEL(IL),NPAIR)
          IL=IL+NPAIR
          CALL MOVLEI(JPAIR(1),IZEVEL(IL),NPAIR)
          IL=IL+NPAIR
        ENDIF
      ENDIF
      IZEVEL(IL)=NJSET
      IL=IL+1
      CALL MOVLEI(NKINPT,IZEVEL(IL),5)
      IL=IL+5
      CALL MOVLEI(NPOM,IZEVEL(IL),1)
      IL=IL+1
C
C          /JETSET/ COMMON BLOCK
      IF(NJSET.LT.1) GOTO 12
      DO 50 I=1,NJSET
      CALL MOVLEV(PJSET(1,I),ZEVEL(IL),5)
      IL=IL+5
      IZEVEL(IL)=JORIG(I)
      IZEVEL(IL+1)=JTYPE(I)
      IZEVEL(IL+2)=JDCAY(I)
      IL=IL+3
      IF(IL.LE.MAXLEN-9) GO TO 50
      IZEVEL(1)=IZEVEL(1)+1
      CALL BUFOUT(IL)
      IF(I.EQ.NJSET) GO TO 12
50    CONTINUE
C
C          /PARTCL/ COMMON BLOCK
C          IF ITEVT.LT.0, WRITE OUT ONLY STABLE PARTICLES
C          FLAG BY NPTCL=-(NO. OF STABLE PARTICLES)
C          SUPPRESS ORIGIN AND DECAY INFORMATION
12    IF(NPTCL.EQ.0) GOTO 999
      IF(ITEVT.GT.0) GOTO 997
C          ONLY STABLE PARTICLES
      DO 992 K=1,NPTCL
      IF(IDCAY(K).NE.0) GOTO 992
      JET=IABS(IORIG(K))/1000
      CALL MOVLEV(PPTCL(1,K),ZEVEL(IL),5)
      IZEVEL(IL+5)=(JET*10000+IABS(IDENT(K)))*ISIGN(1,IDENT(K))
      IL=IL+6
      IF(IL.LE.MAXLEN-6) GOTO 992
      IZEVEL(1)=IZEVEL(1)+1
      CALL BUFOUT(IL)
      IF(K.EQ.NPTCL) RETURN
  992 CONTINUE
      GOTO 999
  997 CONTINUE
C          ALL PARTICLES
C          NOTE IDCAY CAN EXCEED 2**24 LIMIT OF PAIRPAK
      DO 998 K=1,NPTCL
      CALL MOVLEV(PPTCL(1,K),ZEVEL(IL),5)
      IZEVEL(IL+5)=IORIG(K)
      IZEVEL(IL+6)=IDENT(K)
      IZEVEL(IL+7)=IDCAY(K)/IPACK
      IZEVEL(IL+8)=MOD(IDCAY(K),IPACK)
      IL=IL+9
      IF(IL.LE.MAXLEN-9) GOTO 998
      IZEVEL(1)=IZEVEL(1)+1
      CALL BUFOUT(IL)
      IF(K.EQ.NPTCL) RETURN
  998 CONTINUE
  999 CONTINUE
      IZEVEL(1)=IZEVEL(1)+1
      CALL BUFOUT(IL)
      RETURN
      END
+EOD
+DECK,ZEROL.
      SUBROUTINE ZEROL(Z,N)
C          SET N VALUES OF Z IN LEVEL2 TO ZERO
+CDE,ITAPES
      DIMENSION Z(N)
+SELF,IF=LEVEL2.
      LEVEL2,Z
+SELF.
      DO 1 I=1,N
    1 Z(I)=0
      RETURN
      END
+EOD
+PATCH,ISARUN,IF=INTERACT.
+EOD
+DECK,DIALOG.
      SUBROUTINE DIALOG
C
C          Set up user data with interactive commands from standard
C          Fortran input.
C
C          V6.26: Fixed FORCE to allow automatic top decays and to use
C          correct limit for maximum number.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,MBGEN
+CDE,FORCE
+CDE,EEPAR
+CDE,DKYTAB
+CDE,QCDPAR
+CDE,IDRUN
+CDE,FRGPAR
+CDE,KEYS
+CDE,PRTOUT
+CDE,SEED
+CDE,TYPES
+CDE,PRIMAR
+CDE,JETLIM
+CDE,NODCAY   
+CDE,WCON
+CDE,DYLIM
+CDE,QLMASS
+CDE,Q1Q2
+CDE,JETPAR
+CDE,ISLOOP
+CDE,TCPAR
+CDE,XMSSM
+CDE,SUGNU
+CDE,W50510,T=PASS,IF=PDFLIB
+CDE,W50517,T=PASS,IF=PDFLIB
+CDE,HCON
+CDE,KKGRAV
+CDE,MGLIMS
+CDE,LUXPAR
+CDE,CONST
C
      LOGICAL SETTYP,DUMY
      CHARACTER*8 TTL(10),WORD,LSTRUC,BLANK,LIST(29)
      CHARACTER*8 WTYP(4),RDID(2)
      CHARACTER*4 YN
      INTEGER IFL,I1,I2,I3,J1,I,IKEY,IJ,J,KK,IDXQK
      INTEGER NSEL,K,KFORCE(5),INDEX,IDG1,IDG2,IDG3,IDG4,IDXQ,IDXLEP
+SELF,IF=SINGLE.
      REAL    SEED
+SELF,IF=DOUBLE.
      DOUBLE PRECISION SEED
+SELF.
      INTEGER NLAP(3,17)
      REAL EMIN,YLIM1,YLIM2,ANGL1,ANGL2,XLIM1,XLIM2,AMW,AMZ
      INTEGER NFTEMP
      CHARACTER*8 HTYPE
+SELF,IF=PDFLIB
      CHARACTER*20 PDFPAR(20)
+SELF,IF=PDFLIB,IF=SINGLE
      REAL PDFVAL(20)
      REAL DX,DSCALE,DXPDF(-6:6)
+SELF,IF=PDFLIB,IF=DOUBLE
      DOUBLE PRECISION PDFVAL(20)
      DOUBLE PRECISION DX,DSCALE,DXPDF(-6:6)
+SELF
      REAL AMLIM1,AMLIM2
      INTEGER JLIM1,JLIM2
C
C          Overlapping variable flags.
      DATA NLAP/1,2,3, 1,2,7 ,1,2,8, 1,3,5, 1,3,6, 1,3,7, 1,3,8, 1,5,7,
     X          1,5,8, 1,6,7, 1,6,8, 2,3,7, 2,3,8, 3,5,7, 3,6,7, 3,5,8,
     X          3,6,8/
      DATA BLANK/'        '/
C          Duplicate data to avoid requiring ALDATA
      DATA LIST/'GL','UP','UB','DN','DB','ST','SB','CH','CB','BT','BB',
     $'TP','TB','NUE','ANUE','E-','E+','NUM','ANUM','MU-','MU+',
     $'NUT','ANUT','TAU-','TAU+','ALL','QUARKS','LEPTONS','NUS'/
C
C          Entry
C
      IFL=0
      NFTEMP=0
C
1111  PRINT 11
11    FORMAT(//,10X,' Use CAPITAL LETTERS only for all commands.',//,
     1 10X,' Give title for this run.')
C
C          Read title
C
      READ 1,TTL
    1 FORMAT(10A8)
      WRITE(ITCOM,1) TTL
      IF(TTL(1).EQ.'STOP    ') GOTO 999
C
C          Read energy and no. of events
C
      PRINT*,' total energy, # of events, # to print, # to skip.'
      READ*,ECM,NEVENT,NEVPRT,NJUMP
      WRITE(ITCOM,*)ECM,NEVENT,NEVPRT,NJUMP
C
C          Reset all variables if title is not 'SAME'
C
      IF(TTL(1).NE.'SAME    ') THEN
        DO 20 I=1,10
   20   TITLE(I)=TTL(I)
        CALL RESET
        KEYON=.FALSE.
C
C          Read reaction and set keys and NJET
C
   21   PRINT 22
   22   FORMAT(/,' Choose one of the following reactions:',/,
     $' TWOJET E+E- DRELLYAN MINBIAS SUSY WPAIR HIGGS',
     $' PHOTON TCOLOR WHIGGS')
        READ 3,REAC
    3   FORMAT(A8)
        DO 18 I=1,MXKEYS
18      KEYS(I)=.FALSE.
        KEYON=.FALSE.
C
        IF(REAC.EQ.'TWOJET  ') THEN
          KEYS(1)=.TRUE.
          IKEY=1
          NJET=2
        ELSEIF(REAC.EQ.'E+E-    ') THEN
          KEYS(2)=.TRUE.
          IKEY=2
          NJET=2
        ELSEIF(REAC.EQ.'DRELLYAN') THEN
          KEYS(3)=.TRUE.
          IKEY=3
          NJET=3
        ELSEIF(REAC.EQ.'MINBIAS ') THEN
          KEYS(4)=.TRUE.
          IKEY=4
          NJET=0
        ELSEIF(REAC.EQ.'SUPERSYM'.OR.REAC.EQ.'SUSY    ') THEN
          KEYS(5)=.TRUE.
          IKEY=5
          NJET=2
        ELSEIF(REAC.EQ.'WPAIR   ') THEN
          KEYS(6)=.TRUE.
          IKEY=6
          NJET=2
        ELSEIF(REAC.EQ.'HIGGS   ') THEN
          KEYS(7)=.TRUE.
          IKEY=7
          NJET=2
       ELSEIF(REAC.EQ.'PHOTON  ') THEN
         KEYS(8)=.TRUE.
         IKEY=8
         NJET=2
        ELSEIF(REAC.EQ.'TCOLOR  ') THEN
          KEYS(9)=.TRUE.
          IKEYS=9
          NJET=2
        ELSEIF(REAC.EQ.'WHIGGS  ') THEN
          KEYS(10)=.TRUE.
          IKEY=10
          NJET=2
        ELSE
          PRINT* ,' You must choose a valid reaction, try again.'
          GOTO 21
        ENDIF
C
        WRITE(ITCOM,3) REAC
      ENDIF
C
      EMIN=1.0
      SCM=ECM**2
      HALFE=ECM/2
      YLIM2=ALOG(ECM)
      YLIM1=-YLIM2
      NSEL=0
      ANGL1=0
      ANGL2=2*PI
      XLIM1=-1.0
      XLIM2=1.0
C
C          Read keyword. For each recognized keyword read corresponding
C          variables and set LOC flag.
C
      NSEL=0
1000  PRINT 99
99    FORMAT(//,
     $'      Choose among the following:',/,
     $'      Jet limits:',/,
     $' JETTYPE1 JETTYPE2 JETTYPE3 P PHI PT TH X Y WMODE1 WMODE2',/,
     $'      Drell Yan/Higgs limits:',/,
     $' HTYPE PHIW QMH QMW QTW THW WTYPE XW YW',/,
     $'      Decays:',/,
     $' FORCE FORCE1 NODECAY NOETA NOEVOLVE NOFRGMNT NOPI0',/,
     $'      Physics parameters:',/,
     $' CUTJET CUTOFF FRAGMENT GAUGINO HMASS HMASSES LAMBDA',/,
     $' MSSMA MSSMB MSSMC MSSMD MSSME SIGQT SIN2W SLEPTON SQUARK',/,
     $' SUGRA TCMASS TMASS WMASS XGEN',/,
     $'      Other:',/,
     $' BEAMS EPOL NPOMERON NSIGMA NTRIES PDFLIB SEED STRUC WFUDGE',/,
     $' WMMODE WPMODE Z0MODE',/,
     $'      Terminate with END. Use HELP for help.',/)
C
100   PRINT* ,' Give a variable name.'
      READ 3,WORD
      IF(WORD.EQ.'HELP    ') GO TO 1000
      NSEL=NSEL+1
C
C          Keyword END
      IF(WORD.EQ.'END     ') THEN
C
C              End of run
C
          WRITE(ITCOM,3) WORD
          PRINT 889
  889 FORMAT(//,10X,' NEW RUN',/,' If you are finished answer STOP.',/,
     1  ' If you answer SAME the parameters from previous run will be',
     2  ' used,',/,' unless you request otherwise.')
        GO TO 101
      ENDIF
C
C          Keyword P
      IF(WORD.EQ.'P       ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 562
        PRINT 563,EMIN,HALFE
        READ*, (PMIN(K),PMAX(K),K=1,NJET)
        WRITE(ITCOM,*)(PMIN(K),PMAX(K),K=1,NJET)
        LOC(1)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword Y
      IF(WORD.EQ.'Y       ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 562
        PRINT 563,YLIM1,YLIM2
        READ*, (YJMIN(K),YJMAX(K),K=1,NJET)
        WRITE(ITCOM,*)(YJMIN(K),YJMAX(K),K=1,NJET)
        LOC(2)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword X
      IF(WORD.EQ.'X       ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 562
        PRINT 563,XLIM1,XLIM2
        READ*, (XJMIN(K),XJMAX(K),K=1,NJET)
        WRITE(ITCOM,*)(XJMIN(K),XJMAX(K),K=1,NJET)
        LOC(3)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword PHI
      IF(WORD.EQ.'PHI     ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 562
        PRINT 563,ANGL1,ANGL2
        READ*, (PHIMIN(K),PHIMAX(K),K=1,NJET)
        WRITE(ITCOM,*)(PHIMIN(K),PHIMAX(K),K=1,NJET)
        LOC(4)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword TH
        IF(WORD.EQ.'TH      '.OR.WORD.EQ.'THETA   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 562
        PRINT 563,ANGL1,PI
        READ*, (THMIN(K),THMAX(K),K=1,NJET)
        WRITE(ITCOM,*)(THMIN(K),THMAX(K),K=1,NJET)
        LOC(5)=NSEL
        LOC(6)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword PT
      IF(WORD.EQ.'PT      '.OR.WORD.EQ.'PPERP   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 562
        PRINT 563,EMIN,HALFE
        READ*, (PTMIN(K),PTMAX(K),K=1,NJET)
        WRITE(ITCOM,*)(PTMIN(K),PTMAX(K),K=1,NJET)
        LOC(7)=NSEL
        LOC(8)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NODECAY
      IF(WORD.EQ.'NODECAY ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571,NODCAY
571     FORMAT(L1)
        WRITE(ITCOM,571) NODCAY
        LOC(9)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NOETA
      IF(WORD.EQ.'NOETA   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571, NOETA
        WRITE(ITCOM,571) NOETA
        LOC(10)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NOPI0
      IF(WORD.EQ.'NOPI0   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571, NOPI0
        WRITE(ITCOM,571)  NOPI0
        LOC(11)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword BEAMS
      IF(WORD.EQ.'BEAMS   ') THEN
        WRITE(ITCOM,3) WORD
   58   PRINT*,' Select each beam enclosed in single quotes.'
        PRINT*,' Allowed names are: P  N  AP  AN'
        READ *,RDID(1),RDID(2)
        IDIN(1)=0
        IDIN(2)=0
        DO 583 K=1,2
        IF(RDID(K).EQ.'P       ') IDIN(K)=+1120
        IF(RDID(K).EQ.'AP      ') IDIN(K)=-1120
        IF(RDID(K).EQ.'N       ') IDIN(K)=+1220
        IF(RDID(K).EQ.'AN      ') IDIN(K)=-1220
583     CONTINUE
        IF(IDIN(1)*IDIN(2).EQ.0) GOTO 58
        LOC(12)=NSEL
        WRITE(ITCOM,4) RDID(1),RDID(2)
        GO TO 1000
      ENDIF
C
C          Keyword FRAGMENT
      IF(WORD.EQ.'FRAGMENT') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, FRPAR
        WRITE(ITCOM,*) FRPAR
        LOC(13)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword SEED
      IF(WORD.EQ.'SEED    ') THEN
+SELF,IF=-RANLUX
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, SEED
        WRITE(ITCOM,*) SEED
        CALL RANFST(SEED)
        LOC(14)=NSEL
        GO TO 1000
+SELF,IF=RANLUX
        LUXK1=0
        LUXK2=0
        READ(ITCOM,*) LUXINT,LUXK1,LUXK2
        WRITE(ITLIS,*) LUXINT,LUXK1,LUXK2
        LOC(14)=NSEL
        GO TO 100
+SELF
      ENDIF
C
C          Keywords JETTYPE1, JETTYPE2, JETTYPE3
      IF(WORD.EQ.'JETTYPE1'.OR.WORD.EQ.'JETTYPE2'.OR.WORD.EQ.
     $'JETTYPE3') THEN
        WRITE(ITCOM,3) WORD
C          Print allowed types
60      IF(KEYS(6)) THEN
          PRINT 6001
          PRINT 6002
6001      FORMAT(' Give a list of jet types enclosed in single quotes ',
     $    'and separated by commas.',/,' Terminate list with a /')
6002      FORMAT(' The recognized W types are: W+, W-, Z0, GM and ALL')
        ELSE
          PRINT 6001
          PRINT 6003, LIST
6003      FORMAT(' The recognized jet types are:',/,4(1X,8A8,/),1X,5A8)
        ENDIF
        IF(KEYS(1)) THEN
          PRINT 6004
6004      FORMAT(' A fourth generation is also allowed:',/,
     $    ' X, XB for up, Y, YB for down.',/,
     $    ' The fourth generation is normally turned off.')
        ENDIF
        IF(WORD.EQ.'JETTYPE1') IJ=1
        IF(WORD.EQ.'JETTYPE2') IJ=2
        IF(WORD.EQ.'JETTYPE3') IJ=3
        READ*,(JETYP(K,IJ),K=1,25)
        DO 61 K=1,25
61      IF(JETYP(K,IJ).NE.BLANK) NJTTYP(IJ)=NJTTYP(IJ)+1
C          Check that only legal jet types are in the list
        IF(SETTYP(0)) GOTO 60
        WRITE(ITCOM,4)(JETYP(K,IJ),K=1,NJTTYP(IJ))
    4   FORMAT(1H',A,2H',)
        IF(NJTTYP(IJ).LT.25) WRITE(ITCOM,*) '/'
        LOC(15)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword SIN2W
      IF(WORD.EQ.'SIN2W   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, SIN2W
        WRITE(ITCOM,*) SIN2W
        LOC(17)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword TMASS
      IF(WORD.EQ.'TMASS   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, AMLEP(6),AMLEP(7),AMLEP(8)
        WRITE(ITCOM,*) AMLEP(6),AMLEP(7),AMLEP(8)
        LOC(18)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword QMH (note that it uses same variable as QMW)
      IF(WORD.EQ.'QMH     ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum MASS for Higgs.'
        READ*,QMIN,QMAX
        WRITE(ITCOM,*)QMIN,QMAX
        LOC(19)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword QMW
      IF(WORD.EQ.'QMW     ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum MASS for W(Z0).'
        READ*,QMIN,QMAX
        WRITE(ITCOM,*)QMIN,QMAX
        LOC(19)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword QTW
      IF(WORD.EQ.'QTW     ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum PT for W(Z0).'
        PRINT 563,EMIN,HALFE
        PRINT*,' Fix QTW to zero for standard Drell-Yan.'
        READ*, QTMIN,QTMAX
        WRITE(ITCOM,*) QTMIN,QTMAX
        LOC(20)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword YW
      IF(WORD.EQ.'YW      ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum Y for W(Z0).'
        PRINT 563,YLIM1,YLIM2
        READ*, YWMIN,YWMAX
        WRITE(ITCOM,*)YWMIN,YWMAX
        LOC(21)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword XW
      IF(WORD.EQ.'XW      ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum X for W(Z0).'
        PRINT 563,XLIM1,XLIM2
        READ*, XWMIN,XWMAX
        WRITE(ITCOM,*)XWMIN,XWMAX
        LOC(22)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword THW
      IF(WORD.EQ.'THW     ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum THETA for W(Z0).'
        PRINT 563,ANGL1,PI
        READ*, THWMIN,THWMAX
        WRITE(ITCOM,*)THWMIN,THWMAX
        LOC(23)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword PHIW
      IF(WORD.EQ.'PHIW    ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give minimum and maximum PHI for W(Z0).'
        PRINT 563,ANGL1,ANGL2
        READ*, PHWMIN,PHWMAX
        WRITE(ITCOM,*)PHWMIN,PHWMAX
        LOC(24)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NONUNU
      IF(WORD.EQ.'NONUNU  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571,NONUNU
        WRITE(ITCOM,571) NONUNU
        LOC(25)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword WTYPE
      IF(WORD.EQ.'WTYPE   ') THEN
        WRITE(ITCOM,3) WORD
   92   PRINT*,' Choose from one set of bosons: W+,W- or Z0,GM'
        PRINT*,' Enclose each in single quotes and terminate with / '
        DO 191 J=1,4
        WTYP(J)=BLANK
  191   GODY(J)=.FALSE.
        READ*,WTYP
        DO 192 K=1,4
        IF(WTYP(K).EQ.'GM      ') GODY(1)=.TRUE.
        IF(WTYP(K).EQ.'W+      ') GODY(2)=.TRUE.
        IF(WTYP(K).EQ.'W-      ') GODY(3)=.TRUE.
        IF(WTYP(K).EQ.'Z0      ') GODY(4)=.TRUE.
  192   CONTINUE
        IF(GODY(1)) JWTYP=1
        IF(GODY(2).OR.GODY(3)) JWTYP=3
        IF(GODY(4)) JWTYP=4
        IF((GODY(3).OR.GODY(2)).AND.(GODY(1).OR.GODY(4)).OR.JWTYP
     1  .EQ.0) THEN
          PRINT 2003
          GOTO 92
        ELSE
          WRITE(ITCOM,4) WTYP
          LOC(26)=NSEL
        ENDIF
        GO TO 1000
      ENDIF
C
C          Keyword LAMBDA
      IF(WORD.EQ.'LAMBDA  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, ALAM
        WRITE(ITCOM,*) ALAM
        ALAM2=ALAM**2
        LOC(27)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NTRIES
      IF(WORD.EQ.'NTRIES  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,NTRIES
        WRITE(ITCOM,*)NTRIES
        LOC(28)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword CUTOFF
      IF(WORD.EQ.'CUTOFF  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,CUTOFF,CUTPOW
        WRITE(ITCOM,*)CUTOFF,CUTPOW
        LOC(29)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword XGEN
      IF(WORD.EQ.'XGEN    ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,XGEN
        WRITE(ITCOM,*)XGEN
        LOC(30)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword SIGQT
      IF(WORD.EQ.'SIGQT   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,SIGQT
        WRITE(ITCOM,*)SIGQT
        LOC(31)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword CUTJET
      IF(WORD.EQ.'CUTJET  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, CUTJET
        WRITE(ITCOM,*) CUTJET
        LOC(32)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword WFUDGE
      IF(WORD.EQ.'WFUDGE  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, WFUDGE
        WRITE(ITCOM,*) WFUDGE
        LOC(50)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword STRUC
      IF(WORD.EQ.'STRUC   ') THEN
        WRITE(ITCOM,3) WORD
        ISTRUC=0
   69   PRINT*,' Choose a structure function: OWENS, BAIER or EICHTEN'
        PRINT*,' Enclose in single quotes'
        READ*,LSTRUC
        IF(LSTRUC.EQ.'OWENS   ') ISTRUC=1
        IF(LSTRUC.EQ.'BAIER   ') ISTRUC=2
        IF(LSTRUC.EQ.'EICHTEN ') ISTRUC=3
        IF(LSTRUC.EQ.'DUKE    '.OR.LSTRUC.EQ.'DO      ') ISTRUC=4
        IF(LSTRUC.EQ.'CTEQ2L  ') ISTRUC=5
        IF(LSTRUC.EQ.'CTEQ3L  ') ISTRUC=6
        IF(LSTRUC.EQ.'CTEQ    '.OR.LSTRUC.EQ.'CTEQ5L  ') ISTRUC=7
        IF(ISTRUC.EQ.0) GOTO 69
        WRITE(ITCOM,*) LSTRUC
        LOC(33)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NPOMERON
      IF(WORD.EQ.'NPOMERON') THEN
        WRITE(ITCOM,3) WORD
   93   PRINT*,' Give min and max; allowed range is 1 to 20.'
        READ*,MNPOM,MXPOM
        IF(MNPOM.LT.1.OR.MNPOM.GT.MXPOM.OR.MXPOM.GT.LIMPOM)
     1  GO TO 93
        WRITE(ITCOM,*)MNPOM,MXPOM
        LOC(34)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword FORCE
      IF(WORD.EQ.'FORCE   ') THEN
        PRINT*,' Force decay of a particle and its anti-particle.'
        PRINT*,' Use FORCE1 if you want to decay only one of them.'
        PRINT*,' Give a particle IDENT and IDENTs for decay mode.'
        PRINT*,' Max. number of decay products is 5.'
        NFTEMP=NFTEMP+2
        IF(NFTEMP.LE.MXFORC) THEN
          WRITE(ITCOM,3) WORD
          DO 72 K=1,5
  72      MFORCE(K,NFTEMP)=0
          READ*,IFORCE(NFTEMP),(MFORCE(K,NFTEMP),K=1,5)
          WRITE(ITCOM,*)IFORCE(NFTEMP),(MFORCE(K,NFTEMP),K=1,5)
          LOC(35)=NSEL
        ELSE
          PRINT*,' You exceeded the maximum allowed forced decays.'
        ENDIF
        GO TO 1000
      ENDIF
C
C          Keyword FORCE1
      IF(WORD.EQ.'FORCE1  ') THEN
        PRINT*,' Force decay of a particle.'
        PRINT*,' Give a particle IDENT and IDENTs for decay mode.'
        PRINT*,' Max. number of decay products is 5.'
        NFTEMP=NFTEMP+1
        IF(NFTEMP.LE.MXFORC) THEN
          WRITE(ITCOM,3) WORD
          DO 73 K=1,5
  73      MFORCE(K,NFTEMP)=0
          READ*,IFORCE(NFTEMP),(MFORCE(K,NFTEMP),K=1,5)
          WRITE(ITCOM,*)IFORCE(NFTEMP),(MFORCE(K,NFTEMP),K=1,5)
          LOC(35)=NSEL
        ELSE
          PRINT*,' You exceeded the maximun allowed forced decays.'
        ENDIF
        GO TO 1000
      ENDIF
C
C          Keyword HMASSES - also see HMASS
      IF(WORD.EQ.'HMASSES ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,
     $  ' Give Higgs masses (HIGGS,H10,H20,H30,H40,H1+,H2+,H1++,H2++)'
        CALL FLAVOR(80,I1,I2,I3,J1,INDEX)
        READ*,(AMLEP(INDEX+K),K=1,9)
        WRITE(ITCOM,*)(AMLEP(INDEX+K),K=1,9)
        LOC(36)=NSEL
        GO TO 1000
      ENDIF
C
C          Keywords WMODE1,WMODE2
      IF(WORD.EQ.'WMODE1  '.OR.WORD.EQ.'WMODE2  ') THEN
        WRITE(ITCOM,3) WORD
95      PRINT 6001
        PRINT 6003, LIST
        IF(WORD.EQ.'WMODE1  ') IJ=1
        IF(WORD.EQ.'WMODE2  ') IJ=2
        READ*,(WWTYP(K,IJ),K=1,25)
        DO 372 K=1,25
372     IF(WWTYP(K,IJ).NE.BLANK) NWWTYP(IJ)=NWWTYP(IJ)+1
        IF(SETTYP(0)) GOTO 95
        WRITE(ITCOM,4)(WWTYP(K,IJ),K=1,NWWTYP(IJ))
        IF(NWWTYP(IJ).LT.25) WRITE(ITCOM,*) '/'
        LOC(37)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NOEVOLVE
      IF(WORD.EQ.'NOEVOLVE') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571,NOEVOL
        WRITE(ITCOM,571) NOEVOL
        LOC(38)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NOHADRON
      IF(WORD.EQ.'NOHADRON') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571,NOEVOL
        WRITE(ITCOM,571) NOEVOL
        LOC(39)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword GAUGINO
      IF(WORD.EQ.'GAUGINO ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give masses (GLSS,GMSS,W+SS,W-SS)'
        CALL FLAVOR(29,I1,I2,I3,J1,IDG1)
        CALL FLAVOR(30,I1,I2,I3,J1,IDG2)
        CALL FLAVOR(39,I1,I2,I3,J1,IDG3)
        CALL FLAVOR(40,I1,I2,I3,J1,IDG4)
        READ*, AMLEP(IDG1),AMLEP(IDG2),AMLEP(IDG3),AMLEP(IDG4)
        WRITE(ITCOM,*) AMLEP(IDG1),AMLEP(IDG2),AMLEP(IDG3),AMLEP(IDG4)
        LOC(40)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword SQUARK
      IF(WORD.EQ.'SQUARK  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give masses (UPSS,DNSS,STSS,CHSS,BTSS,TPSS).'
        CALL FLAVOR(21,I1,I2,I3,J1,IDXQK)
        READ*, (AMLEP(IDXQK+K-1),K=1,6)
        WRITE(ITCOM,*) (AMLEP(IDXQK+K-1),K=1,6)
        LOC(41)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword SLEPTON
      IF(WORD.EQ.'SLEPTON ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,' Give masses (NUESS,E-SS,NUMSS,MU-SS,NUTSS,T-SS).'
        CALL FLAVOR(31,I1,I2,I3,J1,IDXLEP)
        READ*, (AMLEP(IDXLEP+K-1),K=1,6)
        WRITE(ITCOM,*) (AMLEP(IDXLEP+K-1),K=1,6)
        LOC(42)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NSIGMA
      IF(WORD.EQ.'NSIGMA  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,NSIGMA
        WRITE(ITCOM,*) NSIGMA
        LOC(43)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword XGENSS
      IF(WORD.EQ.'XGENSS  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*, XGENSS(9),(XGENSS(KK),KK=1,8)
        WRITE(ITCOM,*) XGENSS(9),(XGENSS(KK),KK=1,8)
        LOC(44)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword HMASS - just standard Higgs
      IF(WORD.EQ.'HMASS   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        CALL FLAVOR(81,I1,I2,I3,J1,INDEX)
        READ *, AMLEP(INDEX)
        WRITE(ITCOM,*) AMLEP(INDEX)
        LOC(45)=NSEL
        GO TO 1000
      ENDIF
C
C          Keywords WPMODE, WMMODE, Z0MODE
      IF(WORD.EQ.'WPMODE  '.OR.WORD.EQ.'WMMODE  '
     $.OR.WORD.EQ.'Z0MODE  ') THEN
        IF(WORD.EQ.'WPMODE  ') IJ=1
        IF(WORD.EQ.'WMMODE  ') IJ=2
        IF(WORD.EQ.'Z0MODE  ') IJ=3
        WRITE(ITCOM,3) WORD
        PRINT 6001
        PRINT 6003, LIST
        READ *, (WMODES(K,IJ),K=1,25)
        DO 463 K=1,25
463     IF(WMODES(K,IJ).NE.BLANK) NWMODE(IJ)=NWMODE(IJ)+1
        WRITE(ITCOM,*) (WMODES(K,IJ),K=1,NWMODE(IJ))
        LOC(46)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword WMASS
      IF(WORD.EQ.'WMASS   ') THEN
        PRINT 584
        READ*, AMW,AMZ
        WRITE(ITCOM,*) AMW,AMZ
        WMASS(1)=0.
        WMASS(2)=AMW
        WMASS(3)=AMW
        WMASS(4)=AMZ
        CALL FLAVOR(80,I1,I2,I3,J,INDEX)
        AMLEP(INDEX)=AMW
        CALL FLAVOR(90,I1,I2,I3,J,INDEX)
        AMLEP(INDEX)=AMZ
        LOC(47)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NEVOLVE
      IF(WORD.EQ.'NEVOLVE ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,NEVOLV
        WRITE(ITCOM,*) NEVOLV
        LOC(48)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NHADRON
      IF(WORD.EQ.'NHADRON ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,NFRGMN
        WRITE(ITCOM,*)NFRGMN
        LOC(49)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword TCMASS
      IF(WORD.EQ.'TCMASS  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 584
        READ*,TCMRHO,TCGRHO
        WRITE(ITCOM,*) TCMRHO,TCGRHO
        LOC(50)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword MSSMA
      IF(WORD.EQ.'MSSMA   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 585
        READ *, XGLSS,XMUSS,XHASS,XTBSS
        WRITE(ITCOM,*) XGLSS,XMUSS,XHASS,XTBSS
        LOC(51)=NSEL
        GOMSSM=.TRUE.
        GO TO 1000
      ENDIF
C
C          Keyword MSSMB
      IF(WORD.EQ.'MSSMB   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 586
        READ*, XQ1SS,XDRSS,XURSS,XL1SS,XERSS
        WRITE(ITCOM,*) XQ1SS,XDRSS,XURSS,XL1SS,XERSS
        LOC(52)=NSEL
        GOMSSM=.TRUE.
        GO TO 1000
      ENDIF
C
C          Keyword MSSMC
      IF(WORD.EQ.'MSSMC   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 587
        READ*, XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS
        WRITE(ITCOM,*)XQ3SS,XBRSS,XTRSS,XL3SS,XTARSS,XATSS,XABSS,XATASS
        LOC(53)=NSEL
        GOMSSM=.TRUE.
        GO TO 1000
      ENDIF
C
C          Keyword PDFLIB: parameters for PDFLIB
+SELF,IF=PDFLIB
      IF(WORD.EQ.'PDFLIB  ') THEN
        WRITE(ITCOM,3) WORD
        DO 541 I=1,20
          PDFPAR(I)='                    '
          PDFVAL(I)=0
541     CONTINUE
        PRINT 588
        READ*, (PDFPAR(I),PDFVAL(I),I=1,20)
        DO 542 I=1,20
          IF(PDFPAR(I).NE.'                    ') THEN
            WRITE(ITCOM,5401) PDFPAR(I)
5401        FORMAT(1H',A,1H')
            WRITE(ITCOM,*) PDFVAL(I)
          ENDIF
542     CONTINUE
        WRITE(ITCOM,*) '/'
        ISTRUC=-999
        LOC(54)=NSEL
        GO TO 1000
      ENDIF
+SELF
C
C          Keyword SUGRA
      IF(WORD.EQ.'SUGRA   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 589
        READ*, XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU
        WRITE(ITCOM,*) XM0SU,XMHSU,XA0SU,XTGBSU,XSMUSU
        LOC(55)=NSEL
        GOMSSM=.TRUE.
        GOSUG=.TRUE.
        GO TO 1000
      ENDIF
C
C          Keyword HTYPE
      IF(WORD.EQ.'HTYPE   ') THEN
        PRINT*,' Enter Higgs type (HL0, HH0, HA0) in single quotes'
        READ*, HTYPE
        IHTYPE=0
        IF(HTYPE.EQ.'HL0     ') IHTYPE=82
        IF(HTYPE.EQ.'HH0     ') IHTYPE=83
        IF(HTYPE.EQ.'HA0     ') IHTYPE=84
        IF(IHTYPE.EQ.0) THEN
          PRINT*, 'Invalid Higgs type - try again'
          GO TO 1000
        ENDIF
        WRITE(ITCOM,3) WORD
        WRITE(ITCOM,*) HTYPE
        LOC(56)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword EPOL
      IF(WORD.EQ.'EPOL    ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 590
        READ*,PLEM,PLEP
        WRITE(ITCOM,*) PLEM,PLEP
        LOC(57)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword MSSMD
      IF(WORD.EQ.'MSSMD   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 591
        READ*,XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS
        WRITE(ITCOM,*) XQ2SS,XSRSS,XCRSS,XL2SS,XMRSS
        LOC(58)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword MSSME
      IF(WORD.EQ.'MSSME   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 592
        READ*, XM1SS,XM2SS
        WRITE(ITCOM,*) XM1SS,XM2SS
        LOC(59)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword GMSB
      IF(WORD.EQ.'GMSB    ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 593
        READ*, XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,XCMGV
        WRITE(ITCOM,*) XLAMGM,XMESGM,XN5GM,XTGBSU,XSMUSU,XCMGV
        LOC(60)=NSEL
        GOMSSM=.TRUE.
        GOGMSB=.TRUE.
        GO TO 1000
      ENDIF
C
C          Keyword NUSUG1: optional GUT scale gaugino masses
      IF(WORD.EQ.'NUSUG1   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 594
        READ*, XNUSUG(1),XNUSUG(2),XNUSUG(3)
        WRITE(ITCOM,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
        LOC(61)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG2: optional GUT scale A terms
      IF(WORD.EQ.'NUSUG2   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 595
        READ*, XNUSUG(6),XNUSUG(5),XNUSUG(4)
        WRITE(ITCOM,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
        LOC(62)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG3: optional GUT scale Higgs masses
      IF(WORD.EQ.'NUSUG3   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 596
        READ*, XNUSUG(7),XNUSUG(8)
        WRITE(ITCOM,*) XNUSUG(7),XNUSUG(8)
        LOC(63)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG4: optional GUT scale 1st/2nd gen. masses
      IF(WORD.EQ.'NUSUG4   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 597
        READ*, XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10)
     $,XNUSUG(9)
        WRITE(ITCOM,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),XNUSUG(10)
     $,XNUSUG(9)
        LOC(64)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NUSUG5: optional GUT scale 3rd gen. masses
      IF(WORD.EQ.'NUSUG5   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 598
        READ*, XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15)
     $,XNUSUG(14)
        WRITE(ITCOM,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),XNUSUG(15)
     $,XNUSUG(14)
        LOC(65)=NSEL
        GO TO 100
      ENDIF
C
C          Keyword NOGRAV: No gravitino decays
      IF(WORD.EQ.'NOGRAV  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 572
        READ 571,NOGRAV
        WRITE(ITCOM,571) NOGRAV
        LOC(66)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword MGVTNO: Sets the gravitino mass
      IF(WORD.EQ.'MGVTNO  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 599
        READ*, XMGVTO
        WRITE(ITCOM,*) XMGVTO
        LOC(67)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword AL3UNI: Impose alpha_s unification at M_GUT
      IF(WORD.EQ.'AL3UNI  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 600
        READ*, AL3UNI
        WRITE(ITCOM,*) AL3UNI
        LOC(68)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword GMSB2: additional GMSB parameters
      IF(WORD.EQ.'GMSB2   ') THEN
       WRITE(ITCOM,3) WORD
       PRINT 601
       READ*, XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM
       WRITE(ITCOM,*) XRSLGM,XDHDGM,XDHUGM,XDYGM,XN51GM,XN52GM,XN53GM
       LOC(69)=NSEL
       GO TO 1000
      ENDIF
C
C          Keyword EEBREM: do bremsstralung
      IF(WORD.EQ.'EEBREM  ') THEN
       WRITE(ITCOM,3) WORD
       PRINT 602
       READ*, RSHMIN,RSHMAX
       WRITE(ITCOM,*) RSHMIN,RSHMAX
       IBREM=.TRUE.
       LOC(70)=NSEL
       GO TO 1000
      ENDIF
C
C          Keyword EEBEAM: do beamstralung
      IF(WORD.EQ.'EEBEAM   ') THEN
       WRITE(ITCOM,3) WORD
       PRINT 603
       READ*, RSHMIN,RSHMAX,UPSLON,SIGZ
       WRITE(ITCOM,*) RSHMIN,RSHMAX,UPSLON,SIGZ
       IBREM=.TRUE.
       IBEAM=.TRUE.
       LOC(71)=NSEL
       GO TO 1000
      ENDIF
C
C          Keyword QMKKG (QMW for EXTRADIM)
      IF(WORD.EQ.'QMKKG   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,'KK graviton mass limits?'
        READ*, QMIN,QMAX
        WRITE(ITCOM,*) QMIN,QMAX
        LOC(19)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword QTKKG (QTW for EXTRADIM)
      IF(WORD.EQ.'QTKKG   ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,'KK graviton qt limits?'
        READ*, QTMIN,QTMAX
        WRITE(ITCOM,*) QTMIN,QTMAX
        LOC(20)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword EXTRAD for EXTRADIM
      IF(WORD.EQ.'EXTRAD  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,'KK delta n, mass, UVCUT flag?'
        READ*, NEXTRAD,MASSD,UVCUT
        WRITE(ITCOM,*) NEXTRAD,MASSD,UVCUT
        LOC(72)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword MIJLIM
      IF(WORD.EQ.'MIJLIM  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,'Dijet pair mass limits i,j,min,max?'
        READ*, JLIM1,JLIM2,AMLIM1,AMLIM2
        WRITE(ITCOM,*) JLIM1,JLIM2,AMLIM1,AMLIM2
        LOC(73)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword MTOT
      IF(WORD.EQ.'MTOT    ') THEN
        WRITE(ITCOM,3) WORD
        PRINT*,'Total mass limits?'
        READ*, EHMGMN,EHMGMX
        WRITE(ITCOM,*) EHMGMN,EHMGMX
        LOC(74)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword SUGRHN: enter right-neutrino parameters
      IF(WORD.EQ.'SUGRHN   ') THEN
       WRITE(ITCOM,3) WORD
       PRINT 604
       READ*, XMN3NR,XMAJNR,XANSS,XNRSS
       WRITE(ITCOM,*) XMN3NR,XMAJNR,XANSS,XNRSS
       LOC(75)=NSEL
       GO TO 1000
      ENDIF
C
C          Keyword AMSB
      IF(WORD.EQ.'AMSB    ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 605
        READ*, XM0SU,XMHSU,XTGBSU,XSMUSU
        WRITE(ITCOM,*) XM0SU,XMHSU,XTGBSU,XSMUSU
        LOC(76)=NSEL
        GOMSSM=.TRUE.
        GOSUG=.TRUE.
        GOAMSB=.TRUE.
        GO TO 1000
      ENDIF
C
C          Keyword SSBCSC
      IF(WORD.EQ.'SSBCSC  ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 606
        READ*, XSBCS
        WRITE(ITCOM,*) XSBCS
        LOC(77)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NOB
      IF(WORD.EQ.'NOB     ') THEN
        WRITE(ITCOM,3) WORD
        READ*, NOB
        WRITE(ITCOM,*) NOB
        LOC(78)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword NOTAU
      IF(WORD.EQ.'NOTAU   ') THEN
        WRITE(ITCOM,3) WORD
        READ*, NOTAU
        WRITE(ITCOM,*) NOTAU
        LOC(79)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword GAMGAM
      IF(WORD.EQ.'GAMGAM  ') THEN
        WRITE(ITCOM,3) WORD
        READ*, GAMGAM
        WRITE(ITCOM,*) GAMGAM
        LOC(80)=NSEL
        GO TO 1000
      ENDIF
C
C          Keyword AMSB2: additional AMSB parameters
      IF(WORD.EQ.'AMSB2   ') THEN
       WRITE(ITCOM,3) WORD
       PRINT 607
       READ*, XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
       WRITE(ITCOM,*) XCQAM,XCDAM,XCUAM,XCLAM,XCEAM,XCHDAM,XCHUAM
       LOC(81)=NSEL
       GO TO 1000
      ENDIF
C
C          Keyword NUHM: enter mu(Q), mA(Q) in lieu of mHD, mHu
      INUHM=0
      IF(WORD.EQ.'NUHM     ') THEN
        WRITE(ITCOM,3) WORD
        PRINT 608
        READ*, XNUSUG(19),XNUSUG(20)
        WRITE(ITCOM,*) XNUSUG(19),XNUSUG(20)
        LOC(82)=NSEL
        INUHM=1
        GO TO 100
      ENDIF
C
C          None of the above
C
      PRINT 99
      GO TO 1000
C
  562 FORMAT(' Give jet limits: min1,max1,min2,max2, etc.',
     1' Terminate list with a /.',/,
     2' To fix a variable give only minimum value.',/)
  563 FORMAT(' Allowed range is ',F9.2,' - ',F9.2)
  572 FORMAT('  T or F?')
  584 FORMAT(' Value?')
  585 FORMAT(' Give M(gluino), mu, M(ha), tan(beta)')
  586 FORMAT(' Give M(ul), M(dr), M(ur), M(el), M(er), ')
  587 FORMAT(' Give M(tl), M(br), M(tr), M(taul), M(taur), A(t),',
     $' A(b), A(tau)')
  588 FORMAT(' Give PDFLIB keyword, value, ...')
  589 FORMAT(' Give M_0, M_(1/2), A_0, tan(beta), sgn(mu)')
  590 FORMAT(' Give polarizations P_L(e-), P_L(e+)')
  591 FORMAT(' Give optional M(cl), M(sr), M(cr), M(mul), M(mur), ')
  592 FORMAT(' Give optional M_1, M_2')
  593 FORMAT(' Give LAM, M_MES, XN5, tan(beta), sgn(mu), C_mgv')
  594 FORMAT(' Give optional GUT scale M_1, M_2, M_3')
  595 FORMAT(' Give optional GUT scale A_t, A_b, A_tau')
  596 FORMAT(' Give optional GUT scale m_Hd, m_Hu')
  597 FORMAT(' Give optional M(ul), M(dr), M(ur), M(el), M(er), ')
  598 FORMAT(' Give optional M(tl), M(br), M(tr), M(Ll), M(Lr), ')
  599 FORMAT(' Enter optional m(gravitino), ')
  600 FORMAT(' Enter .TRUE. if alpha_s unification is wanted:, ')
  601 FORMAT(' Enter Rsl,dmH_d,dmH_u,RDY,n5_1,n5_2,n5_3: ')
  602 FORMAT(' Enter RSHMIN,RSHMAX for bremsstrahlung: ')
  603 FORMAT(' Enter RSHMIN,RSHMAX,UPSLON,SIGZ for beamstrahlung: ')
  604 FORMAT(' Enter M_N3, M_MAJ, A_N, M_NRSS for RHN model: ')
  605 FORMAT(' Give M_0, M_(3/2), tan(beta), sgn(mu)')
  606 FORMAT(' Enter Q_max= max scale choice for SUSY BCs')
  607 FORMAT(' Enter cQ,cD,cU,cL,cE,cHd,cHu: ')
  608 FORMAT(' Enter mu(Q), mA(Q): ')
C
C          CHECK FOR ERRORS AND OVERLAPPING VARIABLES.
C          PRINT ERROR MESSAGE OR WARNINGS
  101 CONTINUE
      IF(LOC(2)*LOC(5).NE.0) PRINT 2001
      IF(LOC(2)*LOC(6).NE.0) PRINT 2001
      IF(LOC(15).NE.0.OR.LOC(37).NE.0) DUMY=SETTYP(0)
      DO 120 I=1,17
      I1=NLAP(1,I)
      I2=NLAP(2,I)
      I3=NLAP(3,I)
      IF(LOC(I1)*LOC(I2)*LOC(I3).NE.0) PRINT 1001
  120 CONTINUE
 1001 FORMAT(//,2X,'YOU HAVE GIVEN LIMITS FOR AN OVERLAPPING SET OF',
     C  ' VARIABLES. SET MINIMIZING PPERP INTERVAL WILL BE USED')
 2001 FORMAT(//,2X,' YOU CANNOT GIVE LIMITS FOR BOTH THETA AND Y. MAKE',
     C  ' UP YOUR MIND. JOB TERMINATED')
 2003 FORMAT(/,'  YOU CANNOT RUN WS AND Z0 OR GAMMAS AT THE SAME TIME')
 2004 FORMAT(//,'  PARAMETER OUT OF RANGE. ')
      GOTO 1111
  999 REWIND ITCOM
      RETURN
      END
+EOD
+DECK,ISARUN
       PROGRAM ISARUN
C
C          MAIN PROGRAM FOR THE INTERACTIVE VERSION OF ISAJET.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,IDRUN
+SELF,IF=ZEBINIT
+CDE,ISABNK
+CDE,ISAUNT
+SELF
C
      CHARACTER*80 FILDKY,FILEVT,FILCOM,FILLIS,FILEX
      CHARACTER*40 V,VISAJE
      CHARACTER*1 YN
      LOGICAL NEWCOM,QPART,QCAL,QLEP
      INTEGER IDKY
C
C
      V=VISAJE()
      PRINT 1000,V
1000  FORMAT(/,10X,A40,/,5X,' (interactive version)',//,
     $15X,'All input should be UPPER CASE.'/
     $15X,'If in trouble, try HELP.'/)
C
C          SPECIFY DECAY TABLE -- OPENED ONLY FOR EXECUTION
      PRINT*,' Enter file name for the decay table.'
      READ 1010,FILDKY
1010  FORMAT(A80)
      PRINT*,' Do you want to print the decay table? (Y/N)'
      READ 1020,YN
1020  FORMAT(A1)
      IF(YN.EQ.'N') THEN
        IDKY=-11
      ELSE
        IDKY=+11
      ENDIF
C
C          SPECIFY OUTPUT FILE -- OPENED ONLY FOR EXECUTION
      PRINT*,' Enter file name for the output data.'
      READ 1010,FILEVT
      PRINT*,
     $' Do you want both resonances and stable particles? (Y/N)'
      READ 1020,YN
      IF(YN.EQ.'N') THEN
        ITEVT=-12
      ELSE
        ITEVT=+12
      ENDIF
C
C          SPECIFY COMMAND FILE
      PRINT* ,' Do you wish to use an OLD command file? (Y/N)'
      READ 1020,YN
      IF(YN.EQ.'Y') THEN
        PRINT* ,' Enter file name for the old command file.'
        READ 1010,FILCOM
        FILEX=FILCOM
        OPEN(UNIT=13,ERR=100,FILE=FILCOM,STATUS='OLD',FORM='FORMATTED')
        NEWCOM=.FALSE.
      ELSE
        PRINT*, ' Enter file name for the new command file.'
        PRINT*, ' If the name is SCRATCH, the file will not be saved.'
        READ 1010,FILCOM
        FILEX=FILCOM
        OPEN(UNIT=13,ERR=100,FILE=FILCOM,STATUS='NEW',FORM='FORMATTED')
        NEWCOM=.TRUE.
      ENDIF
C
C          SPECIFY LISTING FILE
      PRINT*,' Enter file name for the listing.'
      READ 1010, FILLIS
      FILEX=FILLIS
      OPEN(UNIT=14,ERR=100,FILE=FILLIS,STATUS='NEW',FORM='FORMATTED')
C
C          PREPARE COMMAND FILE
      IF(NEWCOM) CALL ISASET(IDKY,ITEVT,13,14)
C
C          EXECUTE COMMAND FILE
      PRINT*,' Do you wish to run this job? (Y/N)'
      READ 1020,YN
      IF(YN.EQ.'Y') THEN
        FILEX=FILDKY
        OPEN(UNIT=11,ERR=100,FILE=FILDKY,STATUS='OLD',FORM='FORMATTED')
        FILEX=FILEVT
        OPEN(UNIT=12,ERR=100,FILE=FILEVT,STATUS='NEW',
     &    FORM='UNFORMATTED')
+SELF,IF=ZEBINIT
C
C          Setup for ZEBRA only
C
      ISUNIT=IABS(ITEVT)
      FILISA=FILEVT
      PRINT *,' Select ZEBRA banks by typing:ISAP or ISAC or ISAL'
      PRINT *,' ISAP: all particles banks will be written'
      PRINT *,' ISAC: pseudo calorimeter banks will be written'
      PRINT *,' ISAL: leptons banks will be written'
      PRINT *,' Any combination is allowed, i.e.',
     $' ISAPISACISAL will write all 3 banks'
      READ 1011,BANK
 1011 FORMAT(A12)
C
C  Set up flags to select type of output
C
      QPART=BANK(1:4).EQ.'ISAP'.OR.BANK(5:8).EQ.'ISAP'.OR.
     $        BANK(9:12).EQ.'ISAP'
      QCAL=BANK(1:4).EQ.'ISAC'.OR.BANK(5:8).EQ.'ISAC'.OR.
     $       BANK(9:12).EQ.'ISAC'
      QLEP=BANK(1:4).EQ.'ISAL'.OR.BANK(5:8).EQ.'ISAL'.OR.
     $     BANK(9:12).EQ.'ISAL'
      CALL ISBKST(QPART,QCAL,QLEP)
C
      CALL MZEBRA(0)
      CALL ISAZEB('O')           ! initialize Zebra for ISAJET
+SELF
        CALL ISAJET(IDKY,ITEVT,13,14)
        PRINT*,' Events have been generated on file'
        PRINT*,FILEVT
      ENDIF
C
C          TERMINATE
      IF(FILCOM(1:7).EQ.'SCRATCH') THEN
        FILEX=FILCOM
        CLOSE(13,ERR=100,STATUS='DELETE')
      ENDIF
      PRINT*,' Job terminated normally.'
      STOP
C
100   PRINT 1030,FILEX
1030  FORMAT(/' Unable to open or close file '/1X,A80/
     $' Job terminated.')
      STOP 99
      END
+EOD
+DECK,ISASET
      SUBROUTINE ISASET(IDKY,IEVT,ICOM,ILIS)
C
C          SUBROUTINE TO SET UP ISAJET RUN THROUGH DIALOG
C          IDKY, IEVT, ICOM, ILIS ARE TAPE NUMBERS AS FOR ISAJET.
C
+CDE,ITAPES
C          SET TAPE NUMBERS
      ITDKY=IABS(IDKY)
      ITEVT=IABS(IEVT)
      ITCOM=IABS(ICOM)
      ITLIS=IABS(ILIS)
C          INITIALIZE
      CALL SETCON
      CALL RESET
C          READ COMMANDS INTERACTIVELY AND WRITE COMMAND FILE.
      CALL DIALOG
      REWIND ITCOM
      RETURN
      END
+EOD
+PATCH,ISAZEB.
+EOD
+DECK,BKISAE                          .
      SUBROUTINE BKISAE
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : BOOK ISAE BANK
C-
C-   Inputs  : NONE
C-   Outputs : NONE
C-   Controls: NONE
C-
C-   Created  31-JAN-1991   Serban Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER IOISAE
      LOGICAL FIRST
+CDE,ZEBCOM.
      DATA FIRST/.TRUE./
C----------------------------------------------------------------------
      IF(FIRST) THEN              ! only for first event
        CALL MZFORM('ISAE','10I 6F 2D',IOISAE)
        FIRST=.FALSE.
      ENDIF
C
C  create ZEBRA bank ISAE (main supporting bank)
C
      CALL MZBOOK(IXMAIN,LISAE,LISAE,1,
     $            'ISAE',9,9,18,IOISAE,-1)

  999 RETURN
      END
+EOD
+DECK,BKISAJ                          .
      SUBROUTINE BKISAJ(LISAJ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Book ISAJ banks
C-   Outputs :
C-     LISAJ = pointer to created bank
C-
C-   Created  11-DEC-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER LISAJ
+CDE,IZISAJ.
+CDE,ZEBCOM.
      INTEGER NLINKS,NDATA
      PARAMETER( NLINKS = 1 )
      PARAMETER( NDATA = 9 )
      INTEGER GZISAJ,IOISAJ,LNEXT
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C----------------------------------------------------------------------
C
      IF(FIRST) THEN
        CALL MZFORM('ISAJ','1I-F',IOISAJ)
        FIRST=.FALSE.
      ENDIF
C
      LISAJ=GZISAJ()
C
      IF(LISAJ.EQ.0) THEN   ! first ISAJ bank
        CALL MZBOOK(IXMAIN,LISAJ,LISAE,-IZISAJ,
     $                    'ISAJ',NLINKS,0,NDATA,IOISAJ,-1)
C
      ELSE                  ! find last ISAJ bank
    1   LNEXT=LQ(LISAJ)
        IF(LNEXT.EQ.0) THEN
          CALL MZBOOK(IXMAIN,LISAJ,LISAJ,0,
     $                    'ISAJ',NLINKS,0,NDATA,IOISAJ,-1)
        ELSE
          LISAJ=LNEXT
          GOTO 1
        ENDIF
      ENDIF
C
  999 RETURN
      END
+EOD
+DECK,BKISAQ                          .
      SUBROUTINE BKISAQ(LISAQ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Book ISAQ banks
C-   Outputs :
C-     LISAQ = pointer to created bank
C-
C-   Created  11-DEC-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER LISAQ
+CDE,IZISAQ.
+CDE,ZEBCOM.
      INTEGER NLINKS,NDATA
      PARAMETER( NLINKS = 2 )
      PARAMETER( NDATA = 9 )
      INTEGER GZISAQ,IOISAQ,LNEXT
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C----------------------------------------------------------------------
C
      IF(FIRST) THEN
        CALL MZFORM('ISAQ','1I-F',IOISAQ)
        FIRST=.FALSE.
      ENDIF
C
      LISAQ=GZISAQ()
C
      IF(LISAQ.EQ.0) THEN   ! first ISAQ bank
        CALL MZBOOK(IXMAIN,LISAQ,LISAE,-IZISAQ,
     $                    'ISAQ',NLINKS,0,NDATA,IOISAQ,-1)
C
      ELSE                  ! find last ISAQ bank
    1   LNEXT=LQ(LISAQ)
        IF(LNEXT.EQ.0) THEN
          CALL MZBOOK(IXMAIN,LISAQ,LISAQ,0,
     $                    'ISAQ',NLINKS,0,NDATA,IOISAQ,-1)
        ELSE
          LISAQ=LNEXT
          GOTO 1
        ENDIF
      ENDIF
C
  999 RETURN
      END
+EOD
+DECK,BKISCM                          .
      SUBROUTINE BKISCM(ND,LISCM)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Book the Bank ISCM
C-
C-   Inputs  : ND    = NUMBER OF WORDS IN ISCM
C-   Outputs : LISCM  = Link of Booked ISCM Bank
C-   Controls: None
C-
C-   Created  13-DEC-1989 10:20:16.28  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER LISCM
      INTEGER IXIO
      INTEGER ND
C
C--   ZEBRA BANKS
+CDE,ZEBCOM.
+CDE,IZISCM.
C
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
C----------------------------------------------------------------------
C
C--   INITIALIZE
C
      LISCM = 0
      IF(FIRST)THEN
        CALL MZFORM('ISCM','-H',IXIO)        ! Describe Bank format
      ENDIF
C
      CALL MZBOOK
     &  (IXMAIN,LISCM,LISAB,-IZISCM,'ISCM',1,1,ND,IXIO,0)
C
  999 RETURN
      END
+EOD
+DECK,BKISJT                          .
      SUBROUTINE BKISJT(LISJT)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Book ISJT banks (jets found with toy calorimeter)
C-   Output:
C-      LISJT = pointer to booked bank
C-
C-   Created  29-JAN-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER LISJT,LISAC,GZISAC,LNEXT,GZISJT
+CDE,IZISJT.
+CDE,ZEBCOM.
      INTEGER NLINKS,NDATA
      PARAMETER( NLINKS = 1 )
      PARAMETER( NDATA  = 9 )
C----------------------------------------------------------------------
C
      LISJT=GZISJT()
C
      IF(LISJT.EQ.0) THEN   ! first ISJT bank
        LISAC=GZISAC()
        CALL MZBOOK(IXMAIN,LISJT,LISAC,-IZISJT,
     $                    'ISJT',NLINKS,0,NDATA,3,-1)
C
      ELSE                  ! find last ISJT bank
    1   LNEXT=LQ(LISJT)
        IF(LNEXT.EQ.0) THEN
          CALL MZBOOK(IXMAIN,LISJT,LISJT,0,
     $                    'ISJT',NLINKS,0,NDATA,3,-1)
        ELSE
          LISJT=LNEXT
          GOTO 1
        ENDIF
      ENDIF
  999 RETURN
      END
+EOD
+DECK,BKISMR                          .
      SUBROUTINE BKISMR(LISMR)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     book ISMR bank
C-
C-   Outputs :
C-      LISMR = pointer to ISMR bank
C-
C-   Created  18-MAY-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISMR.
      INTEGER LISMR,LISAC,GZISAC,GZISMR
C----------------------------------------------------------------------
      LISMR=GZISMR()
      IF(LISMR.NE.0) GOTO 999  ! already exists
      LISAC=GZISAC()
      CALL MZBOOK(IXMAIN,LISMR,LISAC,-IZISMR,
     $            'ISMR',0,0,9,3,-1)
  999 RETURN
      END
+EOD
+DECK,BKISV1                          .
      SUBROUTINE BKISV1(NVERTX,LISV1)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Book ISV1 bank (ISAJET vertices)
C-   Input:
C-     NVERTX = vertex number
C-   Outputs :
C-     LISV1 = pointer to LISV1
C-
C-   Created  11-DEC-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISV1.
+CDE,ZEBCOM.
+CDE,ISALNK.
C
      INTEGER NVERTX,LISV1
      INTEGER IOISV1
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C----------------------------------------------------------------------
      IF(FIRST) THEN
        CALL MZFORM('ISV1','1I-F',IOISV1)   ! format for ISV1
        FIRST=.FALSE.
      ENDIF
      IF(NVERTX.EQ.1) THEN
        CALL MZBOOK(IXMAIN,LVD,LISAE,-IZISV1,
     $              'ISV1',2,1,9,IOISV1,-1)
        LISV1=LVD(1)
      ELSE
        CALL MZBOOK(IXMAIN,LVD(NVERTX),LVD(NVERTX-1),0,
     $                  'ISV1',2,1,9,IOISV1,-1)
        LISV1=LVD(NVERTX)
      ENDIF
  999 RETURN
      END
+EOD
+DECK,BKPJET                          .
      SUBROUTINE BKPJET(LPJHD,LPJET)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Book the Bank PJET -
C-      IF NO PJET BANKS EXIST THEN BOOK THE FIRST ONE
C-      ELSE BOOK NEW PJET BANK AT END OF LINEAR CHAIN OF PJET BANKS
C-
C-   Inputs  : LPJHD - PJET HEADER BANK POINTER
C-   Outputs : LPJET - Link of Booked PJET Bank
C-   Controls: None
C-
C-   Created   7-NOV-1989 18:10:09.84  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
C--   ZEBRA BANKS
+CDE,ZEBCOM.
+CDE,IZPJET.
C
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
C--   INTERNAL VARIABLES
      INTEGER LPJET,LPJETP
      INTEGER LPJHD
      INTEGER IXIO
      INTEGER GZPJHD
C
      INTEGER IDN
C----------------------------------------------------------------------
C
C--   DO PRELIMINARIES ON FIRST CALL
      IF(FIRST)THEN
        CALL MZFORM('PJET','1I 9F 2I',IXIO)
        FIRST=.FALSE.
      END IF
C
      IF(LPJHD.LE.0) LPJHD = GZPJHD()
      IF(LPJHD.LE.0) CALL BKPJHD(LPJHD)
C
      LPJETP=LPJHD-IZPJET
      IDN=0
      IF(LQ(LPJETP).EQ.0) THEN
C
C ****  FIRST PJET BANK NEEDS TO BE BOOKED
C
        CALL MZBOOK(IXMAIN,LPJET,LPJHD,-IZPJET,'PJET',2,2,12,IXIO,0)
        IQ(LPJET-5) = 1
      ELSE
C
C ****  LOOK FOR LAST PJET BANK TO ADD SUBSEQUENT PJET BANKS
C
   10   CONTINUE
        IF(LQ(LPJETP).NE.0) THEN
          LPJETP=LQ(LPJETP)
          IDN=IQ(LPJETP-5)
          GOTO 10
        END IF
C
C--         BOOK THE PJET BANKS, SET THE ID NUMBER
        CALL MZBOOK(IXMAIN,LPJET,LPJETP,0,'PJET',2,2,12,IXIO,0)
        IQ(LPJET-5)=IDN+1
      ENDIF
      IQ(LPJET+1)=1         ! Version number
  999 RETURN
      END
+EOD
+DECK,BKPJHD                          .
      SUBROUTINE BKPJHD(LPJHD)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Book the Bank PJHD
C-      IF NO PJHD BANKS EXIST THEN BOOK THE FIRST ONE
C-      ELSE BOOK NEW PJHD BANK AT END OF LINEAR CHAIN OF PJHD BANKS
C-
C-   Inputs  : NONE
C-   Outputs : LPJHD Link of Booked PJHD Bank
C-   Controls: None
C-
C-   Created   7-NOV-1989 17:57:58.00  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER LPJHD,LPJHDP
      INTEGER IXIO
      INTEGER IDN
C
C--   ZEBRA BANKS
+CDE,ZEBCOM.
+CDE,IZPJHD.
C
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
C----------------------------------------------------------------------
C
C--   INITIALIZE
C
      LPJHD = 0
      IF(FIRST)THEN
C
        FIRST = .FALSE.
        CALL MZFORM('PJHD','3I2F-I',IXIO)        ! Describe Bank format
C
      ENDIF
C
      IDN=0

C
      LPJHDP = LISAE-IZPJHD
C
      IF(LQ(LPJHDP).EQ.0) THEN
C
C ****  FIRST PJHD BANK NEEDS TO BE BOOKED
C

        CALL MZBOOK(IXMAIN,LPJHD,LISAE,-IZPJHD,'PJHD',2,2,8,IXIO,0)
        IQ(LPJHD-5) = 0
      ELSE
C
C ****  LOOK FOR LAST PJHD BANK TO ADD SUBSEQUENT PJHD BANKS
C
   10   CONTINUE
        IF(LQ(LPJHDP).NE.0) THEN
          LPJHDP=LQ(LPJHDP)
          IDN=IQ(LPJHDP-5)
          GOTO 10
        END IF
C
C--         BOOK THE PJHD BANKS, SET THE ID NUMBER
        CALL MZBOOK(IXMAIN,LPJHD,LPJHDP,0,'PJHD',2,2,8,IXIO,0)
        IQ(LPJHD-5)=IDN+1
      ENDIF
      IQ(LPJHD+1)=2         ! Version number
C
  999 RETURN
      END
+EOD
+DECK,BKPJPT                          .
      SUBROUTINE BKPJPT(LPJET,NP,LPJPT)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Book the Bank PJPT under PJET-
C-
C-   Inputs  : LPJET - PJET BANK POINTER
C-             NP - NUMBER OF PARTONS IN THIS PJET
C-   Outputs : LPJPT - Link of Booked PJPT Bank
C-   Controls: None
C-
C-   Created   7-NOV-1989 18:10:09.84  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
C--   ZEBRA BANKS
+CDE,ZEBCOM.
+CDE,IZPJPT.
C
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
C--   INTERNAL VARIABLES
      INTEGER LPJPT,LPJPTP
      INTEGER LPJET
      INTEGER IXIO
C
      INTEGER NP
C----------------------------------------------------------------------
C
C--   DO PRELIMINARIES ON FIRST CALL
      IF(FIRST)THEN
        CALL MZFORM('PJPT','-I',IXIO)
        FIRST=.FALSE.
      END IF
C
      IF(LPJET.LE.0) CALL GZPJET( )
C
      IF ( LQ(LPJET-IZPJPT).LE.0 ) THEN
        CALL MZBOOK(IXMAIN,LPJPT,LPJET,-IZPJPT,'PJPT',NP+1,0,1,IXIO,0)
        IQ(LPJPT+1)=1         ! Version number
      ENDIF
C
  999 RETURN
      END
+EOD
+DECK,BUILD_PJET                      .
      SUBROUTINE BUILD_PJET(RCP_BANK)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : To add PJET banks to existing ISAJET data
C-                        if PJET does not already exist.
C-
C-   Inputs  : RCP_BANK - Name of RCP BANK containing PJET PARAMETERS
C-   Outputs : none
C-   Controls: none
C-
C-   Created  12-JAN-1990   Chip Stewart, Harrison B Prosper
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      CHARACTER*(*) RCP_BANK
C
      INTEGER LISAQ,LPJHD
      INTEGER GZISAQ,GZPJHD
      INTEGER ND,NS,NPJET
C
+CDE,ZEBCOM.
+CDE,IZPJHD.
C
C----------------------------------------------------------------------
C
C ****  Check if PJET exists; check number of links in ISAE
C
      IF ( LISAE .LE. 0 ) GOTO 999
C
      NS = IQ(LISAE-2)                  ! Number of structural links
C
      IF ( NS .GE. IZPJHD ) GOTO 998    ! make PJET anyway
C
C ****  Make 2 new links
C
      CALL MZPUSH ( IXCOM, LISAE, 2, 0, ' ')   ! MZPUSH 2 NEW REFERENCE LINKS
C
C ****  Make one new reference link
C
      LISAQ = GZISAQ ()                         ! Address of first ISAQ
    1 CALL MZPUSH ( IXCOM, LISAQ, 1, 0, ' ')    ! MZPUSH 1 NEW REFERENCE LINKS
      LISAQ = LQ (LISAQ)                        ! NEXT ISAQ
      IF  ( LISAQ.GT. 0 ) GOTO 1
C
C ****  DO PJET CALCULATIONS - IF  NO RCP FILE THEN
C ****  USE DEFAULTS SET IN PJPGET
C
  998 CALL PJET_RCP(RCP_BANK)
      CALL PJETFL
      LPJHD=GZPJHD ()
      NPJET=IQ(LPJHD+3)
      IQ(LISAE+7)=NPJET             !  Number of of PJET banks
  999 RETURN
      END
+EOD
+DECK,CEDIT                           .
      FUNCTION CEDIT(EEM,EHAD,SPHI,CPHI,STH,CTH,ETA)
C======================================================================
C
C   Purpose and Methods :
C   select calorimeter cells to be included in Zebra output
C   called for every cell. If CEDIT=.FALSE. cell will
C   be left out
C
C   Inputs  :
C   EEM = e.m. energy in cell
C   EHAD= had. energy in cell
C   SPHI = sin(phi)   center of cell
C   CPHI = cos(phi)   center of cell
C   STH  = sin(th)         "
C   CTH  = cos(th)         "
C   ETA  = eta             "
C
C   Outputs : NONE
C
C   Created  23-MAY-1987   Serban D. Protopopescu
C
C======================================================================
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL CEDIT
      REAL EEM,EHAD,SPHI,CPHI,STH,CTH,ETA
C======================================================================
      CEDIT=.TRUE.
      IF((EEM+EHAD)*STH.LT..2) CEDIT=.FALSE.
  999 RETURN
      END
+EOD
+DECK,EDIT.
      LOGICAL FUNCTION EDIT(I)
C          DUMMY ROUTINE FOR USER DEFINED LOGICAL FUNCTION
C          EDIT=.TRUE. TO WRITE EVENT ON TAPE
C          EDIT=.FALSE. TO SUPPRESS WRITING
      EDIT=.TRUE.
      RETURN
      END
+EOD
+DECK,GENVTX                          .
      SUBROUTINE GENVTX(MOM,JDPAR,XYZB,XYZ)
C-------------------------------------------------------------
C-
C-   Calculate the decay length and vertices for short lived
C-   particles: D0,D0BAR,D+,D-,F+,F-,B0,B0BAR,B+,B-,BS,BSBAR,
C-              T0,T0BAR,T+,T-,TS+,TS-,TAU+,TAU-
C-              C,B and T baryons
C-
C-   INPUT:
C-   MOM= 4-momenta, mass
C-   JDPAR= particle id
C-   XYZB= x,y and z of parent vertex
C-
C-   OUTPUT:
C-   XYZ= x,y and z of decay vertex
C-        if it is not an allowed decay XYZ is set to XYZB
C-
C-    Written by SDP Dec.,1985
C-
C-------------------------------------------------------------------
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
      REAL MOM(5),XYZ(3),XYZB(3)
      INTEGER JDPAR
      INTEGER MAP(10)       ! mapping from particle id to index
      INTEGER I,INDX,ID,IFL
      REAL ETACT,RANF,P,DCAYL
      REAL CTAU(13)
      DATA CTAU/
     1  .010,               ! tau lifetime
     2  .028,               ! D-    "
     3  .013,               ! D0    "
     4  .006,               ! F-    "
     5  .042,.042,          ! B+,B0 lifetimes
     7  .021,               ! BS  lifetime
     8  3*.0001,            ! top lifetimes
     9  .007,               ! charm baryon lifetimes
     A  .010,               ! beauty  "        "
     B  .0001/              ! top     "        "
      DATA MAP/ 16, 240, 140, 340, 150, 250, 350,
     1         160, 260, 360/
C
C  find the appropriate index for this particle
      CALL UCOPY(XYZB,XYZ,3)
      INDX=0
      ID=IABS(JDPAR)
C
      IF(MOD(ID,10).EQ.0) THEN    ! check for lowest spin hadron
C
C  find index for mesons
        IF(ID.LT.1000) THEN
          DO 1 I=2,10
          IF(MAP(I).EQ.ID) INDX=I
    1     CONTINUE
        ELSE
C  find index for baryons
          IFL=MOD(ID,100)/10       ! find heaviest flavor
          IF(IFL.GT.3) INDX=7+IFL  ! check for heavy quark
C
        ENDIF
C
      ENDIF
      IF(MAP(1).EQ.ID) INDX=1           ! check for taus
      IF(INDX.GT.0.AND.INDX.LT.13) THEN
        P=SQRT(MOM(1)**2+MOM(2)**2+MOM(3)**2)
        ETACT=P/MOM(5)*CTAU(INDX)
        DCAYL=-ETACT*ALOG(RANF())     ! generate decay length
C  calculate decay vertex position
        XYZ(1)=MOM(1)/P*DCAYL+XYZB(1)
        XYZ(2)=MOM(2)/P*DCAYL+XYZB(2)
        XYZ(3)=MOM(3)/P*DCAYL+XYZB(3)
      ENDIF
C
      RETURN
      END
+EOD
+DECK,GRLINK
      SUBROUTINE GRLINK (USER,NLINK)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-   Reserve a location in the ZLINKA common (general link area)
C-   GRLINK will bomb if no more free room
C-
C-   Outputs :
C-   NLINK = reserved structural link location
C-
C-   ENTRY RRLINK: release a reserved structural link location
C-                 returns false if NLINK was not reserved
C-                 will not release the link if USER does not match
C-
C-   Input:
C-   USER  = user identifier (character*8)
C-   NLINK = location to release
C-
C-   Created   9-SEP-1987   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZLINKA
      INTEGER NRL(NRLINK),I,II,NLINK,K
      CHARACTER*8 USER,USERS(NRLINK)
      CHARACTER*80 MSG
      DATA NRL/NRLINK*0/
C----------------------------------------------------------------------
C
      DO 1 I=1,NRLINK
      II=I
      IF (NRL(I) .EQ. 0) GO TO 3
    1 CONTINUE
C
C           no more room
C
      CALL INTMSG(
     $' No more structural links available, list of users follows')
      DO 2 I=1,NRLINK,8
        MSG(1:10)=USERS(I)//'  '
        DO 22 K=1,7
   22   MSG=MSG(1:K*10)//USERS(I+K)//'  '
        CALL INTMSG(MSG)
    2 CONTINUE
      CALL ABORT()
C
C       keep track of reserved link
C
    3 NLINK=II
      NRL(II)=II
      USERS(II)=USER
      RETURN
C
C----------------------------------------------------------------------
      ENTRY RRLINK(USER,NLINK)
C
C        release link if called by owner
      IF(USER.EQ.USERS(NLINK)) NRL(NLINK)=0
C
  999 RETURN
      END
+EOD
+DECK,GSLINK
      SUBROUTINE GSLINK (USER,NLINK)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-   Reserve a location in the ZLINKA common (general link area)
C-   GSLINK will bomb if no more free room
C-
C-   Outputs :
C-   NLINK = reserved structural link location
C-
C-   ENTRY RSLINK: release a reserved structural link location
C-                 will not release the link if USER does not match
C-
C-   Input:
C-   USER  = user identifier (character*8)
C-   NLINK = location to release
C-
C-   Created   9-SEP-1987   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,ZLINKA
      INTEGER NSL(NSLINK),I,II,NLINK,K
      CHARACTER*80 MSG
      CHARACTER*8 USER,USERS(NSLINK)
      DATA NSL/NSLINK*0/
C
      DO 1 I=1,NSLINK
      II=I
      IF (NSL(I) .EQ. 0) GO TO 3
    1 CONTINUE
C
C           no more room
C
      WRITE(ITLIS,11)
   11 FORMAT('No more structural links available, list of users',
     &' follows.')
      DO 2 I=1,NSLINK,8
        MSG(1:10)=USERS(I)//'  '
        DO 22 K=1,7
   22   MSG=MSG(1:K*10)//USERS(I+K)//'  '
        WRITE(ITLIS,12) MSG
   12   FORMAT(A80)
    2 CONTINUE
C
C       keep track of reserved link
C
      STOP
    3 NLINK=II
      NSL(II)=II
      USERS(II)=USER
      RETURN
C
C----------------------------------------------------------------------
      ENTRY RSLINK(USER,NLINK)
C
C        release link if called by owner
      IF(USER.EQ.USERS(NLINK)) NSL(NLINK)=0
C
  999 RETURN
      END
+EOD
+DECK,GZISAC                          .
      FUNCTION GZISAC()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Get pointer to ISAC
C-
C-   Created   8-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISAC.
      INTEGER GZISAC
C----------------------------------------------------------------------
C
      GZISAC=0
      IF(LISAE.NE.0) GZISAC=LQ(LISAE-IZISAC)
  999 RETURN
      END
+EOD
+DECK,GZISAJ                          .
      FUNCTION GZISAJ()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Find pointer to ISAJ
C-
C-   Created  MAY-20-88 Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISAJ
+CDE,ZEBCOM.
+CDE,IZISAJ.
C----------------------------------------------------------------------
C
      GZISAJ=0
      IF(LISAE.NE.0)  GZISAJ=LQ(LISAE-IZISAJ)
C
      RETURN
      END
+EOD
+DECK,GZISAL                          .
      FUNCTION GZISAL()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     get pointer to first ISAL
C-   Returned value  : pointer
C-
C-   Created  17-AUG-1989   Serban Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISAL
+CDE,ZEBCOM.
+CDE,IZISAL.
C----------------------------------------------------------------------
C
      IF(LISAE.GT.0) GZISAL=LQ(LISAE-IZISAL)
  999 RETURN
      END
+EOD
+DECK,GZISAM                          .
      FUNCTION GZISAM()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     get pointer to first ISAM
C-   Returned value  : pointer
C-
C-   D. Hedin 15-oct-90
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISAM
+CDE,ZEBCOM.
+CDE,IZISAM.
C----------------------------------------------------------------------
C
      IF(LISAE.GT.0) GZISAM=LQ(LISAE-IZISAM)
  999 RETURN
      END
+EOD
+DECK,GZISAQ                          .
      FUNCTION GZISAQ()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Find pointer to ISAQ
C-
C-   Created  MAY-20-88 Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISAQ
+CDE,ZEBCOM.
+CDE,IZISAQ.
C----------------------------------------------------------------------
C
      GZISAQ=0
      IF(LISAE.NE.0)  GZISAQ=LQ(LISAE-IZISAQ)
C
      RETURN
      END
+EOD
+DECK,GZISCL                          .
      FUNCTION GZISCL()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     get pointer to first ISCL bank
C-   Returned value  :  pointer
C-
C-   Created  29-JAN-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISAC.
+CDE,IZISCL.
      INTEGER GZISCL,GZISAC,LISAC
C----------------------------------------------------------------------
      GZISCL=0
      LISAC=GZISAC()
      IF (LISAC.NE.0  ) GZISCL=LQ(LISAC-IZISCL)
  999 RETURN
      END
+EOD
+DECK,GZISCM                          .
      FUNCTION GZISCM()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-
C-   Returned value  : pointer to ISCM bank (ISAJET commands)
C-
C-   Created   5-JAN-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISCM
+CDE,ZEBCOM.
+CDE,IZISCM.
C----------------------------------------------------------------------
C
      GZISCM=0
      IF(LISAB.GT.0) GZISCM=LQ(LISAB-IZISCM)
  999 RETURN
      END
+EOD
+DECK,GZISJT                          .
      FUNCTION GZISJT()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Find pointer to ISJT bank (jet found in toy calorimeter)
C-   Returned value  : pointer to first bank
C-
C-   Created  29-JAN-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISJT
+CDE,IZISJT.
+CDE,ZEBCOM.
      INTEGER LISAC,GZISAC
C----------------------------------------------------------------------
      GZISJT=0
      LISAC=GZISAC()
      IF(LISAC.GT.0) GZISJT=LQ(LISAC-IZISJT)
  999 RETURN
      END
+EOD
+DECK,GZISMR                          .
      FUNCTION GZISMR()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     get pointer to ISMR bank
C-   Returned value  : pointer value
C-
C-   Created  19-MAY-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISMR
+CDE,ZEBCOM.
+CDE,IZISMR.
      INTEGER LISAC,GZISAC
C----------------------------------------------------------------------
C
      LISAC=GZISAC()
      GZISMR=0
      IF(LISAC.NE.0) GZISMR=LQ(LISAC-IZISMR)
  999 RETURN
      END
+EOD
+DECK,GZISV1                          .
      FUNCTION GZISV1()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Find pointer to ISV1
C-
C-   Created  MAY-20-88 Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISV1
+CDE,ZEBCOM.
+CDE,IZISV1.
C----------------------------------------------------------------------
C
      GZISV1=0
      IF(LISAE.NE.0)  GZISV1=LQ(LISAE-IZISV1)
C
      RETURN
      END
+EOD
+DECK,GZISV2                          .
      FUNCTION GZISV2()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Find pointer to ISV2
C-
C-   Created  MAY-20-88 Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZISV2
+CDE,ZEBCOM.
+CDE,IZISV2.
C----------------------------------------------------------------------
C
      GZISV2=0
      IF(LISAE.NE.0)  GZISV2=LQ(LISAE-IZISV2)
C
      RETURN
      END
+EOD
+DECK,GZPJET                          .
      FUNCTION GZPJET()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Returns the Link to PJET bank
C-
C-   Returned value  : Link to 1st element of PJET linear structure
C-   Inputs  :
C-   Outputs :
C-   Controls:
C-
C-   Created   7-NOV-1989 18:10:09.84  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZPJET
+CDE,ZEBCOM.
+CDE,IZPJET.
      INTEGER LPJHD,GZPJHD
C----------------------------------------------------------------------
C
C--   INITIALIZE
      GZPJET=0
C
C--   GET LINK TO SUPPORTING PJHD BANK
      LPJHD=GZPJHD()
C
C--   CHECK LPJHD
      IF(LPJHD.LE.0) GOTO 999
C
C--   FIND LINK TO PJET
      GZPJET=LQ(LPJHD-IZPJET)

C
  999 RETURN
      END
+EOD
+DECK,GZPJHD                          .
      FUNCTION GZPJHD()
C------------------------------------------------------------------- ---
C-
C-   Purpose and Methods : Returns the Link to PJHD bank
C-
C-   Returned value  : Link to 1st element of PJHD linear structure
C-   Inputs  :
C-   Outputs :
C-   Controls:
C-
C-   Created   7-NOV-1989 17:57:58.00  Chip Stewart
C-   Updated  17-JAN-1990   Boaz Klima
C-      CHECK NUMBER OF STRUCTURAL LINKS
C-
C------------------------------------------------------------------- ---
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER GZPJHD
+CDE,ZEBCOM.
+CDE,IZPJHD.
      INTEGER NS
C------------------------------------------------------------------- ---
C
C--   INITIALIZE
      GZPJHD=0
C
C--   CHECK LISAE
      IF(LISAE.LE.0) GO TO 999
C
C ****  Get number of structural links
C
      NS = IQ(LISAE-2)
      IF ( NS .GT. IZPJHD ) THEN
C--   FIND LINK TO PJHD
        GZPJHD=LQ(LISAE-IZPJHD)
      ENDIF
C
  999 RETURN
      END
+EOD
+DECK,GZPJPT                          .
      INTEGER FUNCTION GZPJPT()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Returns the Link to PJPT bank
C-
C-   Returned value  : Link to 1st element of PJPT linear structure
C-   Inputs  :
C-   Outputs :
C-   Controls:
C-
C-   Created   18-DEC-1989 18:10:09.84  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZPJPT.
      INTEGER LPJET,GZPJET
C----------------------------------------------------------------------
C
C--   INITIALIZE
      GZPJPT=0
C
C--   GET LINK TO SUPPORTING PJHD BANK
      LPJET=GZPJET()
C
C--   CHECK LPJHD
      IF(LPJET.LE.0) GO TO 999
C
C--   FIND LINK TO PJPT
      GZPJPT=LQ(LPJET-IZPJPT)
C
  999 RETURN
      END
+EOD
+DECK,INTVTX                          .
      SUBROUTINE INTVTX(XYZ)
C-------------------------------------------------------
C-
C-  Subroutine to generate an interaction vertex.
C-
C-  Default is to generate an interaction point with normal distribution
C-  along z given by SIGZ= 25 cm and with x=0,y=0.
C-
C-  If SETVTX is called the interaction point returned in the next
C-  call of INTVTX will be the values given to SETVTX.
C-  SETVTX must be called for every event before event generation
C-  to overwrite the default.
C-
C-  OUTPUT:
C-  XYZ = x,y,z position of vertex
C-
C-  ENTRY SETVTX(XYZ):
C-  INPUT:
C-  XYZ=  x,y,z position of vertex
C-
C-    SDP Nov.,1985
C-
C-------------------------------------------------------
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL XYZ(3)
      REAL A,B,ZSIG,XSET(3)
      LOGICAL SETXYZ
      DATA SETXYZ/.FALSE./
      DATA ZSIG/0.0/   ! sigma of interaction region
C
      IF(SETXYZ) THEN
       CALL UCOPY(XSET,XYZ,3)
      ELSE
        XYZ(1)=0
        XYZ(2)=0
        CALL RANNOR(A,B)
        XYZ(3)=ZSIG*A
      ENDIF
      SETXYZ=.FALSE.
C
      RETURN
      ENTRY SETVTX(XYZ)
C
C      A call to SETVTX forces vertex to have values XYZ
C
      SETXYZ=.TRUE.
      CALL UCOPY(XYZ,XSET,3)
      RETURN
      END
+EOD
+DECK,INZCOM
      SUBROUTINE INZCOM(I)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-       Initialize ZEBCOM (event data Zebra common)
C-
C-   Inputs  : I = 1 data in division 1, otherwise in division 2
C-   Outputs : NONE
C-
C-   Created  28-OCT-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM
      INTEGER I
      LOGICAL FIRST
      SAVE FIRST
      DATA FIRST/.TRUE./
C----------------------------------------------------------------------
C
      IF(FIRST) THEN
C
C **** Initialize store in /ZEBCOM/ common (store 0)
C
        IXCOM=0
        CALL MZSTOR (IXCOM,'/ZEBCOM/','Q',FENCE,LISAE,LREF(1),ZSTOR(1),
     &   ZSTOR(40000),ENDZS)
C
C **** Use division IXMAIN for event data
C
        IXMAIN=IXCOM+2
        IF(I.EQ.1) IXMAIN=IXCOM+1
C
C **** Create a division for run header (3rd division)
C
        CALL MZDIV(IXCOM,IXDVR,'RUN DIV',100,40000,'L')
        FIRST=.FALSE.
      ENDIF
  999 RETURN
      END
+EOD
+DECK,INZLNK
      SUBROUTINE INZLNK
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-       Initialize link area /ZLINKA/
C-
C-   Created  28-OCT-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM
+CDE,ZLINKA
      LOGICAL FIRST
      SAVE FIRST
      DATA FIRST/.TRUE./
C----------------------------------------------------------------------
C
      IF(FIRST) THEN
        CALL MZLINK(IXCOM,'/ZLINKA/',LSLINK,LRLINK,LRLINK(NRLINK))
        FIRST=.FALSE.
      ENDIF
  999 RETURN
      END
+EOD
+DECK,IS1TRK                          .
      SUBROUTINE IS1TRK(ID,XYZ,PXYZ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      User supplied subroutine for one track ISAJET event generation
C-      This example returns a randomly distributed 50 GeV electron
C-      -1.3> eta>1.3
C-
C-   Outputs :
C-     ID      = particle ID (use ISAJET id's)
C-     XYZ(3)  = x,y,z starting point
C-     PXYZ(3) = px,py,pz of particle
C-
C-
C-   Created   6-MAR-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL    XYZ(3),PXYZ(3)
      REAL    PHI,SNTH,CSTH,RANF,ETA,THETA
      INTEGER ID
C----------------------------------------------------------------------
C
      ID=12
      ETA=-1.3+2.6*RANF()
      THETA=2.*ATAN(EXP(-ETA))
      CSTH=COS(THETA)
      SNTH=SQRT(1.-CSTH**2)
      PHI=6.283185*RANF()
      PXYZ(1)=50.*SNTH*COS(PHI)
      PXYZ(2)=50.*SNTH*SIN(PHI)
      PXYZ(3)=50.*CSTH
      CALL INTVTX(XYZ)            ! get random XYZ, standard D0 sigma
  999 RETURN
      END
+EOD
+DECK,ISABFL                          .
      SUBROUTINE ISABFL
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     book and fill ISAB (ISAJET begin-of-run) bank
C-
C-   ENTRY ISA_STOP (program stop, done generating)
C-
C-   ENTRY ISA_RUNNO(IRUN) provide a run number
C-   Input:
C-   IRUN = run number
C-
C-   Created   7-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IDRUN.
+CDE,ITAPES.
+CDE,KEYS.
+CDE,JETLIM.
+CDE,PRIMAR.
+CDE,ZEBCOM.
      INTEGER K,IOISAB,IRN,LOUT,NREAC,IUH
      CHARACTER*4 TTL
      LOGICAL FIRST
      SAVE FIRST,TTL
C----------------------------------------------------------------------
      DATA FIRST/.TRUE./
C
C
      DATA IRN/1/
      IF(ITCOM.NE.0) READ(ITCOM,1) TTL
    1 FORMAT(A4)
C
C  set flag for reaction
      DO 6 K=1,6
        IF(KEYS(K)) NREAC=K
    6 CONTINUE
C
C  create Zebra bank ISAB
      IF(FIRST) CALL MZFORM('ISAB','3I,-F',IOISAB)
      FIRST=.FALSE.
      LISAB=0
      CALL MZBOOK(IXMAIN,LISAB,LISAB,1,
     $            'ISAB',2,2,22,IOISAB,-1)
      IQ(LISAB+1)=IDVER
      IQ(LISAB+2)=NREAC
      IQ(LISAB+3)=NEVENT
      Q(LISAB+4)=ECM
      CALL UCOPY(PTMIN,Q(LISAB+5),6)
      CALL UCOPY(THMIN,Q(LISAB+11),6)
      CALL UCOPY(PHIMIN,Q(LISAB+17),6)
      IF(TTL.NE.'SAME'.AND.ITCOM.NE.0) CALL ISCMFL(ITCOM)
  999 RETURN
C
      ENTRY ISA_STOP
      IF(TTL.EQ.'STOP') THEN
        WRITE(ITLIS,2) TTL
    2   FORMAT(//'   ',A4,' in ISAJET command file, JOB STOPPED')
        STOP
      ENDIF
      RETURN
      END
+EOD
+DECK,ISACFL                          .
      SUBROUTINE ISACFL
C--------------------------------------------------------------------
C-                                                                  -
C-      Trivial calorimeter simulation.                             -
C-      Assume uniform y and phi bins.                              -
C-      Fill Zebra banks  ISAC and ISCL. Needs banks ISP1 and ISV1  -
C-                                                                  -
C-                   SDP May,1986, Rev. May,1988                    -
C-                                                                  -
C--------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAC.
+CDE,IZISCL.
+CDE,IZISP1.
+CDE,IZISV1.
+CDE,ZEBCOM.
      INTEGER NCY,NCPHI
      REAL YCMIN,YCMAX,PI
      PARAMETER (NCY=80,NCPHI=64)
      PARAMETER (YCMIN=-4.,YCMAX=4.,PI=3.1415938)
      INTEGER NCHGM(NCY,NCPHI)
      REAL EHAD(NCY,NCPHI),EEM(NCY,NCPHI)
      REAL CTHCAL(NCY),STHCAL(NCY),CPHCAL(NCPHI),SPHCAL(NCPHI)
      REAL ETACAL(NCY),PHICAL(NCPHI)
      REAL ETA,PHI,THX,EIP,DELPHI,DELY,ET,ETMIN
      REAL SPHI,CPHI,STH,CTH,EEMC,EHADC
      INTEGER IDABS,IY,IPHI,JETNO(NCY,NCPHI)
      INTEGER LISV1,LISP1,LISAC,LISCL,IOISAC,IOISCL,GZISAC
      LOGICAL FIRST,CEDIT
      DATA FIRST/.TRUE./
      LISAC=GZISAC()
      IF(LISAC.NE.0) GOTO 999      ! already exists
C
C          INITIALIZE E ARRAYS
      IF(FIRST) THEN
        DO 50 IPHI=1,NCPHI
        DO 50 IY=1,NCY
        NCHGM(IY,IPHI)=0
        EEM(IY,IPHI)=0.
   50   EHAD(IY,IPHI)=0.
        CALL MZFORM('ISAC','2I 4F',IOISAC)
        CALL MZFORM('ISCL','2I -F',IOISCL)
        FIRST=.FALSE.
C
C            INITIALIZE PSEUDO-CALORIMETER
C
        DELPHI=2.*PI/NCPHI
        DELY=(YCMAX-YCMIN)/NCY
C
C          CALCULATE TRIG. FUNCTIONS.
        DO 60 IPHI=1,NCPHI
        PHI=DELPHI*(IPHI-.5)
        PHICAL(IPHI)=PHI
        CPHCAL(IPHI)=COS(PHI)
        SPHCAL(IPHI)=SIN(PHI)
60      CONTINUE
        DO 70 IY=1,NCY
        ETA=DELY*(IY-.5)+YCMIN
        THX=2.*ATAN(EXP(-ETA))
        ETACAL(IY)=ETA
        CTHCAL(IY)=COS(THX)
        STHCAL(IY)=SIN(THX)
70      CONTINUE
      ENDIF
C
C            Fill calorimeter description in ISAC
C
      CALL MZBOOK(IXMAIN,LISAC,LISAE,-IZISAC,
     $            'ISAC',3,3,6,IOISAC,-1)
C
      IQ(LISAC+1)=NCPHI    ! number of phi cells
      IQ(LISAC+2)=NCY      !   "        y    "
      Q(LISAC+3)=DELPHI   ! phi cell size
      Q(LISAC+4)=DELY     !  y    "   "
      Q(LISAC+5)=YCMIN    ! minimum y
      Q(LISAC+6)=YCMAX    ! maximum y
C
C          Fill calorimeter cells
C
      LISV1=LISAE-IZISV1
C
  100 LISV1=LQ(LISV1)        ! loop over vertices
      IF(LISV1.GT.0) THEN
        LISP1=LISV1-IZISP1
C
  200   LISP1=LQ(LISP1)      ! loop over particles
        IF(LISP1.GT.0) THEN
          IDABS=IABS(IQ(LISP1+1))
          IF(IDABS.EQ.11.OR.IDABS.EQ.13.OR.IDABS.EQ.15
     $        .OR.IDABS.EQ.14..OR.IDABS.EQ.30) GO TO 200
          EIP=Q(LISP1+5)
          PHI=Q(LISP1+7)
          ETA=Q(LISP1+9)
          IF(ETA.LT.YCMIN.OR.ETA.GT.YCMAX) GO TO 200
          IY=INT((ETA-YCMIN)/DELY)+1
          IPHI=INT(PHI/DELPHI)+1
          JETNO(IY,IPHI)=LQ(LISP1-2)    ! pointer to initial parton
          IF(IDABS.EQ.10.OR.IDABS.EQ.12.OR.IDABS.EQ.110.OR.
     $        IDABS.EQ.220) THEN
            EEM(IY,IPHI)=EEM(IY,IPHI)+EIP
            IF(IDABS.EQ.10) THEN
              NCHGM(IY,IPHI)=NCHGM(IY,IPHI)+1
            ELSE
              NCHGM(IY,IPHI)=NCHGM(IY,IPHI)+10000
            ENDIF
          ELSE
            EHAD(IY,IPHI)=EHAD(IY,IPHI)+EIP
            NCHGM(IY,IPHI)=NCHGM(IY,IPHI)+10000
          ENDIF
C
        GOTO 200
        ENDIF
C
      GOTO 100
      ENDIF
C
C        Create Zebra banks ISCL (calorimeter cells)
      LISCL=0
      DO 300 IY=1,NCY
      DO 300 IPHI=1,NCPHI
      EEMC=EEM(IY,IPHI)
      EHADC=EHAD(IY,IPHI)
      STH=STHCAL(IY)
      CTH=CTHCAL(IY)
      SPHI=SPHCAL(IPHI)
      CPHI=CPHCAL(IPHI)
      ETA=ETACAL(IY)
      IF(CEDIT(EEMC,EHADC,SPHI,CPHI,STH,CTH,ETA)) THEN
        IF(LISCL.EQ.0) THEN
          CALL MZBOOK(IXMAIN,LISCL,LISAC,-IZISCL,
     $                'ISCL',2,0,10,IOISCL,-1)
        ELSE
          CALL MZBOOK(IXMAIN,LISCL,LISCL,0,
     $                'ISCL',2,0,10,IOISCL,-1)
        ENDIF
C
        LQ(LISCL-1)=JETNO(IY,IPHI)   ! pointer to initial parton
        IQ(LISCL+1)=IY+IPHI*10000
        IQ(LISCL+2)=NCHGM(IY,IPHI)   ! no. of gammas+10000*(no. of charged)
        Q(LISCL+3)=EEMC
        Q(LISCL+4)=EHADC
        Q(LISCL+5)=STH
        Q(LISCL+6)=CTH
        Q(LISCL+7)=SPHI
        Q(LISCL+8)=CPHI
        Q(LISCL+9)=PHICAL(IPHI)
        Q(LISCL+10)=ETA
      ENDIF
      NCHGM(IY,IPHI)=0
      EEM(IY,IPHI)=0.
      EHAD(IY,IPHI)=0.
  300 CONTINUE
  999 RETURN
      END
+EOD
+DECK,ISADMP                          .
      FUNCTION ISADMP()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-       dump ISAJET event banks
C-
C-   Created   6-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL ISADMP
      CHARACTER*4 PATH
      INTEGER PRUNIT,DMPUNI
      EXTERNAL PRCAEP
C----------------------------------------------------------------------
C
      PRUNIT=DMPUNI()
      CALL PRTEVZ(PRUNIT)
      CALL PATHGT(PATH)
      IF(PATH.EQ.'FAKE') THEN
        PRUNIT=DMPUNI()
        WRITE(PRUNIT,100) PATH
        CALL DMPANY('CAEP',PRCAEP)
      ENDIF
      ISADMP=.TRUE.
  999 RETURN
  100 FORMAT(//,'***********  CAEP dumped for path= ',A)
      END
+EOD
+DECK,ISAEFL                          .
      SUBROUTINE ISAEFL
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     fill all ISAJET event banks
C-
C-   Created   7-NOV-1988   Serban D. Protopopescu
C-   Modified 15-Jan-1990           "
C-             this version set up for ISAJET, ISAE is head bank
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IDRUN.
+CDE,FINAL.
+CDE,JETPAR.
+CDE,JETSET.
+CDE,KEYS.
+CDE,PRIMAR.
+CDE,ISABNK.
+CDE,IZISV1.
+CDE,ZEBCOM.
+CDE,SEED.
C
      INTEGER QREF(MXJSET),PQREF(5)
      INTEGER I,K,IOISAE,IUH,LISV1,GZISV1
      INTEGER NPART,NVERTX,NQS,NQF,NLEP,NJT,NREAC,NPJET
      INTEGER LISAJ,LISAQ,GZISAQ,GZISAJ,LPJHD,GZPJHD
      INTEGER ISA_RUNNO
      LOGICAL QPART,QCAL,QLEP
      LOGICAL FIRST
      DOUBLE PRECISION DSEED
      REAL SSEED(2)
      EQUIVALENCE(DSEED,SSEED)
C
      LOGICAL EDIT,YES
C----------------------------------------------------------------------
C
      DATA FIRST/.TRUE./
C
      IF(.NOT.EDIT(I)) GOTO 999   ! quit if don't wish to write event
C
      DO 6 I=1,10
        IF(KEYS(I)) NREAC=I
    6 CONTINUE
C
C  create head bank
C
      CALL MZWIPE(0)      ! make sure division is wiped before starting
C
C  create ZEBRA bank ISAE (main supporting bank)
C
      CALL BKISAE
      READ(XSEED,'(E24.15)') DSEED
      Q(LISAE+11)=SIGF*1000.        ! cross section in microbarns
      Q(LISAE+12)=Q(LISAE+11)/NEVENT  ! weight
      Q(LISAE+13)=QSQ               ! effective q**2
      Q(LISAE+14)=SHAT              ! hard scattering invariant s
      Q(LISAE+15)=THAT              !  "      "          "      t
      Q(LISAE+16)=UHAT              !  "      "          "      u
      Q(LISAE+17)=SSEED(1)          !  part 1 of SEED
      Q(LISAE+18)=SSEED(2)          !  part 2 of SEED
      IQ(LISAE+1)=IDG(1)            ! event id
      IQ(LISAE+2)=IDG(2)            !   "
      IQ(LISAE+3)=IEVT              ! event number
      IQ(LISAE+4)=NREAC             ! reaction type
      NPART=0
      NVERTX=0
      NLEP=0
      NPJET=0
C
C  recalculate jet and parton momenta starting from particles
      CALL QRECAL
C
C  create ZEBRA banks for primary partons
      CALL ISAJFL
C
C  create ZEBRA banks ISAQ (initial and final partons)
C
      CALL ISAQFL
C
C  create ISP1 ZEBRA banks (stable particles)
C  and ISV1 ZEBRA banks (short lived vertices)
C
      CALL ISAPFL(NPART,NVERTX)
C
C  create ISAC ZEBRA bank (pseudocalorimeter) if requested
C
      CALL ISLBNK(QPART,QCAL,QLEP)    ! find banks requested
      IF(QCAL) CALL ISACFL
C
C  create ISAL ZEBRA banks (leptons) if requested
C
      IF(QLEP) CALL ISALFL(NLEP)
C
      IF(.NOT.QPART) THEN        ! drop particle and vertex banks
        LISV1=GZISV1()
        CALL MZDROP(IXCOM,LISV1,'L')
        NPART=0
        NVERTX=0
      ENDIF
      CALL PJETFL
      LPJHD=GZPJHD()
      NPJET=IQ(LPJHD+3)
C
C fill rest of ISAE
C
      CALL ISNUMQ(NJT,NQS)      ! find number of primary and secondary partons
C
      IQ(LISAE+5)=NJT               ! number of primary parton banks
      IQ(LISAE+6)=NQS               !  "     of stable parton banks
      IQ(LISAE+7)=NPJET             !  "     of PJET banks
      IQ(LISAE+8)=NPART             !  "     of particle banks
      IQ(LISAE+9)=NVERTX            !  "     of vertex banks
      IQ(LISAE+10)=NLEP             !  "     of lepton banks
  999 RETURN
      END
+EOD
+DECK,ISAFFL                          .
      SUBROUTINE ISAFFL
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Book and fill ISAF (ISAJET end-of-run) bank
C-
C-   Created   7-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IDRUN.
+CDE,FINAL.
+CDE,PRIMAR.
+CDE,ZEBCOM.
      INTEGER IOISAF,LISAF
      LOGICAL FIRST
C----------------------------------------------------------------------
      DATA FIRST/.TRUE./
C
C
C  create Zebra bank ISAF  (end record)
      CALL MZFORM('ISAF','2I-F',IOISAF)
      CALL MZBOOK(IXMAIN,LISAE,LISAE,1,
     $            'ISAF',0,0,4,IOISAF,0)
      LISAF=LISAE
      IQ(LISAF+1)=IEVT
      IQ(LISAF+2)=NEVENT
      Q(LISAF+3)=SIGF*1000.
      IF(IEVT.GT.0) Q(LISAF+4)=SIGF/IEVT*1000.
  999 RETURN
      END
+EOD
+DECK,ISAJFL                          .
      SUBROUTINE ISAJFL
C-------------------------------------------------------------------
C-
C-  Fill ISAJ Zebra banks (primary partons)
C-
C-  INPUT:
C-
C-  OUTPUT:
C-  NJT  = number of partons
C-
C-      SDP JAN.,1986
C-
C--------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,KEYS.
+CDE,PJETS.
+CDE,PRIMAR.
+CDE,ZEBCOM.
+CDE,ISALNK.
      INTEGER I,IOISAJ,LISAJ
      REAL PHI1,THETA,ETA
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
      IF(NJET.NE.0) THEN
C
        IF(KEYS(3))  THEN  ! special section for Drell-Yan
          CALL BKISAJ(LISAJ)
          PQREF(1)=LISAJ
          PQREF(2)=LISAJ
          IQ(LISAJ+1)=IDENTW !    particle id
          CALL UCOPY(QWJET,Q(LISAJ+2),5)   ! momenta and masses
          CALL ISPETA(QWJET,THETA,PHI1,ETA)   ! calculate phi,theta and eta
          Q(LISAJ+7)=PHI1
          Q(LISAJ+8)=THETA
          Q(LISAJ+9)=ETA
        ENDIF
C
        DO 200 I=1,NJET       ! loop over primary jets
        IF((.NOT.KEYS(3).OR.I.EQ.3).AND.      ! only 3rd jet for Drell-Yan
     $     (PJETS(4,I).GT.0.01))         THEN ! and check jet energy
          CALL BKISAJ(LISAJ)
          PQREF(I)=LISAJ
          IQ(LISAJ+1)=IDJETS(I)     !    particle id
          CALL UCOPY(PJETS(1,I),Q(LISAJ+2),5) ! momenta and mass
C   calculate phi,theta and eta
          CALL ISPETA(PJETS(1,I),THETA,PHI1,ETA)
          Q(LISAJ+7)=PHI1
          Q(LISAJ+8)=THETA
          Q(LISAJ+9)=ETA
C
         ENDIF
  200    CONTINUE
C
      ENDIF
      RETURN
      END
+EOD
+DECK,ISALFL                          .
      SUBROUTINE ISALFL(NLEP)
C-------------------------------------------------------------------
C-
C-      Fill Zebra banks  ISAL, same format as ISP1 but only
C-      leptons with reference links to ISP1, ISAQ, ISAJ
C-      Needs banks ISP1 and ISV1
C-
C-      OUTPUT:
C-      NLEP = number of leptons
C-
C-                   SDP May,1986
C-
C---------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAL.
+CDE,IZISP1.
+CDE,IZISV1.
+CDE,ZEBCOM.
      INTEGER LISV1,LISP1,LISAL,IOISAL,JBIAS,IDABS
      INTEGER NLEP
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
      IF(FIRST) THEN
        CALL MZFORM('ISAL','1I -F',IOISAL)
        FIRST=.FALSE.
      ENDIF
C
C        set pointers for first lepton bank
C
      JBIAS=-IZISAL
      LISAL=LISAE
      NLEP=0
C
C          Find leptons
C
      LISV1=LISAE-IZISV1
C
  100 LISV1=LQ(LISV1)        ! loop over vertices
      IF(LISV1.GT.0) THEN
        LISP1=LISV1-IZISP1
C
  200   LISP1=LQ(LISP1)      ! loop over particles
        IF(LISP1.GT.0) THEN
          IDABS=IABS(IQ(LISP1+1))
          IF(IDABS.LT.11.OR.IDABS.GT.15) GOTO 200
C
          CALL MZBOOK(IXMAIN,LISAL,LISAL,JBIAS,
     $               'ISAL',4,1,9,IOISAL,-1)
          CALL UCOPY(Q(LISP1+1),Q(LISAL+1),9)   ! same information as in ISP1
          LQ(LISAL-4)=LISP1         ! reference link to ISP1
          LQ(LISAL-2)=LQ(LISP1-2)   ! reference link to ISAQ
          LQ(LISAL-3)=LQ(LISP1-3)   ! reference link to ISAJ
          NLEP=NLEP+1
C
          JBIAS=0
          GOTO 200
        ENDIF
C
      GOTO 100
      ENDIF
      RETURN
      END
+EOD
+DECK,ISAOBR                          .
      FUNCTION ISAOBR()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-       Print out to USER.OUT begin-of-run record
C-
C-   Created   6-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL ISAOBR
      INTEGER USUNIT,PRUNIT
C----------------------------------------------------------------------
C
      ISAOBR=.TRUE.
      PRUNIT=USUNIT()
      CALL PRISAB(PRUNIT,0,0,0,0)
  999 RETURN
      END
+EOD
+DECK,ISAOER                          .
      FUNCTION ISAOER()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-       Print out to USER.OUT end-of-run record
C-
C-   Created   6-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL ISAOER
      INTEGER USUNIT,PRUNIT
C----------------------------------------------------------------------
C
      ISAOER=.TRUE.
      PRUNIT=USUNIT()
      CALL PRISAF(PRUNIT,0,0,0,0)
  999 RETURN
      END
+EOD
+DECK,ISAPFL                          .
      SUBROUTINE ISAPFL(NPART,NVERTX)
C-----------------------------------------------------------------------
C-                                                                     -
C-                                                                     -
C-      Search for stable and unstable particles                       -
C-      fill particle Zebra banks ISP1                                 -
C_      generate short lived vertices                                  -
C-      fill vertex Zebra banks ISV1                                   -
C-      NOTE: if number of decay vertices exceeds 100 results can      -
C-            be incorrect                                             -
C-                                                                     -
C-       OUTPUT:                                                       -
C-       NPART  = number of stable particles                           -
C-       NVERTX = number of vertices                                   -
C-                                                                     -
C-       WRITTEN BY SDP Dec.,1985, rev. Dec,1986                       -
C-   Updated  13-DEC-1989   Serban D. Protopopescu
C-                                                                     -
C-----------------------------------------------------------------------
C
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,JETSET.
+CDE,PARTCL.
+CDE,PRIMAR.
+CDE,IZISV1.
+CDE,IZISP1.
+CDE,ZEBCOM.
+CDE,ISALNK.
C
      INTEGER ITAG(4000)
      EQUIVALENCE(ITAG,ZSTOR)
      INTEGER NVERTX,NPART
      REAL XYZB(3),XYZ(3,NVD),MOM(5)
      INTEGER I,ID,IV,LVP,IVT1,IVT2,IPREV
      INTEGER IOISP1,IOISV1
      INTEGER JET,LISV1,LISP1,LISAQ,LISAJ
      INTEGER JSPIN,K,IFL,JOR,JP,IWPOS,IWNEG
      INTEGER NJT,NQS
      REAL PHI1,THETA,ETA,PTOT
      LOGICAL FIRST,PEDIT,ADDQ,BOTDIQ
      DATA FIRST/.TRUE./
C-----------------------------------------------------------------------
C
      NPART=0
      NVERTX=0
      IF(NPTCL.NE.0) THEN
C
C  First make a Zebra bank for primary vertex
        CALL INTVTX(XYZ)       ! generate a primary vertex
        CALL VZERO(MOM,3)
        MOM(4)=ECM
        MOM(5)=ECM
        ID=-1
        NVERTX=1
        CALL BKISV1(NVERTX,LISV1)
        IQ(LISV1-5)=1
        IQ(LISV1+1)=ID
        CALL UCOPY(MOM,Q(LISV1+2),5)
        CALL UCOPY(XYZ,Q(LISV1+7),3)
        LQ(LISV1-2)=0                !  no parent vertex
C
C   loop over all particles to generate short lived vertices
C   and flag which particles belong to each vertex
C
        CALL MZWORK(IXCOM,ITAG,ITAG(NPTCL),0)  ! create array for flags
        DO 30 I=1,NPTCL
   30   ITAG(I)=1
C
        DO 50 I=1,NPTCL
C
          IF(IDCAY(I).EQ.0) GOTO 50
          IVT1=IDCAY(I)/IPACK
          IVT2=MOD(IDCAY(I),IPACK)
          IF(ITAG(I).NE.1) THEN     ! tag granddaughters
            DO 41 K=IVT1,IVT2
   41       ITAG(K)=ITAG(I)
          ENDIF
          IF(IDENT(I).EQ.IDENT(IVT1)) GOTO 50  ! ISAJET idiosyncracy
C
          ID=IABS(IDENT(I))
          IF(IDENT(I).EQ. 80) IWPOS=I    ! tag W+
          IF(IDENT(I).EQ.-80) IWNEG=I    ! tag W-
          JSPIN=MOD(ID,10)
          IFL=MOD(ID,100)/10
C
C   check for ground state heavy flavors or taus
          IF(((JSPIN.EQ.0.AND.IFL.GT.3).OR.(ID.EQ.16))
     &      .AND.(ID.NE.80)) THEN
            IV=ITAG(I)
            LVP=LVD(IV)
            NVERTX=NVERTX+1
            CALL UCOPY(XYZ(1,IV),XYZB,3)
C                  generate decay vertex
            CALL GENVTX(PPTCL(1,I),IDENT(I),XYZB,XYZ(1,NVERTX))
            CALL BKISV1(NVERTX,LISV1)
            IQ(LISV1+1)=IDENT(I)
            CALL UCOPY(PPTCL(1,I),Q(LISV1+2),5)
            CALL UCOPY(XYZ(1,NVERTX),Q(LISV1+7),3)
            LQ(LISV1-2)=LVP     !  reference link to parent vertex
C
            DO 42 K=IVT1,IVT2
   42       ITAG(K)=NVERTX      ! tag daughter particles
          ENDIF
C
   50   CONTINUE
C
C  fill now all ISP1 banks
        IF(FIRST) CALL MZFORM('ISP1','1I-F',IOISP1)  ! format for ISP1
        CALL ISNUMQ(NJT,NQS)
        NQS=NJSET            ! use total number of partons
C
        DO 100 I=1,NPTCL       ! loop over all particles
C
          ID=IABS(IDENT(I))
C           check for bottom di-quarks
          BOTDIQ=.FALSE.
          IF(MOD(ID/100,10).EQ.5) BOTDIQ=.TRUE.
C
C          move partons to parton banks
          IF((ID.LT.100.AND.ID.NE.10.AND.ID.NE.20).OR.BOTDIQ) THEN
            IF(I.EQ.IWPOS.OR.I.EQ.IWNEG) THEN ! add W to ISAJ
              NJT=NJT+1
              CALL BKISAJ(LISAJ)
              IQ(LISAJ+1)=IDENT(I)                  ! particle id
              CALL UCOPY(PPTCL(1,I),Q(LISAJ+2),5)   ! momenta and mass
C
C   calculate PHI1,THETA and ETA
              CALL ISPETA(PPTCL(1,I),THETA,PHI1,ETA)
              Q(LISAJ+7)=PHI1
              Q(LISAJ+8)=THETA
              Q(LISAJ+9)=ETA
C   set pointers
              PQREF(NJT)=LISAJ
              JOR=IABS(IORIG(I))
              JET=JOR/IPACK
              LQ(LISAJ-1)=PQREF(JET)
              IORIG(I)=-NJT*IPACK          ! remake ORIG to point to ISAJ
            ENDIF
C
            IVT1=IDCAY(I)/IPACK
            IF(IDENT(I).EQ.IDENT(IVT1)) GOTO 100  ! ISAJET idiosyncracy
C
            IF(ID.LT.17.OR.BOTDIQ) THEN
C                  add this parton to ISAQ
              JOR=IABS(IORIG(I))
              JP=MOD(JOR,IPACK)
              ADDQ=.TRUE.
C                check that leptons are from direct W decays
C                and not on parton list already
              IF(ID.GT.10.AND.ID.LT.17) THEN
                ADDQ=.FALSE.
                IF(IDENT(I).EQ.IDENT(JP).AND.IORIG(I).GT.0)
     &            ADDQ=.TRUE.
              ENDIF
              IF(ADDQ) THEN
                IF(IORIG(I).GT.0) THEN   ! trace back ancestry if needed
   81             JOR=IABS(IORIG(JP))
                  IF(IORIG(JP).GT.0) THEN
                    JP=MOD(JOR,IPACK)
                    GOTO 81
                  ENDIF
                  JP=MOD(JOR,IPACK)
                ENDIF
                JET=JOR/IPACK
                CALL BKISAQ(LISAQ)
                NQS=NQS+1
                IQ(LISAQ+1)=IDENT(I)                  ! particle id
                CALL UCOPY(PPTCL(1,I),Q(LISAQ+2),5)   ! momenta and mass
C
C   calculate PHI1,THETA and ETA
                CALL ISPETA(PPTCL(1,I),THETA,PHI1,ETA)
                Q(LISAQ+7)=PHI1
                Q(LISAQ+8)=THETA
                Q(LISAQ+9)=ETA
                LQ(LISAQ-1)=PQREF(JET)
                IORIG(I)=-(JET*IPACK+NQS)   ! remake ORIG to point to ISAQ
                QREF(NQS)=LISAQ
              ENDIF
C
            ENDIF
C
          ENDIF
C
C     put stable particles in particle banks
          IF(IDCAY(I).EQ.0) THEN
            PTOT=SQRT(PPTCL(1,I)**2+PPTCL(2,I)**2+PPTCL(3,I)**2)
C
C           Keep only selected particles with non-0 momentum
            IF(PEDIT(IDENT(I),PPTCL(1,I)).AND.PTOT.GT.0) THEN
              IV=ITAG(I)
              LISV1=LVD(IV)
              CALL MZBOOK(IXMAIN,LISP1,LISV1,-IZISP1,
     $                  'ISP1',5,1,9,IOISP1,-1)
              JOR=IABS(IORIG(I))
C   set reference link to parent parton
              JP=MOD(JOR,IPACK)
              IF(IORIG(I).GT.0) THEN   ! trace back ancestry if needed
   91           JOR=IABS(IORIG(JP))
                IF(IORIG(JP).GT.0) THEN
                  JP=MOD(JOR,IPACK)
                  GOTO 91
                ENDIF
                JP=MOD(JOR,IPACK)
              ENDIF
              IF(JP.GT.0) LQ(LISP1-2)=QREF(JP)
              JET=JOR/IPACK
              LQ(LISP1-3)=PQREF(JET)
C
C   fill Zebra bank
              NPART=NPART+1
              IQ(LISP1-5)=NPART                     ! impose part. no.
              IQ(LISP1+1)=IDENT(I)                  ! particle id
              CALL UCOPY(PPTCL(1,I),Q(LISP1+2),5)   ! momenta and mass
C
C   calculate PHI1,THETA and ETA
              CALL ISPETA(PPTCL(1,I),THETA,PHI1,ETA)
              Q(LISP1+7)=PHI1
              Q(LISP1+8)=THETA
              Q(LISP1+9)=ETA
            ENDIF
C
          ENDIF
  100   CONTINUE
        FIRST=.FALSE.
C
C   renumber vertices in sequence
        NVERTX=0
        LISV1=LVD(1)
  110   NVERTX=NVERTX+1
        IQ(LISV1-5)=NVERTX        ! impose a vertex number
        LISV1=LQ(LISV1)
        IF(LISV1.NE.0) GOTO 110
      ENDIF
C
C
      RETURN
      END
+EOD
+DECK,ISAQFL                          .
      SUBROUTINE ISAQFL
C-------------------------------------------------------------------
C-
C-  Fill ISAQ Zebra banks (initial and final partons)
C-
C-      SDP JAN.,1986
C-   Updated  12-DEC-1989   Serban D. Protopopescu
C-
C--------------------------------------------------------------------
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,JETSET.
+CDE,ZEBCOM.
+CDE,ISALNK.
      INTEGER I,LISAQ,JOR
      REAL PHI1,THETA,ETA
C--------------------------------------------------------------------
C
      LISAQ=0
C
      IF(NJSET.NE.0) THEN
C
        DO 200 I=1,NJSET       ! loop over all partons
C   keep only stable partons and skip ones with 0 energy
C   skip also t-quarks as decay products will be added later
          IF(JDCAY(I).EQ.0.AND.PJSET(4,I).GT.0.
     &      .AND.IABS(JTYPE(I)).NE.6) THEN
            JOR=JORIG(I)/JPACK
            CALL BKISAQ(LISAQ)
            QREF(I)=LISAQ
            LQ(LISAQ-1)=0      !  reference link is 0 for initial partons
            IF(JOR.LT.10)
     $        LQ(LISAQ-1)=PQREF(JOR)
C   fill Zebra bank
            IQ(LISAQ+1)=JTYPE(I)                  ! parton type
            CALL UCOPY(PJSET(1,I),Q(LISAQ+2),5)   ! momenta and mass
C   calculate PHI1,theta and eta
            CALL ISPETA(PJSET(1,I),THETA,PHI1,ETA)
            Q(LISAQ+7)=PHI1
            Q(LISAQ+8)=THETA
            Q(LISAQ+9)=ETA
          ENDIF
  200   CONTINUE
C
      ENDIF
      RETURN
      END
+EOD
+DECK,ISA_RUNNO                       .
      FUNCTION ISA_RUNNO()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Give a run number during event generation
C-   Returned value  : run number
C-
C-   ENTRY ISA_SETRUN(IRUN) give a run number
C-   Input:
C-   IRUN = run number
C-   Created  25-JUL-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER ISA_RUNNO,IRN,IRUN
      INTEGER ISA_SETRUN
      SAVE IRN
      DATA IRN/1/
C----------------------------------------------------------------------
C
      ISA_RUNNO=IRN
  999 RETURN
C
      ENTRY ISA_SETRUN(IRUN)
      IRN=IRUN
      RETURN
      END
+EOD
+DECK,ISA_SMEAR                       .
      SUBROUTINE ISA_SMEAR(ITYP,ENERGY)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-
C-   Inputs  :
C-   ITYP   = 1 for e.m., 2 for had. energy, 3 special region
C-   ETA    = eta for energy
C-   ENERGY = energy to be smeared
C-
C-   Output:
C-   ENERGY = smeared energy
C-
C-   ENTRY ISMRFL : fill ISMR bank with resolution parameters
C-
C-   Created  29-JUN-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER ITYP
      INTEGER LISMR,LDISMR,I
      REAL    ENERGY,R1
      REAL    A(3),B(3),C(3)
C   e.m. resolution= 2% constant, 15%/sqrt(E), 30 MeV noise/tower
C   had. resolution= 3% constant, 50%/sqrt(E), 120 Mev noise/tower
C   special region = 80%/sqrt(E) in CC to EC transition region
      DATA A/.02,.03,.03/
      DATA B/.15,.50,.80/
      DATA C/.03,.12,.12/
C----------------------------------------------------------------------
C
C    smear energies by resolution
C
      CALL NORRAN(R1)
      ENERGY=ENERGY+R1*SQRT((A(ITYP)*ENERGY)**2+ENERGY*B(ITYP)**2
     &  +C(ITYP)**2)
C
      RETURN
C
      ENTRY ISMRFL
C
        CALL BKISMR(LISMR)
        DO I=1,3
          LDISMR=LISMR+(I-1)*3
          Q(LDISMR+1)=A(I)
          Q(LDISMR+2)=B(I)
          Q(LDISMR+3)=C(I)
        ENDDO
C
  999 RETURN
      END
+EOD
+DECK,ISASRT                          .
      SUBROUTINE ISASRT(X,NCH,IMAP)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Sorts a floating point array X into ascending order.
C-                         The array IMAP contains ordered list of pointers
C-
C-   Inputs  : X - Floating point array
C-             NCH  - Number of elements in X
C-   Outputs : IMAP - pointer to ordered list in X
C-   Controls: None
C-
C-   Created   3-OCT-1988   Rajendran Raja
C-   Based on the Algorithm of D.L.Shell, High speed sorting
C-   procedure , Communications of the ACM, Vol 2, July 1959, PP 30-32
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL X(*)
      REAL TEMP
      INTEGER IMAP(*),NCH,M,I,J,K,IM,IT
C----------------------------------------------------------------------
      M=NCH
   10 M=M/2       !binary chop
      IF(M.EQ.0)GO TO 999
      K=NCH-M
      J=1
   20 I=J
   30 IM=I+M
      IF(X(I).LE.X(IM))GO TO 40
      TEMP = X(I)
      X(I) = X(IM)
      X(IM) = TEMP
      IT = IMAP(I)
      IMAP(I)=IMAP(IM)
      IMAP(IM)=IT
      I = I-M
      IF(I.GE.1)GO TO 30
   40 J=J+1
      IF(J.GT.K)GO TO 10
      GO TO 20
  999 RETURN
      END
+EOD
+DECK,ISAWBG                          .
       SUBROUTINE ISAWBG
C------------------------------------------------------------------
C-
C-     subroutine ISAWBG writes beginning record (1001)
C-
C-     WRITTEN BY SDP 12/85, rev. Sept.86
C-
C------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ISAUNT.
+CDE,ZEBCOM.
C----------------------------------------------------------------------
C
      CALL ISABFL          ! fill ISAB bank
C
C  write out beginning record
      CALL FZOUT(ISUNIT,IXMAIN,LISAB,1,' ',1,0,0)
      CALL MZWIPE(0)
       RETURN
       END
+EOD
+DECK,ISA_WEIGHT                      .
      FUNCTION ISA_WEIGHT()
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      return weight for ISAJET event
C-   Returned value  : weight (microbarns/event)
C-
C-   Created  30-JAN-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL ISA_WEIGHT
+CDE,ZEBCOM.
C----------------------------------------------------------------------
C
      ISA_WEIGHT=0
      IF(LISAE.GT.0) ISA_WEIGHT=Q(LISAE+12)
  999 RETURN
      END
+EOD
+DECK,ISAWEV                          .
      SUBROUTINE ISAWEV
C------------------------------------------------------------------
C-
C- ISAWEV replaces ISAJET ISAWEV
C-
C-  write ZEBRA bank ISAE, ISAJ and ISAQ (main, primary partons,
C-  initial and final partons)
C-
C-  Default is to write ISV1 and ISP1, if QPART false they are dropped
C-  If QLEP true write ISAL banks
C-  If QCAL true write ISAC banks (toy calorimeter)
C-
C-      WRITTEN BY SDP 12/85, Modified Dec. 19,1988
C-
C------------------------------------------------------------------
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,ISAUNT.
      LOGICAL QPART,QCAL,QLEP,ISEDIT
      INTEGER LISV1,GZISV1
C
      CALL ISAEFL             ! fill all ISAJET event banks
C
C  write out event record
      IF(ISEDIT()) THEN
        CALL FZOUT(ISUNIT,IXMAIN,LISAE,1,' ',1,0,0)
      ENDIF
  999 RETURN
      END
+EOD
+DECK,ISAWND                          .
      SUBROUTINE ISAWND
C-----------------------------------------------------------------
C-
C-  Replaces ISAJET ISAWND. Write Zebra end record (1002).
C-
C-    SDP Jan.,1986
C-
C-----------------------------------------------------------------
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,ISAUNT.
C----------------------------------------------------------------------
C
      CALL ISAFFL     ! fill ISAF bank
C
C  write out end record
      CALL FZOUT(ISUNIT,IXMAIN,LISAE,1,' ',1,0,0)
      CALL MZWIPE(0)
      CALL ISA_STOP
      RETURN
      END
+EOD
+DECK,ISAZEB                          .
      SUBROUTINE ISAZEB(CHIO)
C---------------------------------------------------------------
C-
C-    Initialize Zebra for Isajet
C-    Uses /ZEBCOM/ as the common block for Zebra banks
C-
C-    INPUT:
C-    CHIO = character IO control: 'I' for input, 'O' for output
C-
C-     SDP  JAN. 30,1991
C-
C---------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ISAUNT.
+CDE,ISABNK.
+CDE,ZEBCOM.
+CDE,ISALNK.
      CHARACTER*1 CHIO
      LOGICAL FIRST,OK
      DATA FIRST/.TRUE./
C----------------------------------------------------------------
C
C   Do basic initalization
C
      IF(FIRST) THEN
        CALL INZCOM(2)
        FIRST=.FALSE.
C        setup the link area for ISAZEB
        CALL MZLINK(IXCOM,'/ISALNK/',LVD,PQREF(MPQREF),LVD)
C        setup the general link area
        CALL INZLNK
      ELSE
        IF(CHIO.EQ.'I') CALL FZENDI(ISUNIT,'UT')
        IF(CHIO.EQ.'O') CALL FZENDO(ISUNIT,'UT')
        CLOSE(ISUNIT)
      ENDIF
C
C    Initialize for IO
C
      IF(CHIO.EQ.'O') THEN
        CALL FZFILE (ISUNIT,0,'O')
      ELSE IF(CHIO.EQ.'I') THEN
        CALL FZFILE (ISUNIT,0,'I')
      ELSE
        PRINT 101,CHIO
        STOP
      ENDIF
      RETURN
  101 FORMAT(//'  CHIO='A4' IS NOT A RECOGNIZABLE COMMAND FOR ISAZEB,'
     $ /' JOB STOPPED')
      END
+EOD
+DECK,ISCHAR                          .
      FUNCTION ISCHAR ( ID)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : gives the charge of the particle , depending
C-                         on the ISAJET identifier ID.
C-
C-   Inputs  : ID     = Isajet particle ident
C-   Outputs : ISCHAR = 0 Neutral particle
C-                    = +-1 positive or negative charged particle
C-
C-   Created  14-APR-1988   Ghita Rahal-Callot
C-   Modified to use ISAJET charge, Serban Protopopescu 30-Nov-1988
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER ID,  ISCHAR
      REAL CHARGE
C----------------------------------------------------------------------
      ISCHAR=INT(CHARGE(ID))
  999 RETURN
      END
+EOD
+DECK,ISCMFL                          .
      SUBROUTINE ISCMFL(CUNIT)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : TO FILL THE
C-
C-   Inputs  :
C-   CUNIT = unit number for command file
C-
C-   Created  13-DEC-1989   Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER MAXLIN
      PARAMETER( MAXLIN =  200 )
      CHARACTER LINE(MAXLIN)*80
      INTEGER NCHAR(MAXLIN)
      INTEGER LISCM,CUNIT,IER
      INTEGER NLINE,NDATA,I1,I2,L1,IPT,ILINE
+CDE,ZEBCOM.
C----------------------------------------------------------------------
C
C ****  READ IN COMMAND FILE
C
      REWIND(CUNIT)
      NLINE = 0
      NDATA = 0
    1 NLINE = NLINE + 1
      READ (CUNIT,'(A80)',END=2)LINE(NLINE)
      CALL SWORDS(LINE(NLINE),I1,I2,L1)
      LINE(NLINE) = LINE(NLINE)(1:I2)//CHAR(13)
      NCHAR(NLINE) = I2 + 1
      NDATA = NDATA + ( NCHAR(NLINE) + 3 ) / 4
      IF( NLINE.LT.MAXLIN) GOTO 1
    2 CALL BKISCM(NDATA+1,LISCM)
      REWIND(CUNIT)
      IPT = LISCM + 1
C
C ****  FILL ISCM WITH COMMAND FILE
C
      DO ILINE = 1, NLINE
        CALL UCTOH(LINE(ILINE)(1:NCHAR(ILINE)),IQ(IPT),4,NCHAR(ILINE))
        IPT = IPT + ( NCHAR(ILINE) + 3 ) / 4
      END DO
  999 RETURN
      END
+EOD
+DECK,ISEDIT                          .
      FUNCTION ISEDIT()
C-
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-        dummy hook for editing events written to output stream
C-
C-   Created   7-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
C-
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL ISEDIT
+CDE,ZEBCOM.
C-------------------------------------------------------
      ISEDIT=.TRUE.
      RETURN
      END

+EOD
+DECK,ISLBNK                          .
      SUBROUTINE ISLBNK(QPART,QCAL,QLEP)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Return flags indicating which banks to write
C-
C-   Outputs :
C-   QPART= value set by call to ISBKST
C-   QCAL =     "
C-   QLEP =     "
C-
C-   ENTRY ISBKST(QPART,QCAL,QLEP)
C-
C-   Created   7-NOV-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL QPART,QCAL,QLEP,QPS,QCS,QLS
      SAVE QPS,QCS,QLS
C----------------------------------------------------------------------
C
C
      QPART=QPS
      QCAL=QCS
      QLEP=QLS
      RETURN
C
      ENTRY ISBKST(QPART,QCAL,QLEP)
      QPS=QPART
      QCS=QCAL
      QLS=QLEP
  999 RETURN
C
      END
+EOD
+DECK,ISMEAR                          .
      SUBROUTINE ISMEAR
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     Smear pseudo-calorimeter ISCL bank
C-     store smearing parameters in bank ISMR
C-
C-   Created  18-MAY-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISCL.
      INTEGER LISAC,GZISAC,LISMR,GZISMR,LISCL,ITYP
      REAL    EEM,EHAD,ABSETA
C----------------------------------------------------------------------
      IF ( GZISMR().EQ.0 ) THEN
        LISAC=GZISAC()
        IF(LISAC.EQ.0)  THEN ! If pseudo-calorimeter data not available
          CALL ISACFL        ! make it
        ELSE
C         remake the ISAC bank if it has no link for ISMR
          IF(IQ(LISAC-3).LT.2) THEN
            CALL MZDROP(IXCOM,LISAC,' ')
            CALL ISACFL
          ENDIF
        ENDIF
C
        LISAC=GZISAC()
        LISCL=LISAC-IZISCL
  400   LISCL=LQ(LISCL)         !  Loop over all non-zero cells
        IF(LISCL.GT.0.) THEN
          ABSETA=ABS(Q(LISCL+10))
          EEM=Q(LISCL+3)
          EHAD=Q(LISCL+4)
          IF(EEM.GT.0) CALL ISA_SMEAR(1,EEM)
          IF(EHAD.GT.0) THEN
            ITYP=2
            IF(ABSETA.GT.1.0.AND.ABSETA.LT.1.5) ITYP=3
            CALL ISA_SMEAR(ITYP,EHAD)
          ENDIF
C
C            refill bank with smeared energies
          Q(LISCL+3)=EEM
          Q(LISCL+4)=EHAD
          GOTO 400
        ENDIF
C
C          book and fill ISMR
        CALL ISMRFL
C
      ENDIF
  999 RETURN
      END
+EOD
+DECK,ISNUMQ                          .
      SUBROUTINE ISNUMQ(NJT,NQS)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Find number of primary (ISAJ) and secondary (ISAQ) parton banks
C-   Outputs :
C-      NJT= number of ISAJ banks
C-      NQS= number of ISAQ banks
C-
C-   Created  13-DEC-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER NJT,NQS
      INTEGER LISAJ,LISAQ,GZISAJ,GZISAQ
C----------------------------------------------------------------------
      NJT=0
      NQS=0
C
C  find number of primary parton banks
      LISAJ=GZISAJ()
  11  IF(LISAJ.NE.0) THEN
        NJT=NJT+1
        LISAJ=LQ(LISAJ)
        GOTO 11
      ENDIF
C  find number of stable parton banks
      LISAQ=GZISAQ()
  12  IF(LISAQ.NE.0) THEN
        NQS=NQS+1
        LISAQ=LQ(LISAQ)
        GOTO 12
      ENDIF
  999 RETURN
      END
+EOD
+DECK,ISPETA                          .
      SUBROUTINE ISPETA(P,THETA,PHI,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-     convert a momentum P(3) to theta, phi and eta (pseudo-rapidity)
C-   Inputs  :
C-     P(3) = px, py, pz
C-   Outputs :
C-    THETA = polar angle
C-    PHI   = atan(px,py) range 0 to twopi
C-    ETA   = pseudo-rapidity
C-
C-   Created  13-DEC-1989   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      REAL TWOPI
      PARAMETER (TWOPI=6.283185)
      REAL    P(3),THETA,PHI,ETA
      REAL    PTOT,PZOP
C----------------------------------------------------------------------
C
      PHI=ATAN2(P(2),P(1)+.00001) ! protection
      IF(PHI.LT.0) PHI=PHI+TWOPI
      PTOT=SQRT(P(1)**2+P(2)**2+P(3)**2)
      PZOP=P(3)/(PTOT+.0001)    ! protect against 0 momentum
      THETA=ACOS(PZOP)
C             protect against small theta
      ETA=10.*SIGN(1.,PZOP)
      IF(ABS(PZOP).LT.0.9999) ETA=-ALOG(TAN(THETA/2.))
C
  999 RETURN
      END
+EOD
+DECK,OPANGL                          .
      FUNCTION OPANGL(P1,P2)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : DETERMINE OPENING ANGLE BETWEEN TWO VECTORS
C-
C-   Returned value  : OPENING ANGLE IN RADIANS
C-   Inputs  : P1,P2 - 4 VECTORS ( IGNORE P(4) )
C-   Outputs : NONE
C-   Controls: NONE
C-
C-   Created   6-NOV-1989   Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER I
      REAL DOT,COSA,OPANGL,P1(4),P2(4),P1M,P2M
C----------------------------------------------------------------------
      DOT = 0.0
      DO I = 1, 3
        DOT = DOT + P1(I)*P2(I)
      END DO
      P1M  = SQRT (P1(1)*P1(1) + P1(2)*P1(2) + P1(3)*P1(3) )
      P2M  = SQRT (P2(1)*P2(1) + P2(2)*P2(2) + P2(3)*P2(3) )
      COSA = DOT / (P1M*P2M)
      IF (ABS(COSA) .GT.1.0 )  THEN
        IF (COSA.LT.0.0) COSA = -1.0
        IF (COSA.GT.0.0) COSA =  1.0
      END IF
      OPANGL = ACOS( COSA )
  999 RETURN
      END
+EOD
+DECK,PEDIT                           .
      FUNCTION PEDIT(ID,P)
C======================================================================
C
C   Purpose and Methods :
C   select particles to be included in Zebra output
C   called for every particle. If PEDIT=.FALSE. particle will
C   be left out
C
C   Inputs  :
C   ID  = particle id
C   P(4)= particle momenta, px,py,pz and E
C
C   Outputs : NONE
C
C   Created  23-MAY-1987   Serban D. Protopopescu
C
C======================================================================
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      LOGICAL PEDIT
      INTEGER ID
      REAL P(4)
C======================================================================
      PEDIT=.TRUE.
      IF(P(4).LE.0.0) PEDIT=.FALSE.
  999 RETURN
      END
+EOD
+DECK,PJANGL                          .
      SUBROUTINE PJANGL(LPJHDI,OP_CUT,ET_CUT,MAX_IT,IR,MUON,NJET)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Determine Jets from Partons using opening
C-     angle cone algorithm. Boost into parton rest frame - then sort jets.
C-
C-   Inputs  : LPJHD          ...  Address of PJHD bank to hang PJET from
C-             OP_CUT         ...  opening angle in Radians to look for partons
C-             ET_CUT         ...  Et at which a jet doesn't count
C-             MAX_IT         ...  Maximum number of iteration around jet axis
C-             IR             ...  DONT use Initial Radiation then set IR.NE.0
C-             MUON           ...  MUON switch  - 0=no MUONS  - 1=use MUONS
C-   Outputs : NJET - number of PJETs found - PJET bank
C-   Controls: none
C-
C-   Created   5-NOV-1989   Chip Stewart
C-   Updated  15-JAN-1990   Harrison B. Prosper
C-      Removed declarations of LISAE etc.
C-   Updated  25-JAN-1990   Harrison B. Prosper
C-      Increase NPMAX from 50 t0 100
C-   Updated  16-MAY-1990   Chip Stewart  Boaz Klima
C-      Added MUON switch
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C INPUT
      REAL    OP_CUT,ET_CUT
      REAL    OPANGL
      INTEGER MAX_IT,IR,MUON
C INPUT BANK POINTERS
      INTEGER LSUP,GZISAQ
C PARTON MOMENTA
      INTEGER NP,NPMAX
      PARAMETER (NPMAX=100)
      REAL    P(4),EM,PM
      REAL    P_LAB(4,NPMAX),P_CM(4,NPMAX),P_TMP(4,NPMAX)
      REAL    PBOOST(4),P_CHK(4)
      REAL    PT(NPMAX),P_AXIS(4),P_JET(4,NPMAX),PT_JET(NPMAX)
C PJET MOMENTA AND MAPPING
      REAL PJET(4,NPMAX)                 ! PARTON JET 4 MOMENTA
      INTEGER MAPINV(NPMAX,NPMAX)    ! PARTON JET MAPING  PJET --> ISAQ
      INTEGER NQ(NPMAX)               ! PARTON JET NUMBER OF PARTNONS /JET
C BOOKEEPING ARRAYS, POINTERS
      INTEGER ORDER(NPMAX),JETMAP(NPMAX),SEEDMP(NPMAX)
      LOGICAL SKPMAP(NPMAX)
      INTEGER PJ_ID(NPMAX)
      INTEGER ID,I,IP,IJ,JP,IDABS
      INTEGER NJET,IPASS
      LOGICAL LX,LY,LZ
C OBLIGATORY ETA PHI ETC...
      REAL    ETA,PHI,TH
      REAL    ETMAX
      CHARACTER NAME*8,LABEL*8
C ZEBRA INCLUDES
+CDE,ZEBCOM.
+CDE,LKPJET.
+CDE,IZISAQ.
+CDE,ITAPES.
C ZEBRA POINTERS
      INTEGER GZPJHD,LPJHDI
C----------------------------------------------------------------------
C
      LPJHD = LPJHDI
      IF(LPJHD.EQ.0) LPJHD = GZPJHD()    ! GET LINK to 1st PJHD if LPJHD zero
C
      IF(LPJHD.EQ.0) CALL BKPJHD(LPJHD)  ! If no PJHD bank then Book 1st PJHD
C
C ****  add up parton momenta from ISAQ
C
      LSUP = LISAE-IZISAQ   ! find pointer to first bank
      NP = 0
      CALL VZERO(PBOOST(1),4)
      CALL VZERO(SKPMAP(1),NPMAX)
   10 CALL GTISAQ(LSUP,LISAQ,ID,P,PHI,TH,ETA)
      IF( LISAQ .GT. 0 ) THEN
        NP = NP + 1
C
C ****  NO NEUTRINOS !
C
        IDABS=IABS(IQ(LISAQ+1))
        IF(IDABS.EQ.11.OR.IDABS.EQ.13.OR.IDABS.EQ.15)SKPMAP(NP)=.TRUE.
        IF(IDABS.EQ.14.AND.MUON.EQ.0) SKPMAP(NP) = .TRUE.
C
        IF (IR.NE.0 .AND. LQ(LISAQ-1).EQ.0) SKPMAP(NP) = .TRUE.
        IF (.NOT. SKPMAP(NP) ) THEN
          CALL UCOPY(P(1),P_LAB(1,NP),4)
          DO I = 1, 4
            PBOOST(I) = PBOOST(I) + P(I)
          END DO
        END IF
        LSUP = LISAQ
        GOTO 10
      END IF
      CALL VZERO(SEEDMP(1),NP)
      CALL VZERO(JETMAP,NP)            ! zero any jet pointers
C
C ****  BOOST TO PARTON REST FRAME
C
      DO 90 IP = 1, NP
        ORDER(IP) = IP
        IF ( SKPMAP(IP) ) THEN
          PT(IP) = 0
          GOTO 90
        END IF
C        CALL LBOOST (PBOOST ,1 ,P_LAB(1,IP),P_CM(1,IP) )
        CALL LOREN4 (PBOOST ,P_LAB(1,IP),P_CM(1,IP) )
        PT(IP) = -1.0 * SQRT ( P_CM(1,IP)*P_CM(1,IP)
     &    + P_CM(2,IP)*P_CM(2,IP) )
C ****** CHECK BOOST - WHAT IS PT AFTER BOOST ?
        DO I = 1, 4
          P_CHK(I) = P_CHK(I) + P_CM(I,IP)
        END DO
C ******
   90 CONTINUE
C
C ****   ORDER PARTONS IN PT
C
      CALL ISASRT(PT,NP,ORDER)
      DO IP = 1, NP
        PT(IP) = -1*PT(IP)
        DO I = 1, 4
          P_TMP(I,IP) = P_CM(I,ORDER(IP))
        END DO
        IF ( SKPMAP( ORDER(IP) ) ) THEN
          CALL VZERO(P_TMP(1,IP),4)
          SEEDMP(IP) = 999
          JETMAP(IP) = 999
        END IF
      END DO
C
C ****  INITIALIZE JET ALG
C
      NJET=0
    1 ETMAX=0.
      IPASS=0
      IP = 0
C
C ****  FIND SEED PARTON WITH HIGHEST UNUSED PT
C
  200 IP = IP + 1                       ! loop over unused cells
      IF( IP.LE.NP ) THEN
        IF (SEEDMP(IP).EQ.0 .AND.  JETMAP(IP).EQ.0) THEN
          IF(PT(IP) .GT. ETMAX) THEN
            ETMAX= PT (IP)
            SEEDMP(IP)  = NJET + 1    ! DON'T USE SAME PARTON AS SEED TWICE
            DO I = 1, 4
              P_AXIS(I) = P_TMP(I,IP)
            END DO
          ENDIF
        ENDIF
C
        GOTO 200
      ENDIF
C
C ****  EXIT FOR JET ALGORITHM
C
      IF(ETMAX.EQ. 0.0 ) GOTO 400       !  no more jets to be found
C
      NJET=NJET+1
      IF(NJET.GT.NPMAX) THEN
        WRITE(ITLIS,99) NJET
   99   FORMAT(' ERROR IN CJANGL...NJET > ',I5)
        RETURN
      ENDIF
C
C
C ****  LOOP OVER ITERATIONS THROUGH ALGORITHM
C
    2 IPASS=IPASS+1
C
      IF(IPASS.GT. NP)  THEN
        WRITE(ITLIS,88) IPASS
   88   FORMAT(' ERROR IN CJANGL...IPASS > ',I6)
        RETURN
      ENDIF
C
C **** START A NEW JET
C
      CALL VZERO(P_JET(1,NJET),4)
      IP = 0
  300 IP = IP + 1                       ! loop over unused cells
      IF( IP.LE.NP ) THEN
        IF( JETMAP( IP ) .EQ. 0) THEN
C
          IF( OPANGL ( P_AXIS, P_TMP(1,IP) ) .LT. OP_CUT ) THEN  ! add cell
            DO I = 1, 4
              P_JET(I,NJET)= P_JET(I,NJET) + P_TMP(I,IP)
            END DO
            JETMAP(IP) = NJET
          ENDIF
C
        ENDIF
C
        GOTO 300
      ENDIF
C
C ****  CHECK IF NEED FURTHER ITERATIONS
C
      LX = P_JET(1,NJET).EQ. P_AXIS(1)
      LY = P_JET(2,NJET).EQ. P_AXIS(2)
      LZ = P_JET(3,NJET).EQ. P_AXIS(3)
      IF ( LX .AND. LY. AND. LZ .OR. IPASS.GE.MAX_IT) GOTO 3
C
C ****  SET AXIS TO JET MOMENTA, RESET MAP AND GO THROUGH ANOTHER ITERATION
C
      CALL UCOPY(P_JET(1,NJET),P_AXIS(1),4)
      DO IP = 1, NP
        IF ( JETMAP(IP) .EQ. NJET) JETMAP(IP) = 0
      END DO
      GOTO 2
C
C **** DISCARD JET IF Et < ETCUT, FILL COMMON OTHERWISE.
C
    3 PT_JET (NJET) =SQRT(P_JET(1,NJET)**2+P_JET(2,NJET)**2)
      IF(PT_JET(NJET) .LT. ET_CUT) THEN
        DO IP = 1, NP
          IF ( JETMAP(IP) .EQ. NJET) JETMAP(IP) = 0
        END DO
        DO I = 1, 4
          P_JET(I,NJET) = 0.0
        END DO
        NJET=NJET-1
      ENDIF
      GO TO 1
C
C ****  FOUND ALL JETS - FILL PJET BANK
C
  400 CALL VZERO(PJET(1,1),4*NJET)
      CALL VZERO(NQ(1),NP)
C
      DO IP = 1, NP
        JP = JETMAP( IP )
        IF( JP .GT. 0  .AND. JP.LT.NPMAX) THEN
          DO I = 1, 4
            PJET(I,JP) =
     &        PJET(I,JP) + P_LAB(I,ORDER(IP))
          END DO
          NQ( JP) =  NQ( JP ) + 1
          MAPINV( NQ(JP), JP ) = ORDER(IP)
        END IF
      END DO
C
C ****  FILL PJ_ID WITH ISAQ NUMERIC ID'S
C
      LISAQ=GZISAQ()
      NP = 0
  195 CONTINUE
      NP = NP + 1
      PJ_ID(NP) = IQ(LISAQ-5)
      LISAQ = LQ( LISAQ )
      IF( LISAQ .NE. 0 ) GOTO 195
      DO 295 IJ = 1, NJET
        PT_JET(IJ) = SQRT( PJET(1,IJ)*PJET(1,IJ) +
     &    PJET(2,IJ)*PJET(2,IJ) )
C
C ****  FINAL CHECK OF JET PT AFTER BOOST BACK TO PP CMS FRAME
C
        IF ( PT_JET(IJ).LT.ET_CUT ) GOTO 295
C
C ****  BOOK AND FILL JET BANK FOR THIS JET
C
        CALL BKPJET(LPJHD,LPJET)
        Q(LPJET+2) = PT_JET(IJ)
        Q(LPJET+3) = PJET(1,IJ)
        Q(LPJET+4) = PJET(2,IJ)
        Q(LPJET+5) = PJET(3,IJ)
        Q(LPJET+6) = PJET(4,IJ)
        CALL ISPETA(PJET(1,IJ),TH,PHI,ETA)
        Q(LPJET+8) = PHI
        Q(LPJET+9)  = TH
        Q(LPJET+10) = ETA
        EM = PJET(4,IJ)
        PM = SQRT ( PJET(1,IJ)*PJET(1,IJ)
     &    + PJET(2,IJ)*PJET(2,IJ)
     &    + PJET(3,IJ)*PJET(3,IJ) )
        Q(LPJET+7) = SQRT ( (EM+PM)* ABS( (EM-PM) ) )  ! SMALL MASS PROBLEM
        IQ(LPJET+11) = 0
        IQ(LPJET+12) = 0
C
C ****  BOOK AND FILL JET POINTER BANK FOR ALL PJETS
C
        CALL PJPTFL (PJ_ID,MAPINV(1,IJ),NPMAX,NQ(IJ))
  295 CONTINUE
C
  999 RETURN
      END
+EOD
+DECK,PJCONE                          .
      SUBROUTINE PJCONE(LPJHDI,DRCUT,ETCUT,MXPASS,IR,MUON,NPJ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : COMBINES PARTONS INTO PARTON JETS
C-
C-   Inputs  : LPJHD, DRCUT, ETCUT, MXPASS,IR,MUON
C-   Outputs : NPJ
C-   Controls: None
C-
C-             LPJHD  - Address of PJHD bank to hang PJET from.
C-             DRCUT  - dR=sqrt(dETA**2+dPHI**2) cut around Leading Partons.
C-             ETCUT  - Transverse Energy cut ( minimum for defining a JET ).
C-             MXPASS - Maximum number of iterations.
C-             IR     - Initial Radiation switch: throw out if IR.NE.0.
C-             MUON   - MUON switch: throw out if MUON.EQ.0.
C-             NPJ    - No. of Parton Jets found.
C-
C-   Created  27-OCT-1989   Boaz Klima
C-   Updated  15-DEC-1989   Boaz Klima   :  FORTRAN77 compatible
C-   Updated  15-JAN-1990   Harrison B. Prosper
C-      Removed declarations of LISAE etc. (already in LKPJET.INC)
C-   Updated  19-JAN-1990   Boaz Klima
C-      Add call to PJPTFL ( reference link to ISAQ )
C-   Updated  25-JAN-1990   Harrison B. Prosper
C-      Increased NPMAX from 50 to 100
C-   Updated  16-MAY-1990   Chip Stewart, Boaz Klima
C-      Added MUON switch
C-   Updated  22-MAY-1990   Boaz Klima
C-      NOT using Phi and Theta from ISAQ
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,PI.
+CDE,ZEBCOM.
+CDE,LKPJET.
C
      INTEGER IER
      LOGICAL FIRST
      DATA FIRST/.TRUE./
C
      CHARACTER*8 NAME,LABEL
      INTEGER NPMAX, MXPASS, IR, MUON
      PARAMETER (NPMAX=100)
      REAL    SUM, DIF
      INTEGER NP, JP, J, JO, JOP1, JOP2, JP1, JP2, ISKP, IP, IPN, IJ
      REAL    PTN, PTO, PTNO, PTNOR, X1, Y1, PHI1, PHI2
      REAL    DETA, DPHI, DR, DRCUT, ETCUT
      INTEGER JIORD(NPMAX), JDORD(NPMAX), JCNN(NPMAX,NPMAX)
      INTEGER JSKP(NPMAX)
      INTEGER NJET, LJETS, I, JJ, INFI, IDABS
      INTEGER GZJETS
      INTEGER GZISAJ, GZISAQ
      REAL    P_PX(NPMAX),P_PY(NPMAX),P_PZ(NPMAX), P_E(NPMAX)
      REAL    P_MS(NPMAX), P_PHI(NPMAX), P_THE(NPMAX), P_ETA(NPMAX)
      REAL    P_P(NPMAX), P_PT(NPMAX), PDM_PT(NPMAX)
      INTEGER NPJ
      REAL    PJ_PX(NPMAX), PJ_PY(NPMAX), PJ_PZ(NPMAX), PJ_E(NPMAX)
      REAL    PJ_MS(NPMAX), PJ_PHI(NPMAX), PJ_THE(NPMAX)
      REAL    PJ_ETA(NPMAX), PJ_P(NPMAX), PJ_PT(NPMAX)
      INTEGER PJ_MPI(NPMAX,NPMAX)    ! PARTON JET MAPING  PJET --> ISAQ
      INTEGER PJ_ID(NPMAX)          ! PARTON LINKS TO ISAQ
      INTEGER PJ_NP(NPMAX)               ! NUMBER OF PARTONS IN PARTON JET
      REAL    EPS
      PARAMETER( EPS = 1.0E-5 )
C ZEBRA POINTERS
      INTEGER GZPJHD,LPJHDI
C----------------------------------------------------------------------
C
      LPJHD = LPJHDI
      IF(LPJHD.EQ.0) LPJHD = GZPJHD()    ! GET LINK to PJHD header bank
C
      IF(LPJHD.EQ.0) CALL BKPJHD(LPJHD)
C
C ***  BOOK THE BANK IF ARGUMENT = 0.
C
C ... GET ISAJET BANKS INFO
C
      LISAJ=GZISAJ()
   10 CONTINUE
      LISAJ = LQ( LISAJ )
      IF( LISAJ .NE. 0 ) GOTO 10
      LISAQ=GZISAQ()
      NP = 0
   20 CONTINUE
C
C ****  NO NEUTRINOS ( OR MUONS if muon switch is set to 0) !
C
      IDABS=IABS(IQ(LISAQ+1))
      IF(IDABS.EQ.11.OR.IDABS.EQ.13.OR.IDABS.EQ.15)
     &  GOTO 30
      IF(MUON.EQ.0  .AND. IDABS.EQ.14) GOTO 30
C
      NP = NP + 1
      INFI = 2
C
C ****  WANT TO INCLUDE INITIAL RADIATION PARTONS ?
C
      IF ( IR.NE.0 ) INFI = LQ(LISAQ-1)
C
      IF ( INFI.NE.0 ) THEN
        P_PX(NP)  = Q(LISAQ+ 2)
        P_PY(NP)  = Q(LISAQ+ 3)
        P_PZ(NP)  = Q(LISAQ+ 4)
        P_E(NP)   = Q(LISAQ+ 5)
        P_MS(NP)  = Q(LISAQ+ 6)
        P_PT(NP)  = SQRT( P_PX(NP)**2+P_PY(NP)**2 )
        P_P(NP)   = SQRT( P_PT(NP)**2+P_PZ(NP)**2 )
        P_PHI(NP) = ATAN2 (P_PY(NP),P_PX(NP)+EPS)
        IF(P_PHI(NP).LT.0.)P_PHI(NP)=P_PHI(NP)+TWOPI
        P_THE(NP) = ATAN2 (P_PT(NP),P_PZ(NP)+EPS)
        P_ETA(NP) = -ALOG ( TAN(P_THE(NP)/2.) + EPS )
      ELSE
        NP = NP - 1
      ENDIF
   30 LISAQ = LQ( LISAQ )
      IF( LISAQ .NE. 0 ) GOTO 20
C
C ... ORDER PARTONS IN PT
C
      DO 100 JP = 1 , NP
        JIORD(JP) = JP
  100 PDM_PT(JP)=P_PT(JP)
      CALL ISASRT(PDM_PT(1),NP,JIORD)
      DO 105 JP = 1 , NP
  105 JDORD(JP) = JIORD(NP-JP+1)
C
C ... COMBINE PARTONS CLOSE IN R SPACE
C
      DO 110 J = 1 , NP
        JO=JDORD(J)
  110 JCNN(JO,1)=0
      ISKP=0
      DO 120 JP1 = 1 , NP-1
        JOP1=JDORD(JP1)
C ... CHECK IF PARTON ALREADY CONNECTED TO OTHER ONE
        IF ( JCNN(JOP1,1).EQ.-1 ) GOTO 120
        DO 130 JP2 = JP1+1 , NP
          JOP2=JDORD(JP2)
C ... CHECK IF PARTON ALREADY CONNECTED TO OTHER ONE
          IF ( JCNN(JOP2,1).EQ.-1 ) GOTO 130
          DETA = P_ETA(JOP1) - P_ETA(JOP2)
          PHI1 = P_PHI(JOP1)
          PHI2 = P_PHI(JOP2)
          X1 = COS(PHI2-PHI1)
          Y1 = SIN(PHI2-PHI1)
          IF(X1.EQ.0.0) THEN
            DPHI = HALFPI
          ELSE
            DPHI = ATAN2(Y1,X1)
          END IF
          DR = SQRT(DETA**2+DPHI**2)
C --- CRITERION FOR COMBINING PARTONS
          IF ( DR.LT.DRCUT ) THEN
            JCNN(JOP1,1)=JCNN(JOP1,1)+1
            JCNN(JOP2,1)=-1
            JCNN(JOP1,JCNN(JOP1,1)+1)=JOP2
            ISKP=ISKP+JCNN(JOP1,1)
            JSKP(ISKP)=JOP2
          ELSE
            GOTO 130
          ENDIF
  130   CONTINUE
  120 CONTINUE
C
C ... BOOKKEEPING FOR PARTON JETS
C
      DO 150 IP = 1 , NPJ
        PJ_PX(IP) =0.
        PJ_PY(IP) =0.
        PJ_PZ(IP) =0.
        PJ_E(IP)  =0.
        PJ_MS(IP) =0.
        PJ_PHI(IP)=0.
        PJ_THE(IP)=0.
        PJ_ETA(IP)=0.
        PJ_P(IP)  =0.
        PJ_PT(IP) =0.
  150 CONTINUE
      NPJ=0
      DO 200 JP1 = 1 , NP
        JOP1=JDORD(JP1)
C ... ALREADY CONNECTED, SINGLE PARTON JET, OR HAS OTHERS TO CONNECT TO
        IF ( JCNN(JOP1,1).GE.0 ) THEN
          NPJ=NPJ+1
          PJ_NP(NPJ)=1
          PJ_MPI(PJ_NP(NPJ),NPJ)=JOP1
          PJ_PX(NPJ)  = P_PX(JOP1)
          PJ_PY(NPJ)  = P_PY(JOP1)
          PJ_PZ(NPJ)  = P_PZ(JOP1)
          PJ_E(NPJ)   = P_E(JOP1)
          PJ_MS(NPJ)  = P_MS(JOP1)
          PJ_PHI(NPJ) = P_PHI(JOP1)
          PJ_THE(NPJ) = P_THE(JOP1)
          PJ_ETA(NPJ) = P_ETA(JOP1)
          PJ_P(NPJ)   = P_P(JOP1)
          PJ_PT(NPJ) = P_PT(JOP1)
          IF ( JCNN(JOP1,1).EQ.0 ) GOTO 205
          DO 210 JJ = 1 , JCNN(JOP1,1)
            PJ_NP(NPJ)=PJ_NP(NPJ)+1
            PJ_MPI(PJ_NP(NPJ),NPJ)=JCNN(JOP1,JJ+1)
            PJ_E(NPJ)  = PJ_E(NPJ)  + P_E(JCNN(JOP1,JJ+1))
            PJ_PX(NPJ) = PJ_PX(NPJ) + P_PX(JCNN(JOP1,JJ+1))
            PJ_PY(NPJ) = PJ_PY(NPJ) + P_PY(JCNN(JOP1,JJ+1))
            PJ_PZ(NPJ) = PJ_PZ(NPJ) + P_PZ(JCNN(JOP1,JJ+1))
  210     CONTINUE
          PJ_PT(NPJ) = SQRT( PJ_PX(NPJ)**2 + PJ_PY(NPJ)**2 )
          PJ_P(NPJ) = SQRT( PJ_PT(NPJ)**2 + PJ_PZ(NPJ)**2 )
          PJ_PHI(NPJ) = ATAN2 (PJ_PY(NPJ),PJ_PX(NPJ)+EPS)
          IF(PJ_PHI(NPJ).LT.0.)PJ_PHI(NPJ)=PJ_PHI(NPJ)+TWOPI
          PJ_THE(NPJ) = ATAN2 (PJ_PT(NPJ),PJ_PZ(NPJ)+EPS)
          PJ_ETA(NPJ) = -ALOG ( TAN(PJ_THE(NPJ)/2.) + EPS )
          SUM = PJ_E(NPJ) + PJ_P(NPJ)
          DIF = PJ_E(NPJ) - PJ_P(NPJ)
          IF ( DIF.LT.0. ) DIF = 0.
          PJ_MS(NPJ) = SQRT( SUM*DIF )
C --- CRITERION FOR DROPPING A PARTON JET ( ET < ETCUT )
  205     IF ( PJ_PT(NPJ).GT.ETCUT ) GOTO 200
          NPJ=NPJ-1
        ENDIF
  200 CONTINUE
C
C ****  FILL PJ_ID WITH ISAQ LINKS
C
      LISAQ=GZISAQ()
      NP = 0
  300 CONTINUE
      IDABS=IABS(IQ(LISAQ+1))
      IF(IDABS.EQ.11.OR.IDABS.EQ.13.OR.IDABS.EQ.15)
     &  GOTO 330
      IF (MUON.EQ.0 .AND. IDABS.EQ.14) GOTO 330
C
      NP = NP + 1
      INFI = 2
      IF ( IR.NE.0 ) INFI = LQ(LISAQ-1)
      IF ( INFI.NE.0 ) THEN
        PJ_ID(NP) = IQ(LISAQ-5)        ! Save numeric bank Id
      ELSE
        NP = NP - 1
      ENDIF
  330 LISAQ = LQ( LISAQ )
      IF( LISAQ .NE. 0 ) GOTO 300
      DO IJ = 1, NPJ
C
C ****  BOOK AND FILL JET BANK FOR THIS JET
C
        CALL BKPJET(LPJHD,LPJET)
        Q(LPJET+2) = PJ_PT(IJ)
        Q(LPJET+3) = PJ_PX(IJ)
        Q(LPJET+4) = PJ_PY(IJ)
        Q(LPJET+5) = PJ_PZ(IJ)
        Q(LPJET+6) = PJ_E(IJ)
        Q(LPJET+7) = PJ_MS(IJ)
        Q(LPJET+8) = PJ_PHI(IJ)
        Q(LPJET+9)  = PJ_THE(IJ)
        Q(LPJET+10) = PJ_ETA(IJ)
C
C ****  BOOK AND FILL JET POINTER BANK FOR THIS  PJET
C
        CALL PJPTFL (PJ_ID,PJ_MPI(1,IJ),NPMAX,PJ_NP(IJ))
      ENDDO

C-
  999 RETURN
      END
+EOD
+DECK,PJETFL                          .
      SUBROUTINE PJETFL
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Fill in the contents of the bank PJET
C-
C-   Inputs  : none
C-   Outputs : none
C-   Controls: none
C-
C-   Created   7-NOV-1989 18:10:09.84  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,LKPJET.
C
      INTEGER I,J,NJET,GZISAQ
      LOGICAL FIRST,OPEN_ANGLE,DR_CONE
      INTEGER MAXALG
      PARAMETER( MAXALG = 20 )
      REAL ETCUT(MAXALG),DRCUT(MAXALG)
      INTEGER MAXIT(MAXALG), IR(MAXALG), MUON(MAXALG)
      CHARACTER ALG(MAXALG)*20
      INTEGER N
C----------------------------------------------------------------------
C
C ****  Activate PJET temporary link area
C
      CALL PJLINK (PJLON)
C
C
C ****  GET ALGORITHM PARAMETERS FROM PJPGET
C
      CALL PJPGET(N,ALG,ETCUT,DRCUT,MAXIT,IR,MUON)
C
C ****  DON'T DO PJET IF NO ISAQ BANKS OR NO PJET PARAMETERS
C
      LISAQ = GZISAQ()
      IF (N.EQ.0 .OR. LISAQ.LE.0) GOTO 999
C
C ****  LOOP OVER ALGORITHMS
C
      DO I = 1, N
C
C ****  Book next PJHD bank to hang this PJET from
C
        CALL BKPJHD(LPJHD)
        IF (INDEX(ALG(I),'CONE').GT.0) THEN
          CALL PJCONE(LPJHD,DRCUT(I),ETCUT(I),MAXIT(I),
     &      IR(I),MUON(I),NJET)
          IQ(LPJHD+2) = 1                 ! Delta R CONE ALGORITHM
        ELSE IF (INDEX(ALG(I),'ANGL').GT.0) THEN
          CALL PJANGL(LPJHD,DRCUT(I),ETCUT(I),MAXIT(I),
     &      IR(I),MUON(I),NJET)
          IQ(LPJHD+2) = 2                 ! CMS OPENING ANGLE ALGORITHM
        END IF
        IQ(LPJHD+3) = NJET                 ! NUMBER OF JETS FROM CONE ALGORITHM
        Q(LPJHD+4) = DRCUT(I)              ! Delta R /Opening Angle CUT
        Q(LPJHD+5) = ETCUT(I)              ! JET ET CUT
        IQ(LPJHD+6) = MAXIT(I)             ! MAX_PASS = 1 FOR DR CONE
        IQ(LPJHD+7) = IR(I)                ! INIT RAD SWITCH  = NOT 0 FOR NO IR
        IQ(LPJHD+8) = MUON(I)              ! MUON SWITCH  = 0 for NO MUONS
      END DO
      CALL PJISAQ(0)
C
C ****  De-activate temporary link area
C
      CALL PJLINK (PJLOFF)
C-
C----------------------------------------------------------------------
  999 RETURN
      END
+EOD
+DECK,ISA_PJETS
      SUBROUTINE ISA_PJETS(DRCUT,ETCUT,NPJ,PJ_PT,PJ_PHI,PJ_ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : COMBINES PARTONS INTO PARTON JETS
C-                         based on PJCONE
C-   Inputs
C-             DRCUT  - dR=sqrt(dETA**2+dPHI**2) cut around Leading Partons.
C-             ETCUT  - Transverse Energy cut ( minimum for defining a JET ).
C-
C-   Outputs : 
C-        NPJ        = No. of Parton Jets found.
C-        PJ_PT(NPJ) = pt of partons
C-        PJ_PHI(NPJ)= phi "
C-        PJ_ETA(NPJ)= eta "
C-        
C-   created  16-APR-1996   Serban D. Protopopescu   
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,PJETS
+CDE,JETSET
C
      INTEGER NPJ
      REAL    DRCUT
      REAL    PJ_PHI(*), PJ_ETA(*)
      REAL    PJ_PT(*)
      INTEGER NP, JP, J, JO, JOP1, JOP2, JP1, JP2, ISKP, IP
      REAL    X1, Y1, PHI1, PHI2,TH
      REAL    DETA, DPHI, DR,  ETCUT
      INTEGER NPMAX
      PARAMETER (NPMAX=50)
      INTEGER JIORD(NPMAX), JDORD(NPMAX), JCNN(NPMAX,NPMAX)
      INTEGER JSKP(NPMAX)
      INTEGER I, JJ
      REAL    P_JIN(4,NPMAX), P_PHI(NPMAX), P_ETA(NPMAX)
      REAL    P_PT(NPMAX),PDM_PT(NPMAX)
      REAL    PJ(4,NPMAX)
      REAL    EPS
      DOUBLE PRECISION PI, TWOPI, HALFPI, RADIAN
C
C last significant (correctly rounded) decimal place on VAX:
C                                                |
C                                                V
        PARAMETER (PI=        3.1415 92653 58979 32384 6 D0)
        PARAMETER (TWOPI=     6.2831 85307 17958 64769 3 D0)
        PARAMETER (HALFPI=    1.5707 96326 79489 66192 3 D0)
        PARAMETER (RADIAN= 0.0174532 92519 94329 5769237 D0)

C
C
      PARAMETER( EPS = 1.0E-5 )
C----------------------------------------------------------------------
C
      NP=0
      DO I=1,NJSET
        IF(JDCAY(I).EQ.0.AND.IABS(JTYPE(I)).LT.10) THEN
          NP = NP + 1
          CALL UCOPY(PJSET(1,I),P_JIN(1,NP),4)
          P_PT(NP)  = SQRT( P_JIN(1,NP)**2+P_JIN(2,NP)**2 )
          P_PHI(NP) = ATAN2 (P_JIN(2,NP),P_JIN(1,NP)+EPS)
          IF(P_PHI(NP).LT.0.)P_PHI(NP)=P_PHI(NP)+TWOPI
          TH = ATAN2 (P_PT(NP),P_JIN(3,NP)+EPS)
          P_ETA(NP) = -ALOG ( ABS(TAN(TH/2.)) + EPS )
          IF(NP.GE.NPMAX) GOTO 35
        ENDIF
      ENDDO
   35 CONTINUE    ! jump here if more than NPMAX partons
C
C ... ORDER PARTONS IN PT
C
      DO 100 JP = 1 , NP
        JIORD(JP) = JP
  100 PDM_PT(JP)=P_PT(JP)
      CALL ISASRT(PDM_PT(1),NP,JIORD)
      DO 105 JP = 1 , NP
  105 JDORD(JP) = JIORD(NP-JP+1)
C
C ... COMBINE PARTONS CLOSE IN R SPACE
C
      DO 110 J = 1 , NP
        JO=JDORD(J)
  110 JCNN(JO,1)=0
      ISKP=0
      DO 120 JP1 = 1 , NP-1
        JOP1=JDORD(JP1)
C ... CHECK IF PARTON ALREADY CONNECTED TO OTHER ONE
        IF ( JCNN(JOP1,1).EQ.-1 ) GOTO 120
        DO 130 JP2 = JP1+1 , NP
          JOP2=JDORD(JP2)
C ... CHECK IF PARTON ALREADY CONNECTED TO OTHER ONE
          IF ( JCNN(JOP2,1).EQ.-1 ) GOTO 130
          DETA = P_ETA(JOP1) - P_ETA(JOP2)
          PHI1 = P_PHI(JOP1)
          PHI2 = P_PHI(JOP2)
          X1 = COS(PHI2-PHI1)
          Y1 = SIN(PHI2-PHI1)
          IF(X1.EQ.0.0) THEN
            DPHI = HALFPI
          ELSE
            DPHI = ATAN2(Y1,X1)
          END IF
          DR = SQRT(DETA**2+DPHI**2)
C --- CRITERION FOR COMBINING PARTONS
          IF ( DR.LT.DRCUT ) THEN
            JCNN(JOP1,1)=JCNN(JOP1,1)+1
            JCNN(JOP2,1)=-1
            JCNN(JOP1,JCNN(JOP1,1)+1)=JOP2
            ISKP=ISKP+JCNN(JOP1,1)
            JSKP(ISKP)=JOP2
          ELSE
            GOTO 130
          ENDIF
  130   CONTINUE
  120 CONTINUE
C
C ... BOOKKEEPING FOR PARTON JETS
C
      DO 150 IP = 1 , NPJ
        PJ_PHI(IP)=0.
        PJ_ETA(IP)=0.
        PJ_PT(IP) =0.
  150 CONTINUE
      NPJ=0
      DO 200 JP1 = 1 , NP
        JOP1=JDORD(JP1)
C ... ALREADY CONNECTED, SINGLE PARTON JET, OR HAS OTHERS TO CONNECT TO
        IF ( JCNN(JOP1,1).GE.0 ) THEN
          NPJ=NPJ+1
          CALL UCOPY(P_JIN(1,JOP1),PJ(1,NPJ),4)
          PJ_PHI(NPJ) = P_PHI(JOP1)
          PJ_ETA(NPJ) = P_ETA(JOP1)
          PJ_PT(NPJ) = P_PT(JOP1)
          IF ( JCNN(JOP1,1).EQ.0 ) GOTO 205
          DO 210 JJ = 1 , JCNN(JOP1,1)
            PJ(1,NPJ) = PJ(1,NPJ) + P_JIN(1,JCNN(JOP1,JJ+1))
            PJ(2,NPJ) = PJ(2,NPJ) + P_JIN(2,JCNN(JOP1,JJ+1))
            PJ(3,NPJ) = PJ(3,NPJ) + P_JIN(3,JCNN(JOP1,JJ+1))
            PJ(4,NPJ) = PJ(4,NPJ) + P_JIN(4,JCNN(JOP1,JJ+1))
  210     CONTINUE
          PJ_PT(NPJ) = SQRT( PJ(1,NPJ)**2 + PJ(2,NPJ)**2 )
          PJ_PHI(NPJ) = ATAN2 (PJ(2,NPJ),PJ(1,NPJ)+EPS)
          IF(PJ_PHI(NPJ).LT.0.)PJ_PHI(NPJ)=PJ_PHI(NPJ)+TWOPI
          TH = ATAN2 (PJ_PT(NPJ),PJ(3,NPJ)+EPS)
          PJ_ETA(NPJ) = -ALOG ( ABS(TAN(TH/2.)) + EPS )
C --- CRITERION FOR DROPPING A PARTON JET ( ET < ETCUT )
  205     IF ( PJ_PT(NPJ).GT.ETCUT ) GOTO 200
          NPJ=NPJ-1
        ENDIF
  200 CONTINUE
C
C ... ORDER PJETS IN PT
C
      DO 300 JP = 1 , NPJ
        JIORD(JP) = JP
  300 PDM_PT(JP)=PJ_PT(JP)
      CALL ISASRT(PDM_PT(1),NPJ,JIORD)
      DO 305 JP = 1 , NPJ
        P_PT(JP)=PJ_PT(JP)
        P_ETA(JP)=PJ_ETA(JP)
        P_PHI(JP)=PJ_PHI(JP)
  305 JDORD(JP) = JIORD(NPJ-JP+1)
      DO 306 JP = 1 , NPJ
        PJ_PT(JP)=P_PT(JDORD(JP))
        PJ_ETA(JP)=P_ETA(JDORD(JP))
        PJ_PHI(JP)=P_PHI(JDORD(JP))
  306 CONTINUE
C-
  999 RETURN
      END
+DECK,PJISAQ                          .
      SUBROUTINE PJISAQ(LPJHDI)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : TO FILL LINK FROM ISAQ (-2) TO
C-   A REFERENCE LINK TO PJET JET NUMBER.
C-
C-   Inputs  :   LPJHDI - ADDRESS OF PJET HEADER BANK LPJHDI 
C-               = 0 - first PJHD bank
C-   Outputs : NONE
C-   Controls: NONE
C-
C-   Created  29-NOV-1989   Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER LPJHD,LPJET,LPJPT,LPJHDI
      INTEGER LISAQ,J
      INTEGER GZPJHD
+CDE,ZEBCOM.
+CDE,IZPJET.
+CDE,IZPJPT.
C----------------------------------------------------------------------
C
C ****  DETERMINE WHICH ISAQ PARTONS GOTO WHICH PJET FROM PJPT
C
      LPJHD = LPJHDI
      LPJET=0
      IF (LPJHD .EQ. 0 ) LPJHD = GZPJHD ()           ! PJET HEADER BANK
      IF(LPJHD.GT.0) LPJET = LQ ( LPJHD - IZPJET)    ! PJET BANK FROM PJHD
      IF(LPJET.LE.0) GOTO 999
    1 LPJPT = LQ ( LPJET - IZPJPT)              ! PJET POINTER BANK
      DO 2, J = 2, IQ(LPJPT-3)                  ! LOOP OVER POINTERS TO ISAQ
C
C ****  OVERWRITE ISAQ LINK WITH REFERNCE TO PJET BANKS
C
       LISAQ = LQ(LPJPT- J)
       LQ (LISAQ - 2) = LPJET
    2 CONTINUE
      LPJET = LQ ( LPJET  )
      IF ( LPJET .GT. 0 ) GOTO 1
  999 RETURN
      END
+EOD
+DECK,PJLINK                          .
      SUBROUTINE PJLINK (SWITCH)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Activate/de-activate PJET temporary link
C-   area.
C-
C-   Inputs  : SWITCH   [I]     1 -- Activate link area
C-                              0 -- De-activate link area
C-   Outputs : None
C-   Controls: None
C-
C-   Created  13-JAN-1990   Harrison B. Prosper
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER SWITCH
+CDE,ZEBCOM.
+CDE,LKPJET.
C----------------------------------------------------------------------
      IF ( SWITCH .EQ. 1 ) THEN
        CALL MZLINT (IXMAIN,'LKPJET',JPJET,KPJET(MXPJET),JPJET)
      ELSE
        JPJET(1) = 0                    ! De-activate link area
      ENDIF
  999 RETURN
      END
+EOD
+DECK,PJPGET                          .
      SUBROUTINE PJPGET(N,ALG,ETCUT,DRCUT,MAXIT,IR,MUON)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : GETS PJET PARAMETERS - SETS PARAMETERS TO DEFAULTS
C-   IF PJPSET IS NOT CALLED PRIOR TO PJPGET
C-
C-   Inputs  : NONE
C-   Outputs : N     = NUMBER OF PJET ALGORITHMS
C-             ALG   = ALGORITHM TPYE 'CONE' OR 'ANGLE'
C-             ETCUT = ET CUT FR PJET JETS
C-             DRCUT = CONE CUT (IN R OR ANGLE)
C-             MAXIT = MAXIMUM NUMBER OF ITERATIONS
C-             IR    = INIT RADIATION FLAG 0=USE IR,   1=NO IR
C-             MUON  = MUON FLAG           0=NO MUONS, 1=use MUONS in PJET
C-   Controls: NONE
C-
C-   Created  14-DEC-1989   Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER MAXALG
      PARAMETER( MAXALG = 30 )
      REAL ETCUT(*),DRCUT(*)
      INTEGER MAXIT(*), IR(*), MUON(*)
      CHARACTER ALG(*)*(*)
      INTEGER N,I
      REAL ETCUTL(MAXALG),DRCUTL(MAXALG)
      INTEGER MAXITL(MAXALG), IRL(MAXALG), MUONL(MAXALG)
      CHARACTER ALGL(MAXALG)*8
      INTEGER NL
C----------------------------------------------------------------------
      SAVE ETCUTL,DRCUTL,MAXITL,IRL,ALGL,NL,MUONL
      DATA ETCUTL(1),DRCUTL(1),MAXITL(1),IRL(1),ALGL(1),MUONL(1),NL
     &  /        5.0,     0.45,        1,    0 , 'CONE',      0, 1/
      N = NL
      DO I = 1, N
        IF ( I .LE. MAXALG)   THEN
          ETCUT(I) = ETCUTL(I)
          DRCUT(I) = DRCUTL(I)
          MAXIT(I) = MAXITL(I)
          IR(I)    = IRL(I)
          MUON(I)  = MUONL(I)
          ALG(I)   = ALGL(I)
        END IF
      END DO
      RETURN
C
C ****  ENTRY PJPSET SET PJET PARAMETERS TO VALUES INPUT.
C
      ENTRY PJPSET(N,ALG,ETCUT,DRCUT,MAXIT,IR,MUON)
      NL = N
      DO I = 1, NL
        IF ( I .LE. MAXALG)   THEN
          ETCUTL(I) = ETCUT(I)
          DRCUTL(I) = DRCUT(I)
          MAXITL(I) = MAXIT(I)
          IRL(I)    = IR(I)
          MUONL(I)    = MUON(I)
          ALGL(I)   = ALG(I)
        END IF
      END DO
C----------------------------------------------------------------------
  999 RETURN
      END
+EOD
+DECK,PJPTFL                          .
      SUBROUTINE PJPTFL (ISAQID,POINTR,MAX_ISAQ,NMISAQ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : For every PJET bank book and fill the pointer
C-   bank PJPT. Fill reference links in PJPT with ISAQ addresses.
C-
C-   Inputs  : ISAQID(*)        [I]     List of ISAQ bank ids
C-             POINTR(MAX_ISAQ) [I]     Reference pointer array
C-             MAX_ISAQ         [I]     Maximum array dimension
C-             NMISAQ           [I]     number of ISAQ parton in this PJET
C-   Outputs :
C-   Controls:
C-
C-   Created  19-JAN-1990   Boaz Klima
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER MAX_ISAQ
      INTEGER ISAQID(*),POINTR(MAX_ISAQ),NMISAQ
      INTEGER ID,IP,GZISAQ,GZPJET,RFLINK,LZFIND,JET
+CDE,ZEBCOM.
+CDE,LKPJET.
C----------------------------------------------------------------------
C
C ****  LPJET address should be in LKPJET common
C
      IF ( LPJET .LE. 0 ) GOTO 999
C
C ****  Get address of first ISAQ bank
C
      LISAQ=GZISAQ()
      IF ( LISAQ.LE.0 ) GOTO 999
C
C ****  BOOK AND FILL JET POINTER BANK FOR THIS JET
C
      CALL BKPJPT(LPJET,NMISAQ,LPJPT)
      DO IP = 1, NMISAQ
        ID = ISAQID ( POINTR(IP) ) ! Get ID of ISAQ bank
C
C ****  Given bank ID find address
C
        RFLINK = LZFIND(IXMAIN,LISAQ,ID,-5)     ! Get ISAQ address
        IF ( RFLINK .GT. 0 ) THEN
          LQ(LPJPT-IP-1) = RFLINK
        ELSE
          LQ(LPJPT-IP-1) = 0
        ENDIF
      ENDDO
  999 RETURN
      END
+EOD
+DECK,QRECAL                          .
      SUBROUTINE QRECAL
C---------------------------------------------------------
C-
C-  Recalculate jet momenta starting from particles
C-
C-     SDP Jan.,1986, rev. Sept. 86
C-
C---------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,JETSET.
+CDE,KEYS.
+CDE,PARTCL.
+CDE,PJETS.
+CDE,PRIMAR.
      INTEGER IOR,I,K,J,JET
      REAL MASQ
C
      IF(NJSET.NE.0) THEN
C
      CALL VZERO(PJSET,5*NJSET)   ! Zero parton vectors
      CALL VZERO(PJETS,15)        ! Zero primary jet vectors
C
      DO 100 I=1,NPTCL
      DO 90 J=1,4            !  protect against exact zeros
   90 IF(ABS(PPTCL(J,I)).LT..00001) PPTCL(J,I)=.00001
      IF(IORIG(I).LT.0) THEN
        IOR=IABS(IORIG(I))
        K=MOD(IOR,IPACK)
        DO 91 J=1,4
   91   PJSET(J,K)=PJSET(J,K)+PPTCL(J,I)
        JET=IOR/IPACK
        IF(JET.LT.4.AND.JET.GT.0) THEN
          DO 92 J=1,4
   92     PJETS(J,JET)=PJETS(J,JET)+PPTCL(J,I)
        ENDIF
      ENDIF
  100 CONTINUE
C
C  Recalculate primary parton jet masses
      DO 200 I=1,NJET
      MASQ=PJETS(4,I)**2-PJETS(1,I)**2-PJETS(2,I)**2-PJETS(3,I)**2
      IF(MASQ.GT.0) PJETS(5,I)=SQRT(MASQ)
      IF(KEYS(3))  THEN    ! recalculate W vector
          DO 201 J=1,4
  201     QWJET(J)=PJETS(J,1)+PJETS(J,2)
          QWJET(5)=SQRT(QWJET(4)**2-QWJET(1)**2-QWJET(2)**2
     1    -QWJET(3)**2)
      ENDIF
  200 CONTINUE
C
C  Recalculate parton jet masses
      DO 210 I=1,NJSET
      IF(JDCAY(I).EQ.0) THEN
        MASQ=PJSET(4,I)**2-PJSET(1,I)**2-PJSET(2,I)**2-PJSET(3,I)**2
        IF(MASQ.GT.0) PJSET(5,I)=SQRT(MASQ)
      ENDIF
  210 CONTINUE
C
      ENDIF
      RETURN
      END
+EOD
+DECK,RANDOM                          .
      FUNCTION RANDOM()
C------------------------------------------------------------------
C-
C- Generate a random number
C-
C------------------------------------------------------------------
C
      RANDOM=RANF()
C
      RETURN
      END
+EOD
+DECK,SWORDS.
      SUBROUTINE SWORDS (STRING,I,J,N)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Find position of first and last non-blank
C-                         and non-tab characters in specified string.
C-                         This routine is a useful for removing
C-                         trailing and leading blanks.
C-
C-   Inputs  : STRING      String to be searched
C-
C-   Outputs : I           Start of "words"
C-             J           End of "words"
C-             N           Length of "words"
C-
C-   Created   9-MAR-1988   Harrison B. Prosper
C-   Updated  20-DEC-1988   Harrison B. Prosper
C----------------------------------------------------------------------
      IMPLICIT NONE
      INTEGER       I,J,K,L,M,N,LSTR
      CHARACTER*(*) STRING
C
      CHARACTER*1 SPACE,TAB
      PARAMETER( SPACE = ' ' )
C----------------------------------------------------------------------
C
+SELF,IF=IBM
C          Not ASCII
      TAB=' '
+SELF,IF=-IBM
C          ASCII
      TAB=CHAR(9)
+SELF
      I = 1
      J = 0
      N = 0
      LSTR = LEN (STRING)
      CALL WORD (STRING(1:LSTR),I,J,N)
C
C ****  If string contains non-blank characters do a back-search
C
      IF ( N .GT. 0 ) THEN
        DO 10 K = LSTR,I,-1
          IF ( STRING(K:K) .NE. SPACE .AND.
     &         STRING(K:K) .NE. TAB ) THEN
            J = K
            GOTO 20
          ENDIF
   10   CONTINUE
      ENDIF
   20 CONTINUE
      N = J-I+1
C
  999 RETURN
      END
+EOD
+DECK,WORD
      SUBROUTINE WORD (STRING,I,J,N)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Find first sub-string bounded by blanks or
C-                         tabs from the specified string, and return
C-                         the start and end position of the sub-string.
C-                         This routine is useful for splitting a string
C-                         into "words". See also SWORDS.
C-
C-   Inputs  : STRING      String to be searched
C-
C-   Outputs : I           Start of "word"
C-             J           End of "word"
C-             N           Length of "word"
C-
C-   Created   9-MAR-1988   Harrison B. Prosper
C-
C----------------------------------------------------------------------
      IMPLICIT NONE
      CHARACTER*(*) STRING
      INTEGER       I,J,N,K,LSTR
C
      CHARACTER*1 TAB,SPACE
      PARAMETER( SPACE = ' ' )
C----------------------------------------------------------------------
C
+SELF,IF=IBM
C          Not ASCII
      TAB=' '
+SELF,IF=-IBM
C          ASCII
      TAB=CHAR(9)
+SELF
      I = 1
      J = 0
      N = 0
      LSTR = LEN (STRING)
C
      DO 10 K = 1,LSTR
        IF ( STRING(K:K) .NE. SPACE .AND.
     &       STRING(K:K) .NE. TAB ) THEN
          I = K
          N = INDEX (STRING(K:LSTR),SPACE) - 1
          IF ( N .LE. 0 ) THEN
            N = INDEX (STRING(K:LSTR),TAB) - 1
            IF ( N .LE. 0 ) THEN
              N = LSTR - I + 1
            ENDIF
          ENDIF
          J = I + N - 1
          GOTO 999
        ENDIF
   10 CONTINUE
C
  999 RETURN
      END
+EOD
+DECK,ZABEND                          .
      SUBROUTINE ZABEND
C----------------------------------------------------------------
C-
C-      do not allow for graceful exit from a Zebra fatal error
C-
C------------------------------------------------------------------
      PRINT *,' ZABEND CALLED IS IN ISAZEB.OLB'
      CALL ABORT
      END
+EOD
+DECK,ZVERTX                          .
      SUBROUTINE ZVERTX(ZV,DZ)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Dummy routine returns Z and DZ of vertx
C-
C-   Inputs  : None
C-   Outputs : ZV,DZ   Z position and Spread of Vertex
C-   Controls: None
C-
C-   Created  23-MAR-1989   Rajendran Raja
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISV1.
      INTEGER LISV1
      REAL ZV,DZ
C----------------------------------------------------------------------
      ZV = 0.0
      DZ = 0.0
C
      IF(LISAE.NE.0) THEN
        LISV1=LQ(LISAE-IZISV1)
        IF(LISV1.NE.0) ZV=Q(LISV1+9)
      ENDIF
C
  999 RETURN
      END
+EOD
+PATCH,ISZRUN.
+EOD
+DECK,GTISAJ                          .
      SUBROUTINE GTISAJ(LSUP,LISAJ,ID,P,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISAJ linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISAJ to get information
C-           from first bank in linear structure hanging from vertex
C-           bank ISV1, and LISAJ from preceding bank otherwise.
C-   Outputs :
C-     LISAJ= structural link to ISAJ providing information
C-     ID   = particle ID
C-     P(4) = 4-momentum (px, py, pz, E)
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created  29-JAN-1990   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISAJ,ID,LQISAJ,GZISAJ
      REAL    P(4),TH,PHI,ETA
C----------------------------------------------------------------------
C
      IF(LSUP.EQ.0) THEN
        LQISAJ=GZISAJ()
      ELSE
        LQISAJ=LQ(LSUP)
      ENDIF
      IF(LQISAJ.NE.0) THEN
        ID=IQ(LQISAJ+1)
        P(1)=Q(LQISAJ+2)
        P(2)=Q(LQISAJ+3)
        P(3)=Q(LQISAJ+4)
        P(4)=Q(LQISAJ+5)
        PHI=Q(LQISAJ+7)
        TH=Q(LQISAJ+8)
        ETA=Q(LQISAJ+9)
      ENDIF
      LISAJ=LQISAJ
  999 RETURN
      END
+EOD
+DECK,GTISAL                          .
      SUBROUTINE GTISAL(LSUP,LISAL,ID,P,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISAL linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISAL (or 0)
C-           to get information from first bank in linear structure
C-           and LISAL for preceding bank otherwise.
C-   Outputs :
C-     LISAL= structural link to ISAL providing information
C-     ID   = particle ID
C-     P(4) = 4-momentum (px, py, pz, E)
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   17-AUG-1989 Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISAL,ID,LQISAL,GZISAL
      REAL    P(4),TH,PHI,ETA
C----------------------------------------------------------------------
C
      IF(LSUP.EQ.0) THEN
        LQISAL=GZISAL()
      ELSE
        LQISAL=LQ(LSUP)
      ENDIF
      IF(LQISAL.NE.0) THEN
        ID=IQ(LQISAL+1)
        P(1)=Q(LQISAL+2)
        P(2)=Q(LQISAL+3)
        P(3)=Q(LQISAL+4)
        P(4)=Q(LQISAL+5)
        PHI=Q(LQISAL+7)
        TH=Q(LQISAL+8)
        ETA=Q(LQISAL+9)
      ENDIF
      LISAL=LQISAL
  999 RETURN
      END
+EOD
+DECK,GTISAM                          .
      SUBROUTINE GTISAM(LSUP,LISAM,ID,ITYPE,ITRIG,ISPR,
     A P,PHI,TH,ETA,SPR)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISAM linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISAM (or 0)
C-           to get information from first bank in linear structure
C-           and LISAM for preceding bank otherwise.
C-   Outputs :
C-     LISAM= structural link to ISAM providing information
C-     ID   = particle ID
C      ITYPE = 0=PROMPT, 1=DECAY, 2=PUNCH
C      ITRIG = 0=DOESN'T PASS MU TRIGGER, 1=CCT, 2=OTC
C      ISPR = SPARE
C-     P(4) = 4-momentum (px, py, pz, E)
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C      SPR  = SPARE
C-
C-   Created   D. HEDIN 15-0CT-90
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER ITYPE,ITRIG,ISPR,LSUP,LISAM,ID,LQISAM,GZISAM
      REAL    P(4),SPR,TH,PHI,ETA
C----------------------------------------------------------------------
C
      IF(LSUP.EQ.0) THEN
        LQISAM=GZISAM()
      ELSE
        LQISAM=LQ(LSUP)
      ENDIF
      IF(LQISAM.NE.0) THEN
        ID=IQ(LQISAM+1)
        ITYPE=IQ(LQISAM+2)
        ITRIG=IQ(LQISAM+3)
        ISPR=IQ(LQISAM+4)
        P(1)=Q(LQISAM+5)
        P(2)=Q(LQISAM+6)
        P(3)=Q(LQISAM+7)
        P(4)=Q(LQISAM+8)
        PHI=Q(LQISAM+9)
        TH=Q(LQISAM+10)
        ETA=Q(LQISAM+11)
        SPR=Q(LQISAM+12)
      ENDIF
      LISAM=LQISAM
  999 RETURN
      END
+EOD
+DECK,GTISAQ                          .
      SUBROUTINE GTISAQ(LSUP,LISAQ,ID,P,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISAQ linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISAQ to get information
C-           from first bank in linear structure hanging from vertex
C-           bank ISV1, and LISAQ from preceding bank otherwise.
C-   Outputs :
C-     LISAQ= structural link to ISAQ providing information
C-     ID   = particle ID
C-     P(4) = 4-momentum (px, py, pz, E)
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISAQ,ID,LQISAQ,GZISAQ
      REAL    P(4),TH,PHI,ETA
C----------------------------------------------------------------------
C
      IF(LSUP.EQ.0) THEN
        LQISAQ=GZISAQ()
      ELSE
        LQISAQ=LQ(LSUP)
      ENDIF
      IF(LQISAQ.NE.0) THEN
        ID=IQ(LQISAQ+1)
        P(1)=Q(LQISAQ+2)
        P(2)=Q(LQISAQ+3)
        P(3)=Q(LQISAQ+4)
        P(4)=Q(LQISAQ+5)
        PHI=Q(LQISAQ+7)
        TH=Q(LQISAQ+8)
        ETA=Q(LQISAQ+9)
      ENDIF
      LISAQ=LQISAQ
  999 RETURN
      END
+EOD
+DECK,GTISCL                          .
      SUBROUTINE GTISCL(LSUP,LISCL,EEM,EHAD,SNTH,CSTH,CSPHI,SNPHI,
     &  PHI,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISCL linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISCL to get information
C-           from first bank in linear structure hanging from vertex
C-           bank ISV1, and LISCL from preceding bank otherwise.
C-   Outputs :
C-     LISCL= structural link to ISCL providing information
C-     EEM  = e.m. energy
C-     EHAD = hadronic energy
C-     SNTH = sin(theta)
C-     CSTH = cos(theta)
C-     SNPHI= sin(phi)
C-     CSPHI= cos(phi)
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISCL,LQISCL,GZISCL
      REAL    EEM,EHAD,SNTH,CSTH,SNPHI,CSPHI,PHI,ETA
C----------------------------------------------------------------------
+CDE,IZISCL.
C
      IF ( LSUP.EQ.0 ) THEN
        LQISCL=GZISCL()
      ELSE
        LQISCL=LQ(LSUP)
      ENDIF
      IF(LQISCL.NE.0) THEN
        EEM=Q(LQISCL+3)
        EHAD=Q(LQISCL+4)
        SNTH=Q(LQISCL+5)
        CSTH=Q(LQISCL+6)
        SNPHI=Q(LQISCL+7)
        CSPHI=Q(LQISCL+8)
        PHI=Q(LQISCL+9)
        ETA=Q(LQISCL+10)
      ENDIF
      LISCL=LQISCL
  999 RETURN
      END
+EOD
+DECK,GTISJT                          .
      SUBROUTINE GTISJT(LSUP,LISJT,EJT,P,MASS,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISJT linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be 0 to get information
C-           from first bank in linear structure,
C-           and LISJT from preceding bank otherwise.
C-   Outputs :
C-     LISJT= structural link to ISJT providing information
C-     EJT   = jet transverse energy
C-     P(4) = 4-momentum (px, py, pz, E)
C-     MASS = jet mass
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISJT,LQISJT,GZISJT
      REAL    EJT,P(4),MASS,TH,PHI,ETA
C----------------------------------------------------------------------
C
      IF ( LSUP.EQ.0 ) THEN
        LQISJT=GZISJT()
      ELSE
        LQISJT=LQ(LSUP)
      ENDIF
      IF(LQISJT.NE.0) THEN
        EJT=Q(LQISJT+1)
        P(1)=Q(LQISJT+2)
        P(2)=Q(LQISJT+3)
        P(3)=Q(LQISJT+4)
        P(4)=Q(LQISJT+5)
        MASS=Q(LQISJT+6)
        PHI=Q(LQISJT+7)
        TH=Q(LQISJT+8)
        ETA=Q(LQISJT+9)
      ENDIF
      LISJT=LQISJT
  999 RETURN
      END
+EOD
+DECK,GTISP1                          .
      SUBROUTINE GTISP1(LSUP,LISP1,ID,P,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISP1 linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISV1-IZISP1 to get information
C-           from first bank in linear structure hanging from vertex
C-           bank ISV1, and LISP1 for preceding bank otherwise.
C-   Outputs :
C-     LISP1= structural link to ISP1 providing information
C-     ID   = particle ID
C-     P(4) = 4-momentum (px, py, pz, E)
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISP1,ID,LQISP1
      REAL    P(4),TH,PHI,ETA
C----------------------------------------------------------------------
+CDE,IZISP1.
C
      LQISP1=LQ(LSUP)
      IF(LQISP1.NE.0) THEN
        ID=IQ(LQISP1+1)
        P(1)=Q(LQISP1+2)
        P(2)=Q(LQISP1+3)
        P(3)=Q(LQISP1+4)
        P(4)=Q(LQISP1+5)
        PHI=Q(LQISP1+7)
        TH=Q(LQISP1+8)
        ETA=Q(LQISP1+9)
      ENDIF
      LISP1=LQISP1
  999 RETURN
      END
+EOD
+DECK,GTISP2                          .
      SUBROUTINE GTISP2(LSUP,LISP2,ID,P,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISP2 linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISV2-IZISV2 to get information
C-           from first bank in linear structure hanging from vertex
C-           bank ISV2, and LISP2 for preceding bank otherwise.
C-   Outputs :
C-     LISP2= structural link to ISP2 providing information
C-     ID   = particle ID
C-     P(4) = 4-momentum (px, py, pz, E)
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISP2,ID,LQISP2
      REAL    P(4),TH,PHI,ETA
C----------------------------------------------------------------------
+CDE,IZISP2.
C
      LQISP2=LQ(LSUP)
      IF(LQISP2.NE.0) THEN
        ID=IQ(LQISP2+1)
        P(1)=Q(LQISP2+2)
        P(2)=Q(LQISP2+3)
        P(3)=Q(LQISP2+4)
        P(4)=Q(LQISP2+5)
        PHI=Q(LQISP2+7)
        TH=Q(LQISP2+8)
        ETA=Q(LQISP2+9)
      ENDIF
      LISP2=LQISP2
  999 RETURN
      END
+EOD
+DECK,GTISV1                          .
      SUBROUTINE GTISV1(LSUP,LISV1,ID,P,X,Y,Z)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISV1 linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISV1 or 0 to get information
C-           from first bank in linear structure,
C-           and LISV1 for preceding bank otherwise.
C-   Outputs :
C-     LISV1= structural link to ISV1 providing information
C-     ID   = decaying particle ID (1 for primary vertex)
C-     P(4) = 4-momentum (px, py, pz, E)
C-     X,Y,Z   = vertex coordinates
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISV1,ID,LQISV1,GZISV1
      REAL    P(4),X,Y,Z
C----------------------------------------------------------------------
C
      IF ( LSUP.EQ.0 ) THEN
        LQISV1=GZISV1()
      ELSE
        LQISV1=LQ(LSUP)
      ENDIF
      IF(LQISV1.NE.0) THEN
        ID=IQ(LQISV1+1)
        P(1)=Q(LQISV1+2)
        P(2)=Q(LQISV1+3)
        P(3)=Q(LQISV1+4)
        P(4)=Q(LQISV1+5)
        X=Q(LQISV1+7)
        Y=Q(LQISV1+8)
        Z=Q(LQISV1+9)
      ENDIF
      LISV1=LQISV1
  999 RETURN
      END
+EOD
+DECK,GTISV2                          .
      SUBROUTINE GTISV2(LSUP,LISV2,ID,P,X,Y,Z)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in ISV2 linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be LISAE-IZISV2 or 0 to get information
C-           from first bank in linear structure,
C-           and LISV2 for preceding bank otherwise.
C-   Outputs :
C-     LISV2= structural link to ISV2 providing information
C-     ID   = decaying particle ID (1 for primary vertex)
C-     P(4) = 4-momentum (px, py, pz, E)
C-     X,Y,Z   = vertex coordinates
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER LSUP,LISV2,ID,LQISV2,GZISV2
      REAL    P(4),X,Y,Z
C----------------------------------------------------------------------
C
      IF ( LSUP.EQ.0 ) THEN
        LQISV2=GZISV2()
      ELSE
        LQISV2=LQ(LSUP)
      ENDIF
      IF(LQISV2.NE.0) THEN
        ID=IQ(LQISV2+1)
        P(1)=Q(LQISV2+2)
        P(2)=Q(LQISV2+3)
        P(3)=Q(LQISV2+4)
        P(4)=Q(LQISV2+5)
        X=Q(LQISV2+7)
        Y=Q(LQISV2+8)
        Z=Q(LQISV2+9)
      ENDIF
      LISV2=LQISV2
  999 RETURN
      END
+EOD
+DECK,GTPJET                          .
      SUBROUTINE GTPJET(LSUP,LPJET,ET,P,MASS,PHI,TH,ETA)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in PJET linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be 0 to get information
C-           from first bank in linear structure,
C-           and LPJET from preceding bank otherwise.
C-   Outputs :
C-     LPJET= structural link to PJET providing information
C-     ET   = jet transverse energy
C-     P(4) = 4-momentum (px, py, pz, E)
C-     MASS = jet mass
C-     TH   = theta
C-     PHI  = phi
C-     ETA  = eta (pseudo-rapidity)
C-
C-   Created   7-DEC-1988   Serban D. Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZPJET.
      INTEGER LSUP,LPJET,LQPJET,GZPJET
      REAL    ET,P(4),MASS,TH,PHI,ETA
C----------------------------------------------------------------------
      IF ( LSUP.EQ.0 ) THEN
        LQPJET=GZPJET()
      ELSE
        LQPJET=LQ(LSUP)
      ENDIF
      IF(LQPJET.NE.0) THEN
        ET = Q(LQPJET+2)
        P(1)=Q(LQPJET+3)
        P(2)=Q(LQPJET+4)
        P(3)=Q(LQPJET+5)
        P(4)=Q(LQPJET+6)
        MASS=Q(LQPJET+7)
        PHI=Q(LQPJET+8)
        TH=Q(LQPJET+9)
        ETA=Q(LQPJET+10)
      ENDIF
      LPJET=LQPJET
  999 RETURN
      END
+EOD
+DECK,GTPJHD                          .
      SUBROUTINE GTPJHD(LSUP,LPJHD,NALG,NPJET,
     &  DRCUT,ETCUT,MAXIT,IR,MUON)
C----------------------------------------------------------------------
C-
C-   Purpose and Methods :
C-      Fetch information from next bank in PJHD linear structure
C-
C-   Inputs  :
C-     LSUP= supporting link, should be 0 to get information
C-           from first bank in linear structure,
C-           and LPJHD from preceding bank otherwise.
C-   Outputs :
C-     LPJHD = structural link to PJHD providing information
C-     NALG  = PJET ALGORITHM NUMBER 1=DR CONE : 2 = CMS OPENING ANGLE
C-     NPJET = PJET NUMBER OF JETS
C-     DRCUT = PJET DR CUT OR OPEN_ANGLE_CUT
C-     ETCUT = PJET JET ET CUT
C-     MAXIT = PJET MAXIMUM NUMBER OF ITERATIONS
C-     IR    = PJET INITIAL RADIATION TAG - 0 USE IR - 1 NO IR
C-     MUON  = PJET MUON  TAG - 0 IF NO MUONS - 1 IF USE MUONS
C-
C-   Created 14-NOV-1989   Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZPJHD.
      INTEGER LSUP,LPJHD,LQPJHD
      REAL    DRCUT,ETCUT
      INTEGER NALG,NPJET,MAXIT,IR,MUON
C----------------------------------------------------------------------
      IF ( LSUP.EQ.0 ) LSUP= LISAE-IZPJHD
      LQPJHD=LQ(LSUP)
      IF(LQPJHD.NE.0) THEN
        NALG = IQ(LQPJHD+2)
        NPJET = IQ(LQPJHD+3)
        DRCUT =  Q(LQPJHD+4)
        ETCUT =  Q(LQPJHD+5)
        MAXIT = IQ(LQPJHD+6)
        IR    = IQ(LQPJHD+7)
        IF (IQ(LQPJHD+1).GT.1) THEN
          MUON  = IQ(LQPJHD+8)
        ELSE
          MUON = 0
        END IF
      ENDIF
      LPJHD=LQPJHD
  999 RETURN
      END
+EOD
+DECK,ISZJET                          .
      SUBROUTINE ISZJET(RJET,EJCUT,ECCUT,ETSTOP,NJMAX,NCJET)
C-------------------------------------------------------------------
C-
C-       Book and fill banks ISJT with jet ET and 4-momenta
C-       previous ISJT banks are dropped
C-
C-       Expects calorimeter information in Zebra banks ISCL
C-
C-       Uses a simple jet-finding algorithm (similar to UA1):
C-        find highest remaining cell with ET>ETSTOP and sum
C-        surrounding cells with--
C-            DELTA(Y)**2+DELTA(PHI)**2<RJET**2
C-            ET>ECCUT.
C-          keep jets with ET>EJCUT.
C-          the UA1 parameters are RJET=1.0 and EJCUT=5.0
C-
C-    INPUT:
C-    RJET  = size of Y, PHI region for jet
C-    EJCUT = minimum jet ET
C-    ECCUT = minimum ET for cell to be added to jet
C-    ETSTOP= minimum ET in a cell for seed
C-    NJMAX= maximum number of jets
C-
C-    OUTPUT:
C-    NCJET= number of jets found
C-
C-                       SDP May,1986
C--------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
      INTEGER GZISJS
      REAL TWOPI
      PARAMETER (TWOPI=6.283185)
+CDE,IZISAC.
+CDE,IZISAE.
+CDE,IZISCL.
+CDE,ZEBCOM.
+CDE,ZLINKA.
      CHARACTER*64 MESG
      REAL RJET,EJCUT
      INTEGER NJMAX,NCJET,NLISJT
      REAL ECCUT,ETSTOP,PHIMAX,ETAMAX,PHI,ETA,MASSQ
      INTEGER LISAC,LISCL,LISJT,GZISJT
      INTEGER IPASS,NCLS,I,GZISAC
      REAL EEM,EHAD,ETMAX,SNTH,CSTH,SNPH,CSPH,E,RSQ,RJSQ
      REAL PCJET(4),ETJET,ET,PHI1,THETA,PTOT
      REAL ETCMAX(50)
      LOGICAL FIRST
      SAVE NLISJT,FIRST
      DATA NLISJT/0/
      DATA FIRST/.TRUE./
C-----------------------------------------------------------------------
C
      IF(FIRST) THEN
        CALL GSLINK('ISZJET',NLISJT)  ! reserve a link for ISJT
        FIRST=.FALSE.
      ENDIF
      LISJT=GZISJT()
      IF(LISJT.NE.0) CALL MZDROP(IXCOM,LISJT,'L')
      RJSQ=RJET**2
      LISJT=0
      NCJET=0
      IPASS=0
      LISAC=GZISAC()
      LISCL=LISAC-IZISCL
  100 LISCL=LQ(LISCL)         ! zero any jet pointers
      IF(LISCL.GT.0.) THEN
C
        LQ(LISCL-2)=0
        GOTO 100
      ENDIF
C
C          find highest cell remaining
C
1     ETMAX=0.
      NCLS=0
      LISCL=LISAC-IZISCL
  200 LISCL=LQ(LISCL)         ! loop over unused cells
      NCLS=NCLS+1
      IF(LISCL.GT.0.) THEN
        IF(LQ(LISCL-2).EQ.0) THEN
          EEM=Q(LISCL+3)
          EHAD=Q(LISCL+4)
          SNTH=Q(LISCL+5)
          ET=(EEM+EHAD)*SNTH
          IF(ET.GT.ETMAX) THEN
            ETMAX=ET
            PHIMAX=Q(LISCL+9)
            ETAMAX=Q(LISCL+10)
          ENDIF
        ENDIF
C
        GOTO 200
      ENDIF
      IF(ETMAX.LT.ETSTOP) GOTO 999 !  no more jets to be found
C
C          errors
C
      IPASS=IPASS+1
      IF(IPASS.GT.NCLS) THEN
        WRITE(ITLIS,88) IPASS
  88    FORMAT(' ERROR IN ISZJET...IPASS > ',I6)
        RETURN
      ENDIF
      NCJET=NCJET+1
      IF(NCJET.GT.NJMAX) THEN
        WRITE(ITLIS,99) NCJET
  99    FORMAT(' ERROR IN ISZJET...NCJET > ',I5)
        RETURN
      ENDIF
C
C        Start a new jet
C
      LSLINK(NLISJT)=LISJT
      ETCMAX(NCJET)=0
      CALL BKISJT(LISJT)
      NCLS=0
      CALL VZERO(PCJET,4)
      LISCL=LISAC-IZISCL
  300 LISCL=LQ(LISCL)         ! loop over unused cells
      NCLS=NCLS+1
      IF(LISCL.GT.0) THEN
C
        IF(LQ(LISCL-2).EQ.0) THEN
          EEM=Q(LISCL+3)
          EHAD=Q(LISCL+4)
          SNTH=Q(LISCL+5)
          ET=(EEM+EHAD)*SNTH
          PHI=Q(LISCL+9)
          ETA=Q(LISCL+10)
          RSQ=(PHI-PHIMAX)**2+(ETA-ETAMAX)**2
C
          IF(ET.GT.ECCUT.AND.RSQ.LT.RJSQ) THEN  ! add cell to jet
            E=EEM+EHAD
            CSTH=Q(LISCL+6)
            SNPH=Q(LISCL+7)
            CSPH=Q(LISCL+8)
            PCJET(1)=PCJET(1)+E*SNTH*CSPH
            PCJET(2)=PCJET(2)+E*SNTH*SNPH
            PCJET(3)=PCJET(3)+E*CSTH
            PCJET(4)=PCJET(4)+E
            LQ(LISCL-2)=LISJT
            IF(ET.GT.ETCMAX(NCJET)) THEN  ! find cell with max. ET contrib.
              ETCMAX(NCJET)=ET
              LQ(LISJT-1)=LQ(LISCL-1)   ! reference to parent parton
            ENDIF
          ENDIF
C
        ENDIF
C
        GOTO 300
      ENDIF
C
C          discard jet if ET < EJCUT, fill bank otherwise.
C
      ETJET=SQRT(PCJET(1)**2+PCJET(2)**2)
      IF(ETJET.LT.EJCUT) THEN
        NCJET=NCJET-1
        CALL MZDROP(IXMAIN,LISJT,' ')
        LISJT=LSLINK(NLISJT)
      ELSE
        IQ(LISJT-5)=NCJET
        Q(LISJT+1)=ETJET                  ! jet ET
        CALL UCOPY(PCJET,Q(LISJT+2),4)    ! jet 4-momenta
        MASSQ=PCJET(4)**2-PCJET(1)**2-PCJET(2)**2-PCJET(3)**2
        Q(LISJT+6)=0
        IF(MASSQ.GT.0) Q(LISJT+6)=SQRT(MASSQ)   ! jet mass
C   calculate PHI1,theta and eta
          PHI1=ATAN2(PCJET(2),PCJET(1))
          IF(PHI1.LT.0) PHI1=PHI1+TWOPI
          PTOT=SQRT(PCJET(1)**2+PCJET(2)**2+PCJET(3)**2)
          THETA=ACOS(PCJET(3)/PTOT)
          ETA=-ALOG(TAN(THETA/2.))
          Q(LISJT+7)=PHI1
          Q(LISJT+8)=THETA
          Q(LISJT+9)=ETA
      ENDIF
      GO TO 1
C
  999 RETURN
      END
+EOD
+DECK,ISZRUN
      PROGRAM ISZRUN
C----------------------------------------------------------------
C-
C-  Sample program to histogram ISAJET events
C-  written in ZEBRA format with trivial calorimetry.
C-  User must provide subroutines ISZUSR and ISZUSD
C-  start with ISZUSR example provided with ISZRUN patch
C-
C-     SDP May,1986
C-----------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ISABNK.
+CDE,ISAUNT.
+CDE,ZEBCOM.
+CDE,QUEST.
+CDE,ITAPES.
      CHARACTER*80 FILIS
      INTEGER BEGR,ENDR,NT,NF,IOS,IXWIPE,NDUMP
C
      ITLIS=2
      PRINT 4
    4 FORMAT(' Name of file for printout?')
      READ 2,FILIS
      OPEN(UNIT=ITLIS,FILE=FILIS,STATUS='NEW',FORM='FORMATTED')
      CALL MZEBRA(0)
C
C  File to be read
      NT=0
      PRINT 1
    1 FORMAT(/'  Data file with ISAJET events?')
      READ 2,FILISA
    2 FORMAT(A)
C
C  Number of events to dump
      PRINT 6
  6   FORMAT(/' Number of events to dump? [none if 0 or less]')
      READ *,NDUMP
100   CONTINUE
      NF=0
      ISUNIT=1
      OPEN(UNIT=ISUNIT,FILE=FILISA,STATUS='OLD',FORM='UNFORMATTED')
C
C  Initialize ZEBRA
      CALL ISAZEB('I')
      CALL UCTOH('ISAB',BEGR,4,4)
      CALL UCTOH('ISAF',ENDR,4,4)
C
C  Read beginning record
      CALL FZIN(ISUNIT,IXMAIN,LISAE,1,' ',0,0)
      IF(IQ(LISAE-4).NE.BEGR) THEN   ! not an ISAJET file
        PRINT 3,IQ(LISAE-4)
    3   FORMAT('  IT IS NOT AN ISAJET FILE, FIRST BANK IS ',A4,
     $   /,'  JOB TERMINATED')
        STOP
      ENDIF
C
C  Read events
   10 IXWIPE=IXCOM+IXMAIN
      CALL MZWIPE(IXWIPE)
      CALL FZIN (ISUNIT,IXMAIN,LISAE,1,' ',0,0)
      IOS = IQUEST(1)
      IF(IOS.EQ.0) THEN     ! handle non-event record
        IF(IQ(LISAE-4).EQ.BEGR) IOS=1
        IF(IQ(LISAE-4).EQ.ENDR) IOS=2
C               Move header to run division
        IF(IOS.EQ.1) THEN
          IXWIPE=IXCOM+IXDVR
          CALL MZWIPE(IXWIPE)
          CALL MZCOPY(IXMAIN,LISAE,IXDVR,LISAB,1,' ')
        ENDIF
      ENDIF
C
      IF (IOS .LT. 0) THEN
         WRITE (ITLIS,102) IQUEST(1)
 102     FORMAT ('0Error encountered with IQUEST(1) = ',I5)
      ENDIF

      IF(IOS.EQ.0) THEN   ! this is an event record
C
        NT=NT+1
        NF=NF+1
        CALL ISZUSR(ITLIS)            ! User provided subroutine
C                                     ! see example in ISAZEB
        IF(NDUMP.GT.0) THEN
          NDUMP=NDUMP-1
          CALL PRTEVZ(ITLIS)
        ENDIF
        GOTO 10
      ENDIF
      IF(IOS.LT.3) GOTO 10
      CLOSE(ISUNIT)
      PRINT 41,NF,NT
 41   FORMAT(' No. of event on file =, 'I6,'  total = ',I7)
      NF=0
      PRINT 5
   5  FORMAT(' Next file (STOP to stop)')
      READ 2,FILISA
      IF(FILISA.NE.'STOP') GO TO 100
C
      CALL ISZUSD(ITLIS)              ! user provided subroutine
C                                     ! for end of job (entry point
C                                     ! in ISZUSR example)
      STOP
      END
+EOD
+DECK,ISZUSR                          .
      SUBROUTINE ISZUSR(PRUNIT)
C------------------------------------------------------------------------
C-                                                                      -
C-    Example of a user provided subroutine                             -
C-    to histogram ISAJET events with ZEBRA format                      -
C-    It uses ISAZEB utility subroutines to create                      -
C-    trivial calorimeter data (no depth, no shower generation)         -
C-                                                                      -
C-                                                                      -
C-   If toy calorimeter banks are not in input data they can be
C-   generated by:
C-
C-     CALL ISACFL  (unsmeared data)
C-     CALL ISMEAR  (smeared data)                                      -
C-
C-                                                                      -
C-          then to find jets with a simplified version of the UA1 jet  -
C-          algorithm with jet radius rjet and minimum scalar transverse-
C-          energy ejcut                                                -
C-            (RJET=1., EJCUT=5. for UA1)                               -
C-       need to supply also ECCUT= min. ET for cell to be added to jet -
C-          and  ETSTOP= min. ET in a cell to start a jet:              -
C-                                                                      -
C-     CALL ISZJET(RJET,EJCUT,ECCUT,ETSTOP,NJMAX,NCJET)                 -
C-                                                                      -
C-                                                                      -
C-    INPUT:                                                            -
C-    PRUNIT = unit number for listing                                  -
C-                                                                      -
C-                 SDP May, 1986                                        -
C-                                                                      -
C------------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
      INTEGER NJMAX
      PARAMETER (NJMAX=50)    ! maximum number of jets allowed
      INTEGER NCJET           ! no. of jets
+CDE,IZISP1.
+CDE,ZEBCOM.
C
C          HBOOK and other variables.
C         NWMEMO = number of words for histograms
      INTEGER NWMEMO
      PARAMETER (NWMEMO=10000)
      COMMON/PAWC/HMEMOR(NWMEMO)
      REAL HMEMOR
C
      INTEGER PRUNIT,I,IJTMX,ICLMX,IPTMX,NCLS,ID,IDV
      INTEGER LISAC,LISCL,LISP1,LISV1,LISJT,LISJS,LISAL
      REAL AN,ETMAX,PTSQ,PTSQMX,PX,PY,PTMAX,WEIGHT,ISA_WEIGHT
      REAL P(4),CSTH,SNTH,ETA,THETA,PHI,SNPHI,CSPHI,MASS
      REAL ET,EEM,EHAD,EJT,ABSETA,X,Y,Z
      REAL RJET,EJCUT,ECCUT,ETSTOP
      LOGICAL FIRST
C
C          INITIALIZE
C
      DATA FIRST/.TRUE./
      IF(FIRST) THEN
        CALL HLIMIT(-NWMEMO)
        CALL HOUTPU(PRUNIT)
        CALL HERMES(PRUNIT)
C
C          SET UP HISTOGRAMS
C
        CALL HBOOK1(1,'ET MAX CELL$',100,0.,100.,0.)
        CALL HBOOK1(2,'NO. JETS$',20,0.,20.,0.)
        CALL HBOOK1(3,'ET MAX JET$',100,0.,100.,0.)
        CALL HBOOK1(4,'PT MAX PART$',100,0.,100.,0.)
        CALL HBOOK1(5,'PT MAX LEPTON$',100,0.,100.,0.)
        FIRST=.FALSE.
      ENDIF
C
C                ANALYZE EVENTS
C
      WEIGHT=ISA_WEIGHT()
C
C        Loop over vertices and particles
C        and find particle with highest PT
C
      PTSQMX=0
      LISV1=0
C
  100 CALL GTISV1(LISV1,LISV1,IDV,P,X,Y,Z) ! loop over vertices
      IF(LISV1.GT.0) THEN
        LISP1=LISV1-IZISP1
C
  200   CALL GTISP1(LISP1,LISP1,ID,P,PHI,THETA,ETA) ! loop over particles
        IF(LISP1.GT.0) THEN
          PTSQ=P(1)**2+P(2)**2
          IF(PTSQ.GT.PTSQMX) PTSQMX=PTSQ
          GOTO 200
        ENDIF
C
        GOTO 100
      ENDIF
      PTMAX=SQRT(PTSQMX)
      CALL HFILL(4,PTMAX,0.,WEIGHT)
C
C       find lepton with highest Et
C
      PTSQMX=0
      LISAL=0
  300 CALL GTISAL(LISAL,LISAL,ID,P,PHI,THETA,ETA)
      IF(LISAL.NE.0) THEN
        PTSQ=P(1)**2+P(2)**2
        IF(PTSQ.GT.PTSQMX) PTSQMX=PTSQ
        GOTO 300
      ENDIF
      PTMAX=SQRT(PTSQMX)
      CALL HFILL(5,PTMAX,0.,WEIGHT)
C
C          find highest et cell
C
      ETMAX=0
C
C       generate smeared calorimeter data
C       will not generate new banks if they already exist
      CALL ISMEAR              ! call ISACFL instead for unsmeared data
C
      LISCL=0
  400 CALL GTISCL(LISCL,LISCL,EEM,EHAD,SNTH,CSTH,CSPHI,SNPHI,
     &  PHI,ETA)
      IF(LISCL.GT.0.) THEN
        ET=(EEM+EHAD)*SNTH
        IF(ET.GT.ETMAX) ETMAX=ET
        GOTO 400
      ENDIF
      CALL HFILL(1,ETMAX,0.,WEIGHT)
C
C           find jets
C
      DATA RJET,EJCUT,ECCUT,ETSTOP/0.7,5.0,.5,1.0/
      CALL ISZJET(RJET,EJCUT,ECCUT,ETSTOP,NJMAX,NCJET)
C
      AN=NCJET
      CALL HFILL(2,AN,0.,WEIGHT)
C
C       Find jet with maximum ET
C
      EJT=1.
      ETMAX=0.
      LISJT=0
  500 CALL GTISJT(LISJT,LISJT,EJT,P,MASS,PHI,THETA,ETA)
      IF(LISJT.NE.0) THEN
        IF(EJT.GT.ETMAX) ETMAX=EJT
        GOTO 500
      ENDIF
      CALL HFILL(3,ETMAX,0.,WEIGHT)
      RETURN
C
      ENTRY ISZUSD    ! entry point for end-of-job
      CALL HISTDO
      RETURN
      END
+EOD
+DECK,PRISAB                          .
      SUBROUTINE PRISAB(PRUNIT,LISABI,NISAB,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAB (event) bank
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISABI,NISAB,CFL and IFL ignored
C-
C-     SDP  Jan,1986
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISABI
      INTEGER NISAB,IFL,NREAC,K,BEGR
      CHARACTER CFL*(*)
      CHARACTER*8 REACTN(10)
      DATA REACTN/'(TWOJET)','(E+E-)','(DRLYAN)',
     1            '(MBIAS)','(SUSY)','(WPAIR)','(HIGGS)',
     1            ' ',' ','(GEANT)'/
C
      IF(LISAB.GT.0) THEN  ! check bank exists
        CALL UHTOC('ISAB',BEGR,4,4)
        IF(IQ(LISAB-4).NE.BEGR) RETURN  ! not begin-of-run record
C
C          Print titles
C
          WRITE(PRUNIT,100)
C
C   Print contents of bank
C
         WRITE(PRUNIT,101) IQ(LISAB+1)
         NREAC=IQ(LISAB+2)
         WRITE(PRUNIT,102) NREAC,REACTN(NREAC)
         WRITE(PRUNIT,103) IQ(LISAB+3),Q(LISAB+4)
         WRITE(PRUNIT,104) (Q(LISAB+K),K=5,22)
C
      ENDIF
      RETURN
  100 FORMAT('0',//,1X,80('-'),/,' ISAJET BEG. RUN BANK (ISAB)',/)
  101 FORMAT(/' Isajet version no.='I8)
  102 FORMAT(/' Reaction=',I3,2X,A8)
  103 FORMAT(/' NO. of events generated='I10,3X,' CM ENERGY='F12.3)
  104 FORMAT(/' PT  limits='6F15.3,/,' TH  limits='6F15.3,/,
     $ ' PHI limits='6F15.3)
      END
+EOD
+DECK,PRISAC                          .
      SUBROUTINE PRISAC(PRUNIT,LISACI,NISAC,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAC (calorimeter description) bank
C-
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISACI= bank address (not used)
C-  NISAC = bank number  (not used)
C-  CFL   = not used
C-
C-  IFL   = not used
C-
C-     SDP  May, 1986
C-
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAC.
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISACI,NISAC,IFL
      INTEGER NCPHI,NCY
      REAL DELPHI,DELY,YCMIN,YCMAX
      CHARACTER CFL*(*)
      INTEGER LISAC
C
      IF(LISAE.LE.0) RETURN
        LISAC=LQ(LISAE-IZISAC)
C
    1 IF(LISAC.GT.0) THEN
C
C   Print contents of bank
C
        NCPHI=IQ(LISAC+1)    ! number of phi cells
        NCY=IQ(LISAC+2)      !   "        y    "
        DELPHI=Q(LISAC+3)   ! phi cell size
        DELY=Q(LISAC+4)     !  y    "   "
        YCMIN=Q(LISAC+5)    ! minimum y
        YCMAX=Q(LISAC+6)    ! maximum y
        WRITE(PRUNIT,101) NCPHI,NCY,DELPHI,DELY,YCMIN,YCMAX
C
      ENDIF
C
C
      RETURN
  101 FORMAT('0',///,' Calorimeter description bank ISAC',//,
     $' Number of phi cells=',I4,10X,'Number of y cells=',I4,/,
     $' phi cell size (rad)=',F10.5,10X,'y cell size=',F10.5,/,
     $' minimum y=',F10.3,10X,'maximum y=',F10.3)
      END
+EOD
+DECK,PRISAE                          .
      SUBROUTINE PRISAE(PRUNIT,LISAEI,NISAE,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAE (event) bank
C-
C-  INPUT:
C-  PRUNIT = unit number for printout
C-  LISAEI,NISAE,CFL and IFL ignored
C-
C-     SDP  Jan,1986
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISAEI
      INTEGER NISAE,IFL
      CHARACTER CFL*(*)
      INTEGER ID1,ID2,IEVT,NREAC,NJT,NQS,NPJET,NPART,NVERTX,NLEP
      REAL SIGF,WT,QSQ,SHAT,THAT,UHAT
      DOUBLE PRECISION DSEED
      REAL    SSEED(2)
      EQUIVALENCE(DSEED,SSEED(1))
      CHARACTER*8 REACTN(10)
      DATA REACTN/'(TWOJET)','(E+E-)','(DRLYAN)',
     1            '(MBIAS)','(SUSY)','(WPAIR)','(HIGGS)',
     1            '(PHOTON)',' ','(GEANT)'/
C
      IF ( LISAE.GT.0 ) THEN
C
C          Print titles
C
        WRITE(PRUNIT,100)
C
C   Print contents of bank
C
        ID1 = IQ(LISAE+1)
        ID2 = IQ(LISAE+2)
        IEVT = IQ(LISAE+3)
        NREAC = IQ(LISAE+4)
        NJT = IQ(LISAE+5)
        NQS = IQ(LISAE+6)
        NPJET = IQ(LISAE+7)
        NPART = IQ(LISAE+8)
        NVERTX = IQ(LISAE+9)
        NLEP = IQ(LISAE+10)
        SIGF = Q(LISAE+11)
        WT = Q(LISAE+12)
        QSQ = Q(LISAE+13)
        SHAT = Q(LISAE+14)
        THAT = Q(LISAE+15)
        UHAT = Q(LISAE+16)
        SSEED(1)=Q(LISAE+17)
        SSEED(2)=Q(LISAE+18)
        WRITE(PRUNIT,101) NREAC,REACTN(NREAC)
        WRITE(PRUNIT,105) DSEED
        WRITE(PRUNIT,102) ID1,ID2,IEVT
        WRITE(PRUNIT,103) NJT,NQS,NPJET,NPART,NVERTX,NLEP
        WRITE(PRUNIT,104) SIGF,WT,QSQ,SHAT,THAT,UHAT
C
      ENDIF
      RETURN
  100 FORMAT('0',//,1X,80('-'),/,' ISAJET EVENT BANK (ISAE)',/)
  101 FORMAT(/' Reaction = ',I3,2X,A8)
  102 FORMAT(' EVENT ID = ',I10,'-'I10,4X,'EVENT NUMBER = ',I10)
  103 FORMAT(3X,'NISAJ   NISAQ   NPJET   NISP1   NISV1   NISAL',/,7I8)
  104 FORMAT(5X,'SIGMA',6X,'WEIGHT',8X,'Q**2',8X,'SHAT',8X,'THAT',
     $  8X,'UHAT',/,6E12.4)
  105 FORMAT(/,' SEED=',E24.15,/)
      END
+EOD
+DECK,PRISAF                          .
      SUBROUTINE PRISAF(PRUNIT,LISAFI,NISAF,CFL,IFL)
C-------------------------------------------------------------------
C-                                                                 -
C-  Print out for ISAF, end of run bank                            -
C-                                                                 -
C-  INPUT:                                                         -
C-  PRUNIT= unit number for printout                               -
C-  LISAFI,NISAF,CFL and IFL ignored                               -
C-                                                                 -
C-     SDP  Dec,1986                                               -
C-                                                                 -
C-------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAF.
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISAFI,LISAF
      INTEGER NISAF,IFL,ENDR
      CHARACTER CFL*(*)
C
      LISAF=LISAE
      IF(LISAF.GT.0) THEN   ! check bank exists
        CALL UHTOC('ISAF',ENDR,4,4)
        IF(IQ(LISAF-4).NE.ENDR) RETURN  ! not end-of-run record
C
C          Print titles
C
          WRITE(PRUNIT,100)
C
C   Print contents of bank
C
         WRITE(PRUNIT,101) IQ(LISAF+1),IQ(LISAF+2)
         WRITE(PRUNIT,102) Q(LISAF+3),Q(LISAF+4)
C
      ENDIF
      RETURN
  100 FORMAT('0',//,1X,80('-'),/,' ISAJET END RUN BANK (ISAF)',/)
  101 FORMAT(/,'  no. of events for this run=',I8,/,
     $         '  no. of events requested   =',I8)
  102 FORMAT(/,'  cross section (microbarns)=',E15.4,/,
     $         '       final weight         =',E15.4)
      END
+EOD
+DECK,PRISAJ                          .
      SUBROUTINE PRISAJ(PRUNIT,LISAJI,NISAJ,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAJ (parton) bank
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISAJI= bank address
C-  NISAJ = bank number
C-  CFL   = flag to control printout
C-          'ALL' for all banks, 'LINEAR' for one linear structure
C-          'ONE' for one bank only
C-          LISAJI must be provided for 'LINEAR',
C-          LISAJI or NISAJ may be provided for 'ONE',
C-          LISAJI and NISAJ ignored for 'ALL'
C-  IFL   = 0  print everything
C-          1  print only 4-momenta and mass
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISAJ,GZISAJ
      INTEGER PRUNIT,LISAJI,NISAJ,IFL
      INTEGER K,K1,K2,NJ
      CHARACTER*8 NAME,LABEL
C
      LISAJ=LISAJI
      IF(CFL.EQ.'ALL') THEN
        LISAJ=GZISAJ()
      ENDIF
C
      IF(CFL.EQ.'ONE') THEN
        IF(LISAJ.LE.0) LISAJ=LZLOC(IXMAIN,'ISAJ',NISAJ)
      ENDIF
C
C          Print titles
C
      WRITE(PRUNIT,100)
C
    1 IF(LISAJ.GT.0) THEN
C
C   Print contents of bank
C
        NJ=IQ(LISAJ-5)
        K1=LISAJ+2
        K2=LISAJ+9
        IF(IFL.EQ.1) K2=LISAJ+6
        NAME=LABEL(IQ(LISAJ+1))
        WRITE(PRUNIT,101) NJ,NAME,(Q(K),K=K1,K2)
C
        IF(CFL.NE.'ONE') THEN
          LISAJ=LQ(LISAJ)
          GOTO 1
        ENDIF
C
      ENDIF
      RETURN
  100 FORMAT('0',///,' JET BANKS (ISAJ)',/,
     1 ' NO.  NAME ',10X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 ,6X,'MASS',7X,'PHI',5X,'THETA',7X,'ETA')
  101 FORMAT(I4,2X,A8,2X,5F10.3,3F10.4)
      END
+EOD
+DECK,PRISAL                          .
      SUBROUTINE PRISAL(PRUNIT,LISALI,NISAL,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAL (particle) bank
C-
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISALI= bank address
C-  NISAL = bank number
C-  CFL   = flag to control printout
C-          'ALL' for all banks, 'LINEAR' for one linear structure
C-          'ONE' for one bank only
C-          LISALI must be provided for 'LINEAR',
C-          LISALI or NISAL may be provided for 'ONE',
C-          LISALI and NISAL ignored for 'ALL'
C-  IFL   = not used
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISALI,NISAL,IFL
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISP1,LISAL,GZISAL
      INTEGER LISAQ,LISAJ
      INTEGER NP,NV,NQ,NJ,K,K1,K2,IOR
      CHARACTER*8 NAME,LABEL
C
      LISAL=LISALI
C
C          Print titles
C
        WRITE(PRUNIT,100)
C
      IF(CFL.EQ.'ONE') THEN
        IF(LISAL.LE.0.AND.NISAL.GT.0) LISAL=LZLOC(IXMAIN,'ISAL',NISAL)
      ENDIF
C
      IF(CFL.EQ.'ALL') THEN
        LISAL=GZISAL()
      ENDIF
C
    1 IF(LISAL.GT.0) THEN
C
C          find the parent jet, parton and particle
        NJ=0
        NQ=0
        NP=0
        LISAQ=LQ(LISAL-2)
        LISAJ=LQ(LISAL-3)
        LISP1=LQ(LISAL-1)
        IF(LISAJ.GT.0) NJ=IQ(LISAJ-5)
        IF(LISAQ.GT.0) NQ=IQ(LISAQ-5)
        IF(LISP1.GT.0) NP=IQ(LISP1-5)
C
C   Print contents of bank
C
        K1=LISAL+2
        K2=LISAL+9
        NAME=LABEL(IQ(LISAL+1))
        WRITE(PRUNIT,101) NP,NAME(1:4),NJ,NQ,(Q(K),K=K1,K2)
C
        IF(CFL.NE.'ONE') THEN  ! find next bank in linear structure
          LISAL=LQ(LISAL)
          GOTO 1
        ENDIF
C
      ENDIF
C
C
      RETURN
  100 FORMAT('0',/,' LEPTON BANKS (ISAL)',/,
     1 '  NO. NAME   JET# PAR#',6X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 ,6X,'MASS',7X,'PHI',5X,'THETA',7X,'ETA')
  101 FORMAT(I4,2X,A4,1X,2I5,2X,5F10.3,3F10.4)
      END
+EOD
+DECK,PRISAM                          .
      SUBROUTINE PRISAM(PRUNIT,LISAMI,NISAM,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAM (particle) bank
C-
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISAMI= bank address
C-  NISAM = bank number
C-  CFL   = flag to control printout
C-          'ALL' for all banks, 'LINEAR' for one linear structure
C-          'ONE' for one bank only
C-          LISAMI must be provided for 'LINEAR',
C-          LISAMI or NISAM may be provided for 'ONE',
C-          LISAMI and NISAM ignored for 'ALL'
C-  IFL   = not used
C-
C-     DH 10-1990
C-
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAM.
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISAMI,NISAM,IFL
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISP1,LISAM
      INTEGER LISAQ,LISAJ
      INTEGER NP,NV,NQ,NJ,K,K1,K2,IOR
      CHARACTER*8 NAME,LABEL
C
      LISAM=LISAMI
C
C          Print titles
C
        WRITE(PRUNIT,100)
C
      IF(CFL.EQ.'ONE') THEN
        IF(LISAM.LE.0.AND.NISAM.GT.0) LISAM=LZLOC(IXMAIN,'ISAM',NISAM)
      ENDIF
C
      IF(CFL.EQ.'ALL') THEN
        LISAM=LQ(LISAE-IZISAM)
      ENDIF
C
    1 IF(LISAM.GT.0) THEN
C
C          find the parent jet, parton and particle
        NJ=0
        NQ=0
        NP=0
        LISAQ=LQ(LISAM-2)
        LISAJ=LQ(LISAM-3)
        LISP1=LQ(LISAM-1)
        IF(LISAJ.GT.0) NJ=IQ(LISAJ-5)
        IF(LISAQ.GT.0) NQ=IQ(LISAQ-5)
        IF(LISP1.GT.0) NP=IQ(LISP1-5)
C
C   Print contents of bank
C
        K1=LISAM+5
        K2=LISAM+11
        NAME=LABEL(IQ(LISAM+1))
        WRITE(PRUNIT,101) NP,NAME(1:4),NJ,NQ,IQ(LISAM+2),
     A  IQ(LISAM+3),(Q(K),K=K1,K2)
C
        IF(CFL.NE.'ONE') THEN  ! find next bank in linear structure
          LISAM=LQ(LISAM)
          GOTO 1
        ENDIF
C
      ENDIF
C
C
      RETURN
  100 FORMAT('0',/,' LEPTON BANKS (ISAM)',/,
     1 '  NO. NAME   JET# PAR# SRCE TRIG',6X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 ,7X,'PHI',5X,'THETA',7X,'ETA')
  101 FORMAT(I4,2X,A4,1X,4I5,2X,4F10.3,3F10.4)
      END
+EOD
+DECK,PRISAQ                          .
      SUBROUTINE PRISAQ(PRUNIT,LISAQI,NISAQ,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISAQ (parton) bank
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISAQI= bank address
C-  NISAQ = bank number
C-  CFL   = flag to control printout
C-          'ALL' for all banks, 'LINEAR' for one linear structure
C-          'ONE' for one bank only
C-          LISAQI must be provided for 'LINEAR',
C-          LISAQI or NISAQ may be provided for 'ONE',
C-          LISAQI and NISAQ ignored for 'ALL'
C-  IFL   = 0  print everything
C-          1  print only 4-momenta and mass
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      INTEGER PRUNIT,LISAQI,NISAQ,IFL
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISAQ,GZISAQ
      INTEGER NQ,NJ,NPJ,K,K1,K2
      CHARACTER*8 NAME,LABEL
C
      LISAQ=LISAQI
      IF(CFL.EQ.'ONE') THEN
        IF(LISAQ.EQ.0) THEN
          IF(NISAQ.EQ.0) GOTO 98      ! error exit
          LISAQ=LZLOC(IXMAIN,'ISAQ',NISAQ)
        ENDIF
      ENDIF
C
      IF(CFL.EQ.'ALL') THEN
        LISAQ=GZISAQ()   ! find pointer to first bank
      ENDIF
C
C        print title
C
      IF(IFL.EQ.0) WRITE (PRUNIT,100)
      IF(IFL.NE.0) WRITE (PRUNIT,101)
C
    1 IF(LISAQ.GT.0) THEN
C
C
C ****  find parent (ISAJ) jet
C
        NJ=LQ(LISAQ-1)
        IF(NJ.NE.0) NJ=IQ(NJ-5)
C
C ****  find associated PJET if PJET links exists
C
        NPJ = 0
        IF( IQ(LISAQ-3) .GT. 1) THEN
          NPJ=LQ(LISAQ-2)
          IF(NPJ.NE.0) NPJ=IQ(NPJ-5)
        END IF
C
C   Print contents of bank
C
        NQ=IQ(LISAQ-5)
        K1=LISAQ+2
        K2=LISAQ+9
        IF(IFL.NE.0) K2=LISAQ+6
        NAME=LABEL(IQ(LISAQ+1))
        WRITE(PRUNIT,102) NQ,NAME(1:4),NJ,NPJ,(Q(K),K=K1,K2)
C
        IF(CFL.NE.'ONE') THEN
          LISAQ=LQ(LISAQ)               ! pointer to next bank
          GOTO 1
        ENDIF
C
      ENDIF
C
      RETURN
   98 PRINT 111,LISAQ,NISAQ
      RETURN
   99 PRINT 112,LISAQ
      RETURN
  100 FORMAT('0',///,' PARTON BANKS (ISAQ)',/,
     1 ' NO.  NAME  JET   PJET',5X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 6X,'MASS',7X,'PHI',5X,'THETA',7X,'ETA')
  101 FORMAT('0',///,' PARTON BANKS (ISAQ)',/,
     1 ' NO.  NAME   JET  PJET',5X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 6X,'MASS')
  102 FORMAT(I3,4X,A4,2I4,5F10.3,3F10.4)
  111 FORMAT('0',//,'  FOR A SINGLE BANK PRINTOUT OF ISAQ YOU MUST',
     1 ' DEFINE POINTER OR BANK NUMBER',/,' THEY ARE NOW SET TO',2I10)
  112 FORMAT('0',//,' FOR PRINTOUT OF LINEAR ARRAY OF ISAQ',
     1 ' YOU MUST DEFINE POINTER',/,' IT IS NOW SET TO',I10)
      END
+EOD
+DECK,PRISCL                          .
      SUBROUTINE PRISCL(PRUNIT,LISCLI,NISCL,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISCL (parton) bank
C-
C-  INPUT:
C-  PRUNIT= unit number for printout
C-  LISCLI= bank address
C-  NISCL = bank number
C-  CFL   = flag to control printout
C-          'ALL' for all banks, 'LINEAR' for one linear structure
C-          'ONE' for one bank only
C-          LISCLI must be provided for 'LINEAR',
C-          LISCLI or NISCL may be provided for 'ONE',
C-          LISCLI and NISCL ignored for 'ALL'
C-  IFL   = 0  print everything
C-          1  print only indices, no. of hadrons and gammas,
C-             e.m. and hadronic energy
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAC.
+CDE,IZISCL.
+CDE,ZEBCOM.
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISAC,LISCL
      INTEGER PRUNIT,LISCLI,NISCL,IFL
      INTEGER K,K1,K2,IETA,IPHI,NCH,NG,NCELLS
C
      LISCL=LISCLI
      IF(CFL.EQ.'ALL') THEN
        LISAC=LQ(LISAE-IZISAC)
        LISCL=LQ(LISAC-IZISCL)
      ENDIF
C
      IF(CFL.EQ.'ONE') THEN
        IF(LISCL.LE.0) LISCL=LZLOC(IXMAIN,'ISCL',NISCL)
      ENDIF
C
C          Print titles
C
      IF(IFL.EQ.0) WRITE(PRUNIT,100)
      IF(IFL.EQ.1) WRITE(PRUNIT,101)
      NCELLS=0
C
    1 IF(LISCL.GT.0) THEN
C
C   Print contents of bank
C
        NCELLS=NCELLS+1
        IF(NCELLS.EQ.100) THEN
          NCELLS=0
          WRITE(PRUNIT,103)   ! print header
        ENDIF
        IPHI=IQ(LISCL+1)/10000
        IETA=MOD(IQ(LISCL+1),10000)
        NCH=IQ(LISCL+2)/10000
        NG=MOD(IQ(LISCL+2),10000)
        K1=LISCL+3
        K2=LISCL+10
        IF(IFL.EQ.1) K2=LISCL+4
        WRITE(PRUNIT,102) IETA,IPHI,NCH,NG,(Q(K),K=K1,K2)
C
        IF(CFL.NE.'ONE') THEN
          LISCL=LQ(LISCL)
          GOTO 1
        ENDIF
C
      ENDIF
      RETURN
  100 FORMAT('0',///,' PSEUDOCALORIMETER BANKS (ISCL)',/,
     $ ' IETA IPHI    NCH  NG',7X,'EEM',6X,'EHAD'
     $ ,6X,'SINT',6X,'COST',6X,'SINP',6X,'COSP',7X,'PHI',7X,'ETA')
  101 FORMAT('0',///,' PSEUDOCALORIMETER BANKS (ISCL)',/,
     $ ' IETA IPHI    NCH  NG',7X,'EEM',6X,'EHAD')
  103 FORMAT('0',/,' IETA IPHI    NCH  NG',7X,'EEM',6X,'EHAD'
     $ ,6X,'SINT',6X,'COST',6X,'SINP',6X,'COSP',7X,'PHI',7X,'ETA')
  102 FORMAT(2I5,2X,2I5,2X,2F10.3,6F10.4)
      END
+EOD
+DECK,PRISCM                          .
      SUBROUTINE PRISCM ( PRUNIT, LISCM, NISCM, CFL, IFL )
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Print on unit PRUNIT the content of one or more
C-              banks 'ISCM'.
C-
C-   Inputs  : PRUNIT [I] : Unit number for printout
C-             LISCM  [I] : Pointer to the one bank ( CFL = 'ONE' ) or to the
C-                          first of a linear structure ( CFL = 'LINEAR' ).
C-                          Unused if CFL = 'ALL'.
C-             NISCM  [I] : Bank number, used only if CFL='ONE' and LISCM = 0
C-             CFL    [C*]: Character flag, other input depends on it's value:
C-                          'ONE' : LISCM point to a bank, or if <0, NISCM is
C-                                  the bank number.
C-                          'LINEAR' : LISCM points to the first bank of the
C-                                  Linear structure
C-                          'ALL' : Prints all banks
C-             IFL    [I] : Defines the amount of printing: 0 means full
C-                          printout, 1 is the minimum, 2 gives more, ...
C-   Outputs : on unit PRUNIT
C-   Controls: none
C-
C-   Created  13-DEC-1989 10:20:16.28  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ZEBCOM.
+CDE,IZISCM.
+CDE,IZISAB.
C
      INTEGER PRUNIT, LISCM, NISCM, IFL
      CHARACTER*(*) CFL
      CHARACTER LINE*80,STRING*4,CR*1
      INTEGER N
      INTEGER LISCM1, GZISCM, LZLOC, J
C----------------------------------------------------------------------
      LISCM1 = LISCM
      CR = CHAR(13)
      IF( CFL .EQ. 'LINEAR' ) THEN
        IF( LISCM .LE. 0 ) GOTO 990
      ELSEIF( CFL .EQ. 'ONE' ) THEN
        IF( LISCM .LE. 0 ) THEN
          IF( NISCM .EQ. 0 ) GOTO 980          ! Error exit
          LISCM1 = LZLOC( IXMAIN, 'ISCM', NISCM )
        ENDIF
      ELSEIF( CFL .EQ. 'ALL' ) THEN
C
C ****  Here, you have to find the first bank to be printed
C
        LISCM1 = GZISCM( )
      ELSE
        WRITE( PRUNIT, 1000 ) CFL
1000    FORMAT(/' ** PRISCM ** Illegal value of CFL = ',a/)
        GOTO 999
      ENDIF
    1 CONTINUE
C
C  ***  Print the content of the bank pointed by LISCM1
C
      LINE = ' '
      N = 0
      WRITE( PRUNIT, 1200 )
      DO   J = 1, IQ( LISCM1-1)
        CALL UHTOC ( IQ( LISCM1 + J ),4,STRING,4)
        IF (N.GT.0) THEN
          LINE(1:N+4)  = LINE(1:N)//STRING(1:4)
        ELSE
          LINE(1:4)  = STRING(1:4)
        END IF
        IF (INDEX(STRING,CR ) .GT. 0 ) THEN
          WRITE( PRUNIT, 1100 ) LINE
          LINE = ' '
          N = 0
        ELSE
          N = N + 4
        END IF
      END DO
 1200 FORMAT(/' ISAJET COMMAND FILE       ** ISCM  BANK ** ',/1X)
 1100 FORMAT(A80)
C
C  ***  Look if another bank is needed
C
      IF( CFL .EQ. 'ONE' ) GOTO 999
      IF( CFL .EQ. 'LINEAR' ) THEN
        LISCM1 = LQ( LISCM1 )
        IF( LISCM1 .NE. 0 ) GOTO 1
      ELSE
C
C ****  Find the next bank for the ALL command.
C
        LISCM1 = GZISCM()
      ENDIF
  999 RETURN
C
C  *** Error : Linear without bank pointer
C
  990 WRITE( PRUNIT, 2000 ) LISCM
 2000 FORMAT(/' ** PRISCM ** called for LINEAR without valid bank '
     &        'pointer, LISCM =',I10/)
      GOTO 999
C
C  *** Error : One bank, but neither pointer nor number
C
  980 WRITE( PRUNIT, 2100 ) LISCM, NISCM
 2100 FORMAT(/'  ** PRISCM ** called for ONE without bank pointer and '
     &        'bank number, LISCM =',I10,' NISCM =', I10/)
      GOTO 999
      END
+EOD
+DECK,PRISJT                          .
      SUBROUTINE PRISJT ( PRUNIT, LISJT, NISJT, CFL, IFL )
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Print on unit PRUNIT the content of one or more
C-              banks 'ISJT'.
C-
C-   Inputs  : PRUNIT [I] : Unit number for printout
C-             LISJT  [I] : Pointer to the one bank ( CFL = 'ONE' ) or to the
C-                          first of a linear structure ( CFL = 'LINEAR' ).
C-                          Unused if CFL = 'ALL'.
C-             NISJT  [I] : Bank number, used only if CFL='ONE' and LISJT = 0
C-             CFL    [C*]: Character flag, other input depends on it's value:
C-                          'ONE' : LISJT point to a bank, or if <0, NISJT is
C-                                  the bank number.
C-                          'LINEAR' : LISJT points to the first bank of the
C-                                  Linear structure
C-                          'ALL' : Prints all banks
C-             IFL    [I] : Defines the amount of printing: not used
C-
C-   Outputs : on unit PRUNIT
C-   Controls: none
C-
C-   Created  21-JULY-1989  Serban Protopopescu
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ZEBCOM.
C
      INTEGER PRUNIT, LISJT, NISJT, IFL
      CHARACTER*(*) CFL
      INTEGER LISJT1, GZISJT, LZLOC, J,LSUP,NJET,ND
C----------------------------------------------------------------------
C
      LISJT1 = LISJT
      IF( CFL .EQ. 'LINEAR' ) THEN
        IF( LISJT .LE. 0 ) GOTO 990
C
      ELSEIF( CFL .EQ. 'ONE' ) THEN
        IF( LISJT .LE. 0 ) THEN
          IF( NISJT .EQ. 0 ) GOTO 980          ! Error exit
          LISJT1 = LZLOC( IXMAIN, 'ISJT', NISJT )
        ENDIF
C
      ELSEIF( CFL .EQ. 'ALL' ) THEN
        LISJT1=GZISJT()
        IF ( LISJT1.LE.0 ) THEN
          WRITE(PRUNIT,981)
          GOTO 999                    ! no banks
        ENDIF
      ELSE
        WRITE( PRUNIT, 1000 ) CFL
1000    FORMAT(/' ** PRISJT ** Illegal value of CFL = ',a/)
        GOTO 999
      ENDIF
      WRITE( PRUNIT, 1101 ) ' No. ',' ET ',' Px ',' Py ',' Pz ',' E ',
     &  ' Mass ',' Phi ',' Theta ',' Eta '
    1 CONTINUE
C
C  ***  Print the content of the bank pointed by LISJT1
C
      IF(LISJT1.EQ.0) GOTO 999
      NJET=IQ(LISJT1-5)
      ND=IQ(LISJT1-1)
      WRITE( PRUNIT, 1100 ) NJET,(Q( LISJT1 + J ) , J = 1, ND)
C
C  ***  Look if another bank is needed
C
      IF( CFL .EQ. 'ONE' ) GOTO 999
      IF( CFL .EQ. 'LINEAR'.OR.CFL.EQ.'ALL' ) THEN
        LISJT1 = LQ( LISJT1 )
        IF( LISJT1 .NE. 0 ) GOTO 1
      ELSE
      ENDIF
  999 RETURN
C
C  *** Error : Linear without bank pointer
C
  990 WRITE( PRUNIT, 2000 ) LISJT
 2000 FORMAT(/' ** PRISJT ** called for LINEAR without valid bank '
     &        'pointer, LISJT =',I10/)
      GOTO 999
C
C  *** Error : One bank, but neither pointer nor number
C
  980 WRITE( PRUNIT, 2100 ) LISJT, NISJT
 2100 FORMAT(/'  ** PRISJT ** called for ONE without bank pointer and '
     &        'bank number, LISJT =',I10,' NISJT =', I10/)
      GOTO 999
  981 FORMAT(/' ** PRISJT ** no ISJT banks'/)
 1101 FORMAT(/'ISAJET TOY CALORIMETER JETS (ISJT)',
     &  /A5,1X,9A8,2A4,1X,A8)
 1100 FORMAT(I3,3X,9F8.2)
      END
+EOD
+DECK,PRISP1                          .
      SUBROUTINE PRISP1(PRUNIT,LISP1I,NISP1,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISP1 (particle) bank
C-
C-
C-  INPUT:
C-  PRUNIT = unit number for printout
C-  LISP1I = bank address
C-  NISP1  = bank number
C-  CFL    = flag to control printout
C-           'ALL' for all banks, 'LINEAR' for one linear structure
C-           'ONE' for one bank only
C-            LISP1I must be provided for 'LINEAR',
C-            LISP1I or NISP1 may be provided for 'ONE',
C-            LISP1I and NISP1 ignored for 'ALL'
C-  IFL    = not used
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISP1.
      INTEGER PRUNIT,LISP1I,NISP1,IFL
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISV1,LISP1,GZISV1,GZISP1
      INTEGER LISAQ,LISAJ,IDAUV
      INTEGER NP,NV,NQ,NJ,K,K1,K2,IOR
      CHARACTER*8 NAME,LABEL
C
      LISP1 = LISP1I
C
C          Print titles
C
      WRITE(PRUNIT,100)
C
      IF ( CFL.EQ.'ONE' ) THEN
        IF ( LISP1.LE.0 .AND. NISP1.GT.0 )
     &     LISP1 = LZLOC(IXMAIN,'ISP1',NISP1)
      ENDIF
C
      IF ( CFL.EQ.'ALL' ) THEN
        LISV1=GZISV1()
        IF ( LISV1.LE.0 ) RETURN
        LISP1=LQ(LISV1-IZISP1)
      ENDIF
C
    1 IF ( LISP1.GT.0 ) THEN
C
C          find the parent jet and parton
        NJ = 0
        NQ = 0
        LISAQ = LQ(LISP1-2)
        LISAJ = LQ(LISP1-3)
        IF ( LISAJ.GT.0 ) NJ = IQ(LISAJ-5)
        IF ( LISAQ.GT.0 ) NQ = IQ(LISAQ-5)
C
C               find daughter vertex
        IDAUV = LQ(LISP1-4)
        IF ( IDAUV.GT.0 ) IDAUV = IQ(IDAUV-5)
C
C          find the supporting vertex
        IOR = LQ(LISP1+1)
        NV = IQ(IOR-5)
C
C   Print contents of bank
C
        NP = IQ(LISP1-5)
        K1 = LISP1+2
        K2 = LISP1+9
        NAME = LABEL(IQ(LISP1+1))
        WRITE(PRUNIT,101) NP,NAME(1:4),NV,NJ,NQ,IDAUV,(Q(K),K=K1,K2)
C
        IF ( CFL.NE.'ONE' ) THEN  ! FIND NEXT BANK IN LINEAR STRUCTURE
          LISP1 = LQ(LISP1)
          GOTO 1
        ENDIF
C
      ENDIF
C
      IF ( CFL.EQ.'ALL' ) THEN    ! FIND NEXT VERTEX
        LISV1 = LQ(LISV1)
        IF ( LISV1.GT.0 ) THEN
          LISP1 = LQ(LISV1-IZISP1)
          GOTO 1
        ENDIF
      ENDIF
C
      RETURN
  100 FORMAT('0',/,' PARTICLE BANKS (ISP1)',/,
     1 '  NO. NAME   VTX# JET# PAR# DAUV',7X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 ,6X,'MASS',7X,'PHI',5X,'THETA',7X,'ETA')
  101 FORMAT(I4,2X,A4,2X,4I5,2X,5F10.3,3F10.4)
      END
+EOD
+DECK,PRISP2                          .
      SUBROUTINE PRISP2(PRUNIT,LISP2I,NISP2,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISP2 (particle) bank
C-
C-
C-  INPUT:
C-  PRUNIT = unit number for printout
C-  LISP2I = bank address
C-  NISP2  = bank number
C-  CFL    = flag to control printout
C-           'ALL' for all banks, 'LINEAR' for one linear structure
C-           'ONE' for one bank only
C-            LISP2I must be provided for 'LINEAR',
C-            LISP2I or NISP2 may be provided for 'ONE',
C-            LISP2I and NISP2 ignored for 'ALL'
C-  IFL    = not used
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-     SK   Apr,1986 , modified from SDP's PRISP1
C-
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISV2.
+CDE,IZISP2.
      INTEGER PRUNIT,LISP2I,NISP2,IFL
      CHARACTER CFL*(*)
      INTEGER LZLOC,LISV2,LISP2
      INTEGER LISAQ,LISAJ,IDAUV
      INTEGER NP,NV,K,K1,K2,IOR
      CHARACTER*8 NAME,LABEL
C
      LISP2 = LISP2I
C
C          Print titles
C
      WRITE(PRUNIT,100)
C
      IF ( CFL.EQ.'ONE' ) THEN
        IF ( LISP2.LE.0 .AND. NISP2.GT.0 )
     &     LISP2 = LZLOC(IXMAIN,'ISP2',NISP2)
      ENDIF
C
      IF ( CFL.EQ.'ALL' ) THEN
        IF ( LISAE.NE.0 ) LISV2 = LQ(LISAE-IZISV2)
        IF ( LISV2.NE.0 ) LISP2 = LQ(LISV2-IZISP2)
        IF ( LISAE.LE.0 .OR. LISV2.LE.0 ) RETURN
      ENDIF
C
    1 IF ( LISP2.GT.0 ) THEN
C
C               find daughter vertex
        IDAUV = LQ(LISP2-4)
        IF ( IDAUV.GT.0 ) IDAUV = IQ(IDAUV-5)
C          find the supporting vertex
        IOR = LQ(LISP2+1)
        NV = IQ(IOR-5)
C
C   Print contents of bank
C
        NP = IQ(LISP2-5)
        K1 = LISP2+2
        K2 = LISP2+9
        NAME = LABEL(IQ(LISP2+1))
        WRITE(PRUNIT,101) NP,NAME(1:4),NV,IDAUV,(Q(K),K=K1,K2)
C
        IF ( CFL.NE.'ONE' ) THEN  ! FIND NEXT BANK IN LINEAR STRUCTURE
          LISP2 = LQ(LISP2)
          GOTO 1
        ENDIF
C
      ENDIF
C
      IF ( CFL.EQ.'ALL' ) THEN    ! FIND NEXT VERTEX
        LISV2 = LQ(LISV2)
        IF ( LISV2.GT.0 ) THEN
          LISP2 = LQ(LISV2-IZISP2)
          GOTO 1
        ENDIF
      ENDIF
C
      RETURN
  100 FORMAT(/' PARTICLE BANKS (ISP2)'/
     1 '  NO. NAME   VTX# DAUV',7X,'PX',8X,'PY',8X,'PZ',9X,'E'
     2 ,6X,'MASS',7X,'PHI',5X,'THETA',7X,'ETA')
  101 FORMAT(I4,2X,A4,2X,2I5,2X,5F10.3,3F10.4)
      END
+EOD
+DECK,PRISP3                          .
      SUBROUTINE PRISP3(PRUNIT,LISP3I,NISP3,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISP3 (parton) bank
C-
C-  INPUT:
C-  PRUNIT = unit number for printout
C-  LISP3I = bank address
C-  NISP3  = bank number
C-  CFL    = flag to control printout
C-           'ALL' for all banks, 'LINEAR' for one linear structure
C-           'ONE' for one bank only
C-            LISP3I must be provided for 'LINEAR',
C-            LISP3I or NISP3 may be provided for 'ONE',
C-            LISP3I and NISP3 ignored for 'ALL'
C-  IFL    = not used
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-     SK   Apr,1986   Modified from SDP's PRISV1.
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISP3.
      CHARACTER CFL*(*)
      INTEGER LZLOC,IDAUV
      INTEGER PRUNIT,LISP3I,NISP3,IFL
      INTEGER NV,K,K1,K2,K3,IORV,IORP,LISP3
      CHARACTER*8 NAME,LABEL
C
C          Print titles
C
      WRITE(PRUNIT,100)
C
      LISP3 = LISP3I
      IF ( CFL.EQ.'ALL' ) THEN
        LISP3 = LQ(LISAE-IZISP3)
      ENDIF
C
    1 IF ( LISP3.GT.0 ) THEN
C
C       find parent vertex
        IORV = 0
        IF ( LQ(LISP3-2).NE.0 ) IORV = IQ(LQ(LISP3-2)-5)
        IORP = 0
        IF ( LQ(LISP3-3).NE.0 ) IORP = IQ(LQ(LISP3-3)-5)
C
C               find daughter vertex
        IDAUV = LQ(LISP3-4)
        IF ( IDAUV.GT.0 ) IDAUV = IQ(IDAUV-5)
C
C   Print contents of bank
C
        NV = IQ(LISP3-5)
        K1 = LISP3+2
        K2 = LISP3+9
        K3 = LISP3+10
        NAME = LABEL(IQ(LISP3+1))
        WRITE(PRUNIT,101) NV,NAME(1:4),IORV,IORP,IDAUV,(Q(K),K=K1,K2),
     &    IQ(K3)
C
        IF ( CFL.NE.'ONE' ) THEN
          LISP3 = LQ(LISP3)
          GOTO 1
        ENDIF
C
      ENDIF
C
      RETURN
  100 FORMAT(//' PARTICLE BANK (ISP3)'/
     1 ' NO.  NAME IORV IORP DAUV'
     2 ,7X,'PX',8X,'PY',8X,'PZ',9X,'E',6X,'MASS'
     2 ,8X,'X',9X,'Y',9X,'Z',5X,'TRK TYPE')
  101 FORMAT(I4,2X,A4,3I5,2X,5F10.3,3F10.4,3X,I5)
      END
+EOD
+DECK,PRISV1                          .
      SUBROUTINE PRISV1(PRUNIT,LISV1I,NISV1,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISV1 (parton) bank
C-
C-  INPUT:
C-  PRUNIT = unit number for printout
C-  LISV1I = bank address
C-  NISV1  = bank number
C-  CFL    = flag to control printout
C-           'ALL' for all banks, 'LINEAR' for one linear structure
C-           'ONE' for one bank only
C-            LISV1I must be provided for 'LINEAR',
C-            LISV1I or NISV1 may be provided for 'ONE',
C-            LISV1I and NISV1 ignored for 'ALL'
C-  IFL    = not used
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
      CHARACTER CFL*(*)
      INTEGER LZLOC,GZISV1
      INTEGER PRUNIT,LISV1I,NISV1,IFL
      INTEGER NV,K,K1,K2,IORIV,K3,K4,LISV1
      CHARACTER*8 NAME,LABEL
C
C          Print titles
C
      WRITE(PRUNIT,100)
C
      LISV1 = LISV1I
      IF ( CFL.EQ.'ONE' ) THEN
        IF ( LISV1.LE.0 .AND. NISV1.GT.0 )
     &    LISV1 = LZLOC(IXMAIN,'ISV1',NISV1)
      ENDIF
      IF ( CFL.EQ.'ALL' ) THEN
        LISV1 = GZISV1()
      ENDIF
C
    1 IF ( LISV1.GT.0 ) THEN
C
C       find parent vertex
        IORIV = LQ(LISV1-2)
        IF ( IORIV.NE.0 ) IORIV = IQ(IORIV-5)
C
C   Print contents of bank
C
        NV = IQ(LISV1-5)
        K1 = LISV1+2
        K2 = LISV1+9
        NAME = LABEL(IQ(LISV1+1))
        WRITE(PRUNIT,101) NV,NAME(1:4),IORIV,(Q(K),K=K1,K2)
C
        IF ( CFL.NE.'ONE' ) THEN
          LISV1 = LQ(LISV1)
          GOTO 1
        ENDIF
C
      ENDIF
C
      RETURN
  100 FORMAT('0',//,' VERTEX BANK (ISV1)',/,
     1 '  NO.  NAME ORIV',7X,'PX',8X,'PY',8X,'PZ',9X,'E',6X,'MASS'
     2 ,8X,'X',9X,'Y',9X,'Z')
  101 FORMAT(I4,2X,A4,I5,2X,5F10.3,3F10.4)
      END
+EOD
+DECK,PRISV2                          .
      SUBROUTINE PRISV2(PRUNIT,LISV2I,NISV2,CFL,IFL)
C------------------------------------------------------------------
C-
C-  Print out for ISV2 (parton) bank
C-
C-  INPUT:
C-  PRUNIT = unit number for printout
C-  LISV2I = bank address
C-  NISV2  = bank number
C-  CFL    = flag to control printout
C-           'ALL' for all banks, 'LINEAR' for one linear structure
C-           'ONE' for one bank only
C-            LISV2I must be provided for 'LINEAR',
C-            LISV2I or NISV2 may be provided for 'ONE',
C-            LISV2I and NISV2 ignored for 'ALL'
C-  IFL    = not used
C-
C-     SDP  Jan,1986 , Rev. Feb,1986
C-     SK   Apr,1986,  Modified from SDP's PRISV1.
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ZEBCOM.
+CDE,IZISV2.
      CHARACTER CFL*(*)
      INTEGER LZLOC
      INTEGER PRUNIT,LISV2I,NISV2,IFL
      INTEGER NV,K,K1,K2,K3,IORV,IORP,LISV2
      CHARACTER*8 NAME,LABEL
C
C          Print titles
C
      WRITE(PRUNIT,100)
C
      LISV2 = LISV2I
      IF ( CFL.EQ.'ALL' ) THEN
        LISV2 = LQ(LISAE-IZISV2)
      ENDIF
C
    1 IF ( LISV2.GT.0 ) THEN
C
C       find parent vertex
        IORV = LQ(LISV2-2)
        IF ( IORV.GT.0) IORV = IQ(IORV-5)
        IORP = LQ(LISV2-3)
        IF ( IORP.GT.0) IORP = IQ(IORP-5)
C
C   Print contents of bank
C
        NV = IQ(LISV2-5)
        K1 = LISV2+2
        K2 = LISV2+9
        K3 = LISV2 + 10
        NAME = LABEL(IQ(LISV2+1))
        WRITE(PRUNIT,101) NV,NAME(1:4),IORV,IORP,(Q(K),K=K1,K2),IQ(K3)
C
        IF ( CFL.NE.'ONE' ) THEN
          LISV2 = LQ(LISV2)
          GOTO 1
        ENDIF
C
      ENDIF
C
      RETURN
  100 FORMAT(//' VERTEX BANK (ISV2)'/
     1 ' NO.  NAME IORV IORP'
     2 ,7X,'PX',8X,'PY',8X,'PZ',9X,'E',6X,'MASS'
     3 ,8X,'X',9X,'Y',9X,'Z',5X,'VTX TYPE')
  101 FORMAT(I4,2X,A4,2I5,2X,5F10.3,3F10.4,3X,I5)
      END
+EOD
+DECK,PRPJET                          .
      SUBROUTINE PRPJET ( PRUNIT, LPJETI, NPJET, CFL, IFL )
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Print on unit PRUNIT the content of one or more
C-              banks 'PJET'.
C-
C-   Inputs  : PRUNIT [I] : Unit number for printout
C-             LPJETI [I] : Pointer to the one bank ( CFL = 'ONE' ) or to the
C-                          first of a linear structure ( CFL = 'LINEAR' ).
C-                          Unused if CFL = 'ALL'.
C-             NPJET  [I] : Bank number, used only if CFL='ONE' and LPJET = 0
C-             CFL    [C*]: Character flag, other input depends on it's value:
C-                          'ONE' : LPJET point to a bank, or if <0, NPJET is
C-                                  the bank number.
C-                          'LINEAR' : LPJET points to the first bank of the
C-                                  Linear structure
C-                          'ALL' : Prints all banks
C-             IFL    [I] : Defines the amount of printing: 0 means full
C-                          printout, 1 is the minimum, 2 gives more, ...
C-   Outputs : on unit PRUNIT
C-   Controls: none
C-
C-   Created   7-NOV-1989 18:10:09.84  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,IZPJET.
+CDE,IZPJPT.
+CDE,ZEBCOM.
      INTEGER PRUNIT,LPJETI,NPJET,IFL
      CHARACTER CFL*(*)
      INTEGER LZLOC,LPJET,LPJHD,GZPJHD
      INTEGER LPJPT,MAXQ
      PARAMETER (MAXQ=20)
      INTEGER NQ,NJ,K,J,IP,NP(MAXQ)
C
      LPJET=LPJETI
      IF(CFL.EQ.'ONE') THEN
        IF(LPJET.EQ.0) THEN
          IF(NPJET.EQ.0) GOTO 98      ! error exit
          LPJET=LZLOC(IXMAIN,'PJET',NPJET)
          LPJPT = LQ(LPJET-IZPJPT)
        ENDIF
      ENDIF
C
      IF(CFL.EQ.'ALL') THEN
        LPJHD  = GZPJHD ()           ! find PJHD main bank
        CALL PRPJHD(PRUNIT,LPJHD, 0, 'ONE', IFL )
        LPJET  =LQ(LPJHD - IZPJET)   ! find pointer to first bank
        LPJPT = LQ(LPJET-IZPJPT)
      ENDIF
C
C        print title
C
   10 IF ( IQ(LPJHD+2).EQ.1 ) WRITE (PRUNIT,1102) IQ(LPJET+1)
      IF ( IQ(LPJHD+2).EQ.2 ) WRITE (PRUNIT,1103) IQ(LPJET+1)
      WRITE( PRUNIT, 1101 ) ' No. ',' ET ',' Px ',' Py ',' Pz ',' E ',
     &  ' Mass ',' Phi ',' Theta ',' Eta ',' CLASS ',' NEXT ',' PJPT '
C
      IP = 0
    1 IF(LPJET.GT.0) THEN
C
C   Print contents of bank
C
        IP = IP + 1
        DO K = 2, IQ(LPJPT-3)
          NP ( K ) = LQ( LPJPT-K )
          IF (NP(K).NE. 0) NP(K) = IQ(NP(K)-5) ! ISAQ BANK NUMBER
        END DO
        WRITE( PRUNIT, 1100 ) IP , Q(LPJET+2),
     &  (Q(LPJET+J), J = 3, 10) , IQ( LPJET+11), IQ(LPJET+12),
     &  (NP(K) , K = 2, IQ(LPJPT-3) )
C
        IF(CFL.NE.'ONE') THEN
          LPJET=LQ(LPJET)               ! pointer to next bank
          LPJPT = LQ(LPJET-IZPJPT)
          GOTO 1
        ENDIF
C
      ELSE  IF(CFL.EQ.'ALL') THEN
        LPJHD  = LQ(LPJHD) ! find NEXT PJHD  bank
        IF( LPJHD .GT. 0) THEN
          CALL PRPJHD(PRUNIT,LPJHD, 0, 'ONE', IFL )
          LPJET  =LQ(LPJHD - IZPJET)   ! find pointer to first bank
          LPJPT = LQ(LPJET-IZPJPT)
          GOTO 10
        END IF
      ENDIF
C
      RETURN
   98 PRINT 111,LPJET,NPJET
      RETURN
   99 PRINT 112,LPJET
      RETURN
  111 FORMAT('0',//,'  FOR A SINGLE BANK PRINTOUT OF PJET YOU MUST',
     1 ' DEFINE POINTER OR BANK NUMBER',/,' THEY ARE NOW SET TO',2I10)
  112 FORMAT('0',//,' FOR PRINTOUT OF LINEAR ARRAY OF PJET',
     1 ' YOU MUST DEFINE POINTER',/,' IT IS NOW SET TO',I10)
 1100 FORMAT(I3,3X,9F8.2,2I4,4X,15I3,2(/85X,15I3))
 1101 FORMAT(A5,1X,9A8,2A4,1X,A8)
 1102 FORMAT(/,
     &  ' PARTON JETS BANK(PJET)  -  R CONE ALGORITHM  - VERSION',I5)
 1103 FORMAT(/,
     &  ' PARTON JETS BANK(PJET)  -  CM ANGLE ALGORITHM- VERSION', I5)
      END
+EOD
+DECK,PRPJHD                          .
      SUBROUTINE PRPJHD ( PRUNIT, LPJHD, NPJHD, CFL, IFL )
C----------------------------------------------------------------------
C-
C-   Purpose and Methods : Print on unit PRUNIT the content of one or more
C-              banks 'PJHD'.
C-
C-   Inputs  : PRUNIT [I] : Unit number for printout
C-             LPJHD  [I] : Pointer to the one bank ( CFL = 'ONE' ) or to the
C-                          first of a linear structure ( CFL = 'LINEAR' ).
C-                          Unused if CFL = 'ALL'.
C-             NPJHD  [I] : Bank number, used only if CFL='ONE' and LPJHD = 0
C-             CFL    [C*]: Character flag, other input depends on it's value:
C-                          'ONE' : LPJHD point to a bank, or if <0, NPJHD is
C-                                  the bank number.
C-                          'LINEAR' : LPJHD points to the first bank of the
C-                                  Linear structure
C-                          'ALL' : Prints all banks
C-             IFL    [I] : Defines the amount of printing: 0 means full
C-                          printout, 1 is the minimum, 2 gives more, ...
C-   Outputs : on unit PRUNIT
C-   Controls: none
C-
C-   Created   7-NOV-1989 17:57:58.00  Chip Stewart
C-
C----------------------------------------------------------------------
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
+CDE,ZEBCOM.
+CDE,IZPJHD.
C
      INTEGER PRUNIT, LPJHD, NPJHD, IFL
      CHARACTER*(*) CFL
      INTEGER LPJHD1, GZPJHD, LZLOC, J,K,L
C----------------------------------------------------------------------
      LPJHD1 = LPJHD
      IF( CFL .EQ. 'LINEAR' ) THEN
        IF( LPJHD .LE. 0 ) GOTO 990
      ELSEIF( CFL .EQ. 'ONE' ) THEN
        IF( LPJHD .LE. 0 ) THEN
          IF( NPJHD .EQ. 0 ) GOTO 980          ! Error exit
          LPJHD1 = LZLOC( IXMAIN, 'PJHD', NPJHD )
        ENDIF
      ELSEIF( CFL .EQ. 'ALL' ) THEN
C
C ****  Here, you have to find the first bank to be printed
C
        LPJHD1 = GZPJHD( )
      ELSE
        WRITE( PRUNIT, 1000 ) CFL
1000    FORMAT(/' ** PRPJHD ** Illegal value of CFL = ',A/)
        GOTO 999
      ENDIF
    1 CONTINUE
C
C  ***  Print the content of the bank pointed by LPJHD1
C
      IF (IQ(LPJHD+2) .EQ. 1) THEN
        WRITE( PRUNIT,'(/A)') 'PJET CONE (R) ALGORITHM - (PJHD)'
        WRITE( PRUNIT, 1101 )  'NV','N ALG','NPJET','R CONE CUT',
     &  'JET ET CUT', ' MAX ITER ', ' IR ','MUON'
      ELSE IF (IQ(LPJHD+2) .EQ. 2) THEN
        WRITE( PRUNIT,'(/A)') ' PJET ANGLE ALGORITHM - (PJHD) '
        WRITE( PRUNIT, 1101 )  'NV','N ALG','NPJET','ANG CUT(rad)',
     &  'JET ET CUT', ' MAX ITER ', ' IR ',' MUON'
      ELSE
        WRITE( PRUNIT,'(/A)') ' PJET UNDEFINED ALGORITHM - (PJHD) '
        WRITE( PRUNIT, 1101 )  'NV','N ALG','NPJET',' CUT ',
     &  'JET ET CUT', ' MAX ITER ', ' IR ','MUON'
      END IF
      WRITE( PRUNIT, 1100 ) ( IQ( LPJHD1 + J ) , J = 1,3),
     &  ( Q( LPJHD1+K) , K = 4,5), ( IQ( LPJHD1 + L ) , L = 6,8)
 1100 FORMAT( /1X,I5,2I8,2F15.3,3I8)
 1101 FORMAT( 1X,A5,2A8,2A15,3A8)
C
C  ***  Look if another bank is needed
C
      IF( CFL .EQ. 'ONE' ) GOTO 999
      IF( CFL .EQ. 'LINEAR' ) THEN
        LPJHD1 = LQ( LPJHD1 )
        IF( LPJHD1 .NE. 0 ) GOTO 1
      ELSE
C
C ****  Find the next bank for the ALL command.
C
        LPJHD1 = GZPJHD()
      ENDIF
  999 RETURN
C
C  *** Error : Linear without bank pointer
C
  990 WRITE( PRUNIT, 2000 ) LPJHD
 2000 FORMAT(/' ** PRPJHD ** called for LINEAR without valid bank ',
     &        'pointer, LPJHD =',I10/)
      GOTO 999
C
C  *** Error : One bank, but neither pointer nor number
C
  980 WRITE( PRUNIT, 2100 ) LPJHD, NPJHD
 2100 FORMAT(/'  ** PRPJHD ** called for ONE without bank pointer and ',
     &        'bank number, LPJHD =',I10,' NPJHD =', I10/)
      GOTO 999
      END
+EOD
+DECK,PRTEVZ                          .
      SUBROUTINE PRTEVZ(PRUNIT)
C----------------------------------------------------------
C-                                                        -
C-   Print Zebra banks for ISAJET event record            -
C-                                                        -
C-  INPUT:                                                -
C-  PRUNIT=  print unit                                   -
C-                                                        -
C-         SDP Jan.,1985, Jan.,1987                       -
C-   SK  Apr.,1986,   Add calling for ISV2,ISP2 and ISP3  -
C-                                                        -
C----------------------------------------------------------
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,IZISAC.
+CDE,IZISAJ.
+CDE,IZISAL.
+CDE,IZISAQ.
+CDE,IZISV1.
+CDE,IZISP1.
+CDE,ZEBCOM.
      INTEGER PRUNIT,EVTR
      INTEGER LISAJ,LISAQ,LISV1,LISP1,LISAC,LISCL,LISAL
      INTEGER LISV2,LISP2,LISP3,LPJET,GZPJET
C
      IF(LISAE.LE.0) RETURN
        CALL UCTOH('ISAE',EVTR,4,4)
        IF(IQ(LISAE-4).NE.EVTR) RETURN  ! not event record
        CALL PRISAE(PRUNIT,LISAE,0,0,0)
C
      LISAJ=LQ(LISAE-IZISAJ)
      IF(LISAJ.GT.0)
     $  CALL PRISAJ(PRUNIT,LISAJ,0,'LINEAR',0)    ! print jet banks
C
      LISAQ=LQ(LISAE-IZISAQ)
      IF(LISAQ.GT.0)
     $   CALL PRISAQ(PRUNIT,LISAQ,0,'LINEAR',0)    ! print parton banks
C
      IF(IQ(LISAE-2).GT.7) THEN ! check ISAE has link for PJET
        LPJET=GZPJET()
        IF(LPJET.NE.0)
     &    CALL PRPJET(PRUNIT,0,0,'ALL',0)
      ENDIF
C
      LISV1=LQ(LISAE-IZISV1)
   3  IF(LISV1.GT.0) THEN          ! vertex banks
        CALL PRISV1(PRUNIT,LISV1,0,'ONE',0)
        LISP1=LQ(LISV1-IZISP1)
C
        IF(LISP1.GT.0)             ! particle banks
     $      CALL PRISP1(PRUNIT,LISP1,0,'LINEAR',0)
C
        LISV1=LQ(LISV1)
        GOTO 3
      ENDIF
C
      LISV2=LQ(LISAE-4)
   4  IF(LISV2.GT.0) THEN
        CALL PRISV2(PRUNIT,LISV2,0,'ONE',0)
        LISP2=LQ(LISV2-1)
C
        IF(LISP2.GT.0)
     $     CALL PRISP2(PRUNIT,LISP2,0,'LINEAR',0)
C
        LISV2=LQ(LISV2)
        GO TO 4
      ENDIF
C
      LISP3=LQ(LISAE-5)
      IF(LISP3.GT.0)
     $    CALL PRISP3(PRUNIT,LISP3,0,'LINEAR',0)
C
      LISAC=LQ(LISAE-IZISAC)
      IF(LISAC.NE.0) THEN
        CALL PRISAC(PRUNIT,LISAC,0,'ONE',0) ! calorimeter description
        CALL PRISCL(PRUNIT,0,0,'ALL',0)     ! print all cells
      ENDIF
      LISAL=LQ(LISAE-IZISAL)
      IF(LISAL.GT.0) CALL PRISAL(PRUNIT,LISAL,0,'LINEAR',0) ! leptons
      CALL PRISJT(PRUNIT,0,0,'ALL',0)
      RETURN
      END
+EOD
+PATCH,ISAPLT.
+EOD
+DECK,CALINI
      SUBROUTINE CALINI
C
C          Initialize calorimeter for CALSIM and GETJET.  Note that
C          because the initialization is separate, CALSIM can be
C          called more than once to simulate pileup of several events.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C          ISAJET common blocks
+CDE,ITAPES
C
C          ISAPLT common blocks
+CDE,CALOR
+CDE,GETJET
C
      INTEGER IPHI,IY
      REAL PHIX,YX,THX
C          Initialize ET array.
      DO 100 IPHI=1,NCPHI
      DO 100 IY=1,NCY
        ET(IY,IPHI)=0.
        ETEM(IY,IPHI)=0.
100   CONTINUE
C
C          Calculate trig. functions.
      DO 200 IPHI=1,NCPHI
        PHIX=DELPHI*(IPHI-.5)
        CPHCAL(IPHI)=COS(PHIX)
        SPHCAL(IPHI)=SIN(PHIX)
200   CONTINUE
      DO 300 IY=1,NCY
        YX=DELY*(IY-.5)+YCMIN
        THX=2.*ATAN(EXP(-YX))
        CTHCAL(IY)=COS(THX)
        STHCAL(IY)=SIN(THX)
300   CONTINUE
      RETURN
      END
+EOD
+DECK,CALSIM
      SUBROUTINE CALSIM(RESEM,RESHAD)
C
C          Trivial calorimeter simulation. Deposit energy 
C            ET(IY,IPHI)   = total energy in bin (IY,IPHI)
C            ETEM(IY,IPHI) = electromagnetic energy in bin (IY,IPHI)
C          in cells with uniform Y and PHI bins and energy resolutions
C            SIGMA/E=RESEM/SQRT(E)  for electrons and photons
C            SIGMA/E=RESHAD/SQRT(E) for hadrons
C          and with no shower spreading. Note that muons deposit their
C          full energy with hadronic resolution.
C
C          Ver 7.33: Treat gravitino = 91 as non-interacting.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C          ISAJET common blocks
+CDE,ITAPES
+CDE,PARTCL
C
C          ISAPLT common blocks
+CDE,CALOR
+CDE,GETJET
C
      INTEGER IP,IY,IPHI,IDABS
      REAL PI,PTIP,PIP,PPLUS,PMINUS,YIP,PHIIP,EIP,RGEN1,RGEN2,RANF,R1,
     $RESEM,RESHAD
C
C          Fill calorimeter
C
      PI=4.*ATAN(1.)
      DO 200 IP=1,NPTCL
        IF(IDCAY(IP).NE.0) GO TO 200
        IDABS=IABS(IDENT(IP))
        IF(IDABS.EQ.11.OR.IDABS.EQ.13.OR.IDABS.EQ.15.OR.IDABS.EQ.30
     $  .OR.IDABS.EQ.91) GO TO 200
        PTIP=SQRT(PPTCL(1,IP)**2+PPTCL(2,IP)**2)
        PIP=SQRT(PTIP**2+PPTCL(3,IP)**2)
        PPLUS=PPTCL(4,IP)+PPTCL(3,IP)
        PMINUS=PPTCL(4,IP)-PPTCL(3,IP)
        IF(PPLUS.LE.0..OR.PMINUS.LE.0.) GO TO 200
        YIP=.5*ALOG(PPLUS/PMINUS)
        PHIIP=ATAN2(PPTCL(2,IP),PPTCL(1,IP))
        IF(PHIIP.LT.0.) PHIIP=PHIIP+2.*PI
        IF(YIP.LT.YCMIN.OR.YIP.GT.YCMAX) GO TO 200
        IY=INT((YIP-YCMIN)/DELY)+1
        IPHI=INT(PHIIP/DELPHI)+1
        EIP=PPTCL(4,IP)
C
C          Smear energy
        RGEN1=SQRT(-2.*ALOG(RANF()))
        RGEN2=2.*PI*RANF()
        R1=RGEN1*COS(RGEN2)
        IF(IDABS.EQ.10.OR.IDABS.EQ.12.OR.IDABS.EQ.110.OR.
     $  IDABS.EQ.220) THEN
          EIP=EIP+(RESEM*SQRT(EIP))*R1
          ET(IY,IPHI)=ET(IY,IPHI)+EIP*STHCAL(IY)
          ETEM(IY,IPHI)=ETEM(IY,IPHI)+EIP*STHCAL(IY)
        ELSE
          EIP=EIP+(RESHAD*SQRT(EIP))*R1
          ET(IY,IPHI)=ET(IY,IPHI)+EIP*STHCAL(IY)
        ENDIF
200   CONTINUE
      RETURN
      END
+EOD
+DECK,EHIST
      SUBROUTINE EHIST
C
C          Print HBOOK histograms with contents and errors in E format.
C          Supports both HBOOK3 and HBOOK4.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,MYHIST
C
      LOGICAL HEXIST
      CHARACTER*1 APRNT(10,120)
      CHARACTER*10 WORD
+SELF,IF=HBOOK4
      CHARACTER*80 TITLE
+SELF,IF=HBOOK3
      REAL TITLE(8)
+SELF
      INTEGER ID1,ID,NWT,NY,NX,IAD,NCH,J,K
      REAL XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,HMIN,HMAX,Y,HI,HIE
C
C          Print histogram index
      CALL HINDEX
C
C          Loop over weighted histograms
C
      DO 1000 ID1=1,MXHIST
        ID=ID1+NHSHFT
        IF(.NOT.HEXIST(ID)) GO TO 1000
C          Print histogram in standard way
        CALL HPRINT(ID)
C
C          Check for 2 dimensional histogram
        NWT=8
        NY=0
        CALL HGIVE(ID,TITLE,NX,XMIN,XMAX,NY,YMIN,YMAX,NWT,IAD)
        IF(NY.NE.0) THEN
          ZMAX=HMAX(ID)
          ZMIN=HMIN(ID)
          WRITE(ITLIS,2010) ZMIN,ZMAX
2010      FORMAT(/'  * CONTENT MIN = ',E12.5,'  MAX = ',E12.5)
          GO TO 1000
        ENDIF
C
C          Print 1-dimensional channel contents in E format.
C
        NCH=NX
        IF(NCH.GT.100) NCH=100
C          Clear APRNT array
        DO 100 J=1,100
        DO 100 K=1,10
100     APRNT(K,J)=' '
C          Extract contents and convert to E format
        DO 110 J=1,NCH
          Y=HI(ID,J)
          WRITE(WORD,'(E10.4)') Y
          READ(WORD,'(10A1)') (APRNT(K,J),K=1,10)
110     CONTINUE
C          Print channel marks
        WRITE(ITLIS,121)
121     FORMAT('1'//
     1  ' CHANNELS',6X,'0',99X,'1'/
     2  15X,'0',9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7',9X,'8',
     3  9X,'9',9X,'0'/
     4  15X,'0',10('1234567890')/)
C          Print channel contents
        DO 130 K=1,10
          IF(K.EQ.1) WRITE(ITLIS,131) (APRNT(K,J),J=1,NCH)
131       FORMAT(' CONTENTS',7X,100A1)
          IF(K.GT.1) WRITE(ITLIS,132) (APRNT(K,J),J=1,NCH)
132       FORMAT(16X,100A1)
130     CONTINUE
C
C          Print 1-dimensional errors in E format.
C
C          Clear APRNT array
        DO 200 J=1,100
        DO 200 K=1,10
200     APRNT(K,J)=' '
C          Extract errors and convert to E format
        DO 210 J=1,NCH
          Y=HIE(ID,J)
          WRITE(WORD,'(E10.4)') Y
          READ(WORD,'(10A1)') (APRNT(K,J),K=1,10)
202       FORMAT(10A1)
210     CONTINUE
C          Print channel marks
        WRITE(ITLIS,221)
221     FORMAT(//
     1  ' CHANNELS',6X,'0',99X,'1'/
     2  15X,'0',9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7',9X,'8',
     3  9X,'9',9X,'0'/
     4  15X,'0',10('1234567890')/)
C          Print channel errors
        DO 230 K=1,10
          IF(K.EQ.1) WRITE(ITLIS,231) (APRNT(K,J),J=1,NCH)
231       FORMAT(' ERRORS  ',7X,100A1)
          IF(K.GT.1) WRITE(ITLIS,232) (APRNT(K,J),J=1,NCH)
232       FORMAT(16X,100A1)
230     CONTINUE
1000  CONTINUE
C
      RETURN
      END
+EOD
+DECK,GETJET
      SUBROUTINE GETJET(RJET,EJCUT)
C
C          Simple jet-finding algorithm (similar to UA1).
C          Find highest remaining cell > ETSTOP and sum surrounding
C          cells with--
C            DELTA(Y)**2+DELTA(PHI)**2<RJET**2
C            ET>ECCUT.
C          Keep jets with ET>EJCUT.
C          The UA1 parameters are RJET=1.0 and EJCUT=5.0
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C
C          ISAPLT common blocks
+CDE,ITAPES
+CDE,CALOR
+CDE,GETJET
C
      INTEGER IPHI,IY,J,K,NPHI1,NPHI2,NY1,NY2,IPASS,IYMX,IPHIMX,IPHI1,
     $IPHIX,IY1,IYX
      REAL    RJET,ETMAX,ETSTOP,RR,ECCUT,PX,EJCUT
C          Parameters
      DATA ECCUT/.5/
      DATA ETSTOP/1./
C
C          Initialize
C
      DO 100 IPHI=1,NCPHI
      DO 100 IY=1,NCY
100   JETNO(IY,IPHI)=0
      DO 110 J=1,NJMAX
        ETJET(J)=0.
        DO 110 K=1,4
111     PCJET(K,J)=0.
110   CONTINUE
      NCJET=0
      NPHI1=RJET/DELPHI
      NPHI2=2*NPHI1+1
      NY1=RJET/DELY
      NY2=2*NY1+1
      IPASS=0
C
C          Find highest cell remaining
C
1     ETMAX=0.
      DO 200 IPHI=1,NCPHI
        DO 210 IY=1,NCY
          IF(JETNO(IY,IPHI).NE.0) GO TO 210
          IF(ET(IY,IPHI).LT.ETMAX) GO TO 210
          ETMAX=ET(IY,IPHI)
          IYMX=IY
          IPHIMX=IPHI
210     CONTINUE
200   CONTINUE
      IF(ETMAX.LT.ETSTOP) RETURN
C
C          Sum cells
C
      IPASS=IPASS+1
      IF(IPASS.GT.NCY*NCPHI) THEN
        WRITE(ITLIS,8888) IPASS
8888    FORMAT(//' ERROR IN GETJET...IPASS > ',I6)
        STOP 99
      ENDIF
      NCJET=NCJET+1
      IF(NCJET.GT.NJMAX) THEN
        WRITE(ITLIS,9999) NCJET
9999    FORMAT(//' ERROR IN GETJET...NCJET > ',I5)
        STOP 99
      ENDIF
      DO 300 IPHI1=1,NPHI2
        IPHIX=IPHIMX-NPHI1-1+IPHI1
        IF(IPHIX.LE.0) IPHIX=IPHIX+NCPHI
        IF(IPHIX.GT.NCPHI) IPHIX=IPHIX-NCPHI
        DO 310 IY1=1,NY2
          IYX=IYMX-NY1-1+IY1
          IF(IYX.LE.0) GO TO 310
          IF(IYX.GT.NCY) GO TO 310
          IF(JETNO(IYX,IPHIX).NE.0) GO TO 310
          RR=(DELY*(IY1-NY1-1))**2+(DELPHI*(IPHI1-NPHI1-1))**2
          IF(RR.GT.RJET**2) GO TO 310
          IF(ET(IYX,IPHIX).LT.ECCUT) GO TO 310
          PX=ET(IYX,IPHIX)/STHCAL(IYX)
C          Add cell to jet
          PCJET(1,NCJET)=PCJET(1,NCJET)+PX*STHCAL(IYX)*CPHCAL(IPHIX)
          PCJET(2,NCJET)=PCJET(2,NCJET)+PX*STHCAL(IYX)*SPHCAL(IPHIX)
          PCJET(3,NCJET)=PCJET(3,NCJET)+PX*CTHCAL(IYX)
          PCJET(4,NCJET)=PCJET(4,NCJET)+PX
          ETJET(NCJET)=ETJET(NCJET)+ET(IYX,IPHIX)
          JETNO(IYX,IPHIX)=NCJET
310     CONTINUE
300   CONTINUE
C
C          Discard jet if ET < EJCUT.
C
      IF(ETJET(NCJET).GT.EJCUT) GO TO 1
      ETJET(NCJET)=0.
      DO 400 K=1,4
400   PCJET(K,NCJET)=0.
      NCJET=NCJET-1
      GO TO 1
C
      END
+EOD
+DECK,ISAPLT
      SUBROUTINE ISAPLT(JTIN,JTLIS)
C
C          Skeleton of a job to analyse ISAJET events from tape JTIN
C          with a trivial calorimeter simulation and a simple UA1
C          jet-finding algorithm.
C
C          Histogram results with CERN HBOOK 3 or 4. Each histogram
C          should be booked in SETUP with 1 < ID < 100. A second 
C          histogram is then automatically booked with ID + 100. The
C          first histogram is filled in USER. At the end of a run, the
C          cross section SIGF is used to fill the second histogram with
C          the proper weight, and the first histogram is cleared.
C
C          Print 1-dim histograms with contents and errors in E format.
C          Print 2-dim histograms with automatic scaling.
C          All printing is on tape JTLIS.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
C          ISAJET common blocks
+CDE,ITAPES
+CDE,RECTP
+CDE,FINAL
+CDE,PRIMAR
C
C          ISAPLT common blocks
+CDE,MYHIST
C
C          HBOOK and other variables. NWMEMO = number of words for 
C          histograms; it may have to be increased.
      INTEGER NWMEMO
      PARAMETER (NWMEMO=10000)
+SELF,IF=HBOOK4
      COMMON/PAWC/HMEMOR(NWMEMO)
      REAL HMEMOR
+SELF,IF=HBOOK3
      COMMON//HMEMOR(NWMEMO)
      REAL HMEMOR
+SELF
      LOGICAL HEXIST
      CHARACTER*40 V,VISAJE
      INTEGER JTIN,JTLIS,ITAPE,IFL,I
      REAL SIGWT
C
C          Initialize
      V=VISAJE()
      CALL HLIMIT(NWMEMO)
      ITLIS=IABS(JTLIS)
      ITAPE=IABS(JTIN)
      CALL HOUTPU(ITLIS)
      CALL HERMES(ITLIS)
C
C          Set up histograms
      CALL SETUP
C
C          Read next record until eof encountered
      REWIND ITAPE
1     CONTINUE
      IFL=0
      CALL RDTAPE(ITAPE,IFL)
      IF(IFL.EQ.-1) GO TO 3
      IF(IRECTP.EQ.200) GO TO 1
      IF(IRECTP.EQ.300) GO TO 2
C
C          Event record
      CALL USER
      GO TO 1
C
C          End of run record. Weight histograms.
2     CONTINUE
      SIGWT=SIGF/FLOAT(NEVENT)
      IF(SIGWT.EQ.0.) SIGWT=1.
      DO 100 I=1,MXHIST
        IF(.NOT.HEXIST(I)) GO TO 100
        CALL HOPERA(I,'+',I+NHSHFT,I+NHSHFT,SIGWT,1.)
+SELF,IF=HBOOK4
        CALL HRESET(I,' ')
+SELF,IF=HBOOK3
        CALL HRESET(I)
+SELF
100   CONTINUE
      GO TO 1
C
C          End of job. Output histograms.
3     CALL EHIST
      RETURN
      END
+EOD
+DECK,SETUP
      SUBROUTINE SETUP
C
C          User routine to book histograms for HBOOK 3 or 4.
C
C          Sets up two histograms for each plot.
C          Histogram I, 1<I<MXHIST, is unweighted and never printed.
C          Histogram I+NHSHFT is weighted by SIGF/NEVENT unless SIGF=0.
C          Scatter plots are automatically scaled.
C
+SELF,IF=IMPNONE
      IMPLICIT NONE
+SELF
+CDE,ITAPES
+CDE,MYHIST
C
      LOGICAL HEXIST
      INTEGER I
C
C          MXHIST=maximum unweighted histogram ID.
      MXHIST=100
      NHSHFT=100
C
C          Book unweighted histograms with HBOOK1 and HBOOK2 below.
C          ID should be less than MXHIST.
C          2-DIM histograms *MUST* be booked with 1 word/channel.
C-----------------------------------------------------------------------
C-
C-
C-
C-
C-
C-----------------------------------------------------------------------
C
C          Provide automatic scaling for scatter plots.
      CALL HSCALE(0,0.)
C
C          Create copies of histograms with ID2=ID1+NHSHFT
C          Set error bar mode to display errors.
      DO 100 I=1,MXHIST
        IF(.NOT.HEXIST(I)) GO TO 100
+SELF,IF=HBOOK4
        CALL HCOPY(I,I+NHSHFT,' ')
+SELF,IF=HBOOK3
        CALL HCOPY(I,I+NHSHFT)
+SELF
        CALL HBARX(I)
        CALL HBARX(I+NHSHFT)
100   CONTINUE
      RETURN
      END
+EOD
+DECK,USER
      SUBROUTINE USER
C
C          User routine to do analysis for each event.
C
C          All histograms should be booked in SETUP and filled with 
C          HFILL using weight 1. The correct weight SIGF/NEVENT will 
C          be inserted by ISAPLT.
C
C          For a trivial calorimeter simulation with resolutions
C            SIGMA(E)/E = RESEM/SQRT(E)  for electromagnetic
C            SIGMA(E)/E = RESHAD/SQRT(E) for hadronic
C            (RESEM = .15, RESHAD = .35  for uranium calorimeter)
C            (RESEM = .15, RESHAD = .70  for iron calorimeter)
C          use
C
C     CALL CALINI
C     CALL CALSIM(RESEM,RESHAD)
C
C          Then to find jets with a simplified version of the UA1 jet
C          algorithm with jet radius RJET and minimum scalar transverse
C          energy EJCUT (RJET=1., EJCUT=5. for UA1) use
C
C     CALL GETJET(RJET,EJCUT)
C
C          See CALINI, CALSIM, and GETJET for additional comments.
C
C          ISAJET common blocks
+CDE,ITAPES
+CDE,PRIMAR
+CDE,PJETS
+CDE,PARTCL
+CDE,JETSET
+CDE,IDRUN
+CDE,KEYS
+CDE,FINAL
C
C          ISAPLT common blocks
+CDE,CALOR
+CDE,GETJET
C
C          Calculate desired quantities below and fill histograms
C          with HFILL.
C-----------------------------------------------------------------------
C-
C-
C-
C-
C-
C-----------------------------------------------------------------------
      RETURN
      END
+EOD
+PATCH,ISATEXT,T=DATA.
+EOD
+DECK,INTRO
% LaTeX 2.09 or LaTeX 2e
\documentstyle[12pt]{article}

% Page dimensions
\newdimen\SaveWidth \SaveWidth=\textwidth
\newdimen\SaveHeight \SaveHeight=\textheight
\textwidth=6.5in
\textheight=8.9in
\advance\SaveWidth by -\textwidth
\advance\SaveHeight by -\textheight
\divide\SaveWidth by 2
\divide\SaveHeight by 2
\advance\hoffset by \SaveWidth
\advance\voffset by \SaveHeight

\def\sgn{\mathop{\rm sgn}}
\def\GeV{{\rm GeV}}
\def\etmiss{\slashchar{E}_T}

%  \slashchar puts a slash through a character to represent contraction
%  with Dirac matrices.
\def\slashchar#1{\setbox0=\hbox{$#1$}           % set a box for #1
   \dimen0=\wd0                                 % and get its size
   \setbox1=\hbox{/} \dimen1=\wd1               % get size of /
   \ifdim\dimen0>\dimen1                        % #1 is bigger
      \rlap{\hbox to \dimen0{\hfil/\hfil}}      % so center / in box
      #1                                        % and print #1
   \else                                        % / is bigger
      \rlap{\hbox to \dimen1{\hfil$#1$\hfil}}   % so center #1
      /                                         % and print /
   \fi}                                         %

%       \simge and \simle make the "greater than about" and the "less
% than about" symbols with spacing as relations.
\def\simge{%  ``greater than about'' symbol
    \mathrel{\rlap{\raise 0.511ex
        \hbox{$>$}}{\lower 0.511ex \hbox{$\sim$}}}}
\def\simle{%  ``less than about'' symbol
    \mathrel{\rlap{\raise 0.511ex 
        \hbox{$<$}}{\lower 0.511ex \hbox{$\sim$}}}}

\begin{document}

\centerline{\Large\bf ISAJET 7.74}
\medskip
\centerline{\Large\bf A Monte Carlo Event Generator}
\medskip
\centerline{\Large\bf for $pp$, $\bar pp$, and $e^+e^-$ Reactions}
\bigskip\bigskip
\centerline{\bf Frank E. Paige and Serban D. Protopopescu}
\smallskip
\centerline{Physics Department}
\centerline{Brookhaven National Laboratory}
\centerline{Upton, NY 11973, USA}
\bigskip
\centerline{\bf Howard Baer}
\smallskip
\centerline{Department of Physics}
\centerline{Florida State University}
\centerline{Talahassee, FL 32306}
\bigskip
\centerline{\bf Xerxes Tata}
\centerline{Department of Physics and Astronomy}
\centerline{University of Hawaii}
\centerline{Honolulu, HI 96822}

\bigskip\bigskip
\tableofcontents

\newpage
\section{Introduction\label{INTRO}}

      ISAJET is a Monte Carlo program which simulates $pp$, 
$\bar pp$ and $e^+e^-$ interactions at high energies. 
ISAJET is based on
perturbative QCD plus phenomenological models for parton and beam jet
fragmentation. Events are generated in four distinct steps:
\begin{itemize}
\item A primary hard scattering is generated according to the
appropriate QCD cross section.
\item QCD radiative corrections are added for both the initial and the
final state.
\item Partons are fragmented into hadrons independently, and particles
with lifetimes less than about $10^{-12}$ seconds are decayed.
\item Beam jets are added assuming that these are identical to a
minimum bias event at the remaining energy.
\end{itemize}

      ISAJET incorporates ISASUSY, which evaluates branching ratios for
the minimal supersymmetric extension of the standard model. H.~Baer and
X.~Tata are coauthors of this package, and they have done the original
calculations with various collaborators. See the ISASUSY documentation
in the patch Section~\ref{SUSY}.

      ISAJET is supported for ANSI Fortran and for Cray, DEC Ultrix,
DEC VMS, HP/9000 7xx, IBM VM/CMS 370 and 30xx, IBM AIX RS/6000, Linux,
Silicon Graphics 4D, and Sun computers. The CDC 7600 and ETA 10
versions are obsolete and are no longer supported. It is written
mainly in ANSI standard FORTRAN 77, but it does contain some
extensions except in the ANSI version. The code is maintained with a
combination of RCS, the Revision Control System, and the Patchy code
management system, which is part of the CERN Library. The original
sources are kept on physgi01.phy.bnl.gov in
\verb|~isajet/isalibrary/RCS|; decks revised in release \verb|n.nn|
are kept in \verb|~isajet/isalibrary/nnn|. ISAJET is supplied to BNL,
CERN, Fermilab, and SLAC; it is also available from
\begin{verbatim}
http://www.phy.bnl.gov/~isajet
ftp://ftp.phy.bnl.gov/pub/isajet
\end{verbatim}
or by request from the authors.

      Patch ISAPLT contains the skeleton of an HBOOK histogramming
job, a trivial calorimeter simulation, and a jet-finding algorithm.
(The default is HBOOK4; HBOOK3 can be selected with a Patchy switch.)
These are provided for convenience only and are not supported.
+EOD
+DECK,PHYSICS
\newpage
\section{Physics\label{PHYSICS}}

      ISAJET is a Monte Carlo program which simulates $pp$, $\bar pp$
and $e^+e^-$ interactions at high energy. 
The program incorporates
perturbative QCD cross sections, initial state and final state QCD
radiative corrections in the leading log approximation, independent
fragmentation of quarks and gluons into hadrons, and a
phenomenological model tuned to minimum bias and hard scattering data
for the beam jets.

\subsection{Hard Scattering\label{hard}}

      The first step in simulating an event is to generate a primary
hard scattering according to some QCD cross section. This has the
general form
$$
\sigma = \sigma_0  F(x_1,Q^2) F(x_2,Q^2)
$$
where $\sigma_0$ is a cross section calculated in QCD perturbation
theory, $F(x,Q^2)$ is a structure function incorporating QCD scaling
violations, $x_1$ and $x_2$ are the usual parton model momentum
fractions, and $Q^2$ is an appropriate momentum transfer scale.

      For each of the processes included in ISAJET, the basic cross
section $\sigma_0$ is a two-body one, and the user can set limits on
the kinematic variables and type for each of the two primary jets. For
DRELLYAN and WPAIR events the full matrix element for the decay of the
W's into leptons or quarks is also included.

      The following processes are available:

\subsubsection{Minbias} No hard scattering at all, so that the event
consists only of beam jets. Note that at high energy the jet cross
sections become large. To represent the total cross section it is
better to use a sample of TWOJET events with the lower limit on pt
chosen to give a cross section equal to the inelastic cross section or
to use a mixture of MINBIAS and TWOJET events.

\subsubsection{Twojet} All order $\alpha_s^2$ QCD processes, which
give rise in lowest order to two high-$p_t$ jets. Included are, e.g.
\begin{eqnarray*}
g + g &\to& g + g\\
g + q &\to& g + q \\
g + g &\to& q + \bar q
\end{eqnarray*}
Masses are neglected for $c$ and lighter quarks but are taken into
account for $b$ and $t$ quarks. The $Q^2$ scale is taken to be
$$
Q^2 = 2stu/(s^2+t^2+u^2)
$$
The default parton distributions are those of the CTEQ Collaboration,
fit CTEQ5L, using lowest order QCD evolution. A few older sets of parton
distributions are included. There is also an interface to the CERN
PDFLIB compilation of parton distributions. Note that structure
functions for heavy quarks are included, so that processes like
$$
g + t \to g + t
$$
can be generated. The Duke-Owens parton distributions do not contain b
or t quarks.

      Since the $t$ is so heavy, it decays before it can hadronize, so
instead of $t$ hadrons a $t$ quark appears in the particle list. It is
decayed using the $V-A$ matrix element including the $W$ propagator
with a nonzero width, so the same decays should be used for $m_t < m_W$
and $m_t > m_W$; the $W$ should {\it not} be listed as part of the decay
mode.  The partons are then evolved and fragmented as usual; see
below. The real or virtual $W$ and the final partons from the decay,
including any radiated gluons, are listed in the particle table,
followed by their fragmentation products.  Note that for semileptonic
decays the leptons appear twice: the lepton parton decays into a
single particle of the same type but in general somewhat different
momentum. In all cases only particles with $\verb|IDCAY| = 0$ should be
included in the final state.

      A fourth generation $x,y$ is also allowed. Fourth generation
quarks are produced only by gluon fusion. Decay modes are not included
in the decay table; for a sequential fourth generation they would be
very similar to the t decays. In decays involving quarks, it is
essential that the quarks appear last.

\subsubsection{Drellyan} Production of a $W$ in the standard model,
including a virtual $\gamma$, a $W^+$, a $W^-$, or a $Z^0$, and its
decay into quarks or leptons. If the transverse momentum QTW of the
$W$ is fixed equal to zero then the process simulated is
\begin{eqnarray*}
q + \bar q \to W &\to& q + \bar q \\
                 &\to& \ell + \bar\ell
\end{eqnarray*}
Thus the $W$ has zero transverse momentum until initial state QCD
corrections are taken into account. If non-zero limits on the
transverse momentum $q_t$ for the $W$ are set, then instead the
processes
\begin{eqnarray*}
q + \bar q &\to& W + g \\
g + q      &\to& W + q
\end{eqnarray*}
are simulated, including the full matrix element for the $W$ decay.
These are the dominant processes at high $q_t$, but they are of course
singular at $q_t=0$. A cutoff of the $1/q_t^2$ singularity is made by
the replacement
$$
1/q_t^2 \to 1/\sqrt{q_t^4+q_{t0}^4} \quad q_{t0}^2 =  (.2\,\GeV) M
$$
This cutoff is chosen to reproduce approximately the $q_t$ dependence
calculated by the summation of soft gluons and to give about the right
integrated cross section. Thus this option can be used for low as well
as high transverse momenta.

      The scale for QCD evolution is taken to be proportional to the
mass for lowest order Drell-Yan and to the transverse momentum for
high-$p_t$ Drell-Yan. The constant is adjusted to get reasonable
agreement with the $W + n\,{\rm jet}$ cross sections calculated from
the full QCD matrix elements by F.A. Berends, et al., Phys.\ 
Lett.\ B224, 237 (1989).

      For the processes $g + b \to W + t$ and $g + t \to Z + t$, cross
sections with a non-zero top mass are used for the production and the
$W/Z$ decay. These were calculated using FORM 1.1 by J.~Vermaseren. The
process $g + t \to W + b$ is {\it not} included. Both $g + b \to W^- +
t$ and $g + \bar t \to W^- + \bar b$ of course give the same $W^- + t
+ \bar b$ final state after QCD evolution. While the latter process is
needed to describe the $m_t = 0$(!) mass singularity for $q_t \gg
m_t$, it has a pole in the physical region at low $q_t$ from on-shell
$t \to W + b$ decays. There is no obvious way to avoid this without
introducing an arbitrary cutoff.  Hence, selecting only $W + b$ will
produce a zero cross section. The $Q^2$ scale for the parton
distributions in these processes is replaced by $Q^2 + m_t^2$; this
seems physically sensible and prevents the cross sections from
vanishing at small $q_t$.

\subsubsection{Photon} Single and double photon production through the
lowest order QCD processes
\begin{eqnarray*}
g + q &\to& \gamma + q \\
q + \bar q &\to& \gamma + g \\
q + \bar q &\to& \gamma + \gamma
\end{eqnarray*}
Higher order corrections are not included. But $\gamma$'s, $W$'s, and
$Z$'s are radiated from final state quarks in all processes, allowing
study of the bremsstrahlung contributions.

\subsubsection{Wpair} Production of pairs of W bosons in the standard
model through quark-antiquark annihilation,
\begin{eqnarray*}
q + \bar q &\to& W^+ + W^- \\
           &\to& Z^0 + Z^0 \\
           &\to& W^+ + Z^0, W^- + Z^0 \\
           &\to& W^+ + \gamma, W^- + \gamma \\
           &\to& Z^0 + \gamma
\end{eqnarray*}
The full matrix element for the W decays, calculated in the narrow
resonance approximation, is included. However, the higher order
processes, e.g.
$$
q + q \to q + q + W^+ + W^-
$$
are ignored, although they in fact dominate at high enough mass.
Specific decay modes can be selected using the WMODEi keywords.

\subsubsection{Higgs} Production and decay of the standard model Higgs
boson. The production processes are
\begin{eqnarray*}
g + g      &\to& H \quad\hbox{(through a quark loop)} \\
q + \bar q &\to& H \quad\hbox{(with $t + \bar t$ dominant)} \\
W^+ + W^-  &\to& H \quad\hbox{  (with longitudinally polarized $W$)} \\
Z^0 + Z^0  &\to& H \quad\hbox{ (with longitudinally polarized $Z$)}
\end{eqnarray*}
If the (Standard Model) Higgs is lighter than $2 M_W$, then it will
decay into pairs of fermions with branching ratios proportional to
$m_f^2$. If it is heavier than $2 M_W$, then it will decay primarily
into $W^+ W^-$ and $Z^0 Z^0$ pairs with widths given approximately by
\begin{eqnarray*}
\Gamma(H \to W^+ W^-) &=& {G_F M_H^3 \over 8 \pi \sqrt{2} } \\
\Gamma(H \to Z^0 Z^0) &=& {G_F M_H^3 \over 16 \pi \sqrt{2} }
\end{eqnarray*}
Numerically these give approximately
$$
\Gamma_H = 0.5\,{\rm TeV} \left({M_H \over 1\,{\rm TeV}}\right)^3
$$
The width proportional to $M_H^3$ arises from decays into longitudinal
gauge bosons, which like Higgs bosons have couplings proportional to
mass.

      Since a heavy Higgs is wide, the narrow resonance approximation is
not valid. To obtain a cross section with good high energy behavior, it
is necessary to include a complete gauge-invariant set of graphs for the
processes
\begin{eqnarray*}
W^+ W^- &\to& W^+ W^- \\
W^+ W^- &\to& Z^0 Z^0 \\
Z^0 Z^0 &\to& W^+ W^- \\
Z^0 Z^0 &\to& Z^0 Z^0
\end{eqnarray*}
with longitudinally polarized $W^+$, $W^-$, and $Z^0$ bosons in the
initial state. This set of graphs and the corresponding angular
distributions for the $W^+$, $W^-$, and $Z^0$ decays have been
calculated in the effective $W$ approximation and included in HIGGS.
The $W$ structure functions are obtained by integrating the EHLQ
parameterization of the quark ones term by term. The Cabibbo-allowed
branchings
\begin{eqnarray*}
q &\to& W^+ + q' \\
q &\to& W^- + q' \\
q &\to& Z^0 + q
\end{eqnarray*}
are generated by backwards evolution, and the standard QCD evolution is
performed. This correctly describes the $W$ collinear singularity and
so contains the same physics as the effective $W$ approximation.

      If the Higgs is lighter than $2M_W$, then its decay to
$\gamma\gamma$ through $W$ and $t$ loops may be important. This is
also included in the HIGGS process and may be selected by choosing
\verb|GM| as the jet type for the decay.

      If the Higgs has $M_Z < M_H < 2M_Z$, then decays into one real
and one virtual $Z^0$ are generated if the \verb|Z0 Z0| decay mode is
selected, using the calculation of Keung and Marciano, Phys.\ Rev.\
D30, 248 (1984). Since the calculation assumes that one $Z^0$ is
exactly on shell, it is not reliable within of order the $Z^0$ width
of $M_H = 2M_Z$; Higgs and and $Z^0 Z^0$ masses in this region should
be avoided. The analogous Higgs decays into one real and one virtual
charged W are not included.

      Note that while HIGGS contains the dominant graphs for Higgs
production and graphs for $W$ pair production related by gauge invariance,
it does not contain the processes
\begin{eqnarray*}
q + \bar q &\to& W^+ W^- \\
q + \bar q &\to& Z^0 Z^0
\end{eqnarray*}
which give primarily transverse gauge bosons. These must be generated
with WPAIR.

      If the \verb|MSSMi| or \verb|SUGRA| keywords are used with
HIGGS, then one of the three MSSM neutral Higgs is generated instead
using gluon-gluon and quark-antiquark fusion with the appropriate SUSY
couplings. Since heavy CP even SUSY Higgs are weakly coupled to W
pairs and CP odd ones are completely decoupled, $WW$ fusion and $WW
\to WW$ scattering are not included in the SUSY case. ($WW \to WW$ can
be generated using the Standard Model process with a light Higgs mass,
say 100 GeV.) The MSSM Higgs decays into both Standard Model and SUSY
modes as calculated by ISASUSY are included. For more discussion see
the SUSY subsection below and the writeup for ISASUSY. The user must
select which Higgs to generate using HTYPE; see Section 6 below. If a
mass range is not specified, then the range mass $M_H \pm 5\Gamma_H$
is used by default. (This cannot be done for the Standard Model Higgs
because it is so wide for large masses.) Decay modes may be selected
in the usual way.

\subsubsection{WHiggs} Generates associated production of gauge and
Higgs bosons, i.e.,
$$
q + \bar q \to H + W, H + Z\,,
$$
in the narrow resonance approximation. The desired subprocesses can be
selected with JETTYPEi, and specific decay modes of the $W$ and/or $Z$
can be selected using the WMODEi keywords. Standard Model couplings are
assumed unless SUSY parameters are specified, in which case the SUSY
couplings are used.

\subsubsection{SUSY} Generates pairs of supersymmetric particles from
gluon-quark or quark-antiquark fusion. If the MSSMi or SUGRA parameters
defined in Section 6 below are not specified, then only gluinos and
squarks are generated:
\begin{eqnarray*}
g + g      &\to& \tilde g + \tilde g \\
q + \bar q &\to& \tilde g + \tilde g \\
g + q      &\to& \tilde g + \tilde q \\
g + g      &\to& \tilde q + \tilde{\bar q} \\
q + \bar q &\to& \tilde q + \tilde{\bar q} \\
q + q      &\to& \tilde q + \tilde q
\end{eqnarray*}
Left and right squarks are distinguished but assumed to be degenerate.
Masses can be specified using the \verb|GAUGINO|, \verb|SQUARK|, and
\verb|SLEPTON| parameters described in Section 6. No decay modes are
specified, since these depend strongly on the masses. The user can
either add new modes to the decay table (see Section 9) or use the
\verb|FORCE| or \verb|FORCE1| commands (see Section 6).

      If \verb|MSSMA|, \verb|MSSMB|, and \verb|MSSMC| are specified,
then the ISASUSY package is used to calculate the masses and decay
modes in the minimal supersymmetric extension of the standard model
(MSSM), assuming SUSY grand unification constraints in the neutralino
and chargino mass matrix but allowing some additional flexibility in
the masses. The scalar particle soft masses are input via
\verb|MSSMi|, so that the physical masses will be somewhat different
due to $D$-term contributions and mixings for 3rd generation sparticles.
$\tilde t_1$ and $\tilde t_2$ production and decays are now included.
The lightest SUSY particle is assumed to be the lightest neutralino
$\tilde Z_1$. If the \verb|MSSMi| parameters are specified, then the
following additional processes are included using the MSSM couplings
for the production cross sections:
\begin{eqnarray*}
g + q    &\to& \tilde Z_i + \tilde q, \quad \tilde W_i + \tilde q \\
q + \bar q &\to& \tilde Z_i + \tilde g, \quad \tilde W_i + \tilde g \\
q + \bar q &\to& \tilde W_i + \tilde Z_j \\
q + \bar q &\to& \tilde W_i^+ + \tilde W_j^- \\
q + \bar q &\to& \tilde Z_i + \tilde Z_j \\
q + \bar q &\to& \tilde\ell^+ + \tilde\ell^-, \quad \tilde\nu + \tilde\nu
\end{eqnarray*}
Processes can be selected using the optional parameters described in
Section 6 below.

      Beginning with Version 7.42, matrix elements are taken into
account in the event generator as well as in the calculation of decay
widths for MSSM three-body decays of the form $\tilde A \to \tilde B f
\bar f$, where $\tilde A$ and $\tilde B$ are gluinos, charginos, or
neutralinos. This is implemented by having ISASUSY save the poles and
their couplings when calculating the decay width and then using these
to reconstruct the matrix element. Other three-body decays may be
included in the future. Decays selected with \verb|FORCE| use the
appropriate matrix elements.

      An optional keyword \verb|MSSMD| can be used to specify the second
generation masses, which otherwise are assumed degenerate with the first
generation. An optional keyword \verb|MSSME| can be used to specify
values of the $U(1)$ and $SU(2)$ gaugino masses at the weak scale rather
than using the default grand unification values. The chargino and
neutralino masses and mixings are then computed using these values.

\subsubsection{SUSY Models} The 24 MSSMi parameters describe the MSSM at
the weak scale with the additional assumptions of exact flavor and $CP$
conservation; the general MSSM has 105 parameters. These weak-scale
SUSY-breaking parameters presumably arise from spontaneous SUSY breaking
in a hidden sector that is communicated to the MSSM at some scale $M \gg
M_Z$. There are a number of plausible models in which this symmetry
breaking is simple, so that the MSSM at the high scale involves only a
small number of parameters. These are then related to those at the weak
scale by the renormalization group equations (RGE's).

      Isajet therefore implements in subroutine SUGRA the complete
2-loop RGE's for the gauge couplings, Yukawa couplings, and soft
breaking terms. Contributions from right-handed neutrinos are
optionally included. The RGE's are solved iteratively, running from
the weak scale to the high scale $M$ and back using Runge-Kutta
integration. After each iteration the SUSY masses are recalculated,
and the renormalization group improved 1-loop corrected 
Higgs potential is calculated and minimized. These results are
used to modify the RGE $\beta$-functions appropriately as each
threshold is crossed during the next iteration. Beginning with Version
7.65, the constant parts as well as the logarithms from these
thresholds are included using the results of Pierce {\it et al.},
Nucl.\ Phys.\ {\bf B491}, 3 (1997). The whole process is repeated,
increasing the number of Runge-Kutta steps by a factor of 1.2 for each
iteration, until all the RGE variables except $\mu$ and $B$ differ by
less than 0.3\%. Since $\mu$ and $B$ vary rapidly near the weak scale,
they are only required to differ by less than 5\%. The requirement of
good electroweak symmetry breaking, $\mu^2>0$, is only imposed after
the iterative solution has converged.

\medskip

      A number of different models for SUSY breaking at the high scale
are included in ISAJET. The \verb|SUGRA| parameters must be
specified for the
minimal supergravity framework. This assumes that the gauge couplings
unify at the GUT scale, $M \sim 10^{16}\,{\rm GeV}$, defined by
$\alpha_2=\alpha_1$. SUSY breaking occurs at that scale with universal
soft breaking terms produced by gravitational interactions with a hidden
sector. The parameters of the model are
\begin{itemize}
\item $m_0$: the common scalar mass at the GUT scale;
\item $m_{1/2}$: the common gaugino mass at the GUT scale;
\item $A_0$: the common soft trilinear SUSY breaking parameter at the
GUT scale;
\item $\tan\beta$: the ratio of Higgs vacuum expectation values at the
electroweak scale;
\item $\sgn\mu=\pm1$: the sign of the Higgsino mass term.
\end{itemize}
An attractive feature of this model is that the Higgs are unified with
the other scalars at the GUT scale but $m_{H_u}^2$ is driven negative by
the large top Yukawa coupling $f_t$. Isajet imposes this radiative
symmetry breaking for the SUGRA model but not other possible constraints
such as $b$-$\tau$ unification or limits on proton decay.

      The SUGRA model with exact compling constant unification produces
too large a value of $\alpha_s$ at the weak scale. The default is to use
the experimental value, assuming that threshold effects at the GUT scale
produce this. Exact unification can also be imposed.

      The assumption of universality at the GUT scale is rather
restrictive and may not be valid. A variety of non-universal SUGRA
(NUSUGRA) models can be generated using the \verb|NUSUG1|, \dots,
\verb|NUSUG5| keywords. These might be used to study how well one could
test the minimal SUGRA model. The keyword \verb|SSBCSC| can be used to
specify an alternative scale (i.e., not the coupling constant
unification scale) for the RGE boundary conditions.
A SUGRA model with non-universal Higgs masses $m_{H_u}$ and $m_{H_d}$
which are determined via input of weak scale parameters $\mu$
and $m_A$ can be input using the \verb|NUHM| keyword.

\medskip

      An alternative to the SUGRA model is the Gauge Mediated SUSY
Breaking (GMSB) model of Dine, Nelson, and collaborators. In this model
SUSY breaking is communicated through gauge interactions with messenger
fields at a scale $M_m$ small compared to the Planck scale and are
proportional to gauge couplings times $\Lambda_m$. Since $M_m$ is small
and the masses at it are the same for each generation, there are no
flavor changing neutral currents. The messenger fields should form
complete $SU(5)$ representations to preserve the unification of the
coupling constants. The parameters of the GMSB model, which are
specified by the \verb|GMSB| keyword, are
\begin{itemize}
\item $\Lambda_m = F_m/M_m$: the scale of SUSY breaking, typically
10--$100\,{\rm TeV}$;
\item $M_m > \Lambda_m$: the messenger mass scale; 
\item $N_5$: the equivalent number of $5+\bar5$ messenger fields.
\item $\tan\beta$: the ratio of Higgs vacuum expectation values at the
electroweak scale;
\item $\sgn\mu=\pm1$: the sign of the Higgsino mass term;
\item $C_{\rm grav}\ge1$: the ratio of the gravitino mass to the value it
would have had if the only SUSY breaking scale were $F_m$.
\end{itemize}
In GMSB models the lightest SUSY particle is always the nearly massless
gravitino $\tilde G$. The parameter $C_{\rm grav}$ scales the gravitino
mass and hence the lifetime of the next lightest SUSY particle to decay
into it. The \verb|NOGRAV| keyword can be used to turn off gravitino
decays. 

      A variety of non-minimal GMSB models can be generated using
additional parameters set with the GMSB2 keyword. These additional
parameters are
\begin{itemize}
\item $\slashchar{R}$, an extra factor multiplying the gaugino masses
at the messenger scale. (Models with multiple spurions generally have
$\slashchar{R}<1$.)
\item $\delta M_{H_d}^2$, $\delta M_{H_u}^2$, Higgs mass-squared
shifts relative to the minimal model at the messenger scale. (These
might be expected in models which generate $\mu$ realistically.)
\item $D_Y(M)$, a $U(1)_Y$ messenger scale mass-squared term
($D$-term) proportional to the hypercharge $Y$.
\item $N_{5_1}$, $N_{5_2}$, and $N_{5_3}$, independent numbers of
gauge group messengers. They can be non-integer in general.
\end{itemize}
For discussions of these additional parameters, see S. Dimopoulos, S.
Thomas, and J.D. Wells, hep-ph/9609434, Nucl.\ Phys.\ {\bf B488}, 39
(1997), and S.P. Martin, hep-ph/9608224, Phys.\ Rev.\ {\bf D55}, 3177
(1997).

      Gravitino decays can be included in the general MSSM framework by
specifying a gravitino mass with \verb|MGVTNO|. The default is that such
decays do not occur.

\medskip

     Another alternative SUSY model choice allowed is anomaly-mediated
SUSY breaking, developed by Randall and Sundrum.  In this model, it is
assumed that SUSY breaking takes place in other dimensions, and SUSY
breaking is communicated to the visible sector via the superconformal
anomaly. In this model, the lightest SUSY particle is usually the
neutralino which is nearly pure wino-like. The chargino is nearly mass
degenerate with the lightest neutralino. It can be very long lived, or
decay into a very soft pion plus missing energy.  The model incorporated
in ISAJET, based on work by Ghergetta, Giudice and Wells
(hep-ph/9904378), and by Feng and Moroi (hep-ph/9907319) adds a
universal contribution $m_0^2$ to all scalar masses to avoid problems
with tachyonic scalars. The parameters of the model, which can be set
via the \verb|AMSB| keyword, are
\begin{itemize}
\item	$m_0$: Common scalar mass;
\item 	$m_{3/2}$: Gravitino mass, typically $\simge 10\,{\rm TeV}$ since 
$m_i = (\beta_i/g_i) m_{3/2}$.
\item	$\tan\beta$: Usual ratio of vev's at weak scale;
\item	$\sgn\mu$: Usual sign of $\mu$, $\pm1$.
\end{itemize}
Care should be taken with the chargino decay, since it may have
macroscopic decay lengths, or even decay outside the detector.
A variety of non-minimal AMSB models can be generated by using the
AMSB2 keyword, which allows input of $c_f$ multipliers of 
the $m_0^2$ contribution to 
sfermion masses: $m_{\tilde f}^2=m_{\tilde f}^2(AMSB)+c_f m_0^2$, 
for $f=Q,D,U,L,E,H_d$ and $H_u$.

\medskip

     Since neutrinos seem to have mass, the effect of a massive
right-handed neutrino has been included in ISAJET, when calculating the
sparticle mass spectrum. If the keyword \verb|SUGRHN| is used, then the
user must input the 3rd generation neutrino mass (at scale $M_Z$) in
units of GeV, and the intermediate scale right handed neutrino Majorana
mass $M_N$, also in GeV. In addition, one must specify the soft
SUSY-breaking masses $A_n$ and $m_{\tilde\nu_R}$ valid at the GUT scale.
Then the neutrino Yukawa coupling is computed in the simple see-saw
model, and renormalization group evolution includes these effects
between $M_{GUT}$ and $M_N$. Finally, to facilitate modeling of $SO(10)$
SUSY-GUT models, loop corrections to 3rd generation fermion masses have
been included in the ISAJET SUSY models.

\bigskip\bigskip

      The ISASUSY program can also be used independently of the rest of
ISAJET, either to produce a listing of decays or in conjunction with
another event generator. Its physics assumptions are described in more
detail in Section~\ref{SUSY}. ISASUSY accepts soft SUSY breaking
parameters at the weak scale and calculates the masses and decay modes
from them. The ISASUGRA program can also be used independently to solve
the renormalization group equations with SUGRA, NUSUGRA, GMSB, or AMSB
boundary conditions and then to call ISASUSY to calculate the decay
modes. The main programs described in Section~\ref{sugrun} prompt for
interactive input and print the results to a file.

      Generally the MSSM, SUGRA, or GMSB option should be used to study
supersymmetry signatures; the SUGRA or GMSB parameter space is clearly
more manageable. The more general option may be useful to study
alternative SUSY models. It can also be used, e.g., to generate
pointlike color-3 leptoquarks in technicolor models by selecting squark
production and setting the gluino mass to be very large. The MSSM or
SUGRA option may also be used with top pair production to simulate top
decays to SUSY particles.

\subsubsection{$e^+e^-$} An $e^+e^-$ event generator is also included in
ISAJET. The
Standard Model processes included are $e^+e^-$ annihilation through
$\gamma$ and $Z$ to quarks and leptons, and production of $W^+W^-$ and
$Z^0Z^0$ pairs. In contrast to WPAIR and HIGGS for the hadronic
processes, the produced $W$'s and $Z$'s are treated as particles, so
their spins are not properly taken into account in their decays.
(Because the $W$'s and $Z$'s are treated as particles, their decay
modes can be selected using \verb|FORCE| or \verb|FORCE1|, not
\verb|WMODEi|. See Section [6] below.)  Other Standard Model
processes, including $e^+ e^- \to e^+ e^-$ ($t$-channel graph) 
are not included.  Once the primary reaction has been
generated, QCD radiation and hadronization are done as for hadronic
processes. 

The $e^+e^-$ generator can be run assuming no initial state
radiation (the default), or an initial state electron structure function
can be used for bremsstrahlung or the combination bremsstrahlung/beamstrahlung
effect. Bremsstrahlung is implemented using the Fadin-Kuraev
$e^-$ distribution function, and can be turned on using the \verb|EEBREM|
command while stipulating the minimal and maximal subprocess energy.
Beamstrahlung is implemented by invoking the \verb|EEBEAM| keyword.
In this case, in addition the beamstrahlung parameter $\Upsilon$ and
longitudinal beam size $\sigma_z$ (in mm) must be given.
The definition for $\Upsilon$ in terms of other beam parameters can be 
found in the article Phys. Rev. D49, 3209 (1994) by Chen, Barklow and Peskin.
The bremsstrahlung structure function is then convoluted with the 
beamstrahlung distribution (as calculated by M. Peskin) and a spline fit
is created. Since the cross section can contain large spikes, event generation
can be slow if a huge range of subprocess energy is selected for light 
particles; in these scenarios, \verb|NTRIES| must be increased well beyond
the default value.
In Isajet 7.70 and beyond, $e^+e^-\to\gamma\gamma\to f\bar{f}$ 
($f$ is a SM fermion) processes are included, via Peskin's 
photon structure function from brem- and beamstrahlung. These
gamma-gamma induced processes are activated by stipulating the keyword
\verb|GAMGAM| to be \verb|.TRUE.|, when running with \verb|EEBEAM|.
Since the photon structure function is so highly peaked at low $x$, 
it is wise to use \verb|GAMGAM| with only one subprocess at a time, 
a large number for \verb|NTRIES|, and to
use a judicious range of subprocess CM energies in \verb|EEBEAM|.

      $e^+e^-$ annihilation to SUSY particles is included as well with
complete lowest order diagrams, and cascade decays.  The processes
include
\begin{eqnarray*}
e^+ e^- &\to& \tilde q \tilde q \\
e^+ e^- &\to& \tilde\ell \tilde\ell \\
e^+ e^- &\to& \tilde W_i \tilde W_j \\
e^+ e^- &\to& \tilde Z_i \tilde Z_j \\
e^+ e^- &\to& H_L^0+Z^0,H_H^0+Z^0,H_A^0+H_L^0,H_A^0+H_H^0,H^++H^-
\end{eqnarray*}
Note that SUSY Higgs production via $WW$ and $ZZ$ fusion, which can
dominate Higgs production processes at $\sqrt{s} > 500\,\GeV$,
is not included. Spin correlations are neglected, although 
3-body sparticle decay matrix elements are included.

      $e^+e^-$ cross sections with polarized beams are included for
both Standard Model and SUSY processes. The keyword \verb|EPOL| is
used to set $P_L(e^-)$ and $P_L(e^+)$, where
$$
P_L(e) = (n_L-n_R)/(n_L+n_R)
$$
so that $-1 \le P_L \le +1$. Thus, setting \verb|EPOL| to $-.9,0$ will
yield a 95\% right polarized electron beam scattering on an unpolarized
positron beam.

\subsubsection{Technicolor} Production of a technirho of arbitrary
mass and width decaying into $W^\pm Z^0$ or $W^+ W^-$ pairs. The cross
section is based on an elastic resonance in the $WW$ cross section
with the effective $W$ approximation plus a $W$ mixing term taken from
EHLQ.  Additional technicolor processes may be added in the future.

\subsubsection{Extra Dimensions} The possibility that there might be
more than four space-time dimensions at a distance scale $R$ much larger
than $G_N^{1/2}$ has recently attracted interest. In these theories,
$$ 
G_N = {1 \over 8\pi R^\delta M_D^{2+\delta}}\,, 
$$
where $\delta$ is the number of extra dimensions and $M_D$ is the
$4+\delta$ Planck scale. Gravity deviates from the standard theory at a
distance $R \sim 10^{22/\delta-19}\,{\rm m}$, so $\delta\ge2$ is
required. If $M_D$ is of order $1\,{\rm TeV}$, then the usual heirarchy
problem is solved, although there is then a new heirarchy problem of why
$R$ is so large.

      In such models the graviton will have many Kaluza-Klein
excitations with a mass splitting of order $1/R$. While any individual
mode is suppressed by the four-dimensional Planck mass, the large number
of modes produces a cross section suppressed only by $1/M_D^2$. The
signature is an invisible massive graviton plus a jet, photon, or other
Standard Model particle. The \verb|EXTRADIM| process implements this
reaction using the cross sections of Giudice, Rattazzi, and Wells,
hep-ph/9811291. The number $\delta$ of extra dimensions, the mass scale
$M_D$, and the logical flag \verb|UVCUT| are specified using the keyword
\verb|EXTRAD|. If \verb|UVCUT| is \verb|TRUE|, the cross section is cut
off above the scale $M_D$; the model is not valid if the results depend
on this flag.

\subsection{Multiparton Hard Scattering}

      All the processes listed in Section~\ref{hard} are either $2\to2$
processes like \verb|TWOJET| or $2\to1$ $s$-channel resonance processes
followed by a 2-body decay like \verb|DRELLYAN|. The QCD parton shower
described in Section~\ref{qcdshower} below generates multi-parton final
states starting from these, but it relies on an approximation which is
valid only if the additional partons are collinear either with the
initial or with the final primary ones. Since the QCD shower uses exact
non-colliear kinematics, it in fact works pretty well in a larger region
of phase space, but it is not exact.

      Non-collinear multiparton final states are interesting both in
their own right and as backgrounds for other signatures. Both the matrix
elements and the phase space for multiparton processes are complicated;
they have been incorporated into ISAJET for the first time in
Version~7.45. To calculate the matrix elements we have used the MadGraph
package by Stelzer and Long, Comput.\ Phys.\ Commun.\ {\bf81}, 357
(1994), hep-ph/9401258. This automatically generates the amplitude using
\verb|HELAS|, a formalism by Murayama, Watanabe, and Hagiwarak
KEK-91-11, that calculates the amplitude for any Feynman diagram in
terms of spinnors, vertices, and propagators. The MadGraph code has been
edited to incorporate summations over quark flavors. To do the phase
space integration, we have used a simple recursive algorithm to generate
$n$-body phase space. We have included limits on the total mass of the
final state using the \verb|MTOT| keyword. Limits on the $p_T$ and
rapidity of each final parton can be set via the \verb|PT| and \verb|Y|
keyworks, while limits on the mass of any pair of final partons can be
set via the \verb|MIJTOT| keyword. These limits are sufficient to shield
the infrared and collinear singularities and to render the result
finite. However, the parton shower populates all regions of phase space,
so careful thought is needed to combine the parton-shower based and
multiparton based results.

      While the multiparton formalism is rather general, it still takes
a substantial amount of effort to implement any particular process. So
far only one process has been implemented.

\subsubsection{$Z + {\rm 2\ jets}$} The \verb|ZJJ| process generates a
$Z$ boson plus two jets, including the $q\bar{q} \to Z q \bar{q}$, $gg
\to Z q\bar{q}$, $q\bar{q} \to Zgg$, $qq \to Zqq$, and $gq \to Z gq$
processes. The $Z$ is defined to be jet 1; it is treated in the narrow
resonance approximation and is decayed isotropically. The quarks,
antiquarks, and gluons are defined to be jets 2 and 3 and are
symmetrized in the usual way.

\subsection{QCD Radiative Corrections\label{qcdshower}}

      After the primary hard scattering is generated, QCD radiative
corrections are added to allow the possibility of many jets. This is
essential to get the correct event structure, especially at high
energy.

      Consider the emission of one extra gluon from an initial or a
final quark line,
$$
q(p) \to q(p_1) + g(p_2)
$$
From QCD perturbation theory, for small $p^2$ the cross section is
given by the lowest order cross section multiplied by a factor
$$
\sigma = \sigma_0  \alpha_s(p^2)/(2\pi p^2) P(z)
$$
where $z=p_1/p$ and $P(z)$ is an Altarelli-Parisi function. The same
form holds for the other allowed branchings,
\begin{eqnarray*}
g(p) &\to& g(p_1) + g(p_2) \\
g(p) &\to& q(p_1) + \bar q(p_2)
\end{eqnarray*}
These factors represent the collinear singularities of perturbation
theory, and they produce the leading log QCD scaling violations for the
structure functions and the jet fragmentation functions. They also
determine the shape of a QCD jet, since the jet $M^2$ is of order
$\alpha_s p_t^2$ and hence small.

      The branching approximation consists of keeping just these
factors which dominate in the collinear limit but using exact,
non-collinear kinematics. Thus higher order QCD is reduced to a
classical cascade process, which is easy to implement in a Monte Carlo
program. To avoid infrared and collinear singularities, each parton in
the cascade is required to have a mass (spacelike or timelike) greater
than some cutoff $t_c$. The assumption is that all physics at lower
scales is incorporated in the nonperturbative model for hadronization.
In ISAJET the cutoff is taken to be a rather large value,
$(6\,\GeV)^2$, because independent fragmentation is used for the jet 
fragmentation; a low cutoff would give too many hadrons from
overlapping partons. It turns out that the branching approximation not
only incorporates the correct scaling violations and jet structure but
also reproduces the exact three-jet cross section within factors of
order 2 over all of phase space.

      This approximation was introduced for final state radiation by
Fox and Wolfram. The QCD cascade is determined by the probability for
going from mass $t_0$ to mass $t_1$ emitting no resolvable radiation.
For a resolution cutoff $z_c < z < 1-z_c$, this is given by a simple
expression,
$$      
P(t_0,t_1)=\left(\alpha_s(t_0)/\alpha_s(t_1)\right)^{2\gamma(z_c)/b_0}
$$
where
$$
\gamma(z_c)=\int_{z_c}^{1-z_c} dz\,P(z),\qquad
b_0=(33-2n_f)/(12\pi)
$$
Clearly if $P(t_0,t_1)$ is the integral probability, then $dP/dt_1$ is
the probability for the first radiation to occur at $t_1$. It is
straightforward to generate this distribution and then iteratively to
correct it to get a cutoff at fixed $t_c$ rather than at fixed $z_c$.

      For the initial state it is necessary to take account of the
spacelike kinematics and of the structure functions. Sjostrand has
shown how to do this by starting at the hard scattering and evolving
backwards, forcing the ordering of the spacelike masses $t$. The
probability that a given step does not radiate can be derived from the
Altarelli-Parisi equations for the structure functions. It has a form
somewhat similar to $P(t_0,t_1)$ but involving a ratio of the structure
functions for the new and old partons. It is possible to find a bound
for this ratio in each case and so to generate a new $t$ and $z$ as for
the final state. Then branchings for which the ratio is small are
rejected in the usual Monte Carlo fashion. This ratio suppresses the
radiation of very energetic partons. It also forces the branching $g
\to t + \bar t$ for a $t$ quark if the $t$ structure function vanishes
at small momentum transfer.

      At low energies, the branching of an initial heavy quark into a
gluon sometimes fails; these events are discarded and a warning is
printed.

      Since $t_c$ is quite large, the radiation of soft gluons is cut
off. To compensate for this, equal and opposite transverse boosts are
made to the jet system and to the beam jets after fragmentation with a
mean value
$$
\langle p_t^2\rangle = (.1\,\GeV) \sqrt{Q^2}
$$
The dependence on $Q^2$ is the same as the cutoff used for DRELLYAN and
the coefficient is adjusted to fit the $p_t$ distribution for the $W$.

      Radiation of gluons from gluinos and scalar quarks is also
included in the same approximation, but the production of gluino or
scalar quark pairs from gluons is ignored. Very little radiation is
expected for heavy particles produced near threshold.

      Radiation of photons, $W$'s, and $Z$'s from final state quarks is
treated in the same approximation as QCD radiation except that the
coupling constant is fixed. Initial state electroweak radiation is not
included; it seems rather unimportant. The $W^+$'s, $W^-$'s and $Z$'s
are decayed into the modes allowed by the \verb|WPMODE|, \verb|WMMODE|,
and \verb|Z0MODE| commands respectively. {\it Warning:} The branching
ratios implied by these commands are not included in the cross section
because an arbitrary number of $W$'s and $Z$'s can in principle be
radiated.

\subsection{Jet Fragmentation:}

      Quarks and gluons are fragmented into hadrons using the
independent fragmentation ansatz of Field and Feynman. For a quark
$q$, a new quark-antiquark pair $q_1 \bar q_1$ is generated with
$$
u : d : s = .43 : .43 : .14
$$
A meson $q \bar q_1$ is formed carrying a fraction $z$ of the momentum,
$$
E' + p_z' = z (E + p_z)
$$
and having a transverse momentum $p_t$ with $\langle p_t \rangle =
0.35\,\GeV$. Baryons are included by generating a diquark with
probability 0.10 instead of a quark; adjacent diquarks are not
allowed, so no exotic mesons are formed. For light quarks $z$ is
generated with the splitting function
$$
f(z) = 1-a + a(b+1)(1-z)^b, \qquad
a = 0.96, b = 3
$$
while for heavy quarks the Peterson form
$$
f(z) = x (1-x)^2 / ( (1-x)^2 + \epsilon x )^2
$$
is used with $\epsilon = .80 / m_c^2$ for $c$ and $\epsilon = .50 /
m_q^2$ for $q = b, t, y, x$. These values of $\epsilon$ have been
determined by fitting PEP, PETRA, and LEP data with ISAJET and should
not be compared with values from other fits. Hadrons with longitudinal
momentum less than zero are discarded. The procedure is then iterated
for the new quark $q_1$ until all the momentum is used. A gluon is
fragmented like a randomly selected $u$, $d$, or $s$ quark or
antiquark. 

      In the fragmentation of gluinos and scalar quarks, supersymmetric
hadrons are not distinguished from partons. This should not matter
except possibly for very light masses. The Peterson form for $f(x)$ is
used with the same value of epsilon as for heavy quarks, $\epsilon =
0.5 / m^2$.

      Independent fragmentation correctly describes the fast hadrons in
a jet, but it fails to conserve energy or flavor exactly. Energy
conservation is imposed after the event is generated by boosting the
hadrons to the appropriate rest frame, rescaling all of the
three-momenta, and recalculating the energies.

\subsection{Beam Jets}

      There is now experimental evidence that beam jets are different in
minimum bias events and in hard scattering events. ISAJET therefore uses
similar a algorithm but different parameters in the two cases.

      The standard models of particle production are based on pulling
pairs of particles out of the vacuum by the QCD confining field,
leading naturally to only short-range rapidity correlations and to
essentially Poisson multiplicity fluctuations. The minimum bias data
exhibit KNO scaling and long-range correlations. A natural explanation
of this was given by the model of Abramovskii, Kanchelli and Gribov.
In their model the basic amplitude is a single cut Pomeron with
Poisson fluctuations around an average multiplicity $\langle n
\rangle$, but unitarity then produces graphs giving $K$ cut Pomerons
with multiplicity $K\langle n \rangle$.

      A simplified version of the AKG model is used in ISAJET. The
number of cut Pomerons is chosen with a distribution adjusted to fit the
data. For a minimum bias event this distribution is
$$
P(K) = ( 1 + 4 K^2 ) \exp{-1.8 K}
$$
while for hard scattering
$$
P(1) \to 0.1 P(1),\quad  P(2) \to 0.2 P(2),\quad  P(3) \to 0.5 P(3)
$$
For each side of each event an $x_0$ for the leading baryon is selected
with a distribution varying from flat for $K = 1$ to like that for
mesons for large K:
$$
f(x) = N(K) (1- x_0)^c(K),\qquad c(K) = 1/K + ( 1 - 1/K ) b(s)
$$
The $x_i$ for the cut Pomerons are generated uniformly and then
rescaled to $1-x_0$. Each cut Pomeron is then hadronized in its own
center of mass using a modified independent fragmentation model with
an energy dependent splitting function to reproduce the rise in
$dN/dy$:
$$
f(x) = 1 - a  +  a(b(s) + 1)^ b(s),\qquad 
b(s) = b_0 + b_1  \log(s)
$$
The energy dependence is put into $f(x)$ rather than $P(K)$ because in
the AKG scheme the single particle distribution comes only from the
single chain. The probabilities for different flavors are taken to be
$$
u : d : s = .46 : .46 : .08
$$
to reproduce the experimental $K/\pi$ ratio.
+EOD
+DECK,SAMPLE
\newpage
\section{Sample Jobs\label{SAMPLE}}

      The simplest ISAJET job reads a user-supplied parameter file and
writes a data file and a listing file. The following is an example of
a parameter file which generates each type of event:
\begin{verbatim}
SAMPLE TWOJET JOB
800.,100,2,50/
TWOJET
PT
50,100,50,100/
JETTYPE1
'GL'/
JETTYPE2
'UP','UB','DN','DB','ST','SB'/
END
SAMPLE DRELLYAN JOB
800.,100,2,50/
DRELLYAN
QMW
80,100/
WTYPE
'W+','W-'/
END
SAMPLE MINBIAS JOB
800.,100,2,50/
MINBIAS
END
SAMPLE WPAIR JOB
800.,100,2,50/
WPAIR
PT
50,100,50,100/
JETTYPE1
'W+','W-','Z0'/
JETTYPE2
'W+','W-','Z0'/
WMODE1
'E+','E-','NUS'/
WMODE2
'QUARKS'/
END
SAMPLE HIGGS JOB FOR SSC
40000,100,1,1/
HIGGS
QMH
400,1600/
HMASS
800/
JETTYPE1
'Z0'/
JETTYPE2
'Z0'/
WMODE1
'MU+','MU-'/
WMODE2
'E+','E-'/
PT
50,20000,50,20000/
END
SAMPLE SUSY JOB
1800,100,1,10/
SUPERSYM
PT
50,100,50,100/
JETTYPE1
'GLSS','SQUARKS'/
JETTYPE2
'GLSS','SQUARKS'/
GAUGINO
60,1,40,40/
SQUARK
80.3,80.3,80.5,81.6,85,110/
FORCE
29,30,1,-1/
FORCE
21,29,1/
FORCE
22,29,2/
FORCE
23,29,3/
FORCE
24,29,4/
FORCE
25,29,5/
FORCE
26,29,6/
END
SAMPLE MSSM JOB FOR TEVATRON
1800.,100,1,1/
SUPERSYM
BEAMS
'P','AP'/
MSSMA
200,-200,500,2/
MSSMB
200,200,200,200,200/
MSSMC
200,200,200,200,200,0,0,0/
JETTYPE1
'GLSS'/
JETTYPE2
'SQUARKS'/
PT
100,300,100,300/
END
SAMPLE MSSM SUGRA JOB FOR LHC
14000,100,1,10/
SUPERSYM
PT
50,500,50,500/
SUGRA
247,302,-617.5,10,-1/
TMASS
175/
END
SAMPLE SUGRA HIGGS JOB USING DEFAULT QMH RANGE
14000,100,20,50/
HIGGS
SUGRA
200,200,0,2,+1/
HTYPE
'HA0'/
JETTYPE1
'GAUGINOS','SLEPTONS'/
JETTYPE2
'GAUGINOS','SLEPTONS'/
END
SAMPLE E+E- TO SUGRA JOB WITH POLARIZED BEAMS AND BREM/BEAMSTRAHLUNG
500.,100,1,1/
E+E-
SUGRA
125,125,0,3,1/
TMASS
175,-1,1/
EPOL
-.9,0./
EEBEAM
200.,500.,.1072,.12/
JETTYPE1
'ALL'/
JETTYPE2
'ALL'/
NTRIES
10000/
END
SAMPLE WH JOB
2000,100,0,0/
WHIGGS
BEAMS
'P','AP'/
HMASS
100./
JETTYPE1
'W+','W-','HIGGS'/
JETTYPE2
'W+','W-','HIGGS'/
WMODE1
'ALL'/
WMODE2
'ALL'/
PT
10,300,10,300/
END 
SAMPLE EXTRA DIMENSIONS JOB
14000,100,1,100/
EXTRADIM
QMW
5,1000/
QTW
500,1000/
EXTRAD
2,1000,.FALSE./
END
SAMPLE ZJJ JOB AT LHC
14000,100,1,100/
ZJJ
PT
20,7000,20,7000,20,7000/
MIJLIM
0,0,20,7000/
MTOT
100,500/
NSIGMA
200/
NTRIES
10000/
END
STOP
\end{verbatim}
\noindent See Section~\ref{INPUT} of this manual for a complete list
of the possible commands in a parameter file. Note that all input to
ISAJET must be in {\it UPPER} case only.

      Subroutine RDTAPE is supplied to read events from an ISAJET data
file, which is a machine-dependent binary file. It restores the event
data to the FORTRAN common blocks described in Section~\ref{OUTPUT}.
The skeleton of an analysis job using HBOOK and PAW from the CERN
Program Library is provided in patch ISAPLT but is not otherwise
supported. A Zebra output format based on code from the D0
Collaboration is also provided in patch ISAZEB; see the separate
documentation in patch ISZTEXT.

\subsection{DEC VMS}

      On a VAX or ALPHA running VMS, ISAJET can be compiled by
executing the .COM file contained in P=ISAUTIL,D=MAKEVAX. Extract this
deck as ISAMAKE.COM and type
\begin{verbatim}
@ISAMAKE
\end{verbatim}
This will run YPATCHY with the pilot patches described in
Section~\ref{PATCHY} and the VAX flag to extract the source code,
decay table, and documentation. The source code is compiled and made
into a library, which is linked with the following main program,
\begin{verbatim}
      PROGRAM ISARUN
C          MAIN PROGRAM FOR ISAJET
      OPEN(UNIT=1,STATUS='OLD',FORM='FORMATTED',READONLY)
      OPEN(UNIT=2,STATUS='NEW',FORM='UNFORMATTED')
      OPEN(UNIT=3,STATUS='OLD',FORM='FORMATTED')
      OPEN(UNIT=4,STATUS='NEW',FORM='FORMATTED')
      CALL ISAJET(-1,2,3,4)
      STOP
      END
\end{verbatim}
to produce ISAJET.EXE. Two other executables, ISASUSY.EXE and
ISASUGRA.EXE, will also be produced to calculate SUSY masses and decay
modes without generating events. Temporary files can be removed by
typing
\begin{verbatim}
@ISAMAKE CLEAN
\end{verbatim}

      Create an input file \verb|JOBNAME.PAR| following the examples
above or the instructions in Section~\ref{INPUT} and run ISAJET with
the command
\begin{verbatim}
@ISAJET JOBNAME
\end{verbatim}
using the ISAJET.COM file contained P=ISAUTIL,D=RUNVAX. This will
create a binary output file \verb|JOBNAME.DAT| and a listing file
\verb|JOBNAME.LIS|. Analyze the output data using the commands
described in Section~\ref{TAPE}.

      There is also an simple interactive interface to ISAJET which
will prompt the user for commands, write a parameter file, and
optionally execute it.

\subsection{IBM VM/CMS}

      On an IBM mainframe running VM/CMS, run YPATCHY with the pilot
patches described in Section~\ref{PATCHY} and the IBM flag to extract
the source code, decay table, and documentation. Compile the source
code and link it with the main program
\begin{verbatim}
      PROGRAM ISARUN
C          MAIN PROGRAM FOR ISAJET
      OPEN(UNIT=1,STATUS='OLD',FORM='FORMATTED')
      OPEN(UNIT=2,STATUS='NEW',FORM='UNFORMATTED')
      OPEN(UNIT=3,STATUS='OLD',FORM='FORMATTED')
      OPEN(UNIT=4,STATUS='NEW',FORM='FORMATTED')
      CALL ISAJET(-1,2,3,4)
      STOP
      END
\end{verbatim}
to make ISAJET MODULE.

      Create a file called \verb|JOBNAME INPUT| containing ISAJET
input commands following the examples above or the instructions in
Section~\ref{INPUT}. Then run ISAJET using ISAJET EXEC, which is
contained in P=ISAUTIL,D=RUNIBM.  The events will be produced on
\verb|JOBNAME DATA A| and the listing on \verb|JOBNAME OUTPUT A|.

\subsection{Unix}

      The Makefile contained in P=ISAUTIL,D=MAKEUNIX has been tested
on DEC Ultrix, Hewlett Packard HP-UX, IBM RS/6000 AIX, Linux, Silicon
Graphics IRIX, Sun SunOS, and Sun Solaris. It should work with minor
modifications on almost any Unix system with /bin/csh, \verb|ypatchy|
or \verb|nypatchy|, and a reasonable Fortran 77 compiler. Extract the
Makefile and edit it, changing the installation parameters to reflect
your system. Note in particular that CERNlib is usually compiled with
underscores postpended to all external names; you must choose the
appropriate compiler option if you intend to link with it. Then type
\begin{verbatim}
make
\end{verbatim}
This should produce an executable \verb|isajet.x| for the event
generator, which links the code with the following main program:
\begin{verbatim}
      PROGRAM RUNJET
      CHARACTER*60 FNAME
      READ 1000, FNAME
1000  FORMAT(A)
      PRINT 1020, FNAME
1020  FORMAT(1X,'Data file      = ',A)
      OPEN(2,FILE=FNAME,STATUS='NEW',FORM='UNFORMATTED')
      READ 1000, FNAME
      PRINT 1030, FNAME
1030  FORMAT(1X,'Parameter file = ',A)
      OPEN(3,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
      READ 1000, FNAME
      PRINT 1040, FNAME
1040  FORMAT(1X,'Listing file   = ',A)
      OPEN(4,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
      READ 1000, FNAME
      OPEN(1,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
      CALL ISAJET(-1,2,3,4)
      STOP
      END
\end{verbatim}
Two other executables, \verb|isasusy.x| and \verb|isasugra.x|, will
also be produced to calculate SUSY masses and decay modes without
generating events. Type
\begin{verbatim}
make clean
\end{verbatim}
to delete the temporary files.

      Most Unix systems do not allow two jobs to read the same decay
table file at the same time. The shell script in P=ISAUTIL,D=RUNUNIX
copies the decay table to a temporary file to avoid this problem.
Extract this file as \verb|isajet|. Create an input file
\verb|jobname.par| following the examples above or the instructions in
Section~\ref{INPUT} and run ISAJET with the command
\begin{verbatim}
isajet jobname
\end{verbatim}
This will create a binary output file \verb|jobname.dat| and a listing
file \verb|jobname.lis|. Analyze the output data using the commands
described in Section~\ref{TAPE}.

      This section only describes running ISAJET as a standalone
program and generating output in machine-dependent binary form. The
user may elect to analyze events as they are generated; this is
discussed in Section~\ref{MAIN} of this manual.
+EOD
+DECK,PATCHY
\newpage
\section{Patchy and PAM Organization\label{PATCHY}}

      Patchy is a code management system developed at CERN and used to
maintain the CERN Library. It is used to provide versions of ISAJET for
a wide variety of computers. Instructions for using PATCHY are
available from \verb|http://wwwinfo.cern.ch/asdoc/Welcome.html|.

      A master source file in Patchy is called a ``PAM.'' The ISAJET
PAM contains all the source code and documentation plus Patchy
commands to include common blocks and to select the desired version. It
is divided into the following patches: 

      \verb|ISACDE|: contains all common blocks, etc. These are divided
into decks based on their usage.

      \verb|ISADATA|: contains block data ALDATA. This must always be
loaded when using ISAJET.

      \verb|ISAJET|: contains the code for generating events. Each
subroutine is in a separate deck with the same name.

      \verb|ISASSRUN|: contains the main program for ISASUSY, which
prompts for input parameters and prints out all the decay modes. It is
selected by \verb|*ISASUSY|.

      \verb|ISASUSY|: contains code to calculate all the decay widths
and branching fractions in the minimal supersymmetric model.

      \verb|ISATAPE|: contains the code for reading and writing tapes,
again with each subroutine on a separate deck.

      \verb|ISARUN|: contains a main program and a simple interactive
interface.  It is selected by \verb|IF=INTERACT|.

      \verb|ISAZEB|: contains Zebra format output routines, an
alternative to the ISATAPE routines.

      \verb|ISZRUN|: contains the analog of ISAPLT for the Zebra
format. 

      \verb|ISAPLT|: contains a simple calorimeter simulation and the
skeleton of a histogramming job using HBOOK.

      \verb|ISATEXT|: contains the instructions for using ISAJET, i.e.
the text of this document. It also includes the documentation for
ISASUSY.

      \verb|ISZTEXT|: contains the instructions for the Zebra output
routines and a description of the Zebra banks.

      \verb|ISADECAY|: contains the input decay table.

      The code is actually maintained using RCS on a Silicon Graphics
computer at BNL. Patchy is used primarily to handle common blocks and
machine dependent code.

      The input to YPATCHY must contain both \verb|+USE| cards, which
define the wanted program version, and \verb|+EXE| cards, which
determine which patches or decks are written to the ASM file. To
facilitate this selection, the ISAJET PAM contains the following pilot
patches:

      \verb|*ISADECAY|: USE selects ISADECAY and all corrections to it.

      \verb|*ISAJET|: USE selects ISACDE, ISADATA, ISAJET, ISATAPE,
ISARUN and all corrections to them. Note that ISARUN is not actually
selected without \verb|+USE,INTERACT|.

      \verb|*ISAPLT|: USE selects ISACDE, ISAPLT, and all corrections
to them.

      \verb|*ISASUSY|: USE selects CDESUSY, ISASUSY, and ISASSRUN to
create a program to calculate all the MSSM decay modes.

      \verb|*ISATEXT|: USE selects ISACDE, ISATEXT, and all corrections
to them. 

      \verb|*ISAZEB|: USE selects ISAJET with a Zebra output format.

      \verb|*ISZRUN|: USE selects the Zebra analysis package.

      Patches are provided to select the machine dependent features for
specific computers or operating systems:

      \verb|ANSI|: ANSI standard Fortran (no time or date functions)

      \verb|APOLLO|: APOLLO -- only tested by CERN

      \verb|CDC|: CDC 7600 and 60-bit CYBER (obsolete)

      \verb|CRAY|: CRAY with UNICOS

      \verb|DECS|: DEC Station with Ultrix 

      \verb|ETA|: ETA 10 running Unix System V (obsolete)

      \verb|HPUX|: HP/9000 7xx running Unix System V

      \verb|IBM|: IBM 370 and 30xx running VM/CMS 

      \verb|IBMRT|: IBM RS/6000 running AIX 3.x or 4.x

      \verb|LINUX|: PC running Linux with f2c/gcc or g77 compiler

      \verb|SGI|: Silicon Graphics running IRIX

      \verb|SUN|: Sun Sparcstation running SUNOS or Solaris

      \verb|VAX|: DEC VAX or Alpha running VMS

\noindent These patches in turn select a variety of patches and IF
flags, allowing one to select more specific features, as indicated
below. (Replace \verb|&| by \verb|+| everywhere.)
\begin{verbatim}
&PATCH,ANSI.                      GENERIC ANSI FORTRAN.
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,APOLLO.
&DECK,BLANKDEK.
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&USE,IMPNONE.                     IMPLICIT NONE
&EOD.

&PATCH,CDC.                       CDC 7600 OR CYBER 175.
&USE,SINGLE.                      SINGLE PRECISION.
&USE,LEVEL2.                      LEVEL 2 STORAGE.
&USE,CDCPACK.                     PACK 2 WORDS PER WORD FOR INPUT/OUTPUT.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,CRAY.                      CRAY XMP OR 2.
&USE,SINGLE.                      SINGLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,DECS.                      DEC STATION (ULTRIX)
&USE,SUN.
&EOD

&PATCH,ETA.                       ETA-10.
&USE,SINGLE.                      SINGLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,HPUX.                      HP/9000 7XX RUNNING UNIX.
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&USE,IMPNONE.                     IMPLICIT NONE
&EOD

&PATCH,IBM.                       IBM 370 OR 30XX.
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,IBMRT.                     IBM RS/6000 WITH AIX 3.1
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&USE,IMPNONE.                     IMPLICIT NONE
&EOD

&PATCH,LINUX.                     IBM PC WITH LINUX 1.X
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.  STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&USE,IMPNONE.                     IMPLICIT NONE
&EOD

&PATCH,SGI.
SILICON GRAPHICS 4D/XX.
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,SUN.                       SUN (SPARC)
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&EOD

&PATCH,VAX.                       DEC VAX 11/780 OR 8600.
&USE,DOUBLE.                      DOUBLE PRECISION.
&USE,STDIO.                       STANDARD FORTRAN 77 TAPE INPUT/OUTPUT.
&USE,MOVEFTN.                     FORTRAN REPLACEMENT FOR MOVLEV.
&USE,RANFFTN,IF=-CERN.            FORTRAN RANF.
&USE,RANFCALL.                    STANDARD RANSET AND RANGET CALLS.
&USE,NORANLUX,IF=-RANLUX.         NO RANLUX RANDOM NUMBERS.
&USE,NOCERN,IF=-CERN.             NO CERN LIBRARY.
&USE,IMPNONE.                     IMPLICIT NONE
&EOD
\end{verbatim}

      An empty patch INTERACT selects a main program and an interactive
interface which will prompt the user for parameters and do some error
checking. A patch CERN allows ISAJET to take the random number generator
RANF and several other routines from the CERN Library; to use this
include the Patchy command
\begin{verbatim}
&USE,CERN.
\end{verbatim}
Similarly, a patch PDFLIB enables the interface to the PDFLIB parton
distribution compilation by H. Plothow-Besch:
\begin{verbatim}
&USE,PDFLIB
\end{verbatim}
The only internal links with PDFLIB are calls to the routines PDFSET,
PFTOPDG, and DXPDF, and the common blocks W50510 and W50517,
\begin{verbatim}
+CDE,W50510,T=PASS,IF=PDFLIB
+CDE,W50517,T=PASS,IF=PDFLIB
\end{verbatim}
which are used to specify the level of output messages and the logical
unit number for them. A patch RANLUX selects the RANLUX random number
generator instead of the 48-bit congruential generator RANF:
\begin{verbatim}
&USE,RANLUX
\end{verbatim}
RANLUX has a very long period, and each 32-bit integer seed gives an
independent sequence.

      In general it should be sufficient to run YPATCHY with the
following cradle (replace \verb|&| with \verb|+| everywhere):
\begin{verbatim}
&USE,(*ISAJET,*ISATEXT,*ISADECAY,*ISAPLT).     CHOOSE ONE.
&USE,ANSI,DECS,HPUX,IBM,IBMRT,SGI,SUN,....     CHOOSE ONE.
&[USE,INTERACT].                               FOR INTERACTIVE MODE.
&[USE,CERN.]                                   FOR CERN LIBRARY.
&[USE,HBOOK3.]                                 HBOOK 3 FOR ISAPLT.
&EXE.
&PAM.
&QUIT.
\end{verbatim}

      The input to YPATCHY can also contain changes by the user. It is
suggested that these not be made permanent parts of the PAM to avoid
possible conflicts with later corrections.
+EOD
+DECK,MAIN
\newpage
\section{Main Program\label{MAIN}}

      A main program for ISAJET is not supplied in the \verb|isajet.car|
file. To generate events and write them to disk, the user should provide
a main program which opens the files and then calls subroutine ISAJET.
In the following sample, i,j,m,n are arbitrary unit numbers.

      Main program for VMS:
\begin{verbatim}
      PROGRAM RUNJET
C
C          MAIN PROGRAM FOR ISAJET ON BNL VAX CLUSTER.
C
      OPEN(UNIT=i,FILE='$2$DUA14:[ISAJET.ISALIBRARY]DECAY.DAT',
     $STATUS='OLD',FORM='FORMATTED',READONLY)
      OPEN(UNIT=j,FILE='myjob.dat',STATUS='NEW',FORM='UNFORMATTED')
      OPEN(UNIT=m,FILE='myjob.par',STATUS='OLD',FORM='FORMATTED')
      OPEN(UNIT=n,FILE='myjob.lis',STATUS='NEW',FORM='FORMATTED')
C
      CALL ISAJET(+-i,+-j,m,n)
C
      STOP
      END
\end{verbatim}

      Main program for IBM (VM/CMS)
\begin{verbatim}
      PROGRAM RUNJET
C
C          MAIN PROGRAM FOR ISAJET ON IBM ASSUMING FILES HAVE BEEN
C          OPENED WITH FILEDEF.
C
      CALL ISAJET(+-i,+-j,m,n)
C
      STOP
      END
\end{verbatim}

      Main program for Unix; this is created by the standard 
\verb|Makefile|:
\begin{verbatim}
      PROGRAM RUNJET
C
C          Main program for ISAJET on Unix
C
      CHARACTER*60 FNAME
C
C          Open user files
      READ 1000, FNAME
1000  FORMAT(A)
      PRINT 1020, FNAME
1020  FORMAT(1X,'Data file      = ',A)
      OPEN(2,FILE=FNAME,STATUS='NEW',FORM='UNFORMATTED')
      READ 1000, FNAME
      PRINT 1030, FNAME
1030  FORMAT(1X,'Parameter file = ',A)
      OPEN(3,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
      READ 1000, FNAME
      PRINT 1040, FNAME
1040  FORMAT(1X,'Listing file   = ',A)
      OPEN(4,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
C          Open decay table
      READ 1000, FNAME
      OPEN(1,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
C
C          Run ISAJET
      CALL ISAJET(-1,2,3,4)
C
      STOP
      END
\end{verbatim}

      The arguments of ISAJET are tape numbers for files, all of which
should be opened by the main program.

      \verb|TAPEi|: Decay table (formatted). A positive sign prints
the decay table on the output listing. A negative sign suppress
printing of the decay table.

      \verb|TAPEj|: Output file for events (unformatted). A positive
sign writes out both resonances and stable particles. A negative sign
writes out only stable particles.

      \verb|TAPEm|: Commands as defined in Section 6 (formatted).

      \verb|TAPEn|: Output listing (formatted).

\noindent In the sample jobs in Section 3, TAPEm is the default
Fortran input, and TAPEn is the default Fortran output.

\subsection{Interactive Interface}

      To use the interactive interface, replace the call to ISAJET in
the above main program by
\begin{verbatim}
      CALL ISASET(+-i,+-j,m,n)
      CALL ISAJET(+-i,+-j,m,n)
\end{verbatim}
ISASET calls DIALOG, which prompts the user for possible commands,
does a limited amount of error checking, and writes a command file on
TAPEm. This command file is rewound for execution by ISAJET. A main
program is included in patch ISARUN to open the necessary files and to
call ISASET and ISAJET.

\subsection{User Control of Event Loop}

      If the user wishes to integrate ISAJET with another program and
have control over the event generation, he can call the driving
subroutines himself. The driving subroutines are:

      \verb|ISAINI(+-i,+-j,m,n)|: initialize ISAJET. The arguments are
the same as for subroutine ISAJET.

      \verb|ISABEG(IFL)|: begin a run. IFL is a return flag: IFL=0
for a good set of commands; IFL=1001 for a STOP; any other value means
an error.

      \verb|ISAEVT(I,OK,DONE)| generate event I. Logical flag OK
signifies a good event (almost always .TRUE.); logical flag DONE
signifies the end of a run.

      \verb|ISAEND|: end a run.

\noindent There are also subroutines provided to write standard ISAJET
records, or Zebra records if the Zebra option is selected:

      \verb|ISAWBG| to write a begin-of-run record, should be called
immediately after ISABEG

      \verb|ISAWEV| to write an event record, should be called
immediately after ISAEVT

      \verb|ISAWND| to write an end-of-run record, should be called
immediately after ISAEND

      The control of the event loop is somewhat complicated to
accomodate multiple evolution and fragmentation as described in
Section 11. Note in particular that after calling ISAEVT one should
process or write out the event only if OK=.TRUE. The check on the DONE
flag is essential if one is doing multiple evolution and
fragmentation. The following example indicates how events might be
generated, analyzed, and discarded (replace \verb|&| by \verb|+|
everywhere):
\begin{verbatim}
      PROGRAM SAMPLE
C
&SELF,IF=IMPNONE
      IMPLICIT NONE
&SELF
&CDE,ITAPES
&CDE,IDRUN
&CDE,PRIMAR
&CDE,ISLOOP
C
      INTEGER JTDKY,JTEVT,JTCOM,JTLIS,IFL,ILOOP
      LOGICAL OK,DONE
      SAVE ILOOP
C--------------------------------------------------------------------- 
C>         Open files as above
C>         Call user initialization
C--------------------------------------------------------------------- 
C
C          Initialize ISAJET
C
      CALL ISAINI(-i,0,m,n)
    1 IFL=0
      CALL ISABEG(IFL)
      IF(IFL.NE.0) STOP
C
C          Event loop
C
      ILOOP=0
  101 CONTINUE
        ILOOP=ILOOP+1
C          Generate one event - discard if .NOT.OK
        CALL ISAEVT(ILOOP,OK,DONE)
        IF(OK) THEN
C--------------------------------------------------------------------- 
C>         Call user analysis for event
C--------------------------------------------------------------------- 
        ENDIF
      IF(.NOT.DONE) GO TO 101
C
C          Calculate cross section and luminosity
C
      CALL ISAEND
C--------------------------------------------------------------------- 
C>         Call user summary
C--------------------------------------------------------------------- 
      GO TO 1
      END
\end{verbatim}

\subsection{Multiple Event Streams}

      It may be desirable to generate several different kinds of events
simultaneously to study pileup effects. While normally one would want
to superimpose minimum bias or low-pt jet events on a signal of
interest, other combinations might also be interesting. It would be
very inefficient to reinitialize ISAJET for each event. Therefore, a
pair of subroutines is provided to save and restore the context, i.e.
all of the initialization information, in an array. The syntax is
\begin{verbatim}
      CALL CTXOUT(NC,VC,MC)
      CALL CTXIN(NC,VC,MC)
\end{verbatim}
where VC is a real array of dimension MC and NC is the number of words
used, about 20000 in the standard case. If NC exceeds MC, a warning is
printed and the job is terminated. The use of these routines is
illustrated in the following example, which opens the files with names
read from the standard input and then superimposes on each event of
the signal sample three events of a pileup sample. It is assumed that
a large number of events is specified in the parameter file for the
pileup sample so that it does not terminate.
\begin{verbatim}
      PROGRAM SAMPLE
C
C          Example of generating two kinds of events.
C
      CHARACTER*60 FNAME
      REAL VC1(20000),VC2(20000)
      LOGICAL OK1,DONE1,OK2,DONE2
      INTEGER NC1,NC2,IFL,ILOOP,I2,ILOOP2
C
C          Open decay table
      READ 1000, FNAME
1000  FORMAT(A)
      OPEN(1,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
C          Open user files
      READ 1000, FNAME
      OPEN(3,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
      READ 1000, FNAME
      OPEN(4,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
      READ 1000,FNAME
      OPEN(13,FILE=FNAME,STATUS='OLD',FORM='FORMATTED')
      READ 1000,FNAME
      OPEN(14,FILE=FNAME,STATUS='NEW',FORM='FORMATTED')
C
C          Initialize ISAJET
      CALL ISAINI(-1,0,3,4)
      CALL CTXOUT(NC1,VC1,20000)
      CALL ISAINI(-1,0,13,14)
      IFL=0
      CALL ISABEG(IFL)
      IF(IFL.NE.0) STOP1
      CALL CTXOUT(NC2,VC2,20000)
      ILOOP2=0
      CALL user_initialization_routine
C
1     IFL=0
      CALL CTXIN(NC1,VC1,20000)
      CALL ISABEG(IFL)
      CALL CTXOUT(NC1,VC1,20000)
      IF(IFL.NE.0) GO TO 999
      ILOOP=0
C
C          Main event
C
101   CONTINUE
        ILOOP=ILOOP+1
        CALL CTXIN(NC1,VC1,20000)
        CALL ISAEVT(ILOOP,OK1,DONE1)
        CALL CTXOUT(NC1,VC1,20000)
        IF(.NOT.OK1) GO TO 101
        CALL user_analysis_routine
C
C          Pileup
C
        CALL CTXIN(NC2,VC2,20000)
        I2=0
201     CONTINUE
          ILOOP2=ILOOP2+1
          CALL ISAEVT(ILOOP2,OK2,DONE2)
          IF(OK2) I2=I2+1
          IF(DONE2) STOP2
          CALL user_analysis_routine
        IF(I2.LT.3) GO TO 201
        CALL CTXOUT(NC2,VC2,20000)
C
      IF(.NOT.DONE1) GO TO 101
C
C          Calculate cross section and luminosity
C
      CALL CTXIN(NC1,VC1,20000)
      CALL ISAEND
      GO TO 1
C
999   CALL CTXIN(NC2,VC2,20000)
      CALL ISAEND
      CALL user_termination_routine
      STOP
      END
\end{verbatim}
It is possible to superimpose arbitrary combinations of events,
including events of the same reaction type with different parameters.
In general the number of events would be selected randomly based on the
cross sections and the luminosity.

      At this time CTXOUT and CTXIN cannot be used with the Zebra
output routines.

\subsection{Main Programs for ISASUSY and ISASUGRA\label{sugrun}}

     In addition to the event generator, \verb|isajet.car| contains two
programs to calculate SUSY masses and decay modes: ISASUSY, which
accepts weak scale parameters, and ISASUGRA, which calculates the weak
scale parameters from those at some high scale. The main programs, SSRUN
and SUGRUN respectively, are included. They both prompt for interactive
input and then call the appropriate ISAJET subroutines. The output is
formatted and printed by SSPRT and SUGPRT respectively. Executables for
ISASUSY and ISASUGRA are built by the Unix \verb|Makefile| and VMS
\verb|isamake.com|. 

     It is fairly straightforward to modify these routines to scan SUSY
parameters, but given the variety of possible scans, no attempt has been
made to provide code for this. If only masses are needed, SSMSSM can be
modified to remove the calls to the routines that calculate branching
ratios.
+EOD
+DECK,INPUT
\newpage
\section{Input\label{INPUT}}

\subsection{Input Format}

      ISAJET is controlled by commands read from the specified input
file by subroutine READIN. (In the interactive version, this file is
first created by subroutine DIALOG.) Syntax errors will generate a
message and stop execution. Based on these commands, subroutine LOGIC
will setup limits for all variables and check for inconsistencies.
Several runs with different parameters can be combined into one job.
The required input format is:
\begin{verbatim}
Title
Ecm,Nevent,Nprint,Njump/
Reaction
(Optional parameters)
END
(Optional additional runs)
STOP
\end{verbatim}
with all lines starting in column 1 and typed in {\it upper} case. These
lines are explained below.

      Title line: Up to 80 characters long. If the first four letters
are STOP, control is returned to main program. If the first four letters
are SAME, the parameters from previous run are used excepting those
which are explicitly changed.

      Ecm line: This line must always be given even if the title is
SAME. It must give the center of mass energy (Ecm) and the number of
events (Nevent) to be generated. One may also specify the number of
events to be printed (Nprint) and the increment (Njump) for printing.
The first event is always printed if Nprint $>$ 0. For example:
\begin{verbatim}
800.,1000,10,100/
\end{verbatim}
generates 1000 events at $E_{\rm cm} = 800\,\GeV$ and prints 10
events. The events printed are: 1,100,200,\dots. Note that an event
typically takes several pages of output. This line is read with a list
directed format (READ*).

     After Nprint events have been printed, a single line containing the
run number, the event number, and the random number seed is printed
every Njump events (if Njump is nonzero). This seed can be used to start
a new job with the given event if in the new run NSIGMA is set equal to
zero:
\begin{verbatim}
SEED
value/
NSIGMA
0/
\end{verbatim}
In general the same events will only be generated on the same type of
computer.

      Reaction line: This line must be given unless title is SAME, when
it must be omitted. It selects the type of events to be generated. The
present version can generate TWOJET, E+E-, DRELLYAN, MINBIAS, WPAIR,
SUPERSYM, HIGGS, PHOTON, TCOLOR, or WHIGGS events. This line is read
with an A8 format.

\subsection{Optional Parameters}

      Each optional parameter requires two lines.
The first line is a keyword specifying the parameter and the second
line gives the values for the parameter. The parameters can be given in
any order. Numerical values are read with a list directed format
(READ*), jet and particle types are read with a character format and
must be enclosed in quotes, and logical flags with an L1 format. All
momenta are in GeV and all angles are in radians.

      The parameters can be classified in several groups:
\begin{center}
\begin{tabular}{lllll}
\hline\hline
Jet Limits: & W/H Limits: & Decays:     & Constants:  & Other: \\
\hline
JETTYPE1    & HTYPE       & FORCE       & AMSB        & BEAMS \\
JETTYPE2    & PHIW        & FORCE1      & AMSB2       & EPOL \\
JETTYPE3    & QMH         & NOB         & CUTJET      & EEBEAM \\
MIJLIM      & QMW         & NODECAY     & CUTOFF      & EEBREM \\
MTOT        & QTW         & NOETA       & EXTRAD      & GAMGAM \\
P           & THW         & NOEVOLVE    & GRAGMENT    & NPOMERON \\
PHI         & WTYPE       & NOFRGMNT    & GAUGINO     & NSIGMA \\
PT          & XW          & NOGRAV      & GMSB        & NTRIES \\
TH          & YW          & NOPI0       & GMSB2       & PDFLIB \\
X           &             & NOTAU       & HMASS       & SEED \\
Y           &             &             & HMASSES     & STRUC \\
WMODE1      &             &             & LAMBDA      & WFUDGE \\
WMODE2      &             &             & MGVTNO      & WMMODE \\
            &             &             & MSSMA       & WPMODE \\
            &             &             & MSSMB       & Z0MODE \\
            &             &             & MSSMC       & \\
            &             &             & MSSMD       & \\
            &             &             & MSSME       & \\
            &             &             & NUSUG1      & \\
            &             &             & NUHM        & \\
            &             &             & NUSUG2      & \\
            &             &             & NUSUG3      & \\
            &             &             & NUSUG4      & \\
            &             &             & NUSUG5      & \\
            &             &             & SIGQT       & \\
            &             &             & SIN2W       & \\
            &             &             & SLEPTON     & \\
            &             &             & SQUARK      & \\
            &             &             & SSBCSC      & \\
            &             &             & SUGRA       & \\
            &             &             & SUGRHN      & \\
            &             &             & TCMASS      & \\
            &             &             & TMASS       & \\
            &             &             & WMASS       & \\
\hline\hline
\end{tabular}
\end{center}

      It may be helpful to know that the TWOJET, WPAIR, PHOTON,
SUPERSYM, and WHIGGS processes use the same controlling routines and
so share many of the same variables.  In particular, PT limits should
normally be set for these processes, and JETTYPE1 and JETTYPE2 are
used to select the reactions. Similarly, the DRELLYAN, HIGGS, and
TCOLOR processes use the same controlling routines since they all
generate s-channel resonances. The mass limits for these processes are
set by QMW.  Normally the QMW limits will surround the $W^\pm$, $Z^0$,
or Higgs mass, but this is not required.  (QMH acts like QMW for the
Higgs process.) For historical reasons, JETTYPE1 and JETTYPE2 are used
to select the W decay modes in DRELLYAN, while WMODE1 and WMODE2 select
the W decay modes for WPAIR, HIGGS, and WHIGGS. Also, QTW can be used
to generate DRELLYAN events with non-zero transverse momentum, whereas
HIGGS automatically fixes QTW to be zero. (Of course, non-zero
transverse momentum will be generated by gluon radiation.)

      For example the lines
\begin{verbatim}
P
40.,50.,10.,100./
\end{verbatim}
would set limits for the momentum of jet 1 between 40 and 50 GeV, and
for jet 2 between 10 and 100 GeV. As another example the lines
\begin{verbatim}
WTYPE
'W+'/
\end{verbatim}
would specify that for DRELLYAN events only W+ events will be generated.
If for a kinematic variable only the lower limit is specified then that
parameter is fixed to the given value. Thus the lines
\begin{verbatim}
P
40.,,10./
\end{verbatim}
will fix the momentum for jet 1 to be 40 GeV and for jet 2 to be 10
GeV. If only the upper limit is specified then the default value is used
for the lower limit. Jet 1 or jet 2 parameters for DRELLYAN events refer
to the W decay products and cannot be fixed. If QTW is fixed to 0, then
standard Drell-Yan events are generated.

      A complete list of keywords and their default values follows.

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
Keyword                &                   & Explanation                    \\
Values                 & Default values    &                                \\
\hline
AMSB                   &                   & Anomaly-mediated SUSY breaking \\
$m_0$,$m_{3/2}$,$\tan\beta$,$\sgn\mu$ & none & scalar mass, gravitino mass, \\
                       &                   & VEV ratio, sign                \\
                       &                   &                                \\
AMSB2                  &                   & Non-minimal AMSB               \\
$c_Q,c_D,c_U,c_L,c_E,c_{H_d},c_{H_u}$ & 1  & multiplies $m_0^2$ cont'n. to  \\
                       &                   & soft SUSY masses               \\
                       &                   &                                \\
BEAMS                  &                   & Initial beams. Allowed are     \\
type$_1$,type$_2$      & 'P','P'           & 'P','AP','N','AN'.             \\
                       &                   &                                \\
CUTJET                 &                   & Cutoff mass for QCD jet        \\
$\mu_c$                & 6.                & evolution.                     \\
                       &                   &                                \\
CUTOFF                 &                   & Cutoff $qt^2=\mu^2Q^\nu$ for   \\
$\mu^2$, $\nu$         & .200,1.0          & DRELLYAN events.               \\
                       &                   &                                \\
EEBEAM                 &                   & impose brem/beamstrahlung      \\
$\sqrt{\hat{s}}_{min}$, $\sqrt{\hat{s}}_{max}$, $\Upsilon$, $\sigma_z$ &
none & min and max subprocess energy, \\
                       & & beamstrahlung parameter $\Upsilon$ \\
                       & & longitudinal beam size $\sigma_z$ in mm \\
                       &                   &                                \\
EEBREM                 &                 & impose bremsstrahlung for $e^+e^-$ \\
$\sqrt{\hat{s}}_{min}$, $\sqrt{\hat{s}}_{max}$ & none & min and max subprocess 
energy \\
                       &                   &                                \\
EPOL                   &              & Polarization of $e^-$ ($e^+$) beam, \\
$P_L(e^-),P_L(e^+)$    & 0,0               & $P_L(e)=(n_L-n_R)/(n_L-n_R)$,  \\
                       &                   & so that $-1 \le P_L \le 1$     \\
                       &                   &                                \\
EXTRAD                 &                   & Parameters for EXTRADIM process\\
$\delta$,$M_D$,UVCUT   & None              & UVCUT is logical flag          \\
                       &                   &                                \\
FORCE                  &                   & Force decay of particles,      \\
$i,i_1,...,i_5$/       & None              & $\pm i \to \pm(i1+...+i5)$.    \\
                       &                   & Can call 20 times.             \\
                       &                   & See note for $i$ = quark.      \\
                       &                   &                                \\
FORCE1                 &                   & Force decay $i \to i1+...+i5$. \\
$i,i_1,...,i_5$/       & None              & Can call 40 times.             \\
                       &                   & See note for $i$ = quark.      \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
FRAGMENT               &                   & Fragmentation parameters.      \\
$P_{ud}$,\dots         & .4,\dots          & See also SIGQT, etc.           \\
                       &                   &                                \\
GAMGAM                 &             & Activate $\gamma\gamma\to f\bar{f}$  \\
TRUE or FALSE          & FALSE             & in $e^+e^-$ collisions         \\
                       &                   &                                \\
GAUGINO                &                   & Masses for $\tilde g$, 
$\tilde\gamma$,                                                             \\
$m_1$,$m_2$,$m_3,m_4$  & 50,0,100,100      & $\tilde W^+$, and $\tilde Z^0$ \\
                       &                   &                                \\
GMSB                   &                   & GMSB messenger SUSY breaking,  \\
$\Lambda_m$,$M_m$,$N_5$ & none             & mass, number of $5+\bar5$, VEV \\
$\tan\beta$,$\sgn\mu$,$C_{\rm gr}$ &       & ratio, sign, gravitino scale   \\
                       &                   &                                \\
GMSB2                  &                   & non-minimal GMSB parameters    \\
$\slashchar{R}$,$\delta M_{H_d}^2$,$\delta M_{H_u}^2$,$D_Y(M)$ & 1,0,0,0 & 
gaugino mass multiplier \\
$N_{5_1}$,$N_{5_2}$,$N_{5_3}$ & $N_5$     & Higgs mass shifts, D-term mass$^2$\\
                       &                   & indep. gauge group messengers  \\
                       &                   &                                \\
HMASS                  & 0                 & Mass for standard Higgs.       \\
$m$                    &                   &                                \\
                       &                   &                                \\
HMASSES                &                   & Higgs meson masses for         \\
$m_1$,\dots,$m_9$      & 0,...,0           & charges 0,0,0,0,0,1,1,2,2.     \\
                       &                   &                                \\
HTYPE                  &                   & One MSSM Higgs type ('HL0',    \\
'HL0'/ or...           & none              & 'HH0', or 'HA0')               \\
                       &                   &                                \\
JETTYPE1               &                   & )Select types for jets:        \\
'GL','UP',...          & 'ALL'             & )'ALL'; 'GL'; 'QUARKS'='UP',   \\
                       &                   & )'UB','DN','DB','ST','SB',     \\
JETTYPE2               &                   & )'CH','CB','BT','BB','TP',     \\
'GL','UP',...          & 'ALL'             & )'TB','X','XB','Y','YB';       \\
                       &                   & )'LEPTONS'='E-','E+','MU-',    \\
JETTYPE3               &                   & )'MU+','TAU-','TAU+'; 'NUS';   \\
'GL','UP',...          & 'ALL'             & )'GM','W+','W-','Z0'           \\
                       &                   & ) See note for SUSY types.     \\
                       &                   &                                \\
LAMBDA                 &                   & QCD scale                      \\
$\Lambda$              & .2                &                                \\
                       &                   &                                \\
MGVTNO                 &                   & Gravitino mass -- ignored for  \\
$M_{\rm gravitino}$    & $10^{20}$~GeV     & GMSB model                     \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
MIJLIM                 &                   & Multimet mass limits           \\
$i$,$j$,$M_{\rm min}$,$M_{\rm max}$ & 0,0,$1\,\GeV$,$1\,\GeV$ &             \\
                       &                   &                                \\
MSSMA                  &                   & MSSM parameters --             \\
$m(\tilde g)$,$\mu$,   & Required          & Gluino mass, $\mu$, $A$ mass,  \\
$m(A)$,$\tan\beta$     &                   & $\tan\beta$                    \\
                       &                   &                                \\
MSSMB                  &                   & MSSM 1st generation --         \\
$m(q_1)$,$m(d_r)$,$m(u_r)$, & Required     & Left and right soft squark and \\
$m(l_1)$,$m(e_r)$      &                   & slepton masses                 \\
                       &                   &                                \\
MSSMC                  &                   & MSSM 3rd generation --         \\
$m(q_3)$,$m(b_r)$,$m(t_r)$,  & Required    & Soft squark masses, slepton    \\
$m(l_3)$,$m(\tau_r)$,  &                   & masses, and squark and slepton \\
$A_t$,$A_b$,$A_\tau$   &                   & mixings                        \\
                       &                   &                                \\
MSSMD                  &                   & MSSM 2nd generation --         \\
$m(q_2)$,$m(s_r)$,$m(c_r)$,  & from MSSMB  & Left and right soft squark and \\
$m(l_2)$,$m(mu_r)$     &                   & slepton masses                 \\
                       &                   &                                \\
MSSME                  &                   & MSSM gaugino masses --         \\
$M_1$,$M_2$            & MSSMA + GUT       & Default is to scale from gluino\\
                       &                   &                                \\
MTOT                   &                   & Mass range for multiparton     \\
$M_{\rm min}$,$M_{\rm max}$ & None         & processes                      \\
                       &                   &                                \\
NOB                    &                   & Suppress B decays to use       \\
TRUE or FALSE          & FALSE             & external package.              \\
                       &                   &                                \\
NODECAY                &                   & Suppress all decays.           \\
TRUE or FALSE          & FALSE             &                                \\
                       &                   &                                \\
NOETA                  &                   & Suppress eta decays.           \\
TRUE or FALSE          & FALSE             &                                \\
                       &                   &                                \\
NOEVOLVE               &                   & Suppress QCD evolution and     \\
TRUE or FALSE          & FALSE             & hadronization.                 \\
                       &                   &                                \\
NOGRAV                 &                   & Suppress gravitino decays in   \\
TRUE or FALSE          & FALSE             & GMSB model                     \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
NOHADRON               &                   & Suppress hadronization of      \\
TRUE or FALSE          & FALSE             & jets and beam jets.            \\
                       &                   &                                \\
NONUNU                 &                   & Suppress $Z^0$ neutrino decays.\\
TRUE or FALSE          & FALSE             &                                \\
                       &                   &                                \\
NOPI0                  &                   &Suppress $\pi^0$ decays.        \\
TRUE or FALSE          & FALSE             &                                \\
                       &                   &                                \\
NOTAU                  &                   & Suppress tau decays to use     \\
TRUE or FALSE          & FALSE             & external package.              \\
                       &                   &                                \\
NPOMERON               &                   & Allow $n_1<n<n_2$ cut pomerons.\\
$n_1$,$n_2$            & 1,20              & Controls beam jet mult.        \\
                       &                   &                                \\
NSIGMA                 &                   & Generate n unevolved events    \\
$n$                    & 20                & for SIGF calculation.          \\
                       &                   &                                \\
NTRIES                 &                   & Stop if after n tries          \\
$n$                    & 1000              & cannot find a good event.      \\
                       &                   &                                \\
NUHM                   &                   & Optional non-universal SUGRA   \\
$\mu (M_{weak})$, $m_A(M_{weak})$ & none   & Higgs masses in terms of       \\
                       &                   & $\mu$, $m_A$                   \\
                       &                   &                                \\
NUSUG1                 &                   & Optional non-universal SUGRA   \\
$M_1$,$M_2$,$M_3$      & none              & gaugino masses                 \\
                       &                   &                                \\
NUSUG2                 &                   & Optional non-universal SUGRA   \\
$A_t$,$A_b$,$A_\tau$   & none              & $A$ terms                      \\
                       &                   &                                \\
NUSUG3                 &                   & Optional non-universal SUGRA   \\
$M_{H_d}$,$M_{H_u}$    & none              & Higgs masses                   \\
                       &                   &                                \\
NUSUG4                 &                   & Optional non-universal SUGRA   \\
$M_{u_L}$,$M_{d_R}$,$M_{u_R}$, & none      & 1st/2nd generation masses      \\
$M_{e_L}$,$M_{e_R}$    &                   &                                \\
                       &                   &                                \\
NUSUG5                 &                   & Optional non-universal SUGRA   \\
$M_{t_L}$,$M_{b_R}$,$M_{t_R}$, & none      & 3rd generation masses          \\
$M_{\tau_L}$,$M_{\tau_R}$ &                &                                \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
P                      &                   & Momentum limits for jets.      \\
$p_{\rm min}(1)$,\dots,$p_{\rm max}(3)$ & 
1.,$0.5E_{\rm cm}$                         &                                \\

PDFLIB                 &                   & CERN PDFLIB parton distribution\\
'name$_1$',val$_1$,\dots & None            & parameters. See PDFLIB manual. \\
                       &                   &                                \\
PHI                    &                   & Phi limits for jets.           \\
$\phi_{\rm min}(1)$,\dots,$\phi_{\rm max}(3)$ & 0,$2\pi$ &                  \\
                       &                   &                                \\
PHIW                   &                   & Phi limits for W.              \\
$\phi_{\rm min}$,$\phi_{\rm max}$ & 
0,$2\pi$                                   &                                \\
                       &                   &                                \\
PT or PPERP            &                   & $p_t$ limits for jets.         \\
$p_{t,{\rm min}}(1)$,\dots,$p_{t,{\rm max}}(3)$  & 
$.05E_{\rm cm}$,$.2E_{\rm cm}$             & Default for TWOJET only.       \\
                       &                   &                                \\
QMH                    &                   & Mass limits for Higgs.         \\
$q_{\rm min}$,$q_{\rm max}$ & 
$.05E_{\rm cm}$,$.2E_{\rm cm}$             & Equivalent to QMW.             \\
                       &                   &                                \\
QMW                    &                   & Mass limits for $W$.           \\
$q_{\rm min}$,$q_{\rm max}$ & 
$.05E_{\rm cm}$,$.2E_{\rm cm}$             &                                \\
                       &                   &                                \\
QTW                    &                   & $q_t$ limits for $W$. Fix 
$q_t=0$                                                                     \\
$q_{t,{\rm min}}$,$q_{t,{\rm max}}$ & 
.1,$.025E_{\rm cm}$                        & for standard Drell-Yan.        \\
                       &                   &                                \\
SEED                   &                   & Seed $<$281474976710656.D0 for \\
real/integer           & 0                 & RANF or $<$$2^{31}$ for RANLUX.\\
                       &                   &                                \\
SIGQT                  &                   & Internal $k_t$ parameter for   \\
$\sigma$               & .35               & jet fragmentation.             \\
                       &                   &                                \\
SIN2W                  &                   & Weinberg angle. See WMASS.     \\
$\sin^2(\theta_W)$     & .232              &                                \\
                       &                   &                                \\
SLEPTON                &                   & Masses for $\tilde \nu_e$,
$\tilde e$, $\tilde\nu_\mu$, $\tilde\mu$, $\tilde\nu_\tau$, $\tilde\tau$    \\
$m_1$,\dots,$m_6$      & 100,\dots,101.8   &                                \\
                       &                   &                                \\
SQUARK                 &                   & Masses for $\tilde u$,
$\tilde d$, $\tilde s$, $\tilde c$, $\tilde b$, $\tilde t$                  \\
$m_1$,\dots,$m_6$      & 100.3,...,240.    &                                \\
                       &                   &                                \\
SSBCSC                 &                   & Alternate mass scale for RGE   \\
$M$                    & $M_{GUT}$         & boundary conditions.           \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
STRUC                  &                   & Structure functions. CTEQ5L,   \\
name                   & 'CTEQ5L'          & CTEQ3L, CTEQ2L, EHLQ, OR DO    \\
                       &                   &                                \\
SUGRA                  &                   & Minimal supergravity parameters\\
$m_0$,$m_{1/2}$,$A_0$, & none              & scalar M, gaugino M, trilinear \\
$\tan\beta$,$\sgn\mu$  &                   & breaking term, vev ratio, +-1  \\
                       &                   &                                \\
SUGRHN                 &                   & SUGRA see-saw $\nu$-effect     \\
$m_{\nu_\tau}$,$M_N$,$A_n$,$m_{\tilde\nu_R}$ & $0,1E20,0,0$ & nu-mass, 
int. scale, \\
                       &                   & GUT scale nu SSB terms         \\
                       &                   &                                \\
TH or THETA            &                   & Theta limits for jets. Do not  \\
$\theta_{\rm min}(1)$,\dots,$\theta_{\rm max}(3)$ & 0,$\pi$ & also set Y.   \\
                       &                   &                                \\
THW                    &                   & Theta limits for W. Do not     \\
$\theta_{\rm min}$,$\theta_{\rm max}$ & 0,$\pi$ & also set YW.              \\
                       &                   &                                \\
TCMASS                 &                   & Technicolor mass and width.    \\
$m$,$\Gamma$           & 1000,100          &                                \\
                       &                   &                                \\
TMASS                  &                   & t, y, and x quark masses.      \\
$m_t$,$m_y$,$m_x$      & 180.,-1.,-1.      &                                \\
                       &                   &                                \\
WFUDGE                 &                   & Fudge factor for DRELLYAN      \\
factor                 & 1.85              & evolution scale.               \\
                       &                   &                                \\
WMASS                  &                   & W and Z masses. See SIN2W.     \\
$M_W$,$M_Z$            & 80.2, 91.19       &                                \\
                       &                   &                                \\
WMMODE                 &                   & Decay modes for $W^-$ in parton\\
'UP',\dots,'TAU+'      & 'ALL'             & cascade. See JETTYPE.          \\
                       &                   &                                \\
WMODE1                 &                   & )                              \\
'UP','UB',\dots        & 'ALL'             & )Decay modes for WPAIR.        \\
                       &                   & )Same code for quarks and      \\
WMODE2                 &                   & )leptons as JETTYPE.           \\
'UP','UB',\dots        & 'ALL'             & )                              \\
                       &                   &                                \\
WPMODE                 &                   & Decay modes for $W^+$ in parton\\
'UP',\dots,'TAU+'      & 'ALL'             & cascade. See JETTYPE.          \\
                       &                   &                                \\
WTYPE                  &                   & Select W type: W+,W-,GM,Z0.    \\
type$_1$,type$_2$      & 'GM','Z0'         & Do not mix W+,W- and GM,Z0.    \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\begin{center}
\begin{tabular}{lll}
\hline\hline
X                      &                   & Feynman x limits for jets.     \\
$x_{\rm min}(1)$,\dots,$x_{\rm max}(3)$ & 
$-1$,1                                     &                                \\
                       &                   &                                \\
XGEN                   &                   & Jet fragmentation, Peterson    \\
a(1),\dots,a(8)        & .96,3,0,.8,.5,... & with $\epsilon=a(n)/m^2$, 
$n=4$-8.                                                                    \\
                       &                   &                                \\
XGENSS                 &                   & Fragmentation of GLSS, UPSS,   \\
a(1),\dots,a(7)        & .5,.5,...         & etc. with $\epsilon=a(n)/m**2$ \\
                       &                   &                                \\
                       &                   &                                \\
XW                     &                   & Feynman x limits for W.        \\
$x_{\rm min}$,$x_{\rm max}$ & $-1$,1       &                                \\
                       &                   &                                \\
Y                      &                   & Y limits for each jet.         \\
$y_{\rm min}(1)$,\dots,$y_{\rm max}(3)$ & from PT & Do not also set TH.     \\
                       &                   &                                \\
YW                     &                   & Y limits for W.                \\
$y_{\rm min}$,$y_{\rm max}$ & from QTW,QMW & Do not set both YW and THW.    \\
                       &                   &                                \\
Z0MODE                 &                   & Decay modes for $Z^0$ in parton\\
'UP',\dots,'TAU+'      & 'ALL'             & cascade. See JETTYPE.          \\
\hline\hline
\end{tabular}
\end{center}

\newpage
\subsection{Kinematic and Parton-type Parameters}

      While the TWOJET PT limits and the DRELLYAN QMW limits are
formally optional parameters, they are set by default to be fractions of
$\sqrt{s}$. Thus, for example, the parameter file
\begin{verbatim}
DEFAULT TWOJET JOB
14000,100,1,100/
TWOJET
END
STOP
\end{verbatim}
will execute, but it will generate jets between 5\% and 20\% of
$\sqrt{s}$, which is probably not what is wanted. Similarly, the
parameter file
\begin{verbatim}
DEFAULT DRELLYAN JOB
14000,100,1,100/
DRELLYAN
END
STOP
\end{verbatim}
will generate $\gamma + Z$ events with masses between 5\% and 20\% of
$\sqrt{s}$, not masses around the $Z$ mass, and transverse momenta
between $1\,{\rm GeV}$ and 2.5\% of $\sqrt{s}$.

      Normally the user should set PT limits for TWOJET, PHOTON, WPAIR,
SUPERSYM, and WHIGGS events and QMW and QTW limits for DRELLYAN,
HIGGS, and TCOLOR events. If these limits are not set, they will be
selected as fractions of $E_{\rm cm}$. This can give nonsense. For
TWOJET the $p_t$ range should usually be less than about a factor of
two except for $b$ and $t$ jets at low $p_t$ to produce uniform
statistics. For $W^+$, $W^-$, or $Z^0$ events or for Higgs events the
QMW (QMH) range should usually include the mass. But one can select
different limits to study, e.g., virtual $W$ production or the effect
of a lighter or heavier Higgs on WW scattering. If only $t$ decays are
selected, then the lower QMW limit must be above the $t$ threshold.
For standard Drell-Yan events QTW should be fixed to zero,
\begin{verbatim}
QTW
0/
\end{verbatim}
Transverse momenta will then be generated by initial state gluon
radiation. A range of QTW can also be given. For SUPERSYM either the
masses and decay modes should be specified, or the MSSM, SUGRA, GMSB, or
AMSB parameters should be given. For fourth generation quarks it is
necessary to specify the quark masses.

      Note that if the limits given cover too large a kinematic range,
the program can become very inefficient, since it makes a fit to the
cross section over the specified range. NTRIES has to be increased if
narrow limits are set for X, XW or for jet 1 and jet 2 parameters in
DRELLYAN events. For larger ranges several runs can be combined together
using the integrated cross section per event SIGF/NEVENT as the weight.
This cross section is calculated for each run by Monte Carlo integration
over the specified kinematic limits and is printed at the end of the
run. It is corrected for JETTYPEi, WTYPE, and WMODEi selections; it
cannot be corrected for branching ratios of forced decays or for WPMODE,
WMMODE, or Z0MODE selections, since these can affect an arbitrary number
of particles.

      To generate events over a large range, it is much more efficient
to combine several runs. This is facilitated by using the special job
title SAME as described above. Note that SAME cannot be used to combine
standard DRELLYAN events (QTW fixed equal to 0) and DRELLYAN events with
nonzero QTW.

      The cross sections for multiparton final states in general have
infrared and collinear singularities. To obtain sensible results, it
is in general essential to set limits both on the $p_T$ of each final
parton using PT and on the mass of each pair of partons using MIJLIM.
The default lower limits are all $1\,{\rm GeV}$. Using these default
limits without thought will likely give absurd results.

      For TWOJET, DRELLYAN, and most other processes, the JETTYPEi and
WTYPEi keywords should be used to select the subprocesses to be
included. For $e^+ e^- \to W^+ W^-$, $Z^0 Z^0$, use FORCE and FORCE1
instead of WMODEi to select the $W$ decay modes. Note that these {\it
do not} change the calculated cross section. (In the E+E- process, the
$W$ and $Z$ decays are currently treated as particle decays, whereas in
the WPAIR and HIGGS processes they are treated as $2 \to 4$ parton
processes.)

      For HIGGS with $W^+W^-$ or $Z^0Z^0$ decays allowed it is
generally necessary to set PT limits for the W's, e.g.
\begin{verbatim}
PT
50,20000,50,20000/
\end{verbatim} 
If this is not done, then the default lower limit of 1 GeV is used,
and the $t$-channel exchanges will dominate, as they should in the
effective $W$ approximation. Depending on the other parameters, the
program may fail to generate an event in NTRIES tries.

\subsection{SUSY Parameters}

      SUPERSYM (SUSY) by default generates just gluinos and squarks in
pairs. There are no default masses or decay modes. Masses can be set
using GAUGINO, SQUARK, SLEPTON, and HMASSES. Decay modes can be
specified with FORCE or by modifying the decay table. Left and right
squarks are distinguished but assumed to be degenerate, except for
stops. Since version 7.11, types must be selected with JETTYPEi using
the supersymmetric names, e.g.
\begin{verbatim}
JETTYPE1
'GLSS','UPSSL','UPSSR'/
\end{verbatim}
Use of the corresponding standard model names, e.g.
\begin{verbatim}
JETTYPE1
'GL','UP'/
\end{verbatim}
and generation of pure photinos, winos, and zinos are no longer
supported.

      If MSSMA, MSSMB and MSSMC are given, then the specified parameters
are used to calculate all the masses and decay modes with the ISASUSY
package assuming the minimal supersymmetric extension of the standard
model (MSSM). There are no default values, so you must specify values
for each MSSMi, i=A-C. MSSMD can optionally be used to set the second
generation squark and slepton parameters; if it is omitted, then the
first generation ones are used. MSSME can optionally be used to set the
U(1) and SU(2) gaugino masses; if it is omitted, then the grand
unification values are used. The parameters and the use of the MSSM is
preserved if the title is SAME. FORCE can be used to override the
calculated branching ratios. 

      The MSSM option also generates charginos and neutralinos with
cross sections based on the MSSM mixing angles in addition to squarks
and sleptons. These can be selected with JETTYPEi; the complete list of
supersymmetric options is:
\begin{verbatim}
'GLSS',
'UPSSL','UBSSL','DNSSL','DBSSL','STSSL','SBSSL','CHSSL','CBSSL',
'BTSS1','BBSS1','TPSS1','TBSS1',
'UPSSR','UBSSR','DNSSR','DBSSR','STSSR','SBSSR','CHSSR','CBSSR',
'BTSS2','BBSS2','TPSS2','TBSS2',
'W1SS+','W1SS-','W2SS+','W2SS-','Z1SS','Z2SS','Z3SS','Z4SS',
'NUEL','ANUEL','EL-','EL+','NUML','ANUML',MUL-','MUL+','NUTL',
'ANUTL','TAU1-','TAU1+','ER-','ER+','MUR-','MUR+','TAU2-','TAU2+',
'Z0','HL0','HH0','HA0','H+','H-',
'SQUARKS','GAUGINOS','SLEPTONS','ALL'.
\end{verbatim}
Note that mixing between $L$ and $R$ stop states results in 1 (light)
and 2 (heavy) stop, sbottom and stau eigenstates, which depend on the
input parameters of left- and right- scalar masses, plus $A$ terms,
$\mu$ and $\tan\beta$. The last four JETTYPE's generate respectively
all allowed combinations of squarks and antisquarks, all combinations
of charginos and neutralinos, all combinations of sleptons and
sneutrinos, and all SUSY particles. 

      For SUSY Higgs pair production or associated production in E+E-,
select the appropriate JETTYPE's, e.g.
\begin{verbatim}
JETTYPE1
'Z0'/
JETTYPE2
'HL0'/
\end{verbatim}

As usual, this gives only half the cross section. For single production
of neutral SUSY Higgs in $pp$ and $\bar pp$ reactions, use the HIGGS
process together with the MSSMi, SUGRA, GMSB, or AMSB keywords. You must
specify one and only one Higgs type using
\begin{verbatim}
HTYPE
'HL0' or 'HH0' or 'HA0'/     <<<<< One only!
\end{verbatim}
If no QMH range is given, one is calculated using $M \pm 5 \Gamma$ for
the selected Higgs. Decays into quarks, leptons, gauge bosons, lighter
Higgs bosons, and SUSY particles are generated using the on-shell
branching ratios from ISASUSY. You can use JETTYPEi to select the
allowed Higgs modes and WMODEi to select the allowed decays of W and Z
bosons. Since heavy SUSY Higgs bosons couple weakly to W pairs, WW
fusion and WW scattering are not included. 

      SUGRA can be used instead of MSSMi to generate MSSM decays with
parameters determined from $m_0$, $m_{1/2}$, $A_0$, $\tan\beta$, and
$\sgn\mu=\pm1$ in the minimal supergravity framework. The NUSUGi
keywords can optionally be used to specify additional parameters for
non-universal SUGRA models, while SUGRHN is used to specify the
parameterf of an optional right-handed neutrino. Similarly, the GMSB
keyword is used to specify the $\Lambda$, $M_m$, $N_5$, $\tan\beta$,
$\sgn\mu=\pm1$, and $C_{\rm grav}$ parameters of the minimal Gauge
Mediated SUSY Breaking model. GMSB2 can optionally be used to specify
additional parameters of non-minimal GMSB models. The AMSB keyword is
used to specify $m_0$, $m_{3/2}$, $\tan\beta$, and $\sgn\mu$ for the
minimal Anomaly Mediated SUSY Breaking model. Note that $m_{3/2}$ is
much larger than the weak scale, typically 50~TeV.

      WHIGGS is used to generate $W$ plus neutral Higgs events. For the
Standard Model the JETTYPE is \verb|HIGGS|. If any of the SUSY models
is specified, then the appropriate SUSY Higgs type should be used,
most likely \verb|HL0|. In either case WMODEi is used to specify the
$W$ decay modes. The Higgs is treated as a particle; its decay modes
can be set using FORCE.

\subsection{Forced Decay Modes}

      The FORCE keyword requires special care. Its list must contain the
numerical particle IDENT codes, e.g.
\begin{verbatim}
FORCE
140,130,-120/
\end{verbatim}
The charge-conjugate mode is also forced for its antiparticle. Thus the
above example forces both $\bar D^0 \to K^+ \pi^-$ and $D^0 \to K^-
\pi^+$. If only a specific decay is wanted one should use the FORCE1
command; e.g.
\begin{verbatim}
FORCE1
140,130,-120/
\end{verbatim}
only forces $\bar D^0 \to K^+ \pi^-$.

      To force a heavy quark decay one must generally separately force
each hadron containing it. If the decay is into three leptons or quarks,
then the real or virtual W propagator is inserted automatically. Since
Version 7.30, top and fourth generation quarks are treated as
particles and decayed directly rather than first being made into
hadrons. Thus for example
\begin{verbatim}
FORCE1
6,-12,11,5/
\end{verbatim}
forces all top quarks to decay into an positron, neutrino and a
b-quark (which will be hadronized). For the physical top mass, the
positron and neutrino will come from a real W. Note that forcing $t
\to W^+ b$ and $W^+ \to e^+ \nu_e$ does {\it not} give the same
result; the first uses the correct $V-A$ matrix element, while the
second decays the $W$ according to phase space.

      Forced modes included in the decay table or generated by ISASUSY
will automatically be put into the correct order and will use the
correct matrix element. Modes not listed in the decay table are
allowed, but caution is advised because a wrong decay mode can cause
an infinite loop or other unexpected effects.

      FORCE (FORCE1) can be called at most 20 (40) times in any run plus
all subsequent 'SAME' runs. If it is called more than once for a given
parent, all calls are listed, and the last call is used. Note that FORCE
applies to particles only, but that for gamma, W+, W-, Z0 and
supersymmetric particles the same IDENT codes are used both as jet types
and as particles.

\subsection{Parton Distributions}

      The default parton distributions are fit CTEQ5L from the CTEQ
Collaboration using lowest order QCD. The CTEQ3L, CTEQ2L, and the old
EHLQ and Duke-Owens distributions can be selected using the STRUC
keyword.

      If PDFLIB support is enabled (see Section 4), then any of the
distributions in the PDFLIB compilation by H. Plothow-Besch can be
selected using the PDFLIB keyword and giving the proper parameters,
which are identical to those described in the PDFLIB manual and are
simply passed to the routine PDFSET. For example, to select fit 29
(CTEQ3L) by the CTEQ group, leaving all other parameters with their
default values, use
\begin{verbatim}
PDFLIB
'CTEQ',29D0/
\end{verbatim}
Note that the fit-number and the other parameters are of type DOUBLE
PRECISION (REAL on 64-bit machines). There is no internal passing of
parameters except for those which control the printing of messages.

\subsection{Multiparton Processes}

      For multiparton final states one should in general set limits
on the total mass \verb|MTOT| of the final state, on the minimum
\verb|PT| of each light parton, and on the minimum mass \verb|MIMLIM|
of each pair of light partons. Limits for \verb|PT| are set in the
ususal way. Limits for the mass $M_{ij}$ of partons $i,j$ are set using
\begin{verbatim}
MIJLIM
i,j,Mmin,Mmax
\end{verbatim}
If $i=j=0$, the limit is applied to all jet pairs. For example the
following parameter file generates \verb|ZJJ| events at the LHC with a
mimimum $p_T$ of $20\,\GeV$ and a minimum mass of $20\,\GeV$ for all
jet pairs:
\begin{verbatim}
GENERATE ZJJ with PTMIN = 20 GEV AND MMIN = 20 GEV
14000,100,1,100/
ZJJ
PT
20,7000,20,7000,20,7000/
MIJLIM
0,0,20,7000/
MTOT
100,500/
NSIGMA
200/
NTRIES
10000/
END
STOP
\end{verbatim}
The default lower limits for \verb|PT| and \verb|MIJLIM| are
$1\,\GeV$. While these limits are sufficient to make the cross
sections finite, they will in general not give physically sensible
results. Thus, {\it the user must think carefully about what limits
should be set.}
+EOD
+DECK,OUTPUT
\newpage
\section{Output\label{OUTPUT}}

      The output tape or file contains three types of records. A
beginning record is written by a call to ISAWBG before generating a set
of events; an event record is written by a call to ISAWEV for each
event; and an end record is written for each run by a call to ISAWND.
These subroutines load the common blocks described below into a single
\begin{verbatim}
COMMON/ZEVEL/ZEVEL(1024) 
\end{verbatim}
and write it out when it is full. A subroutine RDTAPE, described in
the next section, inverts this process so that the user can analyze
the event.

      ZEVEL is written out to TAPEj by a call to BUFOUT. For the CDC
version IF = PAIRPAK is selected; BUFOUT first packs two words from
ZEVEL into one word in 
\begin{verbatim}
COMMON/ZVOUT/ZVOUT(512) 
\end{verbatim}
using subroutine PAIRPAK and then does a buffer out of ZVOUT to TAPEj.
Typically at least two records are written per event. For all other
computers IF=STDIO is selected, and ZEVEL is written out with a
standard FORTRAN unformatted write.

\subsection{Beginning Record}

      At the start of each run ISAWBG is called. It writes out the
following common blocks:
\begin{verbatim}
+CDE,DYLIM
\end{verbatim}
\begin{tabular}{lcl}
QMIN,QMAX          &=& $W$ mass limits\\
QTMIN,QTMAX        &=& $W$ $q_t$ limits\\
YWMIN,YWMAX        &=& $W$ $\eta$ rapidity limits\\
XWMIN,XWMAX        &=& $W$ $x_F$ limits\\
THWMIN,THWMAX      &=& $W$ $\theta$ limits\\
PHWMIN,PHWMAX      &=& $W$ $\phi$ limits\\
\end{tabular}

\begin{verbatim}
+CDE,IDRUN
\end{verbatim}
\begin{tabular}{lcl}
IDVER              &=& program version\\
IDG(1)             &=& run date (10000$\times$month+100$\times$day+year)\\
IDG(2)             &=& run time (10000$\times$hour+100$\times$minute+second)\\
IEVT               &=& event number\\
\end{tabular}

\begin{verbatim}
+CDE,JETLIM
\end{verbatim}
\begin{tabular}{lcl}
PMIN,PMAX          &=& jet momentum limits\\
PTMIN,PTMAX        &=& jet $p_t$ limits\\
YJMIN,YJMAX        &=& jet $\eta$ rapidity limits\\
PHIMIN,PHIMAX      &=& jet $\phi$ limits\\
THMIN,THMAX        &=& jet $\theta$ limits\\
\end{tabular}

\begin{verbatim}
+CDE,KEYS
\end{verbatim}
\begin{tabular}{lcl}
KEYON              &=& normally TRUE, FALSE if no good reaction\\
KEYS               &=& TRUE if reaction I is chosen\\
                   && 1 for TWOJET\\
                   && 2 for E+E-\\
                   && 3 for DRELLYAN\\
                   && 4 for MINBIAS\\
                   && 5 for SUPERSYM\\
                   && 6 for WPAIR\\
REAC               &=& character reaction code\\
\end{tabular}

\begin{verbatim}
+CDE,PRIMAR
\end{verbatim}
\begin{tabular}{lcl}
NJET               &=& number of jets per event\\
SCM                &=& square of com energy\\
HALFE              &=& beam energy\\
ECM                &=& com energy\\
IDIN               &=& ident code for initial beams\\
NEVENT             &=& number of events to be generated\\
NTRIES             &=& maximum number of tries for good jet parameters\\
NSIGMA             &=& number of extra events to determine SIGF\\
\end{tabular}

\begin{verbatim}
+CDE,Q1Q2
\end{verbatim}
\begin{tabular}{lcl}
GOQ(I,K)           &=& TRUE if quark type I allowed for jet k\\
                   && I = 1  2  3  4  5  6  7  8  9 10 11 12 13\\
                   && \ \ $\Rightarrow$ $g$ $u$ $\bar u$ $d$ $\bar d$ $s$ 
                      $\bar s$ $c$ $\bar c$ $b$ $\bar b$ $t$ $\bar t$\\
                   && I = 14   15 16 17  18   19  20  21  22   23   24   25\\
                   && \ \ $\Rightarrow$ $\nu_e$ $\bar\nu_e$ $e^-$ $e^+$ 
                      $\nu_\mu$ $\bar\nu_\mu$ $\mu^-$ $\mu^+$ $\nu_\tau$ 
                      $\bar\nu_\tau$ $\tau^-$ $\tau^+$\\
GOALL(K)           &=& TRUE if all jet types allowed\\
GODY(I)            &=& TRUE if $W$ type I is allowed.\\
                    I= 1  2  3  4\\
                      GM W+ W- Z0\\
STDDY              &=& TRUE if standard DRELLYAN\\
GOWW(I,K)          &=& TRUE if I is allowed in the decay of K for WPAIR.\\
ALLWW(K)           &=& TRUE if all allowed in the decay of K for WPAIR.\\
\end{tabular}

\begin{verbatim}
+CDE,QCDPAR
\end{verbatim}
\begin{tabular}{lcl}
ALAM               &=& QCD scale $\Lambda$\\
ALAM2              &=& QCD scale $\Lambda^2$\\
CUTJET             &=& cutoff for generating secondary partons\\
ISTRUC             &=& 3 for Eichten (EHLQ), \\
                   &=& 4 for Duke (DO) \\
                   &=& 5 for CTEQ 2L\\
                   &=& 6 for CTEQ 3L\\
                   &=& $-999$ for PDFLIB\\
\end{tabular}

\begin{verbatim}
+CDE,QLMASS
\end{verbatim}
\begin{tabular}{lcl}
AMLEP(6:8)         &=& $t$,$y$,$x$ masses, only elements written\\
\end{tabular}

\subsection{Event Record}

      For each event ISAWEV is called. It writes out the following
common blocks:
\begin{verbatim}
+CDE,FINAL
\end{verbatim}
\begin{tabular}{lcl}
SIGF              &=& integrated cross section, only element written\\
\end{tabular}

\begin{verbatim}
+CDE,IDRUN
\end{verbatim}
\begin{tabular}{lcl}
IDVER              &=& program version\\
IDG                &=& run identification\\
IEVT               &=& event number\\
\end{tabular}

\begin{verbatim}
+CDE,JETPAR
\end{verbatim}
\begin{tabular}{lcl}
P                  &=& jet momentum $\vert\vec p\vert$\\
PT                 &=& jet $p_t$\\
YJ                 &=& jet $\eta$ rapidity\\
PHI                &=& jet $\phi$\\
XJ                 &=& jet $x_F$\\
TH                 &=& jet $\theta$\\
CTH                &=& jet $\cos(\theta)$\\
STH                &=& jet $\sin(\theta)$\\
JETTYP             &=& jet type. The code is listed under /Q1Q2/ above\\
                   &&  {\it continued\dots}\\
\end{tabular}

\begin{tabular}{lcl}
SHAT,THAT,UHAT     &=& hard scattering $\hat s$, $\hat t$, $\hat u$\\
QSQ                &=& effective $Q^2$\\
X1,X2              &=& initial parton $x_F$\\
PBEAM              &=& remaining beam momentum\\
QMW                &=& $W$ mass\\
QW                 &=& $W$ momentum\\
QTW                &=& $W$ transverse momentum\\
YW                 &=& $W$ rapidity\\
XW                 &=& $W$ $x_F$\\
THW                &=& $W$ $\theta$\\
QTMW               &=& $\sqrt{q_{t,W}^2+Q^2}$\\
PHIW               &=& $W$ $\phi$\\
SHAT1,THAT1,UHAT1  &=& invariants for $W$ decay\\
JWTYP              &=& $W$ type. The code is listed under /Q1Q2/ above.\\
ALFQSQ             &=& QCD coupling $\alpha_s(Q^2)$\\
CTHW               &=& $W$ $\cos(\theta)$\\
STHW               &=& $W$ $\sin(\theta)$\\
Q0W                &=& $W$ energy\\
\end{tabular}

\begin{verbatim}
+CDE,JETSET
\end{verbatim}
\begin{tabular}{lcl}
NJSET              &=& number of partons\\
PJSET(1,I)         &=& $p_x$ of parton I\\
PJSET(2,I)         &=& $p_y$ of parton I\\
PJSET(3,I)         &=& $p_z$ of parton I\\
PJSET(4,I)         &=& $p_0$ of parton I\\
PJSET(5,I)         &=& mass of parton I\\
JORIG(I)           &=& JPACK*JET+K if I is a decay product of K.\\
                   && IF K=0 then I is a primary parton.\\
                   && (JET = 1,2,3 for final jets.)\\
                   && (JET = 11,12 for initial jets.)\\
JTYPE(I)           &=& IDENT code for parton I\\
JDCAY(I)           &=& JPACK*K1+K2 if K1 and K2 are decay products of I.\\
                   &&  If JDCAY(I)=0 then I is a final parton\\
MXJSET             &=& dimension for /JETSET/ arrays.\\
JPACK              &=& packing integer for /JETSET/ arrays.\\
\end{tabular}

\begin{verbatim}
+CDE,JETSIG
\end{verbatim}
\begin{tabular}{lcl}
SIGMA              &=& cross section summed over types\\
SIGS(I)            &=& cross section for reaction I (not written)\\
NSIGS              &=& number of nonzero cross sections (not written)\\
INOUT(I)           &=& packed partons for process I (not written)\\
MXSIGS             &=& dimension for JETSIG arrays (not written)\\
SIGEVT             &=& partial cross section for selected channel\\
\end{tabular}

\begin{verbatim}
+CDE,PARTCL
\end{verbatim}
\begin{tabular}{lcl}
NPTCL              &=& number of particles\\
PPTCL(1,I)         &=& $p_x$ for particle I\\
PPTCL(2,I)         &=& $p_y$ for particle I\\
PPTCL(3,I)         &=& $p_z$ for particle I\\
PPTCL(4,I)         &=& $p_0$ for particle I\\
PPTCL(5,I)         &=& mass for particle I\\
IORIG(I)           &=& IPACK*JET+K if I is a decay product of K.\\
                   &=& -(IPACK*JET+K) if I is a primary particle from\\
                   &&  parton K in /JETSET/.\\
                   &=& 0 if I is a primary beam particle.\\
                   && (JET = 1,2,3 for final jets.)\\
                   && (JET = 11,12 for initial jets.)\\
IDENT(I)           &=& IDENT code for particle I\\
IDCAY(I)           &=& IPACK*K1+K2 if decay products are K1-K2 inclusive.\\
                   && If IDCAY(I)=0 then particle I is stable.\\
MXPTCL             &=& dimension for /PARTCL/ arrays.\\
IPACK              &=& packing integer for /PARTCL/ arrays.\\
\end{tabular}

\begin{verbatim}
+CDE,PINITS
\end{verbatim}
\begin{tabular}{lcl}
PINITS(1,I)        &=& $p_x$ for initial parton I\\
PINITS(2,I)        &=& $p_y$ for initial parton I\\
PINITS(3,I)        &=& $p_z$ for initial parton I\\
PINITS(4,I)        &=& $p_0$ for initial parton I\\
PINITS(5,I)        &=& mass for initial parton I\\
IDINIT(I)          &=& IDENT for initial parton I\\
\end{tabular}

\begin{verbatim}
+CDE,PJETS
\end{verbatim}
\begin{tabular}{lcl}
PJETS(1,I)         &=& $p_x$ for jet I\\
PJETS(2,I)         &=& $p_y$ for jet I\\
PJETS(3,I)         &=& $p_z$ for jet I\\
PJETS(4,I)         &=& $p_0$ for jet I\\
PJETS(5,I)         &=& mass for jet I\\
IDJETS(I)          &=& IDENT code for jet I\\
QWJET(1)           &=& $p_x$ for $W$\\
QWJET(2)           &=& $p_y$ for $W$\\
QWJET(3)           &=& $p_z$ for $W$\\
QWJET(4)           &=& $p_0$ for $W$\\
QWJET(5)           &=& mass for $W$\\
IDENTW             &=& IDENT CODE for $W$\\
PPAIR(1,I)         &=& $p_x$ for WPAIR decay product I\\
PPAIR(2,I)         &=& $p_y$ for WPAIR decay product I\\
PPAIR(3,I)         &=& $p_z$ for WPAIR decay product I\\
PPAIR(4,I)         &=& $p_0$ for WPAIR decay product I\\
PPAIR(5,I)         &=& mass for WPAIR decay product I\\
IDPAIR(I)          &=& IDENT code for WPAIR product I\\
JPAIR(I)           &=& JETTYPE code for WPAIR product I\\
NPAIR              &=& 2 for $W^\pm\gamma$ events, 4 for $WW$ events\\
\end{tabular}

\begin{verbatim}
+CDE,TOTALS
\end{verbatim}
\begin{tabular}{lcl}
NKINPT             &=& number of kinematic points generated.\\
NWGEN              &=& number of W+jet events accepted.\\
NKEEP              &=& number of events kept.\\
SUMWT              &=& sum of weighted cross sections.\\
WT                 &=& current weight. (SIGMA$\times$WT = event weight.)\\
\end{tabular}

\begin{verbatim}
+CDE,WSIG
\end{verbatim}
\begin{tabular}{lcl}
SIGLLQ             &=& cross section for $W$ decay.\\
\end{tabular}

      Of course irrelevant common blocks such as /WSIG/ for TWOJET
events are not written out.

\subsection{End Record} 

      At the end of a set ISAWND is called. It writes out the
following common block:
\begin{verbatim}
+CDE,FINAL
\end{verbatim}
\begin{tabular}{lcl}
NKINF             &=& number of points generated to calculate SIGF\\
SIGF              &=& integrated cross section for this run\\
ALUM              &=& equivalent luminosity for this run\\
ACCEPT            &=& ratio of events kept over events generated\\
NRECS             &=& number of physical records for this run\\
\end{tabular}

      Events within a given run have uniform weight. Separate runs can
be combined together using SIGF/NEVENT as the weight per event. This
gives a true cross section in mb units.

      The user can replace subroutines ISAWBG, ISAWEV, and ISAWND to
write out the events in a different format or to update histograms
using HBOOK or any similar package.
+EOD
+DECK,TAPE
\newpage
\section{File Reading\label{TAPE}}

      The FORTRAN instruction
\begin{verbatim}
      CALL RDTAPE(IDEV,IFL)
\end{verbatim}
will read a beginning record, an end record or an event (which can be
more than one record). IDEV is the tape number and
\begin{verbatim}
      IFL=0  for a good read,
      IFL=-1 for an end of file.
\end{verbatim}
The information is restored to the common blocks described above. The
type of record is contained in
\begin{verbatim}
+CDE,RECTP
\end{verbatim}
\begin{tabular}{lcl}
IRECTP            &=& 100 for an event record\\
IRECTP            &=& 200 for a beginning record\\
IRECTP            &=& 300 for an end record\\
IREC              &=& no. of physical records in event record, 0 
                      otherwise\\
\end{tabular}

      The parton momenta from the primary hard scattering are
contained in /PJETS/. The parton momenta generated by the QCD cascade
are contained in /JETSET/. The hadron momenta both from the QCD jets
and from the beam jets are contained in /PARTCL/. The final hadron
momenta and the associated pointers should be used to calculate the
jet momenta, since they are changed both by the QCD cascade and by
hadronization. Particles with IDCAY=0 are stable, while the others are
resonances.

      The weight per event needed to produce a weighted histogram in
millibarn units is SIGF/NEVENT. The integrated cross section SIGF is
calculated by Monte Carlo integration during the run for the given
kinematic limits and JETTYPE, WTYPE, and WMODE selections. Any of three
methods can be used to find the value of SIGF:

      (1) The current value, which is written out with each event, can
be used. To prevent enormous fluctuations at the beginning of a run,
NSIGMA extra primary parton events are generated first. The default
value, NSIGMA = 20, gives negligible overhead but may not be large
enough for good accuracy.

      (2) The value SIGF calculated with the full statistics of the run
can be obtained by reading through the tape until an end record
(IRECTP=300) is found. After SIGF is saved with a different name, the
first event record for the run can be found by backspacing the tape
NRECS times.

      (3) Unweighted histograms can be made for the run and the weight
added after the end record is found. An implementation of this using
special features of HBOOK is contained in ISAPLT.

      The functions AMASS(IDENT), CHARGE(IDENT), and LABEL(IDENT) are
available to determine the mass, charge, and character label in A8
format. Subroutine FLAVOR returns the quark content of any hadron and
may be useful to convert IDENT codes to other schemes. CALL PRTEVT(0)
prints an event.
+EOD
+DECK,DECAY
\newpage
\section{Decay Table\label{DECAY}}

      ISAJET uses an external table of decay modes. Particles can be
put into the table in arbitrary order, but all modes for each particle
must be grouped together. The table is rewound and read in before each
run with a READ* format. Beginning with Version 7.41, the decay table
must begin with a comment of the form
\begin{verbatim}
' ISAJET     V7.41   11-JAN-1999 20:41:57'
\end{verbatim}
If this does not match the internal version number, a warning is
printed. After this initial line, each entry must have the form
\begin{verbatim}
IDENT,MELEM,CBR,ID1,ID2,ID3,ID4,ID5/
\end{verbatim}
where IDENT is the code for the parent particle, MELEM specifies the
decay matrix element, CBR is the cumulative branching ratio, and
ID1,\dots,ID5 are the IDENT codes for the decay products. The
currently defined values of MELEM are:
\begin{center}
\begin{tabular}{cl}
\hline
MELEM   &\quad Matrix Element \\
\hline
0       &\quad Phase Space \\
1       &\quad Dalitz decay \\
2       &\quad $\omega/\phi$ decay \\
3       &\quad $V-A$ decay \\
4       &\quad top decay: $V-A$ plus $W$ propagator \\
5       &\quad $\tau \to \ell \nu \bar \nu$ \\
6       &\quad $\tau \to \nu \pi$, $\nu K$ \\
7       &\quad $\tau \to \nu \rho$, $\nu a_1$ \\
\hline
\end{tabular}
\end{center}
The parent IDENT must be positive; the charge conjugate mode is used
for the antiparticle. The values of CBR must of course be positive and
monotonically increasing for each mode, with the last value being 1.00
for each parent IDENT. The last parent IDENT code must be zero. Care
should be taken in adding new modes, since there is no checking for
validity. In some cases order is important; note in particular that
quarks and gluons must always appear last so that they can be removed
and fragmented into hadrons.

      The format of the decay table for Versions 7.41 and later is
incompatible with that for Versions 7.40 and earlier. Using an
obsolete decay table will produce incorrect results.

      The decay table is contained in patch ISADECAY.
+EOD
+DECK,IDENT
\newpage
\section{IDENT Codes\label{IDENT}}

      ISAJET uses a numerical ident code for particle types. Quarks
and leptons are numbered in order of mass:
\begin{verbatim}
         UP     = 1             NUE    = 11
         DN     = 2             E-     = 12
         ST     = 3             NUM    = 13
         CH     = 4             MU-    = 14
         BT     = 5             NUT    = 15
         TP     = 6             TAU-   = 16
\end{verbatim}
with a negative sign for antiparticles. Arbitrary conventions are:
\begin{verbatim}
         GL     = 9
         GM     = 10
         KS     = 20
         KL     =-20
         W+     = 80
         Z0     = 90
\end{verbatim}
The supersymmetric particle IDENT codes distinguish between the
partners of left and right handed fermions and include the Higgs
sector of the minimal supersymmetric model:
\begin{verbatim}
         UPSSL ... TPSS1 = 21 ... 26
         NUEL ... TAU1-  = 31 ... 36
         UPSSR ... TPSS2 = 41 ... 46
         NUER ... TAU2-  = 51 ... 56
         GLSS  = 29
         Z1SS  = 30            Z2SS  = 40
         Z3SS  = 50            Z4SS  = 60
         W1SS+ = 39            W2SS+ = 49

         HL0   = 82            HH0   = 83
         HA0   = 84            H+    = 86
\end{verbatim}
Finally, the gravitino and graviton are
\begin{verbatim}
         GVSS  = 91            GRAV  = 92
\end{verbatim}
The same symbol is used for the graviton and its (possible) Kaluza-Klein
excitations.

      The code for a meson is a compound integer +-JKL, where J.LE.K are
the quarks and L is the spin. The sign is for the J quark. Glueball
IDENT codes have not been selected, but the choice GL=9 clearly allows
990, 9990, etc. Flavor singlet mesons are ordered by mass,
\begin{verbatim}
         PI0    = 110
         ETA    = 220
         ETAP   = 330
         ETAC   = 440
\end{verbatim}
which is natural for the heavy quarks. Similarly, the code for a
baryon is a compound integer +-IJKL formed from the three quarks I,J,K
and a spin label L=0,1. The code for a diquark is +-IJ00. Additional
states are distinguished by a fifth integer, e.g., 
\begin{verbatim}
         A1+    = 10121
\end{verbatim}
These and a few J=2 mesons are used in some of the B decays.

      A routine PRTLST is provided to print out a complete list of valid
IDENT codes and associated information. The usage is
      CALL PRTLST(LUN, AMY, AMX)
where LUN is the unit number and AMY and AMX are the masses of the Y and
X quarks respectively. This routine should be linked with the ISAJET
library and with ALDATA.

      The complete list of ident codes follows. (Hadrons containing $t$
quarks are defined but are no longer listed since the $t$ quark is
treated as a particle.)
\begin{verbatim}
      IDENT     LABEL           MASS    CHARGE
          1     UP        .30000E+00       .67
         -1     UB        .30000E+00      -.67
          2     DN        .30000E+00      -.33
         -2     DB        .30000E+00       .33
          3     ST        .50000E+00      -.33
         -3     SB        .50000E+00       .33
          4     CH        .16000E+01       .67
         -4     CB        .16000E+01      -.67
          5     BT        .49000E+01      -.33
         -5     BB        .49000E+01       .33
          6     TP        .17500E+03       .67
         -6     TB        .17500E+03      -.67

          9     GL       0.               0.00

         10     GM       0.               0.00

         11     NUE      0.               0.00
        -11     ANUE     0.               0.00
         12     E-        .51100E-03     -1.00
        -12     E+        .51100E-03      1.00
         13     NUM      0.               0.00
        -13     ANUM     0.               0.00
         14     MU-       .10566E+00     -1.00
        -14     MU+       .10566E+00      1.00
         15     NUT      0.               0.00
        -15     ANUT     0.               0.00
         16     TAU-      .18070E+01     -1.00
        -16     TAU+      .18070E+01      1.00

         20     KS        .49767E+00      0.00
        -20     KL        .49767E+00      0.00

         21     UPSSL     none            0.67
        -21     UBSSL     none           -0.67
         22     DNSSL     none           -0.33
        -22     DBSSL     none            0.33
         23     STSSL     none           -0.33
         23     SBSSL     none            0.33
         24     CHSSL     none            0.67
        -24     CBSSL     none           -0.67
         25     BTSS1     none           -0.33
        -25     BBSS1     none            0.33
         26     TPSS1     none            0.67
        -26     TBSS1     none           -0.67

         29     GLSS      none            0.00
         30     Z1SS      none            0.00

         31     NUEL      none            0.00
        -31     ANUEL     none            0.00
         32     EL-       none           -1.00
        -32     EL+       none           +1.00
         33     NUML      none            0.00
        -33     ANUML     none            0.00
         34     MUL-      none           -1.00
        -34     MUL+      none           +1.00
         35     NUTL      none            0.00
        -35     ANUTL     none            0.00
         36     TAU1-     none           -1.00
        -36     TAU1+     none           -1.00

         39     W1SS+     none            1.00
        -39     W1SS-     none           -1.00
         40     Z2SS      none            0.00

         41     UPSSR     none            0.67
        -41     UBSSR     none           -0.67
         42     DNSSR     none           -0.33
        -42     DBSSR     none            0.33
         43     STSSR     none           -0.33
         43     SBSSR     none            0.33
         44     CHSSR     none            0.67
        -44     CBSSR     none           -0.67
         45     BTSS2     none           -0.33
        -45     BBSS2     none            0.33
         46     TPSS2     none            0.67
        -46     TBSS2     none           -0.67

         49     W2SS+     none            1.00
        -49     W2SS-     none           -1.00
         50     Z3SS      none            0.00

         51     NUER      none            0.00
        -51     ANUER     none            0.00
         52     ER-       none           -1.00
        -52     ER+       none           +1.00
         53     NUMR      none            0.00
        -53     ANUMR     none            0.00
         54     MUR-      none           -1.00
        -54     MUR+      none           +1.00
         55     NUTR      none            0.00
        -55     ANUTR     none            0.00
         56     TAU2-     none           -1.00
        -56     TAU2+     none           -1.00
         60     Z4SS      none            0.00

         80     W+        .80200E+02      1.00
         81     HIGGS     .80200E+02      0.00
         82     HL0       none            0.00
         83     HH0       none            0.00
         84     HA0       none            0.00
         86     H+        none            1.00
         90     Z0        .91190E+02      0.00
         91     GVSS      0               0.00
         92     GRAV      0               0.00


        110     PI0       .13496E+00      0.00
        120     PI+       .13957E+00      1.00
       -120     PI-       .13957E+00     -1.00
        220     ETA       .54745E+00      0.00
        130     K+        .49367E+00      1.00
       -130     K-        .49367E+00     -1.00
        230     K0        .49767E+00      0.00
       -230     AK0       .49767E+00      0.00
        330     ETAP      .95760E+00      0.00
        140     AD0       .18645E+01      0.00
       -140     D0        .18645E+01      0.00
        240     D-        .18693E+01     -1.00
       -240     D+        .18693E+01      1.00
        340     F-        .19688E+01     -1.00
       -340     F+        .19688E+01      1.00
        440     ETAC      .29788E+01      0.00
        150     UB.       .51700E+01      1.00
       -150     BU.       .51700E+01     -1.00
        250     DB.       .51700E+01      0.00
       -250     BD.       .51700E+01      0.00
        350     SB.       .53700E+01      0.00
       -350     BS.       .53700E+01      0.00
        450     CB.       .64700E+01      1.00
       -450     BC.       .64700E+01     -1.00
        550     BB.       .97700E+01      0.00

        111     RHO0      .76810E+00      0.00
        121     RHO+      .76810E+00      1.00
       -121     RHO-      .76810E+00     -1.00
        221     OMEG      .78195E+00      0.00
        131     K*+       .89159E+00      1.00
       -131     K*-       .89159E+00     -1.00
        231     K*0       .89610E+00      0.00
       -231     AK*0      .89610E+00      0.00
        331     PHI       .10194E+01      0.00
        141     AD*0      .20071E+01      0.00
       -141     D*0       .20071E+01      0.00
        241     D*-       .20101E+01     -1.00
       -241     D*+       .20101E+01      1.00
        341     F*-       .21103E+01     -1.00
       -341     F*+       .21103E+01      1.00
        441     JPSI      .30969E+01      0.00
        151     UB*       .52100E+01      1.00
       -151     BU*       .52100E+01     -1.00
        251     DB*       .52100E+01      0.00
       -251     BD*       .52100E+01      0.00
        351     SB*       .54100E+01      0.00
       -351     BS*       .54100E+01      0.00
        451     CB*       .65100E+01      1.00
       -451     BC*       .65100E+01     -1.00
        551     UPSL      .98100E+01      0.00

        112     F2        .12750E+01      0.00
        132     K2*+      .14254E+01      1.00
       -132     K2*-      .14254E+01     -1.00
        232     K2*0      .14324E+01      0.00
       -232     AK2*0     .14324E+01      0.00

      10110     F0        .98000E+00      0.00

      10111     A10       .12300E+01      0.00
      10121     A1+       .12300E+01      1.00
     -10121     A1-       .12300E+01     -1.00
      10131     K1+       .12730E+01      1.00
     -10131     K1-       .12730E+01     -1.00
      10231     K10       .12730E+01      0.00
     -10231     AK10      .12730E+01      0.00
      30131     K1*+      .14120E+01      1.00
     -30131     K1*-      .14120E+01     -1.00
      30231     K1*0      .14120E+01      0.00
     -30231     AK1*0     .14120E+01      0.00

      10441     PSI(2S)   .36860E+01      0.00

      20440     CHI0      .34151E+01      0.00
      20441     CHI1      .35105E+01      0.00
      20442     CHI2      .35662E+01      0.00


       1120     P         .93828E+00      1.00
      -1120     AP        .93828E+00     -1.00
       1220     N         .93957E+00      0.00
      -1220     AN        .93957E+00      0.00
       1130     S+        .11894E+01      1.00
      -1130     AS-       .11894E+01     -1.00
       1230     S0        .11925E+01      0.00
      -1230     AS0       .11925E+01      0.00
       2130     L         .11156E+01      0.00
      -2130     AL        .11156E+01      0.00
       2230     S-        .11974E+01     -1.00
      -2230     AS+       .11974E+01      1.00
       1330     XI0       .13149E+01      0.00
      -1330     AXI0      .13149E+01      0.00
       2330     XI-       .13213E+01     -1.00
      -2330     AXI+      .13213E+01      1.00
       1140     SC++      .24527E+01      2.00
      -1140     ASC--     .24527E+01     -2.00
       1240     SC+       .24529E+01      1.00
      -1240     ASC-      .24529E+01     -1.00
       2140     LC+       .22849E+01      1.00
      -2140     ALC-      .22849E+01     -1.00
       2240     SC0       .24525E+01      0.00
      -2240     ASC0      .24525E+01      0.00
       1340     USC.      .25000E+01      1.00
      -1340     AUSC.     .25000E+01     -1.00
       3140     SUC.      .24000E+01      1.00
      -3140     ASUC.     .24000E+01     -1.00
       2340     DSC.      .25000E+01      0.00
      -2340     ADSC.     .25000E+01      0.00
       3240     SDC.      .24000E+01      0.00
      -3240     ASDC.     .24000E+01      0.00
       3340     SSC.      .26000E+01      0.00
      -3340     ASSC.     .26000E+01      0.00
       1440     UCC.      .35500E+01      2.00
      -1440     AUCC.     .35500E+01     -2.00
       2440     DCC.      .35500E+01      1.00
      -2440     ADCC.     .35500E+01     -1.00
       3440     SCC.      .37000E+01      1.00
      -3440     ASCC.     .37000E+01     -1.00
       1150     UUB.      .54700E+01      1.00
      -1150     AUUB.     .54700E+01     -1.00
       1250     UDB.      .54700E+01      0.00
      -1250     AUDB.     .54700E+01      0.00
       2150     DUB.      .54700E+01      0.00
      -2150     ADUB.     .54700E+01      0.00
       2250     DDB.      .54700E+01     -1.00
      -2250     ADDB.     .54700E+01      1.00
       1350     USB.      .56700E+01      0.00
      -1350     AUSB.     .56700E+01      0.00
       3150     SUB.      .56700E+01      0.00
      -3150     ASUB.     .56700E+01      0.00
       2350     DSB.      .56700E+01     -1.00
      -2350     ADSB.     .56700E+01      1.00
       3250     SDB.      .56700E+01     -1.00
      -3250     ASDB.     .56700E+01      1.00
       3350     SSB.      .58700E+01     -1.00
      -3350     ASSB.     .58700E+01      1.00
       1450     UCB.      .67700E+01      1.00
      -1450     AUCB.     .67700E+01     -1.00
       4150     CUB.      .67700E+01      1.00
      -4150     ACUB.     .67700E+01     -1.00
       2450     DCB.      .67700E+01      0.00
      -2450     ADCB.     .67700E+01      0.00
       4250     CDB.      .67700E+01      0.00
      -4250     ACDB.     .67700E+01      0.00
       3450     SCB.      .69700E+01      0.00
      -3450     ASCB.     .69700E+01      0.00
       4350     CSB.      .69700E+01      0.00
      -4350     ACSB.     .69700E+01      0.00
       4450     CCB.      .80700E+01      1.00
      -4450     ACCB.     .80700E+01     -1.00
       1550     UBB.      .10070E+02      0.00
      -1550     AUBB.     .10070E+02      0.00
       2550     DBB.      .10070E+02     -1.00
      -2550     ADBB.     .10070E+02      1.00
       3550     SBB.      .10270E+02     -1.00
      -3550     ASBB.     .10270E+02      1.00
       4550     CBB.      .11370E+02      0.00
      -4550     ACBB.     .11370E+02      0.00

       1111     DL++      .12320E+01      2.00
      -1111     ADL--     .12320E+01     -2.00
       1121     DL+       .12320E+01      1.00
      -1121     ADL-      .12320E+01     -1.00
       1221     DL0       .12320E+01      0.00
      -1221     ADL0      .12320E+01      0.00
       2221     DL-       .12320E+01     -1.00
      -2221     ADL+      .12320E+01      1.00
       1131     S*+       .13823E+01      1.00
      -1131     AS*-      .13823E+01     -1.00
       1231     S*0       .13820E+01      0.00
      -1231     AS*0      .13820E+01      0.00
       2231     S*-       .13875E+01     -1.00
      -2231     AS*+      .13875E+01      1.00
       1331     XI*0      .15318E+01      0.00
      -1331     AXI*0     .15318E+01      0.00
       2331     XI*-      .15350E+01     -1.00
      -2331     AXI*+     .15350E+01      1.00
       3331     OM-       .16722E+01     -1.00
      -3331     AOM+      .16722E+01      1.00
       1141     UUC*      .26300E+01      2.00
      -1141     AUUC*     .26300E+01     -2.00
       1241     UDC*      .26300E+01      1.00
      -1241     AUDC*     .26300E+01     -1.00
       2241     DDC*      .26300E+01      0.00
      -2241     ADDC*     .26300E+01      0.00
       1341     USC*      .27000E+01      1.00
      -1341     AUSC*     .27000E+01     -1.00
       2341     DSC*      .27000E+01      0.00
      -2341     ADSC*     .27000E+01      0.00
       3341     SSC*      .28000E+01      0.00
      -3341     ASSC*     .28000E+01      0.00
       1441     UCC*      .37500E+01      2.00
      -1441     AUCC*     .37500E+01     -2.00
       2441     DCC*      .37500E+01      1.00
      -2441     ADCC*     .37500E+01     -1.00
       3441     SCC*      .39000E+01      1.00
      -3441     ASCC*     .39000E+01     -1.00
       4441     CCC*      .48000E+01      2.00
      -4441     ACCC*     .48000E+01     -2.00
       1151     UUB*      .55100E+01      1.00
      -1151     AUUB*     .55100E+01     -1.00
       1251     UDB*      .55100E+01      0.00
      -1251     AUDB*     .55100E+01      0.00
       2251     DDB*      .55100E+01     -1.00
      -2251     ADDB*     .55100E+01      1.00
       1351     USB*      .57100E+01      0.00
      -1351     AUSB*     .57100E+01      0.00
       2351     DSB*      .57100E+01     -1.00
      -2351     ADSB*     .57100E+01      1.00
       3351     SSB*      .59100E+01     -1.00
      -3351     ASSB*     .59100E+01      1.00
       1451     UCB*      .68100E+01      1.00
      -1451     AUCB*     .68100E+01     -1.00
       2451     DCB*      .68100E+01      0.00
      -2451     ADCB*     .68100E+01      0.00
       3451     SCB*      .70100E+01      0.00
      -3451     ASCB*     .70100E+01      0.00
       4451     CCB*      .81100E+01      1.00
      -4451     ACCB*     .81100E+01     -1.00
       1551     UBB*      .10110E+02      0.00
      -1551     AUBB*     .10110E+02      0.00
       2551     DBB*      .10110E+02     -1.00
      -2551     ADBB*     .10110E+02      1.00
       3551     SBB*      .10310E+02     -1.00
      -3551     ASBB*     .10310E+02      1.00
       4551     CBB*      .11410E+02      0.00
      -4551     ACBB*     .11410E+02      0.00
       5551     BBB*      .14710E+02     -1.00
      -5551     ABBB*     .14710E+02      1.00
            
                     
       1100     UU0.      .60000E+00      0.67
      -1100     AUU0.     .60000E+00     -0.67
       1200     UD0.      .60000E+00      0.33
      -1200     AUD0.     .60000E+00     -0.33
       2200     DD0.      .60000E+00     -0.67
      -2200     ADD0.     .60000E+00      0.67
       1300     US0.      .80000E+00      0.33
      -1300     AUS0.     .80000E+00     -0.33
       2300     DS0.      .80000E+00     -0.67
      -2300     ADS0.     .80000E+00      0.67
       3300     SS0.      .10000E+01     -0.67
      -3300     ASS0.     .10000E+01      0.67
       1400     UC0.      .19000E+01      1.33
      -1400     AUC0.     .19000E+01     -1.33
       2400     DC0.      .19000E+01      0.33
      -2400     ADC0.     .19000E+01     -0.33
       3400     SC0.      .21000E+01      0.33
      -3400     ASC0.     .21000E+01     -0.33
       4400     CC0.      .32000E+01      1.33
      -4400     ACC0.     .32000E+01     -1.33
       1500     UB0.      .49000E+01      0.33
      -1500     AUB0.     .49000E+01     -0.33
       2500     DB0.      .49000E+01     -0.67
      -2500     ADB0.     .49000E+01      0.67
       3500     SB0.      .51000E+01     -0.67
      -3500     ASB0.     .51000E+01      0.67
       4500     CB0.      .65000E+01      0.33
      -4500     ACB0.     .65000E+01     -0.33
       5500     BB0.      .98000E+01     -0.67
      -5500     ABB0.     .98000E+01      0.67
\end{verbatim}
+EOD
+DECK,HIGHER
\newpage
\section{Higher Order Processes\label{HIGHER}}

      Higher order processes can be generated either by the QCD
evolution or by supplying partons from an external generator.

      Frequently it is interesting to generate higher-order processes
with a particular branching in the QCD evolution or with a particular
particle or group of particles being produced from the fragmentation.
Examples include
\begin{enumerate}
\item Branching of jets into heavy quarks (e.g., $g \to b + \bar b$);
\item Decay of such a heavy quark into a lepton or neutrino;
\item Radiation of a photon, $W$, or $Z$ from a jet.
\end{enumerate}
It is important to realize that all of the cross sections and the QCD
evolution in ISAJET are based on leading-log QCD, so generating such
processes does not give the correct higher order QCD cross sections or
``K factors'', even though it may produce better agreement with them in
some cases. 

       ISAJET does produce events with particular topologies which
in many cases are the most important effect of higher order processes.
In the heavy quark example, the lowest order process
$$
g + g \to Q + \bar Q
$$
produces back-to-back heavy quark pairs, whereas the splitting process
$$      
g + g \to g + g, \quad g \to Q + \bar Q
$$
produces collinear pairs. Such collinear pairs are essential to obtain
agreement with experimental data on $b \bar b$ production, and they
often are the dominant background for processes of interest.

      Branchings such as the emission of a heavy quark pair, a photon,
or a $W^\pm$ or $Z^0$ are rare, and since they may occur at any step
in the evolution, one cannot force them to occur. Therefore,
generation of such events is very slow. M. Della Negra (UA1) suggested
first doing $n_1$ QCD evolutions for each hard scattering and
rejecting events without the desired partons, then doing $n_2$
fragmentations for each successful evolution. This generates the
equivalent of $n_1 n_2$ events for each hard scattering, so the cross
section must be divided by $n_1 n_2$. This algorithm can speed up the
generation of $g \to b + \bar b$ splitting by a factor of ten for $n_1
= n_2 = 10$.

      Since the evolution and fragmentation steps are executed $n_1n_2$
times even if good events are found, a single hard scattering can lead
to multiple events. This does not change the inclusive cross sections,
but it does mean that the fluctuations may be larger than expected.
Hence it is important to choose the numbers $n_1$ and $n_2$ carefully.

      The following entities are used in ISAJET for generating events 
with multiple evolution and fragmentation:

      \verb|NEVENT|: The number of primary hard scatterings to be
generated. Set as usual on the input line with the energy.

       \verb|SIGF|: The cross section for the selected hard
scatterings divided by $n_1 \times n_2$. Hence the correct weight is
SIGF/NEVENT, just as for normal running. (The cross section printed at
the end of a run does not contain this factor.)

       \verb|NEVOLVE|: The number $n_1$ of evolutions per hard
scattering. This should never be set unless you supply a REJJET
function. Do not confuse this with NOEVOLVE.

       \verb|NHADRON|: The number $n_2$ of fragmentations for a given
evolution. This should never be set unless you supply a REJFRG
function. Do not confuse this with NOHADRON.

       \verb|REJJET|: A logical function which if true causes the
evolution to be rejected. The user must supply one to make the
selections which he wants. The default always .FALSE. but includes an
example as a comment.

      \verb|REJFRG|: A logical function which if true causes the
fragmentation to be rejected. The user must supply one to make the
selections which he wants. The default always .FALSE. but includes an
example as a comment.

\noindent Note that one can also use function EDIT to make a final
selection of the events. Of course ISAJET must be relinked if EDIT,
REJJET or REJFRG is modified.

      At the end of a run, the jet cross section, the cross section for
the selected events, and the number and fraction of events selected are
printed. The cross section SIGF stored internally is divided by $n_1
\times n_2$ so that if the events are used to make histograms, then
the correct weight per event is
\begin{verbatim}
      SIGF/NEVENT
\end{verbatim}
just as for normal events. Of course NEVENT now has a different meaning;
it is in general larger than the number of events in the file but might
be smaller if NEVOLVE and NHADRON are badly chosen.

      NEVOLVE and NHADRON are set as parameters in the input. One wants
to choose them to give better acceptance of the primary hard scatterings
but not to give multiple events for one hard scattering. For lepton 
production from heavy quarks the values
\begin{verbatim}
NEVOLVE
10/
NHADRON
10/
\end{verbatim}
seem appropriate, giving reasonable efficiency. For radiation of photons
from jets, NEVOLVE can be somewhat larger but NHADRON should be one, and
REJFRG should always return .FALSE., since the selection is just on the
parton process, not on the hadronization.

      The loops over evolutions and fragmentations are done inside of
subroutine ISAEVT and are always executed the same number of times even
though ISAEVT returns after each generated event. Logical flag OK
signals a good event, and logical flag DONE signals that the run is
finished. If you control the event generation loop yourself, you should
make use of these flags as in the following extract from subroutine
ISAJET:
\begin{verbatim}
      ILOOP=0
  101 CONTINUE
        ILOOP=ILOOP+1
        CALL ISAEVT(ILOOP,OK,DONE)
        IF(OK) CALL ISAWEV
      IF(.NOT.DONE) GO TO 101
\end{verbatim}
Otherwise you may get the wrong weights.

      It is possible to supply to ISAJET events with partons generated
by some other program that may have more accurate matrix elements for
higher order processes. Because any such calculation must involve
cutoffs ISAJET assumes that the partons were generated imposing some
$R$ cutoff, where $R=\sqrt{\phi^2+\eta^2}$, and some $E_t$ cutoff.
Given that information ISAJET will generate initial state radiation
partons only below the Et cutoff and final state radiation inside the
$R$ cutoff. The external partons can be supplied to ISAJET by calls to
2 subroutines. To initialize ISAJET for externally supplied partons,
use
\begin{verbatim}
      CALL INISAP(CMSE,REACTION,BEAMS,WZ,NDCAYS,DCAYS,ETMIN,RCONE,OK)
\end{verbatim}
where the inputs are

\smallskip\noindent
\begin{tabular}{lcl}
      CMSE             &=& center of mass energy\\
      REACTION         &=& reaction (only TWOJET and DRELLYAN are \\
                       && implemented so far)\\
      BEAMS(2)         &=& chose 'P ' or 'AP'\\
      ETMIN            &=& minimum ET of supplied partons\\
      RCONE            &=& minimum cone (R) between supplied partons\\
      WZ               &=& option 'W', 'Z', or ' ' no $W$'s or $Z$'s\\
      NDCAYS           &=& number of decay options (if 0, assume decay has\\
                       &&  already been done)\\
      DCAYS            &=& list of particles W or Z can decay into\\
\end{tabular}
\smallskip

\noindent and the output is

\smallskip\noindent
\begin{tabular}{lcl}
      OK   &=& TRUE if initialization is possible\\
\end{tabular}
\smallskip

\noindent Then for each event use
\begin{verbatim}
      CALL IPARTNS(NPRTNS,IDS,PRTNS,IDQ,WEIGHT,WZDK)
\end{verbatim}
where the inputs are

\smallskip\noindent
\begin{tabular}{lcl}
       NPRTNS          &=& number of partons, $\le10$\\
       IDS(NPRTNS)     &=& ids of final partons\\
       PRTNS(4,NPRTNS) &=& parton 4 vectors\\
       IDQ(2)          &=& ids of initial partons\\
       WEIGHT          &=& weight\\
       WZDK            &=& if true last 2 partons are from W,Z decay\\
\end{tabular}
\smallskip

      Further QCD radiation is then generated consistent with
ETMIN and RCONE, and the partons are fragmented into hadrons as usual.
If RCONE is set to a value greater than 1.5 no cone restriction is
applied during parton evolution.
+EOD
+DECK,SUSY
\newpage
\section{ISASUSY: Decay Modes in the Minimal Supersymmetric
Model\label{SUSY}}

      The code in patch ISASUSY of ISAJET calculates decay modes of
supersymmetric particles based on the work of H. Baer, M. Bisset, M.
Drees, D. Dzialo (Karatas), X. Tata, J. Woodside, and their
collaborators. The calculations assume the minimal supersymmetric
extension of the standard model. The user specifies the gluino mass,
the pseudoscalar Higgs mass, the Higgsino mass parameter $\mu$,
$\tan\beta$, the soft breaking masses for the first and third
generation left-handed squark and slepton doublets and right-handed
singlets, and the third generation mixing parameters $A_t$, $A_b$, and
$A_\tau$.  Supersymmetric grand unification is assumed by default in
the chargino and neutralino mass matrices, although the user can
optionally specify arbitrary $U(1)$ and $SU(2)$ gaugino masses at the
weak scale. The first and second generations are assumed by default to
be degenerate, but the user can optionally specify different values.
These inputs are then used to calculate the mass eigenstates, mixings,
and decay modes.

      Most calculations are done at the tree level, but one-loop
results for gluino loop decays, $H \to \gamma\gamma$ and $H \to gg$, loop
corrections to the Higgs mass spectrum and couplings, and leading-log
QCD corrections to $H \to q \bar q$ are included. The Higgs masses have
been calculated using the effective potential approximation including
both top and bottom Yukawa and mixing effects. Mike Bisset and Xerxes
Tata have contributed the Higgs mass, couplings, and decay routines.
Manuel Drees has calculated several of the three-body decays including
the full Yukawa contribution, which is important for large tan(beta).
Note that e+e- annihilation to SUSY particles and SUSY Higgs bosons
have been included in ISAJET versions $>7.11$. ISAJET versions $>7.22$
include the large $\tan\beta$ solution as well as non-degenerate
sfermion masses.

Other processes may be added in future versions as the physics 
interest warrants. Note that
the details of the masses and the decay modes can be quite sensitive
to choices of standard model parameters such as the QCD coupling ALFA3
and the quark masses.  To change these, you must modify subroutine
SSMSSM. By default, ALFA3=.12.

      All the mass spectrum and branching ratio calculations in ISASUSY 
are performed by a call to subroutine SSMSSM. Effective with version 7.23,
the calling sequence is
\begin{verbatim}
      SUBROUTINE SSMSSM(XMG,XMU,XMHA,XTANB,XMQ1,XMDR,XMUR,
     $XML1,XMER,XMQ2,XMSR,XMCR,XML2,XMMR,XMQ3,XMBR,XMTR,
     $XML3,XMLR,XAT,XAB,XAL,XM1,XM2,XMT,IALLOW,IMODEL)
\end{verbatim}
where the following are taken to be independent parameters:

\smallskip\noindent
\begin{tabular}{lcl}
      XMG    &=& gluino mass\\
      XMU    &=& $\mu$ = SUSY Higgs mass\\
             &=& $-2*m_1$ of Baer et al.\\
      XMHA   &=& pseudo-scalar Higgs mass\\
      XTANB  &=& $\tan\beta$, ratio of vev's\\
             &=& $1/R$ (of old Baer-Tata notation).\\
\end{tabular}

\noindent
\begin{tabular}{lcl}
      XMQ1   &=& $\tilde q_l$ soft mass, 1st generation\\
      XMDR   &=& $\tilde d_r$ mass, 1st generation\\
      XMUR   &=& $\tilde u_r$ mass, 1st generation\\
      XML1   &=& $\tilde \ell_l$ mass, 1st generation\\
      XMER   &=& $\tilde e_r$ mass, 1st generation\\
\\
      XMQ2   &=& $\tilde q_l$ soft mass, 2nd generation\\
      XMSR   &=& $\tilde s_r$ mass, 2nd generation\\
      XMCR   &=& $\tilde c_r$ mass, 2nd generation\\
      XML2   &=& $\tilde \ell_l$ mass, 2nd generation\\
      XMMR   &=& $\tilde\mu_r$ mass, 2nd generation\\
\\
      XMQ3   &=& $\tilde q_l$ soft mass, 3rd generation\\
      XMBR   &=& $\tilde b_r$ mass, 3rd generation\\
      XMTR   &=& $\tilde t_r$ mass, 3rd generation\\
      XML3   &=& $\tilde \ell_l$ mass, 3rd generation\\
      XMTR   &=& $\tilde \tau_r$ mass, 3rd generation\\
      XAT    &=& stop trilinear term $A_t$\\
      XAB    &=& sbottom trilinear term $A_b$\\
      XAL    &=& stau trilinear term $A_\tau$\\
\\
      XM1    &=& U(1) gaugino mass\\
             &=& computed from XMG if > 1E19\\
      XM2    &=& SU(2) gaugino mass\\
             &=& computed from XMG if > 1E19\\
\\
      XMT    &=& top quark mass\\
      IALLOW &=& return flag\\
      IMODEL &=& 1 for SUGRA or MSSM\\
             &=& 2 for GMSB
\end{tabular}
\smallskip

\noindent The variable IALLOW is returned:

\smallskip\noindent
\begin{tabular}{lcl}
      IALLOW &=& 1 if Z1SS is not LSP, 0 otherwise\\
\end{tabular}
\smallskip

\noindent All variables are of type REAL except IALLOW and IMODEL, which
are INTEGER, and all masses are in GeV. The notation is taken to
correspond to that of Haber and Kane, although the Tata Lagrangian is
used internally. All other standard model parameters are hard wired in
this subroutine; they are not obtained from the rest of ISAJET. The
theoretically favored range of these parameters is
\begin{eqnarray*}
& 100 < M(\tilde g) < 2000\,\GeV &\\
& 100 < M(\tilde q) < 2000\,\GeV &\\
& 100 < M(\tilde\ell) < 2000\,\GeV &\\
& -1000 < \mu < 1000\,\GeV &\\
& 1 < \tan\beta < m_t/m_b &\\
& M(t) \approx 175\,\GeV &\\
& 100 < M(A) < 2000\,\GeV &\\
& M(\tilde t_l), M(t_r) < M(\tilde q) &\\
& M(\tilde b_r) \sim M(\tilde q) &\\
& -1000 < A_t < 1000\,\GeV &\\
& -1000 < A_b < 1000\,\GeV &
\end{eqnarray*}
It is assumed that the lightest supersymmetric particle is the lightest
neutralino $\tilde Z_1$, the lighter stau $\tilde\tau_1$, or the
gravitino $\tilde G$ in GMSB models. Some choices of the above
parameters may violate this assumption, yielding a light chargino or
light stop squark lighter than $\tilde Z_1$. In such cases SSMSSM does
not compute any branching ratios and returns IALLOW = 1.

      SSMSSM does not check the parameters or resulting masses against
existing experimental data. SSTEST provides a minimal test. This routine
is called after SSMSSM by ISAJET and ISASUSY and prints suitable warning
messages.

      SSMSSM first calculates the other SUSY masses and mixings and puts
them in the common block /SSPAR/:
\begin{verbatim}
C          SUSY parameters
C          AMGLSS               = gluino mass
C          AMULSS               = up-left squark mass
C          AMELSS               = left-selectron mass
C          AMERSS               = right-slepton mass
C          AMNiSS               = sneutrino mass for generation i
C          TWOM1                = Higgsino mass = - mu
C          RV2V1                = ratio v2/v1 of vev's
C          AMTLSS,AMTRSS        = left,right stop masses
C          AMT1SS,AMT2SS        = light,heavy stop masses
C          AMBLSS,AMBRSS        = left,right sbottom masses
C          AMB1SS,AMB2SS        = light,heavy sbottom masses
C          AMLLSS,AMLRSS        = left,right stau masses
C          AML1SS,AML2SS        = light,heavy stau masses
C          AMZiSS               = signed mass of Zi
C          ZMIXSS               = Zi mixing matrix
C          AMWiSS               = signed Wi mass
C          GAMMAL,GAMMAR        = Wi left, right mixing angles
C          AMHL,AMHH,AMHA       = neutral Higgs h0, H0, A0 masses
C          AMHC                 = charged Higgs H+ mass
C          ALFAH                = Higgs mixing angle
C          AAT                  = stop trilinear term
C          THETAT               = stop mixing angle
C          AAB                  = sbottom trilinear term
C          THETAB               = sbottom mixing angle
C          AAL                  = stau trilinear term
C          THETAL               = stau mixing angle
C          AMGVSS               = gravitino mass
C          MTQ                  = top mass at MSUSY
C          MBQ                  = bottom mass at MSUSY
C          MLQ                  = tau mass at MSUSY
C          FBMA                 = b-Yukawa at mA scale
C          VUQ                  = Hu vev at MSUSY
C          VDQ                  = Hd vev at MSUSY
      COMMON/SSPAR/AMGLSS,AMULSS,AMURSS,AMDLSS,AMDRSS,AMSLSS
     $,AMSRSS,AMCLSS,AMCRSS,AMBLSS,AMBRSS,AMB1SS,AMB2SS
     $,AMTLSS,AMTRSS,AMT1SS,AMT2SS,AMELSS,AMERSS,AMMLSS,AMMRSS
     $,AMLLSS,AMLRSS,AML1SS,AML2SS,AMN1SS,AMN2SS,AMN3SS
     $,TWOM1,RV2V1,AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,ZMIXSS(4,4)
     $,AMW1SS,AMW2SS
     $,GAMMAL,GAMMAR,AMHL,AMHH,AMHA,AMHC,ALFAH,AAT,THETAT
     $,AAB,THETAB,AAL,THETAL,AMGVSS,MTQ,MBQ,MLQ,FBMA,
     $VUQ,VDQ
      REAL AMGLSS,AMULSS,AMURSS,AMDLSS,AMDRSS,AMSLSS
     $,AMSRSS,AMCLSS,AMCRSS,AMBLSS,AMBRSS,AMB1SS,AMB2SS
     $,AMTLSS,AMTRSS,AMT1SS,AMT2SS,AMELSS,AMERSS,AMMLSS,AMMRSS
     $,AMLLSS,AMLRSS,AML1SS,AML2SS,AMN1SS,AMN2SS,AMN3SS
     $,TWOM1,RV2V1,AMZ1SS,AMZ2SS,AMZ3SS,AMZ4SS,ZMIXSS
     $,AMW1SS,AMW2SS
     $,GAMMAL,GAMMAR,AMHL,AMHH,AMHA,AMHC,ALFAH,AAT,THETAT
     $,AAB,THETAB,AAL,THETAL,AMGVSS,MTQ,MBQ,MLQ,FBMA,VUQ,VDQ
      REAL AMZISS(4)
      EQUIVALENCE (AMZISS(1),AMZ1SS)
      SAVE /SSPAR/
\end{verbatim}
It then calculates the widths and branching ratios and puts them in the
common block /SSMODE/:
\begin{verbatim}
C          MXSS         =  maximum number of modes
C          NSSMOD       = number of modes
C          ISSMOD       = initial particle
C          JSSMOD       = final particles
C          GSSMOD       = width
C          BSSMOD       = branching ratio
C          MSSMOD       = decay matrix element pointer
C          LSSMOD       = logical flag used internally by SSME3
      INTEGER MXSS
      PARAMETER (MXSS=1000)
      COMMON/SSMODE/NSSMOD,ISSMOD(MXSS),JSSMOD(5,MXSS),GSSMOD(MXSS)
     $,BSSMOD(MXSS),MSSMOD(MXSS),LSSMOD
      INTEGER NSSMOD,ISSMOD,JSSMOD,MSSMOD
      REAL GSSMOD,BSSMOD
      LOGICAL LSSMOD
      SAVE /SSMODE/
\end{verbatim}
Decay modes for a given particle are not necessarily adjacent in this
common block.  Note that the branching ratio calculations use the full
matrix elements, which in general will give nonuniform distributions in
phase space, but this information is not saved in /SSMODE/.  In
particular, the decays $H \to Z + Z^* \to Z + f + \bar f$ give no
indication that the $f \bar f$ mass is strongly peaked near the upper
limit.

      All IDENT codes are defined by parameter statements in the PATCHY
keep sequence SSTYPE:
\begin{verbatim}
C          SM ident code definitions. These are standard ISAJET but
C          can be changed.
      INTEGER IDUP,IDDN,IDST,IDCH,IDBT,IDTP
      INTEGER IDNE,IDE,IDNM,IDMU,IDNT,IDTAU
      INTEGER IDGL,IDGM,IDW,IDZ,IDH
      PARAMETER (IDUP=1,IDDN=2,IDST=3,IDCH=4,IDBT=5,IDTP=6)
      PARAMETER (IDNE=11,IDE=12,IDNM=13,IDMU=14,IDNT=15,IDTAU=16)
      PARAMETER (IDGL=9,IDGM=10,IDW=80,IDZ=90,IDH=81)
C          SUSY ident code definitions. They are chosen to be similar
C          to those in versions < 6.50 but may be changed.
      INTEGER ISUPL,ISDNL,ISSTL,ISCHL,ISBT1,ISTP1
      INTEGER ISNEL,ISEL,ISNML,ISMUL,ISNTL,ISTAU1
      INTEGER ISUPR,ISDNR,ISSTR,ISCHR,ISBT2,ISTP2
      INTEGER ISNER,ISER,ISNMR,ISMUR,ISNTR,ISTAU2
      INTEGER ISZ1,ISZ2,ISZ3,ISZ4,ISW1,ISW2,ISGL
      INTEGER ISHL,ISHH,ISHA,ISHC
      INTEGER ISGRAV
      INTEGER IDTAUL,IDTAUR
      PARAMETER (ISUPL=21,ISDNL=22,ISSTL=23,ISCHL=24,ISBT1=25,ISTP1=26)
      PARAMETER (ISNEL=31,ISEL=32,ISNML=33,ISMUL=34,ISNTL=35,ISTAU1=36)
      PARAMETER (ISUPR=41,ISDNR=42,ISSTR=43,ISCHR=44,ISBT2=45,ISTP2=46)
      PARAMETER (ISNER=51,ISER=52,ISNMR=53,ISMUR=54,ISNTR=55,ISTAU2=56)
      PARAMETER (ISGL=29)
      PARAMETER (ISZ1=30,ISZ2=40,ISZ3=50,ISZ4=60,ISW1=39,ISW2=49)
      PARAMETER (ISHL=82,ISHH=83,ISHA=84,ISHC=86)
      PARAMETER (ISGRAV=91)
      PARAMETER (IDTAUL=10016,IDTAUR=20016)
\end{verbatim}
These are based on standard ISAJET but can be changed to interface with
other generators.  Since masses except the t mass are hard wired, one
should check the kinematics for any decay before using it with possibly
different masses.

      Instead of specifying all the SUSY parameters at the electroweak
scale using the MSSMi commands, one can instead use the SUGRA parameter
to specify in the minimal supergravity framework the common scalar mass
$m_0$, the common gaugino mass $m_{1/2}$, and the soft trilinear SUSY
breaking parameter $A_0$ at the GUT scale, the ratio $\tan\beta$ of
Higgs vacuum expectation values at the electroweak scale, and $\sgn\mu$,
the sign of the Higgsino mass term. The \verb|NUSUGi| keywords allow one
to break the assumption of universality in various ways. \verb|NUSUG1|
sets the gaugino masses; \verb|NUSUG2| sets the $A$ terms; \verb|NUSUG3|
sets the Higgs masses; \verb|NUSUG4| sets the first generation squark
and slepton masses; and \verb|NUSUG5| sets the third generation masses.
The keyword \verb|SSBCSC| can be used to specify an alternative scale
(i.e., not the coupling constant unification scale) for the RGE boundary
conditions.

      The renormalization group equations now include all the two-loop
terms for both gauge and Yukawa couplings and the possible contributions
from right-handed neutrinos. These equations are solved iteratively using
Runge-Kutta numerical integration to determine the weak scale parameters
from the GUT scale ones:
\begin{enumerate}
%
\item The 2-loop RGE's for the gauge, Yukawa, and soft breaking terms
are run from the weak scale $M_Z$ up to the GUT scale (where $\alpha_1 =
\alpha_2$) or other high scale defined by the model, taking all
thresholds into account.
%
\item The GUT scale boundary conditions are imposed, and the RGE's are
run back to $M_Z$, again taking thresholds into account.
%
\item The masses of the SUSY particles and the values of the soft 
breaking parameters B and mu needed for radiative symmetry are
computed, e.g.
$$
\mu^2(M_Z) = {M_{H_1}^2 - M_{H_2}^2  \tan^2\beta \over
\tan^2\beta-1} - M_Z^2/2
$$
These couplings are frozen out at the scale $\sqrt{M(t_L)M(t_R)}$.
%
\item The 1-loop radiative corrections are computed.
%
\item The process is then iterated until stable results are obtained.
\end{enumerate}
This is essentially identical to the procedure used by several other
groups. Other possible constraints such as $b$-$\tau$ unification and 
limits on proton decay have not been included.

      An alternative to the SUGRA model is the Gauge Mediated SUSY
Breaking (GMSB) model of Dine and Nelson, Phys.\ Rev.\ {\bf D48}, 1277
(1973); Dine, Nelson, Nir, and Shirman, Phys.\ Rev.\ {\bf D53}, 2658
(1996). In this model SUSY is broken dynamically and communicated to the
MSSM through messenger fields at a messenger mass scale $M_m$ much less
than the Planck scale. If the messenger fields are in complete
representations of $SU(5$), then the unification of couplings suggested
by the LEP data is preserved. The simplest model has a single $5+\bar5$
messenger sector with a mass $M_m$ and and a SUSY-breaking VEV $F_m$ of
its auxiliary field $F$. Gauginos get masses from one-loop graphs
proportional to $\Lambda_m = F_m / M_m$ times the appropriate gauge
coupling $\alpha_i$; sfermions get squared-masses from two-loop graphs
proportional to $\Lambda_m$ times the square of the appropriate
$\alpha_i$. If there are $N_5$ messenger fields, the gaugino masses and
sfermion masses-squared each contain a factor of $N_5$.

      The parameters of the GMSB model implemented in ISAJET are
\begin{itemize}
\item $\Lambda_m = F_m/M_m$: the scale of SUSY breaking, typically
10--$100\,{\rm TeV}$;
\item $M_m > \Lambda_m$: the messenger mass scale, at which the boundary
conditions for the renormalization group equations are imposed;
\item $N_5$: the equivalent number of $5+\bar5$ messenger fields.
\item $\tan\beta$: the ratio of Higgs vacuum expectation values at the
electroweak scale;
\item $\sgn\mu=\pm1$: the sign of the Higgsino mass term;
\item $C_{\rm grav}\ge1$: the ratio of the gravitino mass to the value it
would have had if the only SUSY breaking scale were $F_m$.
\end{itemize}
The solution of the renormalization group equations is essentially the
same as for SUGRA; only the boundary conditions are changed. In
particular it is assumed that electroweak symmetry is broken radiatively
by the top Yukawa coupling.

      In GMSB models the lightest SUSY particle is always the nearly
massless gravitino $\tilde G$. The phenomenology depends on the nature
of the next lightest SUSY particle (NLSP) and on its lifetime to decay
to a gravitino. The NLSP can be either a neutralino $\tilde\chi_1^0$ or
a slepton $\tilde\tau_1$. Its lifetime depends on the gravitino mass,
which is determined by the scale of SUSY breaking not just in the
messenger sector but also in any other hidden sector. If this is set by
the messenger scale $F_m$, i.e., if $C_{\rm grav}\approx1$, then this
lifetime is generally short. However, if the messenger SUSY breaking
scale $F_m$ is related by a small coupling constant to a much larger
SUSY breaking scale $F_b$, then $C_{\rm grav}\gg1$ and the NLSP can be
long-lived. The correct scale is not known, so $C_{\rm grav}$ should be
treated as an arbitrary parameter. More complicated GMSB models may be
run by using the GMSB2 keyword.

      Patch ISASSRUN of ISAJET provides a main program SSRUN and some
utility programs to produce human readable output.  These utilities must
be rewritten if the IDENT codes in /SSTYPE/ are modified.  To create the
stand-alone version of ISASUSY with SSRUN, run YPATCHY on isajet.car
with the following cradle (with \verb|&| replaced by \verb|+|):
\begin{verbatim}
&USE,*ISASUSY.                         Select all code
&USE,NOCERN.                           No CERN Library
&USE,IMPNONE.                          Use IMPLICIT NONE
&EXE.                                  Write everything to ASM
&PAM,T=C.                              Read PAM file
&QUIT.                                 Quit
\end{verbatim}
Compile, link, and run the resulting program, and follow the prompts for
input.  Patch ISASSRUN also contains a main program SUGRUN that reads
the minimal SUGRA, non-universal SUGRA, or GMSB parameters, solves the
renormalization group equations, and calculates the masses and branching
ratios. To create the stand-alone version of ISASUGRA, run YPATCHY with
the following cradle:
\begin{verbatim}
&USE,*ISASUGRA.                        Select all code
&USE,NOCERN.                           No CERN Library
&USE,IMPNONE.                          Use IMPLICIT NONE
&EXE.                                  Write everything to ASM
&PAM.                                  Read PAM file
&QUIT.                                 Quit
\end{verbatim}
The documentation for ISASUSY and ISASUGRA is included with that for
ISAJET.

      ISASUSY is written in ANSI standard Fortran 77 except that
IMPLICIT NONE is used if +USE,IMPNONE is selected in the Patchy cradle. 
All variables are explicitly typed, and variables starting with
I,J,K,L,M,N are not necessarily integers.  All external names such as
the names of subroutines and common blocks start with the letters SS. 
Most calculations are done in double precision.  If +USE,NOCERN is
selected in the Patchy cradle, then the Cernlib routines EISRS1 and its
auxiliaries to calculate the eigenvalues of a real symmetric matrix and
DDILOG to calculate the dilogarithm function are included.  Hence it is
not necessary to link with Cernlib.

      The physics assumptions and details of incorporating the Minimal
Supersymmetric Model into ISAJET have appeared in a conference
proceedings entitled ``Simulating Supersymmetry with ISAJET 7.0/ISASUSY
1.0'' by H. Baer, F. Paige, S. Protopopescu and X. Tata; this has
appeared in the proceedings of the workshop on {\sl Physics at Current
Accelerators and Supercolliders}, ed.\ J. Hewett, A. White and D.
Zeppenfeld, (Argonne National Laboratory, 1993). Detailed references
may be found therein. Users wishing to cite an appropriate source should,
however, cite the most recent ISAJET manual, e.g. hep-ph/0001086 (1999).

\newpage
\section{IsaTools \label{Tools}}

\def\te{\tilde e}
\def\tl{\tilde l}
\def\tu{\tilde u}
\def\ts{\tilde s}
\def\tb{\tilde b}
\def\tc{\tilde c}
\def\tf{\tilde f}
\def\td{\tilde d}
\def\tQ{\tilde Q}
\def\tL{\tilde L}
\def\tH{\tilde H}
\def\tst{\tilde t}
\def\ttau{\tilde \tau}
\def\tmu{\tilde \mu}
\def\tg{\tilde g}
\def\tnu{\tilde\nu}
\def\tell{\tilde\ell}
\def\tg{\tilde g}
\def\tq{\tilde q}
\def\tw{\tilde W}
\def\tz{\tilde Z}
\def\alt{\stackrel{<}{\sim}}
\def\agt{\stackrel{>}{\sim}}
\hyphenation{super-symmet-ry}

\verb|IsaTools| is a optional set of subroutines included with Isajet
7.72 and later for the evaluation of various low-energy and cosmological
constraints on supersymmetric models using the Isajet supersymmetry
code. The package consists of:
\begin{enumerate}
\item \verb|IsaRED|, subroutines to evaluate the relic density of
(stable) neutralino dark matter in the universe;
\item \verb|IsaBSG|, subroutines to evalue the branching fraction
$BF(b\to s\gamma )$;
\item \verb|IsaAMU|, subroutines to evaluate supersymmetric contributions to
$\Delta a_\mu\equiv (g-2)_\mu/2$;
\item \verb|IsaBMM|, subroutines to evaluate $BF(B_s\rightarrow
\mu^+\mu^-)$ and $BF(B_d\rightarrow \tau^+\tau^- )$ in the MSSM;
\item \verb|IsaRES|, subroutines to evaluate the spin-independent and
spin-dependent neutralino-proton and neutralino-neutron scattering cross
sections for direct detection of dark matter.
\end{enumerate}
Below we provide a brief description of each subroutine along with
appropriate references. The main code author is indicated by
an underline and should be the first choice of contact for any bug 
related problems.

Details on the application of IsaTools and on the structure of IsaRED,
IsaBSG, IsaBMM and IsaRES could be found at the web page\hfil\break
\verb|http://hep.pa.msu.edu/belyaev/proj/dark_matter/isatools_public/|\,.

\subsection{IsaRED (H. Baer, C. Balazs and \underbar{A. Belyaev})} 

\verb|IsaRED| evaluates the neutralino relic density in the MSSM.  The
complete set of tree-level $\tz_1\tz_1$ annihilation and co-annihilation
processes is evaluated. Calculations are based on the matrix element
library created using the CompHEP program and interfaced to Isajet. The
following SUSY particles in the initial state are taken into account:
$\tz_1$, $\tz_2$, $\tw_1$, $\tilde{e_1}$, $\tilde{\mu_1}$,
$\tilde{\tau_1}$, $\tilde{\nu_e}$, $
\tilde{\nu_\mu}$, $\tilde{\nu_\tau}$, $\tilde{u_1}$, $\tilde{d_1}$, $
\tilde{c_1}$, $\tilde{s_1}$, $ \tilde{t_1}$, $\tilde{b_1}$, $\tilde{g}$.

The fully relativistic thermally averaged cross section times velocity
is computed using the Gondolo-Gelmini\cite{gg} and
Gondolo-Edsjo\cite{ge} formalism.  The freeze out temperature is solved
for iteratively, and then the relic density is computed.  To achieve our
final result with relativistic thermal averaging, we perform a
three-dimensional integral over {\it i.}) the final state subprocess
scattering angle, {\it ii.}) the subprocess energy parameter, and {\it
iii.}) the temperature from freeze-out to the present day temperature of
the universe.  We perform the three-dimensional integral using the BASES
algorithm\cite{bases}, which implements sequentially improved sampling
in multi-dimensional Monte Carlo integration, generally with good
convergence properties.  See Ref. \cite{bb1,bbb} for details.

\subsection{IsaBSG (H. Baer and \underbar{M. Brhlik})} 

This subroutine evaluates the $BF(b\to s\gamma)$ using the effective
field theory approach of Anlauf\cite{anlauf}, wherein the Wilson
co-efficients of various operators are calculated at the relevant scales
where various sparticles are integrated out of the theory.  This method
is used to handle the $tW$, $tH^-$ and $\tst_{1,2}\tw_{1,2}$ loops.  The
Wilson co-efficients are evolved to scale $Q=M_W$, wherein the effective
theory is taken to be the SM.  The SM Wilson co-efficients are evolved
to $Q=m_b$ using NLO anomalous dimension matrices. Once at scale
$Q=m_b$, the complete NLO corrections to the $O_2$, $O_7$ and $O_8$
operators are included\cite{greub}.  The scale dependence of the final
result is of order $10\%$.  In the high scale calculation, the weak
scale value of $m_b(M_{SUSY})$ is calculated using two loop RG evolution
with full one loop corrections to $m_b$. This effect is important at
large $\tan\beta$. Also, the $\tg\tq$ and $\tz_i\tq$ loops are included
directly at scale $Q=M_W$, according to the calculation of Masiero et
al.\cite{masiero}.  This necessitates an RG computation of well over 100
soft terms and couplings in order to generate the proper off diagonal
soft terms at scale $Q=M_W$.

\subsection{IsaAMU ({\underbar{H. Baer}} and C. Balazs)}

Supersymmetric contributions to $a_\mu\equiv (g-2)_\mu/2$ come from
$\tw_i\tnu_\mu$ and $\tz_i\tmu_{1,2}$ loops.  Complete formulae for
these contributions in the MSSM can be found in the article by T. Moroi,
Ref. \cite{moroi}. Numerical analyses based on his result are presented
in Ref. \cite{bbft}.

\subsection{IsaBMM (\underbar{J. K. Mizukoshi}, X. Tata and
Y. Wang)}

This subroutine evaluates the branching ratio of the decays
$B_s\rightarrow \mu^+\mu^-$ and $B_d\rightarrow \tau^+\tau^-$, according
to formulae given in Ref. \cite{mtw}:
\begin{eqnarray*}
B(B_{d'} \to \ell^+ \ell^-) &=& \frac{G_F^2\alpha^2 m^3_{B_{d'}} 
\tau_{B_{d'}} f^2_{B_{d'}}}{64\pi^3}
|V^\ast_{tb}V_{td'}|^2\sqrt{1-\frac{4m^2_\ell}{m^2_{B_{d'}}}}
\nonumber \\
&&\times\biggl[\biggl(1-\frac{4m^2_\ell}{m^2_{B_{d'}}}\biggr)
\bigg|\frac{m_{B_{d'}}}
{m_b+m_{d'}}c_{Q_1}\bigg|^2 + \bigg|\frac{2m_\ell}{m_{B_{d'}}}c_{10}
- \frac{m_{B_{d'}}}{m_b+m_{d'}} c_{Q_2}\bigg|^2\biggr],
\end{eqnarray*}
%
where $d'= s, d$ and $\ell = \mu, \tau$. The coefficients of the
effective Hamiltonian of the above processes,
\begin{eqnarray*}
c_{Q_1} &=& \frac{2\pi}{\alpha} \chi_{FC} \frac{m_b m_\ell}{\cos^2\beta
\sin^2\beta}\biggl(\frac{\cos(\beta+\alpha)\sin\alpha}{m^2_h} -
\frac{\sin(\beta+\alpha)\cos\alpha}{m^2_H}\biggr)\;, \nonumber
\\
c_{Q_2} &=& \frac{2\pi}{\alpha} \chi_{FC} \frac{m_b m_\ell}{\cos^2\beta}
\frac{1}{m^2_A}
\end{eqnarray*}
contain the  Higgs-mediated flavor changing  neutral currents that arise
as a consequence of coupling of Higgs superfield $\hat{h}_u$ with down
type fermions at one-loop level. Since this coupling is enhanced for 
large ${\langle h_u \rangle / \langle
h_d \rangle} \equiv \tan\beta$,  the calculations were  performed
keeping only  terms that are most  enhanced by powers of
$\tan\beta$. Therefore,  the $\chi_{FC}$ parameter given in
Ref. \cite{mtw} is  valid only for $\tan\beta \agt 25-30$.  Moreover,  
in the calculations of  one-loop $h, H b d'$,  and   
$A b d'$ vertex corrections, it has been assumed that the chargino masses 
are well approximated by  $|M_2|$ and $|\mu|$.

\subsection{IsaRES (C. Balazs, \underbar{A. Belyaev} and M. Brhlik)} 

\verb|IsaRES| evaluates the spin-independent and spin-dependent
neutralino-proton and neutralino-neutron scattering cross sections
according to formulae contained in Refs. \cite{bb2,bbbo}.


The interactions for elastic scattering of neutralinos on nuclei can be
described by the sum of spin-independent (${\cal L}^{eff}_{scalar}$) and 
spin-dependent (${\cal L}^{eff}_{spin}$) Lagrangian terms:
\begin{equation}
 {\cal L}^{eff}_{elastic}={\cal L}^{eff}_{scalar}+{\cal L}^{eff}_{spin} .
\end{equation}
$\sigma_{SI}$ for 
neutralino scattering off of nuclei  is the main experimental observable 
since $\sigma_{SI}$ contributions from individual nucleons in the nucleus add 
coherently and can be expressed via SI nuclear form-factors. The cross section 
$\sigma_{SI}$ receives contributions from neutralino-quark interactions via 
squark, $Z$ and Higgs boson exchanges, and from neutralino-gluon interactions 
involving quarks, squarks and Higgs bosons at the 1-loop level. The differential 
$\sigma_{SI}$ off a nucleus $X_Z^A$ with mass $m_A$ takes the 
form~\cite{kam_review}
\begin{equation}
 \frac{d\sigma^{SI}}{d|\vec{q}|^2}=\frac{1}{\pi v^2}[Z f_p +(A-Z) f_n]^2 
 F^2 (Q_r),
\end{equation}                                 
where $\vec{q}=\frac{m_A m_{\widetilde Z_1}}{m_A+m_{\widetilde Z_1}}\vec{v}$ is 
the three-momentum transfer, $Q_r=\frac{|\vec{q}|^2}{2m_A}$ and $F^2(Q_r)$ is 
the scalar nuclear form factor, $\vec{v}$ is the velocity of the incident 
neutralino and $f_p$ and $f_n$ are effective neutralino couplings to protons and 
neutrons respectively.
The original calculation has been done in~\cite{drees-nojiri} and can 
be expressed as
\begin{equation}
{f_N \over m_N} = \sum_{q=u,d,s} \frac{f_{Tq}^{(N)}}{m_q} \left[
f_q^{(\tq )}+f_q^{(H)}-{1\over 2}m_q m_{\tz_1}g_q\right]  + 
\frac{2}{27} f^{(N)}_{TG} \sum_{c,b,t} \frac{f_q^{(H)}}{m_q} +\cdots
\end{equation}
%
where $N=p,\ n$ for neutron, proton respectively, and
$f^{(N)}_{TG} = 1 - \sum_{q=u,d,s} f^{(N)}_{Tq} $.
The expressions for the $f_q^{(H)}$ couplings as well as other terms
denoted by $\cdots$ are omitted for the sake of brevity but can be found 
in~\cite{drees-nojiri,baer-brhlik}.

The parameters  $f_{Tq}^{(p)}$, defined by
\begin{equation}
<N|m_q \bar{q} q|N> = m_N f_{Tq}^{(N)} \qquad (q=u,d,s)
\end{equation}
contain uncertainties due to errors on the experimental measurements of quark masses.
We have adopted values of renormalization-invariant  constants $f_{Tq}^{(p)}$
and their uncertainties
determined in~\cite{dirdet-ellis}:
\begin{equation}
f_{Tu}^{(p)} = 0.020 \pm 0.004, \qquad f_{Td}^{(p)} = 0.026 \pm 0.005,
\qquad f_{Ts}^{(p)} = 0.118 \pm 0.062
\end{equation}
\begin{equation}
f_{Tu}^{(n)} = 0.014 \pm 0.003, \qquad f_{Td}^{(n)} = 0.036 \pm 0.008,
\qquad f_{Ts}^{(n)} = 0.118 \pm 0.062.
\end{equation}

The cross section $\sigma_p^{SI}$
for neutralino scattering off the proton is calculated in the limit of zero momentum transfer
\begin{equation}
\sigma^{SI}=\frac{4}{\pi}{m_r^N}^2 f_N^2
\end{equation}
where $m_r^N=m_N m_{\tilde{Z_1}}/(m_N+m_{\tilde{Z_1}})$.

In our calculations we are using the CTEQ5L set of parton density 
functions~\cite{CTEQ5}
evaluated at the QCD scale $Q=\sqrt{M_{SUSY}^2-m_{\tilde{Z}_1}^2}$.
The PDF  parton density 
function can be easily updated to any other PDF upon request.

\subsection{Compiling and Using IsaTools (\underbar{F. Paige})}

\verb|IsaTools| is so far interfaced only to ISASUGRA, not to ISAJET or
ISASUSY. Since \verb|IsaRED| contains about 1.4M lines of Fortran code
generated by CompHEP, both compilation and execution are somewhat slow. 
It was therefore decided to make \verb|IsaTools| optional and to keep
keep this code in a separate file, \verb|isared.tar|.

If you {\it do not} want to use \verb|IsaTools|, edit the
\verb|Makefile| and select
\begin{verbatim}
ISATOOLS =
LIBTOOLS =
\end{verbatim}
Then build ISAJET, ISASUSY, and ISASUGRA as described previously. The
variable \verb|ISATOOLS| serves as a Patchy flag, and the blank value
turns off the calls to \verb|IsaTools| in ISASUGRA.

If you {\it do} want to use \verb|IsaTools|, edit the \verb|Makefile|
and select
\begin{verbatim}
ISATOOLS = ISATOOLS
LIBTOOLS = -lisared
\end{verbatim}
This is the default, and it requires \verb|isared.tar| to be in the same
directory as \verb|isajet.car| and \verb|Makefile|. First build
\verb|libisared.a| for \verb|IsaTools| and then build the rest of
ISAJET, ISASUSY, and ISASUGRA with the commands
\begin{verbatim}
make isatools
make
\end{verbatim}
The outputs from \verb|IsaTools| will appear after the mass spectrum and
before the list of decay modes.

\def\refname{\large\bf References for IsaTools}
\begin{thebibliography}{99}
%
\bibitem{gg} G.\ Gelmini and P.\ Gondolo, Nucl.\ Phys.\ {\bf B351}, 623 (1991).
%
\bibitem{ge} J.\ Edsj\"o and P.\ Gondolo, Phys.\ Rev.\ {\bf D56}, 1879 (1997).\ 
%
\bibitem{bases} S.~Kawabata,
``Monte Carlo Integration Packages Bases And Dice,''
{\it Prepared for 2nd International Workshop on Software Engineering, 
Artificial Intelligence and Expert Systems for High-energy and Nuclear
Physics, La Londe Les Maures, France, 13-18 Jan 1992}.

\bibitem{bb1} H.\ Baer and M.\ Brhlik, Phys.\ Rev.\ {\bf D53}, 597 (1996).
%
\bibitem{bbb} H.\ Baer, C.\ Balazs and A.\ Belyaev,
JHEP{\bf 0203}, 042 (2002) and hep-ph/0211213 (2002).\ 
%
\bibitem{bb_bsg,bbct} H.\ Baer and M.\ Brhlik, Phys.\ Rev.\ {\bf D55}, 3201 (1997);
H.\ Baer, M.\ Brhlik, D.\ Castano and X.\ Tata, 
Phys.\ Rev.\ {\bf D58}, 015007 (1998).
%
\bibitem{anlauf} H.\ Anlauf, Nucl.\ Phys.\ {\bf B430}, 245 (1994).
%
\bibitem{greub} C.\ Greub, T.\ Hurth and Wyler, 
Phys.\ Rev.\ {\bf D54}, 3350 (1996).
%
\bibitem{masiero} S.\ Bertolini, F.\ Borzumati, A.\ Masiero and G.\ Ridolfi, 
Nucl.\ Phys.\ {\bf B353}, 591 (1991).
%
\bibitem{moroi} T.\ Moroi, Phys.\ Rev.\ {\bf D53}, 6565 (1996),
Erratum-ibid.{\bf D56}, 4424 (1997).
%
\bibitem{bbft} H.\ Baer, C.\ Balazs, J.\ Ferrandis and X.\ Tata,
Phys.\ Rev.\ {\bf D64}, 035004 (2001).
%
\bibitem{mtw} J.\ K.\ Mizukoshi, X.\ Tata and Y.\ Wang, 
Phys.\ Rev.\ {\bf D66}, 115003 (2002).
%
\bibitem{bb2} H.\ Baer and M.\ Brhlik, Phys.\ Rev.\ {\bf D57}, 567 (1998).
%
\bibitem{bbbo} H.\ Baer, C.\ Balazs, A.\ Belyaev and J.\ O'Farrill, 
JCAP{\bf 0309}, 007 (2003).

\bibitem{kam_review}
G.~Jungman, M.~Kamionkowski and K.~Griest,
%``Supersymmetric dark matter,''
Phys.\ Rept.\  {\bf 267}, 195 (1996)
[arXiv:hep-ph/9506380].

\bibitem{drees-nojiri}
M.~Drees and M.~Nojiri,
%``Neutralino - nucleon scattering revisited,''
Phys.\ Rev.\ D {\bf 47}, 4226 (1993) and
Phys.\ Rev.\ D {\bf 48}, 3483 (1993)
[arXiv:hep-ph/9307208];

\bibitem{baer-brhlik}
H.~Baer and M.~Brhlik,
%``Neutralino dark matter in minimal supergravity: Direct detection vs.\  collider searches,''
Phys.\ Rev.\ D {\bf 57}, 567 (1998)
[arXiv:hep-ph/9706509].
%%CITATION = HEP-PH 9706509;%%

\bibitem{dirdet-ellis}
J.~R.~Ellis, A.~Ferstl and K.~A.~Olive,
%``Re-evaluation of the elastic scattering of supersymmetric dark matter,''
Phys.\ Lett.\ B {\bf 481}, 304 (2000)
[arXiv:hep-ph/0001005];
%%CITATION = HEP-PH 0001005;%%

%\cite{Lai:1999wy}
\bibitem{CTEQ5}
H.~L.~Lai {\it et al.}  [CTEQ Collaboration],
%``Global {QCD} analysis of parton structure of the nucleon: CTEQ5 parton  distributions,''
Eur.\ Phys.\ J.\ C {\bf 12}, 375 (2000)
[arXiv:hep-ph/9903282].
%%CITATION = HEP-PH 9903282;%%

\end{thebibliography}
+EOD
+DECK,CHANGES
\newpage
\section{Changes in Recent Versions}

        This section contains a record of changes in recently released
versions of ISAJET, taken from the memoranda distributed to users.
Note that the released version numbers are not necessarily consecutive.

\subsection{Version~7.74, February 2006}

In Isajet 7.73, we have modified the ISASUGRA SUSY spectrum calculator
to extract all running parameters for mixed sparticles (the -inos, third
generation squarks and sleptons) at the common scale ${\tt
HIGFRZ}=\sqrt{m_{\tilde t_L} m_{\tilde t_R}}$, to gain consistency in
implementing the one-loop radiative corrections. Non-mixing soft terms
are still extracted at their own scale, to minimize radiative
corrections.  Squark mixing contributions to the gluino mass radiative
correction have also been added. For details, see H. Baer, J. Ferrandis,
S. Kraml and W. Porod, hep-ph/0511123.
We have also adapted the MSSM Higgs mass calculation to use the
running $b$ and $t$ quark masses from the RG code. This typically
decreases the light Higgs mass by 2--3~GeV.

We have also generalized the decay routines and radiative corrections to
gain validity for either sign of the gaugino mass $M_3$. Previously, the
decay formulae were calculated under the assumption of positive gluino
mass, while all along either sign of $M_1$ and $M_2$ were allowed.

We have added an \verb|ISALHA| subroutine which outputs a sparticle
decay table in Les Houches Accord output format (thanks to C. Balazs for
help on this).

Several minor bugs have been corrected in the relic density routine
\verb|ISARED| (thanks to A. Belyaev and A. Pukhov).

\subsection{Version~7.72, August 2005}

Isajet Version 7.72 provides \verb|IsaTools|, including
\begin{enumerate}
\item \verb|IsaRED|, subroutines to evaluate the relic density of
(stable) neutralino dark matter in the universe;
\item \verb|IsaBSG|, subroutines to evalue the branching fraction
$BF(b\to s\gamma )$;
\item \verb|IsaAMU|, subroutines to evaluate supersymmetric
contributions to
$\Delta a_\mu\equiv (g-2)_\mu/2$;
\item \verb|IsaBMM|, subroutines to evaluate $BF(B_s\rightarrow
\mu^+\mu^-)$ and $BF(B_d\rightarrow \tau^+\tau^- )$ in the MSSM;
\item \verb|IsaRES|, subroutines to evaluate the spin-independent and
spin-dependent neutralino-proton and neutralino-neutron scattering cross
sections for direct detection of dark matter.
\end{enumerate}
\verb|IsaTools| is so far interfaced only to ISASUGRA, and it it
requires \verb|isared.tar| in addition to \verb|isajet.car| and the
standard \verb|Makefile| contained therein.

This version also optionally provides from ISASUGRA both an output file
compatible with the SUSY LesHouches Accord and an output file compatible
with the ISAWIG interface for HERWIG. The ISAWIG interface assumes that
$R$-parity is conserved.

Isajet 7.72 also allows for the entry of negative squared Higgs soft
masses in SUGRA models with non-universality using the NUSUG3 keyword.
In addition, in models with non-universal Higgs masses, one now has the
option to use either GUT scale Higgs soft masses using NUSUG3, or weak
scale parameters $\mu$ and $m_A$ can be used as inputs using the NUHM
keyword.

Various small corrections have been made.

\subsection{Version~7.70, October 2004}

The solution of the renormalization group equations for SUSY models has
been converted to double precision. This gives better numerical
stability, especially in difficult regions such as the large $m_0$ or
``focus point'' region of minimal SUGRA. The two-loop corrections for
the top mass have been included.

Non-minimal AMSB models have been added. The keyword \verb|AMSB2| can be
used to set the high-scale s-fermion masses:
$$
m_{\tilde f}^2=m_{\tilde f}^2({\rm AMSB})+c_f m_0^2\,.
$$
The processes $e^+e^-\to\gamma\gamma\to f\bar{f}$ ($f$ is a SM fermion)
have also been included using Peskin's photon structure function from
brem- and beamstrahlung. These gamma-gamma induced processes are
activated by setting the keyword \verb|GAMGAM| to be \verb|.TRUE.| when
running with \verb|EEBEAM|.

\subsection{Version~7.69, August 2003}

The complete set of 1-loop radiative corrections to sparticle masses has
been included in the ISAJET SUSY spectrum calculation, according to the
formulae given by Pierce {\it et al.}, Nucl.\ Phys.\ {\bf B491}, 3
(1997).  Previous versions of ISAJET had included the logarithmic 1-loop
corrections by freezing out soft mass parameters at a scale equal to
their mass. The current calculation includes all finite corrections as
well. Crucial contributions to the encoding of these expressions were
made by Tadas Krupovnickas. We have also adjusted slightly the input
$\overline{DR}$ gauge couplings at $M_Z$ to coincide with measured
central values.  Logarithmic threshold corrections to gauge and Yukawa
couplings are accounted for as in previous ISAJET versions by changing
the beta functions in the RGEs as various soft mass thresholds are
passed. We have also enlarged the set of SUSY RGEs to include running
of the Higgs field vevs. The net effect of these changes is to modify
various sparticle masses by typically 1-5\% from the predictions of
ISAJET 7.64.

The size of the small mass splitting between $\tilde\chi_1^\pm$ and
$\tilde\chi_1^0$ is important for AMSB phenomenology. Rather than
extracting this splitting from the general result, for the AMSB model we
calculate it from the tree and the 1-loop vector boson loop graphs
[taken from Cheng, Dobrescu and Matchev, Nucl.\ Phys.\ {\bf B543}, 47,
(1999)] and use it to set the $\tilde\chi_1^\pm$ mass.

We have modified the RGE solution to use the previous SUSY masses to
compute $\mu$ before computing the new SUSY masses and from them the
loop corrections to $\mu$. This seems to improve the convergence, e.g.,
in the focus point, or hyperbolic branch region, of the mSUGRA model. 
The RGE solution still does not converge properly in isolated regions.

We have also corrected a sign mistake in the $A$-term boundary
conditions for the anomaly-mediated SUSY breaking model.

\subsection{Version~7.64, September 2002}

     The talk by Sabine Kraml at SUSY02 stressed the sensitivity of the
allowed region of radiative electroweak symmetry breaking to fine
details of the calculation. We have reexamined the issue and corrected
several problems. A coding error in the Passarino-Veltman function $B_1$,
\verb|SSB1| has been fixed. The requirement $\mu^2>0$ is not imposed
until after the solution of the renormalization group equations has
stabilized. The value of $m_b(m_Z)$ has been updated to 2.83~GeV. A
running gluino mass has been used in the top and bottom self-energy,
along with $\alpha_s$ evaluated at a higher scale. Since the parameters
of the Higgs potential vary rapidly near the weak scale, the convergence
requirements on these have been loosened, while the requirements on the
other parameters have been somewhat tightened. The combined effect of
these changes is to shift the boundary for radiative electroweak
symmetry breaking to higher scalar masses.

     Stephan Lammel found that the matrix element used to generate
$\tilde g \to \tilde\chi_i^\pm q \bar q$ was missing some poles,
although the branching ratio was correct. This has been fixed.

     The radiative decays $\tilde\chi_i^0 \to \tilde\chi_j^0 \gamma$ 
have been included.

\subsection{Version~7.63, April 2002}

     The SUSY mass calculations have been improved, especially for $M_A$
in terms of other SUSY parameters, by using the MSSM Yukawa couplings
from the renormalization group equations. The numerical precision of the
solution to the SUSY renormalization group equations has also been
improved; this should give better stability near the boundaries of the
allowed regions. The complete 1-loop self-energies for the $t$, $b$, and
$\tau$ have been included from Pierce, Bagger, Matchev, and Zhang,
Nucl.\ Phys.\ B491, 3 (1997). Finally, a number of bugs have been fixed,
including one in the $\tau$ decay of $t$ quarks.

\subsection{Version~7.58, August 2001}

     The CTEQ5L parton distributions have been added and made the
default. 

     Keywords \verb|NOB| and \verb|NOTAU| have been added to turn off
$B$ and $\tau$ decays so that an external decay package such as QQ or
TAUOLA can be used. To preserve the polarization information for
$\tau$'s, separate (non-standard) IDENT codes for $\tau_L$ and $\tau_R$
are used for \verb|NOTAU|. The user must provide an appropriate
interface.

     The RANLUX random number generator has been added as a compile time
option. It has a very long period, and any 32-bit integer seed gives an
independent sequence. If RANLUX is used, the keyword SEED takes the
integer seed plus two additional integers that are normally zero but can
be used to restart the generator. See the CERN Program Library writeups
for more information.

     Right-handed neutrinos are now included if the keyword
\verb|SUGRHN| is used. The user must input the 3rd generation neutrino
mass (at scale $M_Z$), the intermediate scale right handed neutrino
Majorana mass $M_N$, and the soft SUSY-breaking masses $A_n$ and
$m_{\tilde\nu_R}$ at the GUT scale. Then the neutrino Yukawa coupling is
computed in the simple see-saw model, and renormalization group
evolution includes these effects between $M_{GUT}$ and $M_N$.

     The decays $\tilde g \to \tilde W_i u \bar d$ have been updated to
include non-degenerate squark masses. The arbitrary width for $\tilde t
\to \tilde Z_1 c$ used previously has been replaced by the calculated
value. $\overline{DR}$ masses are used consistently. Yukawa couplings in
the the SUGRA routine are now calculated in the $\overline{DR}$
regularization scheme to be consistent with two loop renormalization
group evolution.

     In solving the SUSY renormalization group equations, the
requirement of good electroweak symmetry breaking is imposed only at the
end. Previously a point could be rejected if there was no symmetry
breaking even in the initial iteration with a truncated set of
equations.

     The sign of the $A$ term in the AMSB model has been corrected.

     The Standard Model process $e^+e^- \to ZH$ was missing and has been
added.

     Function ITRANS has been updated to reflect the current PDG
particle codes for SUSY particles.

\subsection{Version~7.51, May 2000}

        Several improvements in the SUSY RGE's have been made. All
two-loop terms including both gauge and Yukawa couplings and the
contributions from right-handed neutrinos are now included. There is a
new keyword \verb|SSBCSC| to specify a scale other than the GUT scale
for the RGE boundary conditions.

        The process $Z+\gamma$ is now included in \verb|WPAIR|. (This
was omitted because it has no contribution from triple gauge boson
couplings.)

        An incorrect type declaration produced unphysical results for
beamsstrahlung on some computers. This has been fixed. While the bug is
serious for $e^+e^-$ with the \verb|EEBEAM| option, it has no effect on
other processes. Some other minor bugs have also been fixed.

\subsection{Version~7.47, December 1999}

        There are several improvements in the treatment of
supersymmetry. The Anomaly Mediated SUSY Breaking model of of Randall
and Sundrum and of Gherghetta, Giudice, and Wells (hep-ph/9904378) has
been added. The parameters of the model are a universal scalar mass
$m_0$ at the GUT scale, a gravitino mass $m_{3/2}$, and the usual
$\tan\beta$ and $\sgn\mu$. These are set by the \verb|AMSB| keyword. The
renormalization group equations have been extended to include two-loop
Yukawa terms and right-handed sneutrinos (with default masses above the
Planck scale). The $\tilde\nu_R$ play a role in the evolution for the
inverted hierarchy models of Bagger, Feng, and Polonsky, hep-ph/9905292.
SUSY loop corrections to Yukawa couplings have been incorporated in the
SUSY mass calculations.

        The Helas library of Murayama, Watanabe, and Hagiwara has been
incorporated together with a simple multi-body phase space generator.
This makes it possible to use code generated by MadGraph to produce
multi-body hard scattering processes. As a first example, a \verb|ZJJ|
process that generates $Z + \hbox{2 jets}$ has been added, with the $Z$
treated as a narrow resonance. Additional processes may be added in
future releases.

        A new \verb|EXTRADIM| process has been added to generate
Kaluza-Klein graviton production in association with a jet or photon in
models with extra dimensions at the TeV scale. The cross sections are
from G.F.Giudice et al., hep-ph/9811291. We thank I. Hinchliffe and L.
Vacavant for providing this.

        A number of bugs have been fixed, including in particular one in
the decay $\widetilde W_i \to \widetilde Z_j \tau \nu$.

\subsection{Version~7.44, April 1999}

        A serious bug introduced in Version~7.42 that could lead to
matrix elements being stored for the wrong mode has been corrected.
Some sign errors in the matrix elements for gaugino decays have also
been corrected.

\subsection{Version~7.42, January 1999}

        Beginning with this version, matrix elements are taken into
account in the event generator as well as in the calculation of decay
widths for MSSM three-body decays of the form $\tilde A \to \tilde B f
\bar f$, where $\tilde A$ and $\tilde B$ are gluinos, charginos, or
neutralinos. This is implemented by having ISASUSY save the poles and
their couplings when calculating the decay width and then using these
to reconstruct the matrix element. Other three-body decays may be
included in the future. Decays selected with \verb|FORCE| use the
appropriate matrix elements.

        As part of the changes to implement these matrix elements, the
format of the decay table has changed. It now starts with a header
line; if this does not match the internal version, then a warning is
printed. The decay table now includes an index MELEM that specifies the
matrix element to be used for all processes. This is also used for
\verb|FORCE| decays and is printed on the run listing for them. SUSY
3-body decays have internally generated negative values of MELEM.

        This version also includes both initial state radiation and
beamstrahlung for $e^+e^-$ interactions. For initial state radiation
(bremsstrahlung), if the \verb|EEBREM| keyword is selected, an electron
structure function will be used. For a convolution of both
bremsstrahlung and beamstrahlung, the keyword \verb|EEBEAM| must be
used, with appropriate inputs (see documentation).

\subsection{Version~7.40, October 1998}

        A new process WHIGGS generates $W^\pm+H$ and $Z+H$ events for
both the Standard Model and SUSY models and also Higgs pair production
for SUSY models. The types and $W$ decay modes are selected with
JETTYPE and WMODE as for WPAIR events. This process is of particular
interest for producing fairly light Higgs bosons at the Tevatron. See
the documentation for more details.

        Some non-minimal GMSB models can be generated using a new
keyword GMSB2. The optional parameters are an extra factor between the
gaugino and scalar masses, shifts in the Higgs masses, a $D$-term
proportional to hypercharge, and independent numbers of messenger
fields for the three gauge groups. The documentation gives more
details and references.

        The default for SUGRA models has been changed to use
$\alpha_s(M_Z)=0.118$, the experimental value. This means that the
couplings do not exactly unify at the GUT scale, presumably because of
the effects of heavy particles. The keyword AL3UNI can be used to
select exact unification, which produces too large a value for
$\alpha_s(M_Z)$.

        A number of three-body slepton decays that occur through
left-right mixing are now included. These are obviously small but
might compete with gravitino decays. In particular, a decay like
$\tilde\mu_R \to \tilde\tau_1 \nu\bar\nu$ might lead to a wrong
momentum measurement in the muon system. So far we have found no case
in which this is probable.

        The new release also includes a separate Unix tar file
\verb|mcpp.tar| containing C++ code to read a standard ISAJET output
file and copy all the information into C++ classes. The tar file
contains makefiles for Software Release Tools, documentation, and
examples as well as the code.

\subsection{Version~7.37, April 1998}

        Version~7.37 incorporates Gauge Mediated SUSY Breaking models
for the first time. In these models, SUSY is broken in a hidden sector
at a relatively low scale, and the masses of the MSSM fields are then
produced through ordinary gauge interactions with messenger fields.
The parameters of the GMSB model in ISAJET are $M_m$, the messenger
mass scale; $\Lambda_m = F_m/M_m$, where $F_m$ is the SUSY breaking
scale in the messenger sector; $N_5$, the number of messenger fields;
the usual $\tan\beta$ and $\sgn\mu$; and $C_{\rm grav} \ge 1$, a
factor which scales the gravitino mass and hence the lifetime for the
lightest MSSM particle to decay into it.

        GMSB models have a light gravitino $\tilde G$ as the lightest
SUSY particle. The phenomenology of the model depends mainly on the
nature of the next lightest SUSY particle, a $\tilde\chi_1^0$ or a
$\tilde\tau_1$, which changes with the number $N_5$ of messengers. The
phenomenology also depends on the lifetime for the $\tilde\chi_1^0 \to
\tilde G \gamma$ or $\tilde\tau_1 \to \tilde G \tau$ decay; this
lifetime can be short or very long. All the relevant decays are
included except for $\tilde\mu \to \nu \nu \tilde\tau_1$, which is very
suppressed.

        The keyword MGVTNO allows the user to independently input a
gravitino gravitino mass for the MSSM option. This allows studies of
SUGRA (or other types) of models where the gravitino is the LSP.

        Version~7.37 also contains an extension of the SUGRA model
with a variety of non-universal gaugino and sfermion masses and $A$
terms at the GUT scale. This makes it possible to study, for example,
how well the SUGRA assumptions can be tested.

        Two significant bugs have also been corrected. The decay modes
for $B^*$ mesons were missing from the decay table since Version~7.29
and have been restored. A sign error in the interference term for
chargino production has been corrected, leading to a larger chargino
pair cross section at the Tevatron.

\subsection{Version 7.32, November 1997}

        This version makes several corrections in various chargino and
neutralino widths, thus changing the branching ratios for large
$\tan\beta$. For $\tilde\chi_2^0$, for example, the $\tilde\chi_1^0
b\bar b$ branching ratio is decreased significantly, while the
$\tilde\chi_1^0 \tau^+ \tau^-$ one is increased. Thus the SUGRA
phenomenology for $\tan\beta \sim 30$ is modified substantially.

        The new version also fixes a few bugs, including a possible
numerical precision problem in the Drell-Yan process at high mass and
$q_T$. It also includes a missing routine for the Zebra interface.

\subsection{Version 7.31, August 1997}

        Version fixes a couple of bugs in Version~7.29. In
particular, the JETTYPE selection did not work correctly for
supersymmetric Higgs bosons, and there was an error in the interactive
interface for MSSM input. Since these could lead to incorrect results,
users should replace the old version. We thank Art Kreymer for finding
these problems. 

        Since top quarks decay before they have time to hadronize,
they are now put directly onto the particle list. Top hadrons ($t\bar
u$, $t\bar d$, etc.) no longer appear, and FORCE should be used
directly for the top quark, i.e.
\begin{verbatim}
FORCE
6,11,-12,5/
\end{verbatim}

        The documentation has been converted to LaTeX. Run either
LaTeX~2.09 or LaTeX~2e three times to resolve all the forward
references. Either US (8.5x11 inch) or A4 size paper can be used.

\subsection{Version 7.30, July 1997}

        This version fixes a couple of bugs in the previous version.
In particular, the JETTYPE selection did not work correctly for
supersymmetric Higgs bosons, and there was an error in the interactive
interface for MSSM input. Since these could lead to incorrect results,
users should replace the old version. We thank Art Kreymer for finding
these problems. 

        Since top quarks decay before they have time to hadronize,
they are now put directly onto the particle list. Top hadrons ($t\bar
u$, $tud$, etc.) no longer appear, and FORCE should be used directly
for the top quark, i.e.
\begin{verbatim}
FORCE
6,11,-12,5/
\end{verbatim}

        The documentation has been converted to \LaTeX. Run either
\LaTeX~2.09 or \LaTeX~2e three times to resolve all the forward
references. Either US ($8.5\times11$~inch) or A4 size paper can be
used.

\subsection{Version 7.29, May 1997}

      While the previous version was applicable for large as well as
small $\tan\beta$, it did contain approximations for the 3-body decays
$\tilde g \to t \bar b \tilde W_i$, $\tilde Z_i \to b \bar b \tilde
Z_j, \tau \tau \tilde Z_j$, and $\tilde W_i \to \tau \nu \tilde Z_j$.
The complete tree-level calculations for three body decays of the
gluino, chargino and neutralino, with all Yukawa couplings and
mixings, have now been included (thanks mainly to M. Drees).  We have
compared our branching ratios with those calculated by A.~Bartl and
collaborators; the agreement is generally good.

      The decay patterns of gluinos, charginos and neutralinos may
differ from previous expectations if $\tan\beta$ is large.  In
particular, decays into $\tau$'s and $b$'s are often enhanced, while
decays into $e$'s and $\mu$'s are reduced.  It could be important for
experiments to study new types of signatures, since the cross sections
for conventional signatures may be considerably reduced.

      We have also corrected several bugs, including a fairly
serious one in the selection of jet types for SUSY Higgs. We thank
A.~Kreymer for pointing this out to us.

\subsection{Version 7.27, January 1997}

      The new version contains substantial improvements in the
treatment of the Minimal Supersymmetric Standard Model (MSSM) and the
SUGRA model.  The squarks of the first two generations are no longer
assumed to be degenerate.  The mass splittings and all the two-body
decay modes are now correctly calculated for large $\tan\beta$.  While
there are still some approximations for three-body modes, ISAJET is
now usable for the whole range $1 \simle \tan\beta \simle M_t/M_b$.  The
most interesting new feature for large $\tan\beta$ is that third
generation modes can be strongly enhanced or even completely dominant.

      To accomodate these changes it was necessary to change the
MSSM input parameters.  To avoid confusion, the MSSM keywords have
been renamed MSSM[A-C] instead of MSSM[1-3], and the order of the
parameters has been changed.  See the input section of the manual for
details.

      Treatment of the MSSM Higgs sector has also been improved.  In
the renormalization group equations the Higgs couplings are frozen at
a higher scale, $Q = \sqrt{M(\tilde t_L)M(\tilde t_R)}$.  Running
$t$, $b$ and $\tau$ masses evaluated at that scale are used to
reproduce the dominant 2-loop effects.  There is some sensitivity to
the choice of $Q$; our choice seems to give fairly stable results over
a wide range of parameters and reasonable agreement with other
calculations.  In particular, the resulting light Higgs masses are
significantly lower than those from Version~7.22.  

      The default parton distributions have been updated to CTEQ3L.
A bug in the PDFLIB interface and other minor bugs have been fixed.

\subsection{Version 7.22, July 1996}

      The new version fixes errors in $\tilde b \to \tilde W t$ and in
some $\tilde t$ decays and Higgs decays. It also contains a new decay
table with updated $\tau$, $c$, and $b$ decays, based loosely on the
QQ decay package from CLEO.  The updated decays are less detailed than
the full CLEO QQ program but an improvement over what existed before.
The new decays involve a number of additional resonances, including
$f_0(980)$, $a_1(1260)$, $f_2(1270)$, $K_1(1270)$, $K_1^*(1400)$,
$K_2^*(1430)$, $\chi_{c1,2,3}$, and $\psi(2S)$, so users may have to
change their interface routines.

      A number of other small bugs have been corrected.

\subsection{Version 7.20, June 1996}

      The new version corrects both errors introduced in Version~7.19
and longstanding errors in the final state QCD shower algorithm. It
also includes the top mass in the cross sections for $g b \to W t$ and
$g t \to Z t$. When the $t$ mass is taken into account, the process $g
t \to W b$ can have a pole in the physical region, so it has been
removed; see the documentation for more discussion. 

        Steve Tether recently pointed out to us that the anomalous
dimension for the $q \to q g$ branching used in the final state QCD
branching algorithm was incorrect. In investigating this we found an
additional error, a missing factor of $1/3$ in the $g \to q \bar q$
branching. The first error produces a small but non-negligible
underestimate of gluon radiation from quarks. The second overestimates
quark pair production from gluons by about a factor of 3. In
particular, this means that backgrounds from heavy quarks $Q$ coming
from $g \to Q \bar Q$ have been overestimated.

      The new version also allows the user to set arbitrary masses
for the $U(1)$ and $SU(2)$ gaugino mases in the MSSM rather than
deriving these from the gluino mass using grand unification. This
could be useful in studying one of the SUSY interpretations of a CDF
$ee\gamma\gamma\etmiss$ event recently suggested by Ambrosanio, Kane,
Kribs, Martin and Mrenna.  Note, however, that radiative decay are
{\it not} included, although the user can force them and multiply by
the appropriate branching ratios calculated by Haber and Wyler,
Nucl.{} Phys.{} B323, 267 (1989). No explicit provision for the decay
$\tilde Z_1 \to \tilde G \gamma$ of the lightest zino into a gravitino
or goldstino and a photon has been made, but forcing the decay $\tilde
Z_1 \to \nu\gamma$ has the same effect for any collider detector.

      A number of other minor bugs have also been corrected. 

\subsection{Version 7.16, October 1995}

       The new version includes $e^+e^-$ cross sections for both SUSY
and Standard Model particles with polarized beams. The $e^-$ and $e^+$
polarizations are specified with a new keyword EPOL. Polarization
appears to be quite useful in studying SUSY particles at an $e^+e^-$
collider.

      The new release also includes some bug fixes for $pp$ reactions,
so you should upgrade even if you do not plan to use the polarized
$e^+e^-$ cross sections.

\subsection{Version 7.13, September 1994}

      Version 7.13 of ISAJET fixes a bug that we introduced in the
recently released 7.11 and another bug in $\tilde g \to \tilde q \bar
q$. We felt it was essential to fix these bugs despite the
proliferation of versions.

      The new version includes the cross sections for the $e^+e^-$
production of squarks, sleptons, gauginos, and Higgs bosons in Minimal
Supersymmetric Standard Model (MSSM) or the minimal supergravity
(SUGRA) model, including the effects of cascade decays. To generate
such events, select the \verb|E+E-| reaction type and either SUGRA or
MSSM, e.g.,
\begin{verbatim}
SAMPLE E+E- JOB
300.,50000,10,100/
E+E-
SUGRA
100,100,0,2,-1/
TMASS
170,-1,1/
END
STOP
\end{verbatim}
The effects of spin correlations in the production and decay, e.g., in
$e^+e^- \to \widetilde W_1^+ \widetilde W_1^-$, are not included. 

      It should be noted that the Standard Model $e^+e^-$ generator in
ISAJET does not include Bhabba scattering or $W^+W^-$ and $Z^0Z^0$
production. Also, its hadronization model is cruder than that
available in some other generators.

\subsection{Version 7.11, September 1994}

      The new version includes the cross sections for the $e^+e^-$
production of squarks, sleptons, gauginos, and Higgs bosons in Minimal
Supersymmetric Standard Model (MSSM) or the minimal supergravity
(SUGRA) model including the effects of cascade decays. To generate
such events, select the \verb|E+E-| reaction type and either SUGRA or
MSSM, e.g.,
\begin{verbatim}
SAMPLE E+E- JOB
300.,50000,10,100/
E+E-
SUGRA
100,100,0,2,-1/
TMASS
170,-1,1/
END
STOP
\end{verbatim}
The effects of spin correlations in the production and decay, e.g., in
$e^+e^- \to \widetilde W_1^+ \widetilde W_1^-$, are not included. 

      It should be noted that the Standard Model $e^+e^-$ generator in
ISAJET does not include Bhabba scattering or $W^+W^-$ and $Z^0Z^0$
production. Also, its hadronization model is cruder than that
available in some other generators.

\subsection{Version 7.10, July 1994}

       This version adds a new option that solves the renormalization group
equations to calculate the Minimal Supersymmetric Standard Model (MSSM)
parameters in the minimal supergravity (SUGRA) model, assuming only that the
low energy theory has the minimal particle content, that electroweak
symmetry is radiatively broken, and that R-parity is conserved.  The minimal
SUGRA model has just four parameters, which are taken to be the common
scalar mass $m_0$, the common gaugino mass $m_{1/2}$, the common trilinear
SUSY breaking term $A_0$, all defined at the GUT scale, and $\tan\beta$; the
sign of $\mu$ must also be given.  The renormalization group equations are
solved iteratively using Runge-Kutta integration including the correct
thresholds.  This program can be used either alone or as part of the event
generator.  In the latter case, the parameters are specified using
\begin{verse}
SUGRA\\
$m_0$, $m_{1/2}$, $A_0$, $\tan\beta$, $\sgn\mu$
\end{verse}
While the SUGRA option is less general than the MSSM, it is theoretically
attractive and provides a much more managable parameter space.

      In addition there have been a number of improvements and bug fixes.  An
occasional infinite loop in the minimum bias generator has been fixed.  A few
SUSY cross sections and decay modes and the JETTYPE flags for SUSY
particles have been corrected.  The treatment of $B$ baryons has been
improved somewhat.

\end{document}
+EOD
+PATCH,ISZTEXT,T=DATA.
+EOD
+DECK,ZTEXT

                          ISAJET ZEBRA INTERFACE
                     F.E. Paige and S.D. Protopopescu
                            Physics Department
                      Brookhaven National Laboratory
                             Upton, NY 11973
                              March 30, 1991


     [1] Overview
     ============

      The ZEBRA  version of ISAJET  contains subroutines  which replace the
usual  output package  for ISAJET  with one using  the CERN  package ZEBRA.
This version  provides some  features which  are not part  of the  standard
ISAJET  output. Momenta  and masses  of the  partons are  rescaled from the
final  particles so that  they match  exactly  (this is not  so in ISAJET).
Resonances   decaying  strongly are  not part  of the  particle  list while
particles with heavy quarks decaying  weakly are part of a vertex list with
the corresponding  vertex position  and appropriate  links to the particles
belonging  to that  vertex.  Thus there  is no need  to  generate secondary
vertices for charmed or other heavy quark particles and the event structure
makes it easy to find which particles come from the decay of a heavy quark.
The  association of  particles  with  parent partons  is also  made easy by
reference  links. For simple  calorimeter  studies banks  are also provided
with  energy sums  over  calorimeter  cells and  banks  containing only the
leptons (see  below). If only those  are written  instead of particle banks
the resulting files are more compact and require considerably less CPU time
to analyze (albeit the information is rather limited). In addition jets are
calculated by  using a cone  algorithm on the partons,  these can be useful
for studying  efficiencies of jet finding  algorithms and comparing results
to theoretical jets. The results of parton jets are in Zebra banks PJET.

      NOTE: The present  version can only handle  one run at a time, so you
cannot supply a command  file with many runs for  now. This problem will be
fixed in a future release.

    [2] Creating and running a job
    ==============================

    There are command files in BNLCL6::$2$DUA14:[ISAJET.ISALIBRARY] to make
EXE files for event generation and analysis.

    To make an EXE generating ISAJET events which are then written to
a file in ZEBRA format users should run command file:

$ @isa$area:MAKE_ISAJET_ZEBRA

this starts from  ISAJET.PAM and  makes  ISAJET_ZEBRA.FOR, ISAJET_ZEBRA.OLB
and  ISAJET_ZEBRA.EXE.  It requires  that  ISA$AREA de  defined as the area
where ISAJET.PAM and command files  reside. It also requires that CERN$AREA
be defined   as the area  for the  CERN  libraries. The above  command file
assumes symbol YPATCHY is defined. If running on a machine other than a VAX
looking at the command file should give a pretty good idea of what needs to
be done.

If you  already have ISAJET_ZEBRA.OLB you can run command file

$ @isa$area:LINK_ISAJET_ZEBRA

to make ISAJET_ZEBRA.EXE, this program runs with an interactive
dialog to generate ISAJET instructions. You can supply your own
ISARUN main program if you wish to bypass the dialog, see command
file MAKE_ISAJET.COM for the simplest example.

User can provide any of 3 logical functions to reduce the
size of output files:
1) EDIT(I)     = if false event will not be written out
                 I is event number
                 Zebra banks have not yet been generated, so
                 user must work from standard ISAJET common blocks
2) ISEDIT()    = same as EDIT but Zebra banks have been filled
3) PEDIT(ID,P) = if false particle will not be included in
                 the list of particles written out
                 ID= particle ID, P(4)= particle momentum vector


To generate a user program that reads an ISAJET output file in ZEBRA
format users should run

$ @isa$area:MAKE_ISZRUN
this makes a sample user analysis subroutine ISZUSR and an ISZRUN.EXE
program. ISZUSR gives an example of how to use the utility subroutines
mentioned in next section for analysis.

If user already has an ISZUSR subroutine he can generate ISZRUN.EXE by

$ @isa$area:LINK_ISZRUN


    [3] Utilities
    =============

    A number of utilities  are provided for the  user to make it easier for
him to use the  information in ZEBRA form without  him having to learn much
about  ZEBRA. It is   nevertheless  recommended that  the user  familiarize
himself with ZEBRA by  reading the first chapter  of the ZEBRA manual. Also
to make  full  use of  the power  of  ZEBRA users  may   eventually want to
familiarize themselves with some of  the utilities provided with it such as
MZDROP and ZSORT.

o For every ZEBRA bank of name ISxx (most ISAJET ZEBRA banks start with
  IS) there exist:
    1) GZISxx : an integer function returning pointer to first bank in
                the linear structure
    2) GTISxx : a subroutine returning the contents of the bank
    3) PRISxx : a subroutine generating a printout of the banks with name ISxx

o To generate a full dump:
        CALL PRTEVZ(unit #)
  This subroutine calls all the PRISxx subroutines.

o Users can provide a primary vertex for each event by:
        CALL SETVTX(XYZ)
  where XYZ is a 3-vector with values x,y,z
  To supply a function for the vertex user should supply subroutine
  INTVTX(XYZ) which returns an XYZ vector with each call. The
  default returns 0,0,0.

o The parameters for generating PJET banks can be controlled by
      CALL PJPSET(N,ALG,ETCUT,DRCUT,MAXIT,IR,MUON)
  where
                                                          Default values
          N     = NUMBER OF PJET ALGORITHMS                      1
          ALG   = ALGORITHM TPYE 'CONE' OR 'ANGLE'            'CONE'
          ETCUT = ET CUT FR PJET JETS                           5.0
          DRCUT = CONE CUT (IN R OR ANGLE)                      0.45
          MAXIT = MAXIMUM NUMBER OF ITERATIONS                   1
          IR    = INIT RADIATION FLAG 0=USE IR,   1=NO IR        0
          MUON  = MUON FLAG    0=NO MUONS, 1=use MUONS in PJET   0


      Other subroutines of interest are:
o ISZJET  find jets using ISCL banks
o ISZUSR  example of a user subroutine for analysis



    [4] Other Subroutines
    =====================

    We list here the subroutines that are part of ISAJET_ZEBRA:

GENVTX  generate secondary vertices (for heavy quark decays)
ISABFL  fill ISAB bank (begin of run bank)
ISACFL  fill ISAC and ISCL banks (calorimeter description and
        calorimeter cells with non-zero energy deposited).
        Entry point ISACIN calculates all numbers needed for
        calorimeter description.
ISAEFL  fill ISAE bank (main header)
ISAFFL  fill ISAF bank (end of run bank)
ISAJFL  fill ISAJ banks (primary jets)
ISALFL  fill ISAL banks (leptons)
ISAPFL  fill ISV1 and ISP1 banks (vertices and particles)
ISAQFL  fill ISAQ banks (secondary partons, both initial and final)
ISCMFL  fill ISCM (copy of command instructions)
ISMEAR  generates smeared calorimeter data (modifies ISCL banks)
PJETFL  fill PJET banks (jets obtained from partons)
QRECAL  to recalculate momenta and masses of partons starting
        from the final particles





   [5] Brief description of Zebra banks
   ====================================

      The beginning and end of run  records have Zebra banks named ISAB and
ISAF  while  the  whole  event  hangs  from  Zebra  bank  ISAE. A  complete
description of the banks is given in section [6].

ISAB data describing event generation              (in beginning record)
ISCM copy of command file used for event generation(       "           )
ISAF cumulative results from run (in end record)
ISAE general event information such as weight, type, etc.
ISAJ primary jet momenta and masses
ISAQ final and initial partons (momenta and masses)
ISV1 primary and short lived vertices (heavy quarks), includes
     id,mass and 4-momenta of decaying particle
ISP1 particles associated with ISV1 (connected via a structural link)
     id,mass and 4-momenta
ISAC simple calorimeter description (no depth)
ISCL energy deposition and cell description in calorimeter cell
ISMR description of smearing parameters
ISAL stable leptons (including neutrinos):id,mass and 4-momenta
     with reference links to calorimeter cell and ISP1 if they
     exist
ISJT jets found by subroutine ISZJET.
PJHD header for PJET banks
PJET jets found adding over partons
PJPT pointers to parton banks (ISAQ) contributing to a jet in PJET

      Whether   banks    ISV1,ISP1,ISAC,ISCL  and  ISAL are  written out is
optional. The ISARUN job  asks user to chose an  option ISAP, ISAC or ISAL.
If ISAP is selected then  ISV1 and ISP1 are  written out, if ISAC then ISAC
and  ISCL are   written out  and  if ISAL  then  ISAL  is  written out. Any
combination can be selected, the  instruction ISAPISACISAL causes all banks
to be written out.

      The banks ISJT are created by calling ISZJET, the banks ISAC and ISCL
must be available. One can create  the banks ISAC,ISCL and/or ISAL starting
from a file  containing ISV1 and  ISP1 by calling  ISACFL and/or ISALFL for
each event.



   [6] Zebra banks documentation
   =============================


                     +------------------+
                     |      ISAE        |
                     | event descriptor |
                     |                  |
                     +------------------+
        struc. link         |||   |  |
                            |||   |  +------------------------------+
                            |||   +-----------------------------+   |
       +-------+------------+|                                  |   |
       |       |             |                                  |   |
  ______     ______       ______    ______                      |   |
 | ISAJ \   | ISAQ \     | ISV1 |  | ISV1 \                     |   |
 |  -1   >  |  -2   >    |  -3  |--| (-3)  >                    |   |
 |______/   |______/     |______|  |______/                     |   |
              :  ^         | :...<..: |                         |   |
              :  :         |   [-2]   |                         |   |
  [PJET -1].<..  :         |          |                         |   |
                 : [-2] ______      ______                      |   |
                 :.....| ISP1 \    | ISP1 \                     |   |
  [PJET -3] ..<........|  -1   >   |  -1   >                    |   |
                       |______/    |______/                     |   |
                        : |[-1]      : : :                      |   |
                    [-4]: v     <....: : :[-4]                  |   |
                        : free  <......: :                      |   |
                        v                v                      |   |
                      ISV2             ISV2                     |   |
                   (end vertex)     (end vertex)                |   |
                                                                |   |
                             +------------+---------------------+   |
                             |            |                         |
                             |            |                         |
                         _________      ______                     ______
                        |  ISAC   |    | ISAL \                   | PJHD \
                        |   -6    |    |  -7   >                  |  -8   >
                        |_________|    |______/                   |______/
                              |                                     |
            +-------+---------+--+                                 ______
            |       |            |               [ISAQ -1]..>.....| PJET \
         ______     ______       ______                           |  -1   >
        | ISCL \   | ISMR \     | ISJT \                          |______/
        |  -1   >  |  -2   >    |  -3   >                             |
        |______/   |______/     |______/                           ______
                                                                  | PJPT |
                                                     [ISAQ]...<...|  -1  |
                                                                  |______|

     +-----------+            +-----------+
     |    ISAB   |            |    ISAF   |
     | begin run |            |  end  run |
     |           |            |           |
     +-----------+            +-----------+
           |
     +----------+
     |   ISCM   |
     |    -1    |
     +----------+



C=======================================================================
C
C  Bank name: ISAC
C  Author   : SDP
C  Date     : June 14,1989
C
C                    Calorimeter descriptor
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C     -3            struct.  to ISJT (jets found using ISZJET)
C     -2            struct.  to smearing parameters (ISMR)
C     -1            struct.  to calorimeter cells (ISCL)
C      0            next     to next ISAC (only one at present)
C     +1            up       to ISAE
C     +2            origin   to ISAE for first and previous ISAC for others
C ............................................................................
C            I-5             calorimeter number
C             -4             bank name,  'ISAC'
C             -3             NL=2
C             -2             NS=0
C             -1             ND=6
C              0             STATUS
C             +1     I       number of phi cells
C              2     I         "       eta     "
C              3     F      phi cell size
C              4     F      eta     "   "
C              5     F      minimum eta
C              6     F      maximum eta
C=======================================================================



C=======================================================================
C
C  Bank name: ISAE
C  Author   : SDP
C  Date     : June 19,1986     DH add ISAM
C
C                Top level bank and event descriptor for ISAZEB
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C     -8            struct.  to PJHD (parton jet structure header)
C     -7            struct.  to lepton bank (ISAL)
C     -6            struct.  to pseudo cal. (ISAC)
C     -5            struct.  to unassociated particles (ISP3)
C     -4            struct.  to long lived vertices (ISV2)
C     -3            struct.  to short  "      "     (ISV1)
C     -2            struct.  to final/initial bank (ISAQ)
C     -1            struct.  to primary jet (ISAJ)
C      0            next     to next ISAE
C     +1            up
C     +2            origin
C ............................................................................
C            I-5             bank number
C             -4             bank name,  'ISAE'
C             -3             NL=7
C             -2             NS=7
C             -1             ND=18
C              0             STATUS
C             +1     I       event id(1)
C              2     I       event id(2)
C              3     I       event number
C              4     I       reaction type
C              5     I       number of primary jet banks
C              6     I         "    of stable parton banks (final+initial)
C              7     I         "    of PJET banks
C              8     I         "    of particle banks
C              9     I         "    of vertex banks
C             10     I         "    of lepton banks
C             11     F       cross section in microbarns
C             12     F       weight
C             13     F       effective q**2
C             14     F       hard scattering invariant s
C             15     F        "      "          "      t
C             16     F        "      "          "      u
C             17     D        Seed (part 1)
C             18     D        Seed (part 2)
C=======================================================================



C=======================================================================
C
C  Bank name: ISAJ
C  Author   : SDP
C  Date     : June 19,1986
C
C                Primary jet information
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C    L-1            ref. to parent primary (ISAJ) (0 if original)
C     +0            next     to next jet (ISAJ)
C     +1            up       to ISAE
C     +2            origin   to ISAE
C ............................................................................
C            I-5             Primary jet number
C             -4             bank name,  'ISAJ'
C             -3             NL=0
C             -2             NS=0
C             -1             ND=9
C              0             STATUS
C             +1     I       jet ID
C              2     F       px
C              3     F       py
C              4     F       pz
C              5     F       p
C              6     F       mass
C              7     F       phi
C              8     F       theta
C              9     F       eta
C=======================================================================



C=======================================================================
C
C  Bank name: ISAL
C  Author   : SDP
C  Date     : June 19,1986
C
C                  Lepton bank (from primary and short lived vertices)
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C    L-4            ref.  to particle bank  (ISP1)
C     -3            ref.  to primary jet    (ISAJ)
C     -2            ref.  to initial parton (ISAQ)
C     -1            struct.  (free)
C      0            next     to next ISAL
C     +1            up       to ISAE
C     +2            origin   to ISAE for first and previous ISAL for others
C ............................................................................
C            I-5             particle number
C             -4             bank name,  'ISAL'
C             -3             NL=4
C             -2             NS=1
C             -1             ND=9
C              0             STATUS
C             +1     I       ISAJET particle ID
C              2     F       px
C              3     F       py
C              4     F       pz
C              5     F       p
C              6     F       mass
C              7     F       phi
C              8     F       theta
C              9     F       eta
C=======================================================================



C=======================================================================
C
C  Bank name: ISAQ
C  Author   : SDP
C  Date     : June 19,1986
C
C            Final and initial partons
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C    L-2            ref.  to PJET (parton structure jets)
C     -1            ref.  to primary jet (ISAJ)
C                            0 for initial parton
C      0            next     to next ISAQ
C     +1            up       to ISAE
C     +2            origin   to ISAE for first and previous ISAQ for others
C ............................................................................
C            I-5             final/initial parton number
C             -4             bank name,  'ISAQ'
C             -3             NL=2
C             -2             NS=0
C             -1             ND=9
C              0             STATUS
C             +1     I       final/initial parton type
C              2     F       px
C              3     F       py
C              4     F       pz
C              5     F       E
C              6     F       mass
C              7     F       phi
C              8     F       theta
C              9     F       eta
C=======================================================================



C=======================================================================
C
C  Bank name: ISCL
C  Author   : SDP
C  Date     : June 19,1986
C
C               Calorimeter cell bank
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C    L-2            ref.  to reconstructed jet (ISJT)
C     -1            ref.  to parent parton (ISAQ)
C      0            next     to next ISCL
C     +1            up       to ISAC
C     +2            origin   to ISAC for first and previous ISAL for others
C ............................................................................
C            I-5             cell number (ordinal)
C             -4             bank name,  'ISCL'
C             -3             NL=2
C             -2             NS=0
C             -1             ND=10
C              0             STATUS
C             +1     I       10000*(phi index) + y index
C              2     I       10000*(# of charged trks) + # of gammas
C              3     F       e.m. energy deposited
C              4     F       had.  "        "
C              5     F       sin(theta) at center of cell
C              6     F       cos(theta)         "
C              7     F       sin(phi)           "
C              8     F       cos(phi)           "
C              9     F       phi                "
C             10     F       eta                "
C===========================================================================




C=======================================================================
C
C  Bank name: ISJT
C  Author   : SDP
C  Date     : June 19,1986
C
C                Jets found by ISZJET
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C     -1            to possible parent parton (ISAQ)
C     +0            next     to next jet (ISJT)
C     +1            up       to ISJT
C     +2            origin   to ISAC
C ............................................................................
C            I-5             jet number
C             -4             bank name,  'ISJT'
C             -3             NL=0
C             -2             NS=0
C             -1             ND=6
C              0             STATUS
C             +1     F       ET (transverse energy)
C              2     F       px
C              3     F       py
C              4     F       pz
C              5     F       E
C              6     F       mass
C              7     F       phi
C              8     F       theta
C              9     F       eta
C=======================================================================




C=======================================================================
C
C  Bank name: ISP1
C  Author   : SDP
C  Date     : June 19,1986
C
C             Particle bank (from primary and short lived vertices)
C
C    LQ     Q/IQ
C ___________________________________________________________________________
C    L-5            ref.  to GCAH
C    L-4            ref.  to secondary vertex (ISV2)
C     -3            ref.  to primary jet    (ISAJ)
C     -2            ref.  to initial parton (ISAQ)
C     -1            struct.  (free)
C      0            next     to next ISP1
C     +1            up       to ISV1
C     +2            origin   to ISV1 for first and previous ISP1 for others
C ............................................................................
C            I-5             particle number
C             -4             bank name,  'ISP1'
C             -3             NL=4
C             -2             NS=1
C             -1             ND=9
C              0             STATUS
C             +1     I       ISAJET particle ID
C              2     F       px
C              3     F       py
C              4     F       pz
C              5     F       E
C              6     F       mass
C              7     F       phi
C              8     F       theta
C              9     F       eta
C=======================================================================



C=======================================================================
C
C  Bank Name : PJET
C  Author    : Chip Stewart
C  Date      :  7-NOV-1989 18:10:09.84
C  Version   : 2.0
C
C  Bank description : PARTON JET BANK
C      PJET is constructed by applying a jet algorithm (CONE or
C      OPENING ANGLE) to either Partons given in the ISAQ bank
C      or Paricles given in the ISP1 bank.
C
C     LQ     Q/IQ
C-----------------------------------------------------------------------
C     +2          Down   link to SPARE
C     -1          Down   link to PJPT
C      0          Next   link to
C     +1          Up     link to PJHD
C     +2          Origin link to PJHD
C.......................................................................
C             -5         Bank number
C             -4         Bank name, 'PJET'
C             -3         NL = 2
C             -2         NS = 2
C             -1         ND = 12
C              0         Status
C             +1     I   NV = 2 Version Number
C              2     F   Et ( =Pt in version NV=1 )
C              3     F   Px
C              4     F   Py
C              5     F   Pz
C              6     F   E
C              7     F   mass
C              8     F   phi
C              9     F   theta
C             10     F   eta
C             11     I   CLASS - (eg. for mapping PJET with RECO )
C             12     I   NEXT
C=======================================================================
C
C  Definitions:
C  -----------
C
C  E  - Sum(Ei) over all the Partons/Particles included in the jet.
C
C  Px - Sum(Pxi).
C  Py - Sum(Pyi).
C  Pz - Sum(Pzi).
C
C  Et - Sum[Ei*sin(Thetai)]
C
C  Comment: In version NV=1 word 2 was Pt = SQRT ( Px**2 + Py**2 )
C
C  Mass - SQRT [ E**2 - ( Px**2 + Py**2 + Pz**2 )]
C
C  For Theta, Phi and Eta the following code was used
C  to calculate them from Px,Py,Pz
C
C  PARAMETER( SMALL = 1.0E-5 )
C  Phi=ATAN2(Py,Px+SMALL)   ;   IF(Phi.LT.0) Phi=Phi+TWOPI
C  Theta=ACOS((Pz+SMALL)/(SQRT(Px*Px+Py*Py+Pz*Pz)+SMALL))
C  Eta=-ALOG(TAN(Theta/2.)+SMALL)
C
C=======================================================================



C=======================================================================
C
C  Bank Name : PJHD
C  Author    : Chip Stewart
C  Date      :  7-NOV-1989 17:57:58.00
C
C  Bank description : Header for PJET structure
C
C     LQ     Q/IQ
C-----------------------------------------------------------------------
C     -2          DOWN   spare
C     -1          DOWN   LINK TO PJET
C      0          Next   link to PJHD
C     +1          Up     link to ISAE
C     +2          Origin link to ISAE
C.......................................................................
C             -5         Bank number
C             -4         Bank name, 'PJHD'
C             -3         NL = 2
C             -2         NS = 2
C             -1         ND = 8
C              0         Status
C              1     I   NV=2 Version number
C              2     I   N_ALG - 1 for DR CONE , 2 for CMS OPEN ANGLE
C              3     I   NJET - NUMBER OF PARTON JETS
C              4     F   algorithm parameters DR_CONE_CUT/OPENING_ANGLE_CUT
C              5     F   algorithm parameters JET_ET_CUT
C              6     I   algorithm parameters MAX ITERATIONS
C              7     I   Initial Radiation switch 0-use IR      1-no IR
C              8     I   MUON switch (IF NV=1 MUON NOT USED) 
C                        0-no MUONS    1-use MUONS
C=======================================================================



C=======================================================================
C
C  Bank Name : PJPT
C  Author    : Chip Stewart
C  Date      : 15-Dec-1989
C
C  Bank description : pointers to Partons (ISAQ) in a given jet
C
C     LQ     Q/IQ
C-----------------------------------------------------------------------
C     -N+1        Ref Link to parton bank ISAQ for Nth parton in this PJET
C     -2          Ref Link to parton bank ISAQ for 1st    "    "  "    "
C     -1          not used
C      0          Next   link to none
C     +1          Up     link to PJET
C     +2          Origin link to PJET
C.......................................................................
C             -5         Bank number
C             -4         Bank name, 'PJPT'
C             -3         NL = N+1
C             -2         NS = 0
C             -1         ND = 1 - number of data words in PJPT bank = 1
C              0         Status
C             +1     I   Bank version (=1)
C=======================================================================

+EOD
+PATCH,ISADECAY,T=DATA.
+EOD
+DECK,DECAY
' ISAJET     V7.74   16-FEB-2006 14:23:44'
    110,      0,    .98850,     10,     10,      0,      0,      0/
    110,      1,   1.00000,     10,     12,    -12,      0,      0/
    220,      0,    .38000,     10,     10,      0,      0,      0/
    220,      0,    .71000,    110,    110,    110,      0,      0/
    220,      0,    .94600,    120,   -120,    110,      0,      0/
    220,      0,    .99500,    120,   -120,     10,      0,      0/
    220,      1,   1.00000,     10,     12,    -12,      0,      0/
    330,      0,    .44100,    220,    120,   -120,      0,      0/
    330,      0,    .66100,    220,    110,    110,      0,      0/
    330,      0,    .95900,    111,     10,      0,      0,      0/
    330,      0,    .98000,    221,     10,      0,      0,      0/
    330,      0,   1.00000,     10,     10,      0,      0,      0/
    121,      0,   1.00000,    120,    110,      0,      0,      0/
    111,      0,    .99989,    120,   -120,      0,      0,      0/
    111,      0,    .99993,     12,    -12,      0,      0,      0/
    111,      0,   1.00000,     14,    -14,      0,      0,      0/
    221,      2,    .89900,    120,   -120,    110,      0,      0/
    221,      0,    .91200,    120,   -120,      0,      0,      0/
    221,      0,    .99992,    110,     10,      0,      0,      0/
    221,      0,   1.00000,     12,    -12,      0,      0,      0/
    331,      0,    .48600,    130,   -130,      0,      0,      0/
    331,      0,    .83700,     20,    -20,      0,      0,      0/
    331,      2,    .98400,    120,   -120,    110,      0,      0/
    331,      0,    .99944,    220,     10,      0,      0,      0/
    331,      0,    .99975,     12,    -12,      0,      0,      0/
    331,      0,   1.00000,     14,    -14,      0,      0,      0/
  10110,      0,    .52000,    120,   -120,      0,      0,      0/
  10110,      0,    .78000,    110,    110,      0,      0,      0/
  10110,      0,    .89000,    130,   -130,      0,      0,      0/
  10110,      0,   1.00000,    -20,     20,      0,      0,      0/
  10121,      0,    .49200,    111,    120,      0,      0,      0/
  10121,      0,   1.00000,    121,    110,      0,      0,      0/
  10111,      0,    .50000,    121,   -120,      0,      0,      0/
  10111,      0,   1.00000,   -121,    120,      0,      0,      0/
    112,      0,    .56700,    120,   -120,      0,      0,      0/
    112,      0,    .85100,    110,    110,      0,      0,      0/
    112,      0,    .87900,    120,   -120,    120,   -120,      0/
    112,      0,    .94500,    120,   -120,    110,    110,      0/
    112,      0,    .94800,    110,    110,    110,    110,      0/
    112,      0,    .97200,    130,   -130,      0,      0,      0/
    112,      0,    .99600,    -20,     20,      0,      0,      0/
    112,      0,   1.00000,    220,    220,      0,      0,      0/
    230,      0,    .50000,     20,      0,      0,      0,      0/
    230,      0,   1.00000,    -20,      0,      0,      0,      0/
    131,      0,    .66670,    230,    120,      0,      0,      0/
    131,      0,   1.00000,    130,    110,      0,      0,      0/
    231,      0,    .66670,    130,   -120,      0,      0,      0/
    231,      0,   1.00000,    230,    110,      0,      0,      0/
  10231,      0,    .28000,    130,   -121,      0,      0,      0/
  10231,      0,    .42000,    230,    111,      0,      0,      0/
  10231,      0,    .52670,    131,   -120,      0,      0,      0/
  10231,      0,    .58000,    231,    110,      0,      0,      0/
  10231,      0,    .69000,    230,    120,   -120,    110,      0/
  10231,      0,    .83440,    230,    120,   -120,      0,      0/
  10231,      0,    .95880,    130,   -120,    110,      0,      0/
  10231,      0,   1.00000,    230,    110,    110,      0,      0/
  10131,      0,    .28000,    230,    121,      0,      0,      0/
  10131,      0,    .42000,    130,    111,      0,      0,      0/
  10131,      0,    .52670,    231,    120,      0,      0,      0/
  10131,      0,    .58000,    131,    110,      0,      0,      0/
  10131,      0,    .69000,    130,    120,   -120,    110,      0/
  10131,      0,    .83440,    130,    120,   -120,      0,      0/
  10131,      0,    .95880,    230,    120,    110,      0,      0/
  10131,      0,   1.00000,    130,    110,    110,      0,      0/
  30231,      0,    .63000,    131,   -120,      0,      0,      0/
  30231,      0,    .94000,    231,    110,      0,      0,      0/
  30231,      0,    .96000,    130,   -121,      0,      0,      0/
  30231,      0,    .97000,    230,    111,      0,      0,      0/
  30231,      0,    .98000,    230,    221,      0,      0,      0/
  30231,      0,    .99330,    230,    120,   -120,      0,      0/
  30231,      0,   1.00000,    230,    110,    110,      0,      0/
  30131,      0,    .63000,    231,    120,      0,      0,      0/
  30131,      0,    .94000,    131,    110,      0,      0,      0/
  30131,      0,    .96000,    230,   -121,      0,      0,      0/
  30131,      0,    .97000,    130,    111,      0,      0,      0/
  30131,      0,    .98000,    130,    221,      0,      0,      0/
  30131,      0,    .99330,    130,    120,   -120,      0,      0/
  30131,      0,   1.00000,    130,    110,    110,      0,      0/
    132,      0,    .33100,    230,    120,      0,      0,      0/
    132,      0,    .49700,    130,    110,      0,      0,      0/
    132,      0,    .66500,    231,    120,      0,      0,      0/
    132,      0,    .74900,    131,    110,      0,      0,      0/
    132,      0,    .80300,    231,    120,    110,      0,      0/
    132,      0,    .85700,    131,    120,   -120,      0,      0/
    132,      0,    .91100,    131,    110,    110,      0,      0/
    132,      0,    .97000,    230,    121,      0,      0,      0/
    132,      0,   1.00000,    130,    111,      0,      0,      0/
    232,      0,    .33100,    130,   -120,      0,      0,      0/
    232,      0,    .49700,    230,    110,      0,      0,      0/
    232,      0,    .66500,    131,   -120,      0,      0,      0/
    232,      0,    .74900,    231,    110,      0,      0,      0/
    232,      0,    .80300,    231,    120,   -120,      0,      0/
    232,      0,    .85700,    231,    110,    110,      0,      0/
    232,      0,    .91100,    131,   -120,    110,      0,      0/
    232,      0,    .97000,    130,   -121,      0,      0,      0/
    232,      0,   1.00000,    230,    111,      0,      0,      0/
     16,      5,    .18000,    -11,     12,     15,      0,      0/
     16,      5,    .35510,    -13,     14,     15,      0,      0/
     16,      6,    .46550,   -120,     15,      0,      0,      0/
     16,      7,    .71700,   -121,     15,      0,      0,      0/
     16,      7,    .88020, -10121,     15,      0,      0,      0/
     16,      6,    .88740,   -130,     15,      0,      0,      0/
     16,      7,    .90080,   -131,     15,      0,      0,      0/
     16,      0,    .95450,   -120,   -120,    120,    110,     15/
     16,      0,    .96850,   -120,    110,    110,    110,     15/
     16,      0,    .96990,   -120,    111,    111,     15,      0/
     16,      0,    .97200,   -130,   -120,    130,     15,      0/
     16,      0,    .97400,    230,   -120,   -230,     15,      0/
     16,      0,    .97420,   -130,    230,    110,     15,      0/
     16,      0,    .97530,    110,    110,   -130,     15,      0/
     16,      0,    .98090,   -130,   -120,    120,     15,      0/
     16,      0,    .98650,   -120,   -230,    110,     15,      0/
     16,      0,    .98820,    220,   -120,    110,     15,      0/
     16,      0,    .98960,   -120,    110,     10,     15,      0/
     16,      0,    .99100,   -120,   -121,    121,     15,      0/
     16,      0,    .99300,    221,   -120,    110,    110,     15/
     16,      0,    .99400,   -121,    110,    110,    110,     15/
     16,      0,    .99800,   -120,    221,    110,     15,      0/
     16,      0,   1.00000,   -130,    230,     15,      0,      0/
    240,      3,    .01140,    -11,     12,    231,      0,      0/
    240,      3,    .02280,    -11,     12,    231,      0,      0/
    240,      3,    .05040,    -11,     12,    231,      0,      0/
    240,      3,    .14330,    -11,     12,    230,      0,      0/
    240,      3,    .14690,    -11,     12,  10231,      0,      0/
    240,      3,    .15070,    -11,     12,    232,      0,      0/
    240,      3,    .15710,    -11,     12,    110,      0,      0/
    240,      3,    .15990,    -11,     12,    220,      0,      0/
    240,      3,    .16100,    -11,     12,    330,      0,      0/
    240,      3,    .16400,    -11,     12,    111,      0,      0/
    240,      3,    .16690,    -11,     12,    221,      0,      0/
    240,      3,    .17830,    -13,     14,    231,      0,      0/
    240,      3,    .18970,    -13,     14,    231,      0,      0/
    240,      3,    .21730,    -13,     14,    231,      0,      0/
    240,      3,    .31020,    -13,     14,    230,      0,      0/
    240,      3,    .31380,    -13,     14,  10231,      0,      0/
    240,      3,    .31760,    -13,     14,    232,      0,      0/
    240,      3,    .32400,    -13,     14,    110,      0,      0/
    240,      3,    .32680,    -13,     14,    220,      0,      0/
    240,      3,    .32790,    -13,     14,    330,      0,      0/
    240,      3,    .33090,    -13,     14,    111,      0,      0/
    240,      3,    .33380,    -13,     14,    221,      0,      0/
    240,      0,    .33470,     14,    -13,      0,      0,      0/
    240,      0,    .33710,     16,    -15,      0,      0,      0/
    240,      0,    .36630,    230,   -120,      0,      0,      0/
    240,      0,    .43850,    230,   -121,      0,      0,      0/
    240,      0,    .51920,    230, -10121,      0,      0,      0/
    240,      0,    .54050,    231,   -120,      0,      0,      0/
    240,      0,    .59130,  30231,   -120,      0,      0,      0/
    240,      0,    .62580,    232,   -120,      0,      0,      0/
    240,      0,    .67610,    231,   -121,      0,      0,      0/
    240,      0,    .73090,    130,   -120,   -120,      0,      0/
    240,      0,    .74640,    230,    110,   -120,      0,      0/
    240,      0,    .75640,    230,    220,   -120,      0,      0/
    240,      0,    .76140,    230,    111,   -120,      0,      0/
    240,      0,    .76640,    230,    221,   -120,      0,      0/
    240,      0,    .77600,    130,   -121,   -120,      0,      0/
    240,      0,    .79600,    131,   -120,   -120,      0,      0/
    240,      0,    .80600,    231,    110,   -120,      0,      0/
    240,      0,    .81600,    231,    220,   -120,      0,      0/
    240,      0,    .82380,    231,    111,   -120,      0,      0/
    240,      0,    .82880,    231,    221,   -120,      0,      0/
    240,      0,    .83880,    131,   -121,   -120,      0,      0/
    240,      0,    .84480,    130,   -120,   -120,    110,      0/
    240,      0,    .85480,    230,   -120,   -120,    120,      0/
    240,      0,    .87480,    230,   -120,    110,    110,      0/
    240,      0,    .87830,    130,   -120,   -120,   -120,    120/
    240,      0,    .88180,    230,   -120,   -120,    120,    110/
    240,      0,    .88530,    130,   -120,   -120,    110,    110/
    240,      0,    .88880,    230,   -120,    110,    110,    110/
    240,      0,    .90880,    230,    230,   -130,      0,      0/
    240,      0,    .91580,    331,   -120,      0,      0,      0/
    240,      0,    .92580,    331,   -120,    110,      0,      0/
    240,      0,    .93400,    230,   -130,      0,      0,      0/
    240,      0,    .93920,    231,   -130,      0,      0,      0/
    240,      0,    .94440,    230,   -131,      0,      0,      0/
    240,      0,    .95840,    231,   -131,      0,      0,      0/
    240,      0,    .96240,   -130,    130,   -120,      0,      0/
    240,      0,    .96340,   -130,    230,    110,      0,      0/
    240,      0,    .96440,    230,   -230,   -120,      0,      0/
    240,      0,    .96540,   -131,    130,   -120,      0,      0/
    240,      0,    .96640,   -130,    131,   -120,      0,      0/
    240,      0,    .96740,   -131,    230,    110,      0,      0/
    240,      0,    .96840,   -130,    231,    110,      0,      0/
    240,      0,    .96940,    231,   -230,   -120,      0,      0/
    240,      0,    .97040,    230,   -231,   -120,      0,      0/
    240,      0,    .97300,    110,   -120,      0,      0,      0/
    240,      0,    .97320,    111,   -120,      0,      0,      0/
    240,      0,    .97640,   -120,   -120,    120,      0,      0/
    240,      0,    .97940,   -120,    110,    110,      0,      0/
    240,      0,    .98240,   -120,   -120,    120,    110,      0/
    240,      0,    .98440,   -120,    110,    110,    110,      0/
    240,      0,    .99200,    220,   -120,      0,      0,      0/
    240,      0,    .99500,    220,   -120,    110,      0,      0/
    240,      0,    .99800,    220,   -120,    120,   -120,      0/
    240,      0,   1.00000,    220,   -120,    110,    110,      0/
    140,      3,    .00450,    -11,     12,    131,      0,      0/
    140,      3,    .00900,    -11,     12,    131,      0,      0/
    140,      3,    .01980,    -11,     12,    131,      0,      0/
    140,      3,    .05620,    -11,     12,    130,      0,      0/
    140,      3,    .05760,    -11,     12,  10131,      0,      0/
    140,      3,    .05910,    -11,     12,    132,      0,      0/
    140,      3,    .06410,    -11,     12,    120,      0,      0/
    140,      3,    .06700,    -11,     12,    121,      0,      0/
    140,      3,    .07150,    -13,     14,    131,      0,      0/
    140,      3,    .07600,    -13,     14,    131,      0,      0/
    140,      3,    .08680,    -13,     14,    131,      0,      0/
    140,      3,    .12320,    -13,     14,    130,      0,      0/
    140,      3,    .12460,    -13,     14,  10131,      0,      0/
    140,      3,    .12610,    -13,     14,    132,      0,      0/
    140,      3,    .13110,    -13,     14,    120,      0,      0/
    140,      3,    .13400,    -13,     14,    121,      0,      0/
    140,      0,    .17310,    130,   -120,      0,      0,      0/
    140,      0,    .19510,    230,    110,      0,      0,      0/
    140,      0,    .20280,    230,    220,      0,      0,      0/
    140,      0,    .22020,    230,    330,      0,      0,      0/
    140,      0,    .24090,    230,    221,      0,      0,      0/
    140,      0,    .32500,    130,   -121,      0,      0,      0/
    140,      0,    .33310,    230,    111,      0,      0,      0/
    140,      0,    .37190,    131,   -120,      0,      0,      0/
    140,      0,    .39750,    231,    110,      0,      0,      0/
    140,      0,    .41340,    231,    220,      0,      0,      0/
    140,      0,    .41540,    231,    330,      0,      0,      0/
    140,      0,    .49520,    130, -10121,      0,      0,      0/
    140,      0,    .55520,    131,   -121,      0,      0,      0/
    140,      0,    .57130,    231,    111,      0,      0,      0/
    140,      0,    .58240,    231,    221,      0,      0,      0/
    140,      0,    .59310,  10131,   -120,      0,      0,      0/
    140,      0,    .60020,  10231,    110,      0,      0,      0/
    140,      0,    .60190,    130,   -120,    110,      0,      0/
    140,      0,    .62320,    230,    120,   -120,      0,      0/
    140,      0,    .63770,    230,    110,    110,      0,      0/
    140,      0,    .65510,    231,    120,   -120,      0,      0/
    140,      0,    .66670,    231,    110,    110,      0,      0/
    140,      0,    .67670,    131,   -120,    110,      0,      0/
    140,      0,    .68350,    130,   -121,    110,      0,      0/
    140,      0,    .69030,    130,   -120,    111,      0,      0/
    140,      0,    .72060,    130,   -120,    221,      0,      0/
    140,      0,    .73060,    130,   -120,    220,      0,      0/
    140,      0,    .73810,    130,   -120,    330,      0,      0/
    140,      0,    .75240,    130,   -120,    120,   -120,      0/
    140,      0,    .79310,    230,    120,   -120,    110,      0/
    140,      0,    .86290,    130,   -120,    110,    110,      0/
    140,      0,    .88290,    230,    110,    110,    110,      0/
    140,      0,    .88670,    130,   -120,    120,   -120,    110/
    140,      0,    .89050,    130,   -120,    110,    110,    110/
    140,      0,    .89430,    230,    120,   -120,    120,   -120/
    140,      0,    .89810,    230,    120,   -120,    110,    110/
    140,      0,    .90690,    230,    331,      0,      0,      0/
    140,      0,    .91200,    230,    130,   -130,      0,      0/
    140,      0,    .91300,     20,     20,     20,      0,      0/
    140,      0,    .91740,    130,   -130,      0,      0,      0/
    140,      0,    .91800,     20,     20,      0,      0,      0/
    140,      0,    .91860,    -20,    -20,      0,      0,      0/
    140,      0,    .92060,   -231,    230,      0,      0,      0/
    140,      0,    .92260,    231,   -230,      0,      0,      0/
    140,      0,    .92450,    131,   -130,      0,      0,      0/
    140,      0,    .92800,   -131,    130,      0,      0,      0/
    140,      0,    .92900,    231,   -231,      0,      0,      0/
    140,      0,    .93100,    230,    130,   -120,      0,      0/
    140,      0,    .93500,   -230,   -130,    120,      0,      0/
    140,      0,    .93700,    331,    110,      0,      0,      0/
    140,      0,    .93950,    331,    120,   -120,      0,      0/
    140,      0,    .94250,    130,   -130,    120,   -120,      0/
    140,      0,    .94550,    130,   -130,    110,    110,      0/
    140,      0,    .94700,   -230,    230,    120,   -120,      0/
    140,      0,    .94850,   -230,    230,    120,   -120,      0/
    140,      0,    .95000,    120,   -120,      0,      0,      0/
    140,      0,    .95090,    110,    110,      0,      0,      0/
    140,      0,    .95190,    220,    110,      0,      0,      0/
    140,      0,    .95290,    330,    110,      0,      0,      0/
    140,      0,    .95390,    220,    220,      0,      0,      0/
    140,      0,    .95790,    121,   -120,      0,      0,      0/
    140,      0,    .96190,   -121,    120,      0,      0,      0/
    140,      0,    .96390,    111,    110,      0,      0,      0/
    140,      0,    .96590,    120,   -120,    110,      0,      0/
    140,      0,    .96690,    110,    110,    110,      0,      0/
    140,      0,    .97500,    120,    120,   -120,   -120,      0/
    140,      0,    .98000,    120,   -120,    110,    110,      0/
    140,      0,    .99400,    120,   -120,    120,   -120,    110/
    140,      0,   1.00000,    120,   -120,    110,    110,    110/
    340,      3,    .00450,    -11,     12,    331,      0,      0/
    340,      3,    .00900,    -11,     12,    331,      0,      0/
    340,      3,    .02000,    -11,     12,    331,      0,      0/
    340,      3,    .05880,    -11,     12,    220,      0,      0/
    340,      3,    .07560,    -11,     12,    330,      0,      0/
    340,      3,    .07830,    -11,     12,    230,      0,      0/
    340,      3,    .07930,    -11,     12,    231,      0,      0/
    340,      3,    .08380,    -13,     14,    331,      0,      0/
    340,      3,    .08830,    -13,     14,    331,      0,      0/
    340,      3,    .09930,    -13,     14,    331,      0,      0/
    340,      3,    .13810,    -13,     14,    220,      0,      0/
    340,      3,    .15490,    -13,     14,    330,      0,      0/
    340,      3,    .15760,    -13,     14,    230,      0,      0/
    340,      3,    .15860,    -13,     14,    231,      0,      0/
    340,      0,    .16770,    -13,     14,      0,      0,      0/
    340,      0,    .25870,    -15,     16,      0,      0,      0/
    340,      0,    .29570,    331,   -120,      0,      0,      0/
    340,      0,    .31570,    220,   -120,      0,      0,      0/
    340,      0,    .36750,    330,   -120,      0,      0,      0/
    340,      0,    .36850,    221,   -120,      0,      0,      0/
    340,      0,    .36950,    111,   -120,      0,      0,      0/
    340,      0,    .37150,   -121,    110,      0,      0,      0/
    340,      0,    .37250,   -120,    110,      0,      0,      0/
    340,      0,    .38290,  10110,   -120,      0,      0,      0/
    340,      0,    .45170,    331,   -121,      0,      0,      0/
    340,      0,    .55750,    220,   -121,      0,      0,      0/
    340,      0,    .68480,    330,   -121,      0,      0,      0/
    340,      0,    .69570,   -120,    120,   -120,      0,      0/
    340,      0,    .70070,   -120,    110,    110,      0,      0/
    340,      0,    .72070,    331,   -120,    110,      0,      0/
    340,      0,    .73070,    220,   -120,    110,      0,      0/
    340,      0,    .74070,    330,   -120,    110,      0,      0/
    340,      0,    .75620,    331,   -120,    120,   -120,      0/
    340,      0,    .76120,    331,   -120,    110,    110,      0/
    340,      0,    .76620,    220,   -120,    120,   -120,      0/
    340,      0,    .77120,    220,   -120,    110,    110,      0/
    340,      0,    .80860,    230,   -130,      0,      0,      0/
    340,      0,    .84380,    231,   -130,      0,      0,      0/
    340,      0,    .88820,    230,   -131,      0,      0,      0/
    340,      0,    .94740,    231,   -131,      0,      0,      0/
    340,      0,    .95670,   -130,    130,   -120,      0,      0/
    340,      0,    .96170,    230,   -130,    110,      0,      0/
    340,      0,    .96370,    230,   -130,   -120,    120,      0/
    340,      0,    .96570,    230,   -130,    110,    110,      0/
    340,      0,    .96870,    331,   -130,      0,      0,      0/
    340,      0,    .97020,    220,   -130,      0,      0,      0/
    340,      0,    .97370,    330,   -130,      0,      0,      0/
    340,      0,    .97670,    220,   -130,    110,      0,      0/
    340,      0,    .97870,    220,   -130,   -120,    120,      0/
    340,      0,    .98070,    330,   -130,    110,      0,      0/
    340,      0,    .98170,    330,   -130,   -120,    120,      0/
    340,      0,    .98470,   -130,    130,   -130,      0,      0/
    340,      0,    .98720,   -230,   -120,      0,      0,      0/
    340,      0,    .98970,   -230,   -121,      0,      0,      0/
    340,      0,    .99070,   -230,   -120,    110,      0,      0/
    340,      0,    .99270,   -230, -10121,      0,      0,      0/
    340,      0,    .99520,   -231,   -120,      0,      0,      0/
    340,      0,    .99770,   -231,   -121,      0,      0,      0/
    340,      0,   1.00000,   -231,   -120,    110,      0,      0/
    241,      0,    .64000,    140,   -120,      0,      0,      0/
    241,      0,    .92000,    240,    110,      0,      0,      0/
    241,      0,   1.00000,    240,     10,      0,      0,      0/
    141,      0,    .55000,    140,    110,      0,      0,      0/
    141,      0,   1.00000,    140,     10,      0,      0,      0/
    341,      0,   1.00000,    340,     10,      0,      0,      0/
    440,      0,    .01200,    120,   -120,    120,   -120,      0/
    440,      0,    .01320,   1120,  -1120,      0,      0,      0/
    440,      0,    .03320,    130,   -130,    120,   -120,      0/
    440,      0,    .05770,    220,    120,   -120,      0,      0/
    440,      0,    .08220,    220,    110,    110,      0,      0/
    440,      0,    .10270,    330,    120,   -120,      0,      0/
    440,      0,    .12320,    330,    110,    110,      0,      0/
    440,      0,    .13030,    331,    331,      0,      0,      0/
    440,      0,    .14430,    220,    130,   -130,      0,      0/
    440,      0,    .16630,    110,    130,   -130,      0,      0/
    440,      0,    .18830,    130,   -230,   -120,      0,      0/
    440,      0,    .21030,   -130,    230,    120,      0,      0/
    440,      0,    .21460,    131,   -131,      0,      0,      0/
    440,      0,    .21880,    231,   -231,      0,      0,      0/
    440,      0,    .22880,    231,   -130,    120,      0,      0/
    440,      0,    .23880,   -231,    130,   -120,      0,      0/
    440,      0,    .25180,    111,    111,      0,      0,      0/
    440,      0,    .26480,    121,   -121,      0,      0,      0/
    440,      0,    .42810,    121,    110,   -121,      0,      0/
    440,      0,    .59140,    120,    111,   -121,      0,      0/
    440,      0,    .75470,    121,    111,   -120,      0,      0/
    440,      0,    .81600,    121,   -121,      0,      0,      0/
    440,      0,    .87730,    111,    111,      0,      0,      0/
    440,      0,    .93860,    131,   -131,      0,      0,      0/
    440,      0,   1.00000,    231,   -231,      0,      0,      0/
    441,      0,    .06020,    -12,     12,      0,      0,      0/
    441,      0,    .12030,    -14,     14,      0,      0,      0/
    441,      0,    .13730,    120,   -120,    110,      0,      0/
    441,      0,    .17360,    111,    111,    110,      0,      0/
    441,      0,    .20990,    121,   -121,    110,      0,      0/
    441,      0,    .24620,    121,    111,   -120,      0,      0/
    441,      0,    .28120,    111,    111,    111,    110,      0/
    441,      0,    .31620,    121,   -121,    111,    110,      0/
    441,      0,    .35120,    111,    111,    121,   -120,      0/
    441,      0,    .38620,    121,   -121,    121,   -120,      0/
    441,      0,    .41420,    111,    111,    111,    221,      0/
    441,      0,    .44220,    121,   -121,    111,    221,      0/
    441,      0,    .44930,    130,   -130,    110,      0,      0/
    441,      0,    .45640,    230,   -230,    110,      0,      0/
    441,      0,    .46350,    130,   -230,   -120,      0,      0/
    441,      0,    .47060,    230,   -130,    120,      0,      0/
    441,      0,    .47770,    131,   -130,    110,      0,      0/
    441,      0,    .48480,    131,   -230,   -120,      0,      0/
    441,      0,    .49190,    231,   -130,    120,      0,      0/
    441,      0,    .49900,    231,   -230,    110,      0,      0/
    441,      0,    .50610,    130,   -131,    110,      0,      0/
    441,      0,    .51320,    130,   -231,   -120,      0,      0/
    441,      0,    .52030,    230,   -131,    120,      0,      0/
    441,      0,    .52740,    230,   -231,    110,      0,      0/
    441,      0,    .53690,    131,   -131,    110,      0,      0/
    441,      0,    .54640,    231,   -231,    110,      0,      0/
    441,      0,    .55590,    131,    231,   -120,      0,      0/
    441,      0,    .56540,    231,   -131,    120,      0,      0/
    441,      0,    .58040,    131,   -131,    111,      0,      0/
    441,      0,    .59540,    231,   -231,    111,      0,      0/
    441,      0,    .61040,    131,    231,   -121,      0,      0/
    441,      0,    .62540,    231,   -131,    121,      0,      0/
    441,      0,    .64240,    120,   -120,    220,      0,      0/
    441,      0,    .65940,    120,   -120,    220,    220,      0/
    441,      0,    .70940,    111,    111,    220,      0,      0/
    441,      0,    .75940,    121,   -121,    220,      0,      0/
    441,      0,    .80940,    121,   -121,    111,    220,      0/
    441,      0,    .85940,    121,   -121,    221,    220,      0/
    441,      0,    .86160,   1120,  -1120,      0,      0,      0/
    441,      0,    .86380,   1220,  -1220,      0,      0,      0/
    441,      0,    .87880,   1111,  -1111,      0,      0,      0/
    441,      0,    .89380,   1121,  -1121,      0,      0,      0/
    441,      0,    .90880,   1221,  -1221,      0,      0,      0/
    441,      0,    .92380,   2221,  -2221,      0,      0,      0/
    441,      0,    .94080,     10,    440,      0,      0,      0/
    441,      0,    .94910,     10,    121,   -121,      0,      0/
    441,      0,    .95740,     10,    111,    111,      0,      0/
    441,      0,    .96640,     10,    220,    120,   -120,      0/
    441,      0,    .98340,     10,    121,   -121,    111,      0/
    441,      0,   1.00000,     10,    111,    111,    111,      0/
  10441,      0,    .00830,    -12,     12,      0,      0,      0/
  10441,      0,    .01660,    -14,     14,      0,      0,      0/
  10441,      0,    .34060,    441,    120,   -120,      0,      0/
  10441,      0,    .52460,    441,    110,    110,      0,      0/
  10441,      0,    .55160,    441,    220,      0,      0,      0/
  10441,      0,    .55260,    441,    110,      0,      0,      0/
  10441,      0,    .64560,     10,  20440,      0,      0,      0/
  10441,      0,    .73260,     10,  20441,      0,      0,      0/
  10441,      0,    .81060,     10,  20442,      0,      0,      0/
  10441,      0,    .81340,     10,    440,      0,      0,      0/
  10441,      0,    .81720,    111,    111,    110,      0,      0/
  10441,      0,    .82100,    121,   -121,    110,      0,      0/
  10441,      0,    .82480,    121,    111,   -120,      0,      0/
  10441,      0,    .82990,    111,    111,    111,    110,      0/
  10441,      0,    .83500,    121,   -121,    111,    110,      0/
  10441,      0,    .84010,    111,    111,    121,   -120,      0/
  10441,      0,    .84520,    121,   -121,    121,   -120,      0/
  10441,      0,    .87020,    111,    111,    111,    221,      0/
  10441,      0,    .89520,    121,   -121,    111,    221,      0/
  10441,      0,    .89920,    130,   -130,    110,      0,      0/
  10441,      0,    .90320,    230,   -230,    110,      0,      0/
  10441,      0,    .90720,    130,   -230,   -120,      0,      0/
  10441,      0,    .91120,    230,   -130,    120,      0,      0/
  10441,      0,    .91520,    131,   -130,    110,      0,      0/
  10441,      0,    .91920,    131,   -230,   -120,      0,      0/
  10441,      0,    .92320,    231,   -130,    120,      0,      0/
  10441,      0,    .92720,    231,   -230,    110,      0,      0/
  10441,      0,    .93120,    130,   -131,    110,      0,      0/
  10441,      0,    .93520,    130,   -231,   -120,      0,      0/
  10441,      0,    .93920,    230,   -131,    120,      0,      0/
  10441,      0,    .94320,    230,   -231,    110,      0,      0/
  10441,      0,    .94690,    231,   -131,    120,      0,      0/
  10441,      0,    .95060,    131,   -131,    111,      0,      0/
  10441,      0,    .95430,    231,   -231,    111,      0,      0/
  10441,      0,    .95800,    131,    231,   -121,      0,      0/
  10441,      0,    .96170,    231,   -131,    121,      0,      0/
  10441,      0,    .96540,    120,   -120,    220,      0,      0/
  10441,      0,    .96910,    120,   -120,    220,    220,      0/
  10441,      0,    .97280,    111,    111,    220,      0,      0/
  10441,      0,    .97650,    121,   -121,    220,      0,      0/
  10441,      0,    .98020,    121,   -121,    111,    220,      0/
  10441,      0,    .98390,    121,   -121,    221,    220,      0/
  10441,      0,    .98790,   1111,  -1111,      0,      0,      0/
  10441,      0,    .99190,   1121,  -1121,      0,      0,      0/
  10441,      0,    .99590,   1221,  -1221,      0,      0,      0/
  10441,      0,   1.00000,   2221,  -2221,      0,      0,      0/
  20440,      0,    .00660,     10,    441,      0,      0,      0/
  20440,      0,    .01410,    120,   -120,      0,      0,      0/
  20440,      0,    .05110,    120,   -120,    120,   -120,      0/
  20440,      0,    .06610,    120,   -120,    120,   -120,    120/
  20440,      0,    .08210,    111,    120,   -120,      0,      0/
  20440,      0,    .09810,    121,   -120,    110,      0,      0/
  20440,      0,    .11410,   -121,    120,    110,      0,      0/
  20440,      0,    .12010,   -231,    130,   -120,      0,      0/
  20440,      0,    .12610,    231,   -130,    120,      0,      0/
  20440,      0,    .13210,   -230,    131,   -120,      0,      0/
  20440,      0,    .13810,    230,   -131,    120,      0,      0/
  20440,      0,    .14520,    130,   -130,      0,      0,      0/
  20440,      0,    .17520,    120,   -120,    130,   -130,      0/
  20440,      0,    .18020,    120,   -120,   1120,  -1120,      0/
  20440,      0,    .36240,    121,    110,   -121,      0,      0/
  20440,      0,    .54460,    120,    111,   -121,      0,      0/
  20440,      0,    .72680,    121,    111,   -120,      0,      0/
  20440,      0,    .79520,    121,   -121,      0,      0,      0/
  20440,      0,    .86360,    111,    111,      0,      0,      0/
  20440,      0,    .93200,    131,   -131,      0,      0,      0/
  20440,      0,   1.00000,    231,   -231,      0,      0,      0/
  20441,      0,    .27300,     10,    441,      0,      0,      0/
  20441,      0,    .28900,    120,   -120,    120,   -120,      0/
  20441,      0,    .31100,    120,   -120,    120,   -120,    120/
  20441,      0,    .32000,    120,   -120,    130,   -130,      0/
  20441,      0,    .32390,    111,    120,   -120,      0,      0/
  20441,      0,    .32780,    121,   -120,    110,      0,      0/
  20441,      0,    .33170,   -121,    120,    110,      0,      0/
  20441,      0,    .33330,   -231,    130,   -120,      0,      0/
  20441,      0,    .33490,    231,   -130,    120,      0,      0/
  20441,      0,    .33650,   -230,    131,   -120,      0,      0/
  20441,      0,    .33810,    230,   -131,    120,      0,      0/
  20441,      0,    .33950,    120,   -120,   1120,  -1120,      0/
  20441,      0,    .48630,    121,    110,   -121,      0,      0/
  20441,      0,    .63310,    120,    111,   -121,      0,      0/
  20441,      0,    .77990,    121,    111,   -120,      0,      0/
  20441,      0,    .83500,    121,   -121,      0,      0,      0/
  20441,      0,    .89010,    111,    111,      0,      0,      0/
  20441,      0,    .94520,    131,   -131,      0,      0,      0/
  20441,      0,   1.00000,    231,   -231,      0,      0,      0/
  20442,      0,    .13500,     10,    441,      0,      0,      0/
  20442,      0,    .13690,    120,   -120,      0,      0,      0/
  20442,      0,    .15890,    120,   -120,    120,   -120,      0/
  20442,      0,    .17090,    120,   -120,    120,   -120,    120/
  20442,      0,    .17790,    111,    120,   -120,      0,      0/
  20442,      0,    .18490,    121,   -120,    110,      0,      0/
  20442,      0,    .19190,   -121,    120,    110,      0,      0/
  20442,      0,    .19430,   -231,    130,   -120,      0,      0/
  20442,      0,    .19670,    231,   -130,    120,      0,      0/
  20442,      0,    .19910,   -230,    131,   -120,      0,      0/
  20442,      0,    .20150,    230,   -131,    120,      0,      0/
  20442,      0,    .20300,    130,   -130,      0,      0,      0/
  20442,      0,    .22200,    120,   -120,    130,   -130,      0/
  20442,      0,    .22210,   1120,  -1120,      0,      0,      0/
  20442,      0,    .22540,    120,   -120,   1120,  -1120,      0/
  20442,      0,    .39750,    121,    110,   -121,      0,      0/
  20442,      0,    .56960,    120,    111,   -121,      0,      0/
  20442,      0,    .74170,    121,    111,   -120,      0,      0/
  20442,      0,    .80630,    121,   -121,      0,      0,      0/
  20442,      0,    .87090,    111,    111,      0,      0,      0/
  20442,      0,    .93550,    131,   -131,      0,      0,      0/
  20442,      0,   1.00000,    231,   -231,      0,      0,      0/
    150,      3,    .01150,     11,    -12,    141,      0,      0/
    150,      3,    .02300,     11,    -12,    141,      0,      0/
    150,      3,    .04900,     11,    -12,    141,      0,      0/
    150,      3,    .06700,     11,    -12,    140,      0,      0/
    150,      0,    .07930,     11,    -12,    140,    110,      0/
    150,      0,    .10400,     11,    -12,    240,    120,      0/
    150,      3,    .11550,     13,    -14,    141,      0,      0/
    150,      3,    .12700,     13,    -14,    141,      0,      0/
    150,      3,    .15300,     13,    -14,    141,      0,      0/
    150,      3,    .17100,     13,    -14,    140,      0,      0/
    150,      0,    .18330,     13,    -14,    140,    110,      0/
    150,      0,    .20800,     13,    -14,    240,    120,      0/
    150,      3,    .22400,     15,    -16,    141,      0,      0/
    150,      3,    .23200,     15,    -16,    140,      0,      0/
    150,      0,    .23300,     15,    -16,    241,    120,      0/
    150,      0,    .23350,     15,    -16,    141,    110,      0/
    150,      0,    .23450,     15,    -16,    240,    120,      0/
    150,      0,    .23500,     15,    -16,    140,    110,      0/
    150,      0,    .24000,     11,    -12,  -2140,   1120,      0/
    150,      0,    .24500,     13,    -14,  -2140,   1120,      0/
    150,      0,    .25440,   -340,    140,      0,      0,      0/
    150,      0,    .26340,   -340,    141,      0,      0,      0/
    150,      0,    .27280,   -341,    140,      0,      0,      0/
    150,      0,    .29020,   -341,    141,      0,      0,      0/
    150,      0,    .30020,   -340,    240,    120,      0,      0/
    150,      0,    .30520,   -340,    140,    110,      0,      0/
    150,      0,    .31520,   -341,    240,    120,      0,      0/
    150,      0,    .32020,   -341,    140,    110,      0,      0/
    150,      0,    .32570,   -340,    240,    120,    110,      0/
    150,      0,    .33120,   -340,    140,    120,   -120,      0/
    150,      0,    .33260,   -340,    140,    110,    110,      0/
    150,      0,    .33810,   -341,    240,    120,    110,      0/
    150,      0,    .34360,   -341,    140,    120,   -120,      0/
    150,      0,    .34500,   -341,    140,    110,    110,      0/
    150,      0,    .34600,   -240,    140,      0,      0,      0/
    150,      0,    .34700,   -240,    141,      0,      0,      0/
    150,      0,    .34800,   -241,    140,      0,      0,      0/
    150,      0,    .34900,   -241,    141,      0,      0,      0/
    150,      0,    .34940,   -240,    240,    120,      0,      0/
    150,      0,    .34960,   -240,    140,    110,      0,      0/
    150,      0,    .35000,   -241,    240,    120,      0,      0/
    150,      0,    .35020,   -241,    140,    110,      0,      0/
    150,      0,    .35050,   -240,    240,    120,    110,      0/
    150,      0,    .35070,   -240,    140,    110,    110,      0/
    150,      0,    .35100,   -240,    140,    120,   -120,      0/
    150,      0,    .36350,    111,    131,    111,    141,      0/
    150,      0,    .37600,    111,    131,    121,    241,      0/
    150,      0,    .38850,    121,    231,    111,    141,      0/
    150,      0,    .40100,    121,    231,    121,    241,      0/
    150,      0,    .42850,  -2140,   1120,    121,    111,      0/
    150,      0,    .45600,  -2140,   1120,    121,    221,      0/
    150,      0,    .45850,  -2140,   1120,    111,    131,      0/
    150,      0,    .46100,  -2140,   1120,    121,    231,      0/
    150,      0,    .46190,    441,    130,      0,      0,      0/
    150,      0,    .46350,    441,    131,      0,      0,      0/
    150,      0,    .46450,    441,    230,    120,      0,      0/
    150,      0,    .46500,    441,    130,    110,      0,      0/
    150,      0,    .46640,    441,    130,   -120,    120,      0/
    150,      0,    .46710,    441,    230,    110,    120,      0/
    150,      0,    .46780,    441,    130,    110,    110,      0/
    150,      0,    .46920,    441,    111,    131,      0,      0/
    150,      0,    .47060,    441,    121,    231,      0,      0/
    150,      0,    .47130,  10441,    130,      0,      0,      0/
    150,      0,    .47280,  10441,    131,      0,      0,      0/
    150,      0,    .47310,  10441,    230,    120,      0,      0/
    150,      0,    .47330,  10441,    130,    110,      0,      0/
    150,      0,    .47370,  10441,    130,   -120,    120,      0/
    150,      0,    .47390,  10441,    230,    110,    120,      0/
    150,      0,    .47410,  10441,    130,    110,    110,      0/
    150,      0,    .47510,  20440,    130,      0,      0,      0/
    150,      0,    .47660,  20440,    131,      0,      0,      0/
    150,      0,    .47690,  20440,    230,    120,      0,      0/
    150,      0,    .47710,  20440,    130,    110,      0,      0/
    150,      0,    .47740,  20440,    130,   -120,    120,      0/
    150,      0,    .47760,  20440,    230,    110,    120,      0/
    150,      0,    .47780,  20440,    130,    110,    110,      0/
    150,      0,    .47880,  20441,    130,      0,      0,      0/
    150,      0,    .48030,  20441,    131,      0,      0,      0/
    150,      0,    .48060,  20441,    230,    120,      0,      0/
    150,      0,    .48080,  20441,    130,    110,      0,      0/
    150,      0,    .48110,  20441,    130,   -120,    120,      0/
    150,      0,    .48130,  20441,    230,    110,    120,      0/
    150,      0,    .48150,  20441,    130,    110,    110,      0/
    150,      0,    .48200,  20442,    130,      0,      0,      0/
    150,      0,    .48300,  20442,    131,      0,      0,      0/
    150,      0,    .48320,  20442,    230,    120,      0,      0/
    150,      0,    .48330,  20442,    130,    110,      0,      0/
    150,      0,    .48360,  20442,    130,   -120,    120,      0/
    150,      0,    .48380,  20442,    230,    110,    120,      0/
    150,      0,    .48400,  20442,    130,    110,    110,      0/
    150,      0,    .48420,    440,    130,      0,      0,      0/
    150,      0,    .48470,    440,    131,      0,      0,      0/
    150,      0,    .48480,    440,    230,    120,      0,      0/
    150,      0,    .48490,    440,    130,    110,      0,      0/
    150,      0,    .48500,    440,    130,   -120,    120,      0/
    150,      0,    .48510,    440,    230,    110,    120,      0/
    150,      0,    .48520,    440,    130,    110,    110,      0/
    150,      0,    .49020,    141,    120,      0,      0,      0/
    150,      0,    .49500,    140,    120,      0,      0,      0/
    150,      0,    .50820,    140,    121,      0,      0,      0/
    150,      0,    .52290,    141,    121,      0,      0,      0/
    150,      0,    .52340,    240,    120,    120,      0,      0/
    150,      0,    .52390,    140,    110,    120,      0,      0/
    150,      0,    .52440,    241,    120,    120,      0,      0/
    150,      0,    .52490,    141,    110,    120,      0,      0/
    150,      0,    .52910,    140,  10121,      0,      0,      0/
    150,      0,    .53320,    140,    111,    120,      0,      0/
    150,      0,    .53730,    140,   -120,    120,    120,      0/
    150,      0,    .55560,    141,  10121,      0,      0,      0/
    150,      0,    .55610,    141,    111,    120,      0,      0/
    150,      0,    .55660,    141,   -120,    120,    120,      0/
    150,      0,    .55860,    240,    121,    120,      0,      0/
    150,      0,    .56060,    240,    110,    120,    120,      0/
    150,      0,    .56260,    241,    121,    120,      0,      0/
    150,      0,    .56460,    241,    110,    120,    120,      0/
    150,      0,    .56510,    141,    121,    110,      0,      0/
    150,      0,    .56560,    141,    121,    110,    110,      0/
    150,      0,    .67400,    111,    121,    111,    141,      0/
    150,      0,    .78240,    111,    121,    121,    241,      0/
    150,      0,    .89080,    221,    121,    111,    141,      0/
    150,      0,   1.00000,    221,    121,    121,    241,      0/
    250,      3,    .01150,     11,    -12,    241,      0,      0/
    250,      3,    .02300,     11,    -12,    241,      0,      0/
    250,      3,    .04900,     11,    -12,    241,      0,      0/
    250,      3,    .06700,     11,    -12,    240,      0,      0/
    250,      0,    .07930,     11,    -12,    240,    110,      0/
    250,      0,    .10400,     11,    -12,    140,   -120,      0/
    250,      3,    .11550,     13,    -14,    241,      0,      0/
    250,      3,    .12700,     13,    -14,    241,      0,      0/
    250,      3,    .15300,     13,    -14,    241,      0,      0/
    250,      3,    .17100,     13,    -14,    240,      0,      0/
    250,      0,    .18330,     13,    -14,    240,    110,      0/
    250,      0,    .20800,     13,    -14,    140,   -120,      0/
    250,      3,    .22400,     15,    -16,    241,      0,      0/
    250,      3,    .23200,     15,    -16,    240,      0,      0/
    250,      0,    .23300,     15,    -16,    141,   -120,      0/
    250,      0,    .23350,     15,    -16,    241,    110,      0/
    250,      0,    .23450,     15,    -16,    140,   -120,      0/
    250,      0,    .23500,     15,    -16,    240,    110,      0/
    250,      0,    .24000,     11,    -12,  -2140,   1220,      0/
    250,      0,    .24500,     13,    -14,  -2140,   1220,      0/
    250,      0,    .25440,   -340,    240,      0,      0,      0/
    250,      0,    .26340,   -340,    241,      0,      0,      0/
    250,      0,    .27280,   -341,    240,      0,      0,      0/
    250,      0,    .29020,   -341,    241,      0,      0,      0/
    250,      0,    .29520,   -340,    240,    110,      0,      0/
    250,      0,    .30520,   -340,    140,   -120,      0,      0/
    250,      0,    .31020,   -341,    240,    110,      0,      0/
    250,      0,    .32020,   -341,    140,   -120,      0,      0/
    250,      0,    .32520,   -340,    240,    120,   -120,      0/
    250,      0,    .32890,   -340,    240,    110,    110,      0/
    250,      0,    .33260,   -340,    140,   -120,    110,      0/
    250,      0,    .33760,   -341,    240,    120,   -120,      0/
    250,      0,    .34130,   -341,    240,    110,    110,      0/
    250,      0,    .34500,   -341,    140,   -120,    110,      0/
    250,      0,    .34600,   -240,    240,      0,      0,      0/
    250,      0,    .34700,   -240,    241,      0,      0,      0/
    250,      0,    .34800,   -241,    240,      0,      0,      0/
    250,      0,    .34900,   -241,    241,      0,      0,      0/
    250,      0,    .34920,   -240,    240,    110,      0,      0/
    250,      0,    .34960,   -240,    140,   -120,      0,      0/
    250,      0,    .34980,   -241,    240,    110,      0,      0/
    250,      0,    .35020,   -241,    140,   -120,      0,      0/
    250,      0,    .35040,   -240,    240,    110,    110,      0/
    250,      0,    .35070,   -240,    240,   -120,    120,      0/
    250,      0,    .35100,   -240,    140,   -120,    110,      0/
    250,      0,    .36350,    111,    131,   -121,    141,      0/
    250,      0,    .37600,    111,    131,    111,    241,      0/
    250,      0,    .38850,    121,    231,   -121,   -141,      0/
    250,      0,    .40100,    121,    231,    111,    241,      0/
    250,      0,    .42850,  -2140,   1220,    111,    121,      0/
    250,      0,    .45600,  -2140,   1220,    221,    121,      0/
    250,      0,    .45850,  -2140,   1220,    111,    131,      0/
    250,      0,    .46350,  -2140,   1220,    121,    231,      0/
    250,      0,    .46440,    441,    230,      0,      0,      0/
    250,      0,    .46600,    441,    231,      0,      0,      0/
    250,      0,    .46700,    441,    130,   -120,      0,      0/
    250,      0,    .46750,    441,    230,    110,      0,      0/
    250,      0,    .46920,    441,    230,   -120,    120,      0/
    250,      0,    .46990,    441,    230,    110,    110,      0/
    250,      0,    .47060,    441,    130,   -120,    110,      0/
    250,      0,    .47130,    441,   -121,    131,      0,      0/
    250,      0,    .47270,    441,    111,    231,      0,      0/
    250,      0,    .47340,  10441,    230,      0,      0,      0/
    250,      0,    .47490,  10441,    231,      0,      0,      0/
    250,      0,    .47520,  10441,    130,   -120,      0,      0/
    250,      0,    .47540,  10441,    230,    110,      0,      0/
    250,      0,    .47580,  10441,    230,   -120,    120,      0/
    250,      0,    .47600,  10441,    230,    110,    110,      0/
    250,      0,    .47620,  10441,    130,   -120,    110,      0/
    250,      0,    .47720,  20440,    230,      0,      0,      0/
    250,      0,    .47870,  20440,    231,      0,      0,      0/
    250,      0,    .47900,  20440,    130,   -120,      0,      0/
    250,      0,    .47920,  20440,    230,    110,      0,      0/
    250,      0,    .47950,  20440,    230,   -120,    120,      0/
    250,      0,    .47970,  20440,    230,    110,    110,      0/
    250,      0,    .47990,  20440,    130,   -120,    110,      0/
    250,      0,    .48090,  20441,    230,      0,      0,      0/
    250,      0,    .48240,  20441,    231,      0,      0,      0/
    250,      0,    .48270,  20441,    130,   -120,      0,      0/
    250,      0,    .48290,  20441,    230,    110,      0,      0/
    250,      0,    .48320,  20441,    230,   -120,    120,      0/
    250,      0,    .48340,  20441,    230,    110,    110,      0/
    250,      0,    .48360,  20441,    130,   -120,    110,      0/
    250,      0,    .48410,  20442,    230,      0,      0,      0/
    250,      0,    .48510,  20442,    231,      0,      0,      0/
    250,      0,    .48530,  20442,    130,   -120,      0,      0/
    250,      0,    .48540,  20442,    230,    110,      0,      0/
    250,      0,    .48570,  20442,    230,   -120,    120,      0/
    250,      0,    .48590,  20442,    230,    110,    110,      0/
    250,      0,    .48610,  20442,    130,   -120,    110,      0/
    250,      0,    .48630,    440,    230,      0,      0,      0/
    250,      0,    .48680,    440,    231,      0,      0,      0/
    250,      0,    .48690,    440,    130,   -120,      0,      0/
    250,      0,    .48700,    440,    230,    110,      0,      0/
    250,      0,    .48710,    440,    230,   -120,    120,      0/
    250,      0,    .48720,    440,    230,    110,    110,      0/
    250,      0,    .48730,    440,    130,   -120,    110,      0/
    250,      0,    .49000,    241,    120,      0,      0,      0/
    250,      0,    .49300,    240,    120,      0,      0,      0/
    250,      0,    .50120,    240,    121,      0,      0,      0/
    250,      0,    .50820,    241,    121,      0,      0,      0/
    250,      0,    .50830,    141,    110,      0,      0,      0/
    250,      0,    .50840,    140,    110,      0,      0,      0/
    250,      0,    .50850,    140,    111,      0,      0,      0/
    250,      0,    .50860,    141,    111,      0,      0,      0/
    250,      0,    .50960,    240,    120,    110,      0,      0/
    250,      0,    .51660,    241,    120,    110,      0,      0/
    250,      0,    .51760,    140,    120,   -120,      0,      0/
    250,      0,    .51810,    140,    110,    110,      0,      0/
    250,      0,    .51910,    141,    120,   -120,      0,      0/
    250,      0,    .51960,    141,    110,    110,      0,      0/
    250,      0,    .52560,    240,  10121,      0,      0,      0/
    250,      0,    .52670,    240,    111,    120,      0,      0/
    250,      0,    .52780,    240,    121,    110,      0,      0/
    250,      0,    .52880,    240,   -120,    120,    120,      0/
    250,      0,    .52980,    240,    110,    120,    110,      0/
    250,      0,    .53080,    140,   -120,    120,    110,      0/
    250,      0,    .53090,    140,    110,    110,    110,      0/
    250,      0,    .54310,    241,  10121,      0,      0,      0/
    250,      0,    .54410,    241,    111,    120,      0,      0/
    250,      0,    .54510,    241,    121,    110,      0,      0/
    250,      0,    .55280,    241,   -120,    120,    120,      0/
    250,      0,    .55380,    241,    110,    120,    110,      0/
    250,      0,    .55480,    141,   -120,    120,    110,      0/
    250,      0,    .55490,    141,    110,    110,    110,      0/
    250,      0,    .66340,    111,    121,   -121,    141,      0/
    250,      0,    .77190,    111,    121,    111,    241,      0/
    250,      0,    .88040,    221,    121,   -121,    141,      0/
    250,      0,    .98890,    221,    121,    111,    241,      0/
    250,      0,    .99250,   -121,    121,    111,    141,      0/
    250,      0,    .99610,   -121,    121,    121,    241,      0/
    250,      0,    .99970,    111,    111,    111,    141,      0/
    250,      0,   1.00000,    111,    111,    121,    241,      0/
    350,      3,    .04600,     11,    -12,    341,      0,      0/
    350,      3,    .06400,     11,    -12,    340,      0,      0/
    350,      0,    .07520,     11,    -12,    240,   -230,      0/
    350,      0,    .08640,     11,    -12,    140,   -130,      0/
    350,      3,    .13240,     13,    -14,    341,      0,      0/
    350,      3,    .15040,     13,    -14,    340,      0,      0/
    350,      0,    .16160,     13,    -14,    240,   -230,      0/
    350,      0,    .17280,     13,    -14,    140,   -130,      0/
    350,      0,    .18030,     15,    -16,   -130,    140,      0/
    350,      0,    .18780,     15,    -16,   -230,    240,      0/
    350,      0,    .19500,     11,    -12,  -2140,   2130,      0/
    350,      0,    .20220,     13,    -14,  -2140,   2130,      0/
    350,      0,    .21720,   -340,    340,      0,      0,      0/
    350,      0,    .23220,   -340,    341,      0,      0,      0/
    350,      0,    .24720,   -341,    340,      0,      0,      0/
    350,      0,    .26220,   -341,    341,      0,      0,      0/
    350,      0,    .26720,    340,   -140,    130,      0,      0/
    350,      0,    .27220,    340,   -240,    230,      0,      0/
    350,      0,    .27720,   -340,    140,   -130,      0,      0/
    350,      0,    .28220,   -340,    240,   -230,      0,      0/
    350,      0,    .28470,    341,   -140,    130,      0,      0/
    350,      0,    .28720,    341,   -240,    230,      0,      0/
    350,      0,    .28970,   -341,    140,   -130,      0,      0/
    350,      0,    .29220,   -341,    240,   -230,      0,      0/
    350,      0,    .29470,    340,   -141,    130,      0,      0/
    350,      0,    .29720,    340,   -241,    230,      0,      0/
    350,      0,    .29970,   -340,    141,   -130,      0,      0/
    350,      0,    .30220,   -340,    241,   -230,      0,      0/
    350,      0,    .30420,    340,   -240,      0,      0,      0/
    350,      0,    .30620,    341,   -240,      0,      0,      0/
    350,      0,    .30820,    340,   -241,      0,      0,      0/
    350,      0,    .31020,    341,   -241,      0,      0,      0/
    350,      0,    .31170,    340,   -240,    110,      0,      0/
    350,      0,    .31320,    340,   -140,    120,      0,      0/
    350,      0,    .31470,    341,   -240,    110,      0,      0/
    350,      0,    .31620,    341,   -140,    120,      0,      0/
    350,      0,    .32870,    111,    131,   -131,    141,      0/
    350,      0,    .34120,    111,    131,   -231,    241,      0/
    350,      0,    .35370,    121,    231,   -131,    141,      0/
    350,      0,    .36620,    121,    231,   -231,    241,      0/
    350,      0,    .39370,  -2140,   2130,    111,    121,      0/
    350,      0,    .42120,  -2140,   2130,    221,    121,      0/
    350,      0,    .42370,  -2140,   2130,    111,    131,      0/
    350,      0,    .42620,  -2140,   2130,    121,    231,      0/
    350,      0,    .42760,    441,    331,      0,      0,      0/
    350,      0,    .42810,    441,    220,      0,      0,      0/
    350,      0,    .42910,    441,    330,      0,      0,      0/
    350,      0,    .42950,    441,  10110,      0,      0,      0/
    350,      0,    .42990,    441,    112,      0,      0,      0/
    350,      0,    .43030,    441,    331,    120,   -120,      0/
    350,      0,    .43070,    441,    331,    110,    110,      0/
    350,      0,    .43090,    441,    220,    120,   -120,      0/
    350,      0,    .43110,    441,    220,    110,    110,      0/
    350,      0,    .43150,    441,    330,    120,   -120,      0/
    350,      0,    .43190,    441,    330,    110,    110,      0/
    350,      0,    .43230,    441,    130,   -130,      0,      0/
    350,      0,    .43270,    441,    230,   -230,      0,      0/
    350,      0,    .43290,    441,    120,   -120,      0,      0/
    350,      0,    .43310,    441,    110,    110,      0,      0/
    350,      0,    .43450,  10441,    331,      0,      0,      0/
    350,      0,    .43500,  10441,    220,      0,      0,      0/
    350,      0,    .43600,  10441,    330,      0,      0,      0/
    350,      0,    .43640,  10441,  10110,      0,      0,      0/
    350,      0,    .43680,  10441,    112,      0,      0,      0/
    350,      0,    .43720,  10441,    331,    120,   -120,      0/
    350,      0,    .43760,  10441,    331,    110,    110,      0/
    350,      0,    .43780,  10441,    220,    120,   -120,      0/
    350,      0,    .43800,  10441,    220,    110,    110,      0/
    350,      0,    .43840,  10441,    330,    120,   -120,      0/
    350,      0,    .43880,  10441,    330,    110,    110,      0/
    350,      0,    .43920,  10441,    130,   -130,      0,      0/
    350,      0,    .43960,  10441,    230,   -230,      0,      0/
    350,      0,    .43980,  10441,    120,   -120,      0,      0/
    350,      0,    .44000,  10441,    110,    110,      0,      0/
    350,      0,    .44070,  20441,    331,      0,      0,      0/
    350,      0,    .44100,  20441,    220,      0,      0,      0/
    350,      0,    .44150,  20441,    330,      0,      0,      0/
    350,      0,    .44170,  20441,  10110,      0,      0,      0/
    350,      0,    .44190,  20441,    331,    120,   -120,      0/
    350,      0,    .44210,  20441,    331,    110,    110,      0/
    350,      0,    .44220,  20441,    220,    120,   -120,      0/
    350,      0,    .44230,  20441,    220,    110,    110,      0/
    350,      0,    .44250,  20441,    330,    120,   -120,      0/
    350,      0,    .44270,  20441,    330,    110,    110,      0/
    350,      0,    .44290,  20441,    130,   -130,      0,      0/
    350,      0,    .44310,  20441,    230,   -230,      0,      0/
    350,      0,    .44380,    440,    331,      0,      0,      0/
    350,      0,    .44410,    440,    220,      0,      0,      0/
    350,      0,    .44460,    440,    330,      0,      0,      0/
    350,      0,    .44480,    440,  10110,      0,      0,      0/
    350,      0,    .44500,    440,    331,    120,   -120,      0/
    350,      0,    .44520,    440,    331,    110,    110,      0/
    350,      0,    .44530,    440,    220,    120,   -120,      0/
    350,      0,    .44540,    440,    220,    110,    110,      0/
    350,      0,    .44560,    440,    330,    120,   -120,      0/
    350,      0,    .44580,    440,    330,    110,    110,      0/
    350,      0,    .44600,    440,    130,   -130,      0,      0/
    350,      0,    .44620,    440,    230,   -230,      0,      0/
    350,      0,    .45120,    341,    120,      0,      0,      0/
    350,      0,    .45500,    340,    120,      0,      0,      0/
    350,      0,    .46800,    340,    121,      0,      0,      0/
    350,      0,    .47800,    341,    121,      0,      0,      0/
    350,      0,    .48000,    340,    120,    110,      0,      0/
    350,      0,    .48200,    341,    120,    110,      0,      0/
    350,      0,    .48400,    240,   -230,    120,      0,      0/
    350,      0,    .48600,    241,   -230,    120,      0,      0/
    350,      0,    .48800,    140,   -130,    120,      0,      0/
    350,      0,    .49000,    141,   -130,    120,      0,      0/
    350,      0,    .49450,    340,  10121,      0,      0,      0/
    350,      0,    .49870,    340,    111,    120,      0,      0/
    350,      0,    .50290,    340,    121,    110,      0,      0/
    350,      0,    .50590,    340,   -120,    120,    120,      0/
    350,      0,    .50790,    340,    110,    110,    120,      0/
    350,      0,    .51240,    341,  10121,      0,      0,      0/
    350,      0,    .51660,    341,    111,    120,      0,      0/
    350,      0,    .52080,    341,    121,    110,      0,      0/
    350,      0,    .52380,    341,    120,    120,    120,      0/
    350,      0,    .52580,    341,    110,    110,    120,      0/
    350,      0,    .72580,    111,    121,   -131,    141,      0/
    350,      0,    .92580,    111,   -231,    241,      0,      0/
    350,      0,    .94440,   -131,    121,    111,    141,      0/
    350,      0,    .96300,   -131,    121,    121,    241,      0/
    350,      0,    .98160,   -231,    111,    111,    141,      0/
    350,      0,   1.00000,   -231,    111,    121,    241,      0/
    151,      0,   1.00000,    150,     10,      0,      0,      0/
    251,      0,   1.00000,    250,     10,      0,      0,      0/
    351,      0,   1.00000,    350,     10,      0,      0,      0/
   1230,      0,   1.00000,   2130,     10,      0,      0,      0/
   1111,      0,   1.00000,   1120,    120,      0,      0,      0/
   1121,      0,    .66670,   1120,    110,      0,      0,      0/
   1121,      0,   1.00000,   1220,    120,      0,      0,      0/
   1221,      0,    .66670,   1220,    110,      0,      0,      0/
   1221,      0,   1.00000,   1120,   -120,      0,      0,      0/
   2221,      0,   1.00000,   1220,   -120,      0,      0,      0/
   1131,      0,    .88000,   2130,    120,      0,      0,      0/
   1131,      0,    .94000,   1130,    110,      0,      0,      0/
   1131,      0,   1.00000,   1230,    120,      0,      0,      0/
   1231,      0,    .88000,   2130,    110,      0,      0,      0/
   1231,      0,    .94000,   1130,   -120,      0,      0,      0/
   1231,      0,   1.00000,   2230,    120,      0,      0,      0/
   2231,      0,    .88000,   2130,   -120,      0,      0,      0/
   2231,      0,    .94000,   1230,   -120,      0,      0,      0/
   2231,      0,   1.00000,   2230,    110,      0,      0,      0/
   1331,      0,    .66670,   2330,    120,      0,      0,      0/
   1331,      0,   1.00000,   1330,    110,      0,      0,      0/
   2331,      0,    .66670,   1330,   -120,      0,      0,      0/
   2331,      0,   1.00000,   2330,    110,      0,      0,      0/
   2140,      3,    .01500,     11,    -12,   2130,      0,      0/
   2140,      3,    .03000,     13,    -14,   2130,      0,      0/
   2140,      3,    .03500,     11,    -12,   1230,      0,      0/
   2140,      3,    .04000,     13,    -14,   1230,      0,      0/
   2140,      0,    .04500,     11,    -12,   1120,   -130,      0/
   2140,      0,    .05000,     13,    -14,   1120,   -130,      0/
   2140,      0,    .05500,     11,    -12,   1220,   -230,      0/
   2140,      0,    .06000,     13,    -14,   1220,   -230,      0/
   2140,      0,    .06250,     11,    -12,   1121,   -130,      0/
   2140,      0,    .06500,     13,    -14,   1121,   -130,      0/
   2140,      0,    .06750,     11,    -12,   1221,   -230,      0/
   2140,      0,    .07000,     13,    -14,   1221,   -230,      0/
   2140,      0,    .09870,   1120,   -130,    120,      0,      0/
   2140,      0,    .10730,   1120,   -231,      0,      0,      0/
   2140,      0,    .11590,   1111,   -130,      0,      0,      0/
   2140,      0,    .14060,   1120,   -230,    110,      0,      0/
   2140,      0,    .14490,   1121,   -230,      0,      0,      0/
   2140,      0,    .16590,   1120,   -230,      0,      0,      0/
   2140,      0,    .18390,   1120,   -230,    120,   -120,      0/
   2140,      0,    .19090,   2130,    120,      0,      0,      0/
   2140,      0,    .23390,   2130,    120,    110,      0,      0/
   2140,      0,    .26190,   2130,    120,   -120,    120,      0/
   2140,      0,    .27690,   2130,    120,    110,    110,      0/
   2140,      0,    .29090,   1230,    120,      0,      0,      0/
   2140,      0,    .34260,   1130,    120,   -120,      0,      0/
   2140,      0,    .35120,   1130,    331,      0,      0,      0/
   2140,      0,    .35720,   2330,    130,    120,      0,      0/
   2140,      0,    .54720,   1131,    221,      0,      0,      0/
   2140,      0,    .73720,   1231,    221,      0,      0,      0/
   2140,      0,    .76720,   2130,    130,   -230,      0,      0/
   2140,      0,    .81720,   1120,   -131,    120,      0,      0/
   2140,      0,    .86720,   1120,   -231,    110,      0,      0/
   2140,      0,    .88220,   1220,    110,    131,      0,      0/
   2140,      0,    .89720,   1220,    120,    231,      0,      0/
   2140,      0,    .93220,   1121,   -131,    120,      0,      0/
   2140,      0,    .96720,   1121,   -231,    110,      0,      0/
   2140,      0,   1.00000,   1221,   -231,    120,      0,      0/
   1140,      0,   1.00000,   2140,    120,      0,      0,      0/
   1240,      0,   1.00000,   2140,    110,      0,      0,      0/
   2240,      0,   1.00000,   2140,   -120,      0,      0,      0/
   1340,      3,    .03750,    -12,     11,   1330,      0,      0/
   1340,      3,    .07500,    -12,     11,   1331,      0,      0/
   1340,      3,    .11250,    -14,     13,   1330,      0,      0/
   1340,      3,    .15000,    -14,     13,   1331,      0,      0/
   1340,      0,    .19900,   1330,    120,      0,      0,      0/
   1340,      0,    .24800,   1231,   -230,      0,      0,      0/
   1340,      0,    .28800,   1330,    120,      0,      0,      0/
   1340,      0,    .32800,   1131,   -230,      0,      0,      0/
   1340,      0,    .36800,   1330,    121,      0,      0,      0/
   1340,      0,    .40800,   1130,   -230,      0,      0,      0/
   1340,      0,    .44800,   1330,    120,    110,      0,      0/
   1340,      0,    .48800,   2330,    120,    120,      0,      0/
   1340,      0,    .52800,   1130,   -130,    120,      0,      0/
   1340,      0,    .56800,   1130,   -230,    110,      0,      0/
   1340,      0,    .60800,   1230,   -230,    120,      0,      0/
   1340,      0,    .66400,   2130,   -230,    120,    110,      0/
   1340,      0,    .72000,   2130,   -130,    120,    120,      0/
   1340,      0,    .77600,   1130,   -230,    120,    120,      0/
   1340,      0,    .83200,   1130,   -230,    110,    110,      0/
   1340,      0,    .88800,   1330,    120,    120,   -120,      0/
   1340,      0,    .94400,   1330,    120,    110,    110,      0/
   1340,      0,   1.00000,   2330,    120,    120,    110,      0/
   3140,      3,    .03750,    -12,     11,   1330,      0,      0/
   3140,      3,    .07500,    -12,     11,   1331,      0,      0/
   3140,      3,    .11250,    -14,     13,   1330,      0,      0/
   3140,      3,    .15000,    -14,     13,   1331,      0,      0/
   3140,      0,    .19900,   1330,    120,      0,      0,      0/
   3140,      0,    .24800,   1231,   -230,      0,      0,      0/
   3140,      0,    .28800,   1330,    120,      0,      0,      0/
   3140,      0,    .32800,   1131,   -230,      0,      0,      0/
   3140,      0,    .36800,   1330,    121,      0,      0,      0/
   3140,      0,    .40800,   1130,   -230,      0,      0,      0/
   3140,      0,    .44800,   1330,    120,    110,      0,      0/
   3140,      0,    .48800,   2330,    120,    120,      0,      0/
   3140,      0,    .52800,   1130,   -130,    120,      0,      0/
   3140,      0,    .56800,   1130,   -230,    110,      0,      0/
   3140,      0,    .60800,   1230,   -230,    120,      0,      0/
   3140,      0,    .66400,   2130,   -230,    120,    110,      0/
   3140,      0,    .72000,   2130,   -130,    120,    120,      0/
   3140,      0,    .77600,   1130,   -230,    120,    120,      0/
   3140,      0,    .83200,   1130,   -230,    110,    110,      0/
   3140,      0,    .88800,   1330,    120,    120,   -120,      0/
   3140,      0,    .94400,   1330,    120,    110,    110,      0/
   3140,      0,   1.00000,   2330,    120,    120,    110,      0/
   2340,      3,    .03750,    -12,     11,   2330,      0,      0/
   2340,      3,    .07500,    -12,     11,   2331,      0,      0/
   2340,      3,    .11250,    -14,     13,   2330,      0,      0/
   2340,      3,    .15000,    -14,     13,   2331,      0,      0/
   2340,      0,    .17500,   2330,    120,      0,      0,      0/
   2340,      0,    .20000,   1330,    110,      0,      0,      0/
   2340,      0,    .22500,   1130,   -130,      0,      0,      0/
   2340,      0,    .25000,   1230,   -230,      0,      0,      0/
   2340,      0,    .29500,   2331,    120,      0,      0,      0/
   2340,      0,    .34000,   1331,    110,      0,      0,      0/
   2340,      0,    .38500,   1131,   -130,      0,      0,      0/
   2340,      0,    .43000,   1231,   -230,      0,      0,      0/
   2340,      0,    .47500,   2330,    121,      0,      0,      0/
   2340,      0,    .52000,   1330,    111,      0,      0,      0/
   2340,      0,    .56500,   1130,   -131,      0,      0,      0/
   2340,      0,    .61000,   1230,   -231,      0,      0,      0/
   2340,      0,    .64900,   2130,   -230,    120,   -120,      0/
   2340,      0,    .68800,   2130,   -230,    110,    110,      0/
   2340,      0,    .72700,   2130,   -130,    120,    110,      0/
   2340,      0,    .76600,   1130,   -230,   -120,    110,      0/
   2340,      0,    .80500,   1130,   -130,    120,   -120,      0/
   2340,      0,    .84400,   1130,   -130,    110,    110,      0/
   2340,      0,    .88300,   1330,    120,   -120,    110,      0/
   2340,      0,    .92200,   1330,    110,    110,    110,      0/
   2340,      0,    .96100,   2330,    120,    120,   -120,      0/
   2340,      0,   1.00000,   2330,    120,    110,    110,      0/
   3240,      3,    .03750,    -12,     11,   2330,      0,      0/
   3240,      3,    .07500,    -12,     11,   2331,      0,      0/
   3240,      3,    .11250,    -14,     13,   2330,      0,      0/
   3240,      3,    .15000,    -14,     13,   2331,      0,      0/
   3240,      0,    .17500,   2330,    120,      0,      0,      0/
   3240,      0,    .20000,   1330,    110,      0,      0,      0/
   3240,      0,    .22500,   1130,   -130,      0,      0,      0/
   3240,      0,    .25000,   1230,   -230,      0,      0,      0/
   3240,      0,    .29500,   2331,    120,      0,      0,      0/
   3240,      0,    .34000,   1331,    110,      0,      0,      0/
   3240,      0,    .38500,   1131,   -130,      0,      0,      0/
   3240,      0,    .43000,   1231,   -230,      0,      0,      0/
   3240,      0,    .47500,   2330,    121,      0,      0,      0/
   3240,      0,    .52000,   1330,    111,      0,      0,      0/
   3240,      0,    .56500,   1130,   -131,      0,      0,      0/
   3240,      0,    .61000,   1230,   -231,      0,      0,      0/
   3240,      0,    .64900,   2130,   -230,    120,   -120,      0/
   3240,      0,    .68800,   2130,   -230,    110,    110,      0/
   3240,      0,    .72700,   2130,   -130,    120,    110,      0/
   3240,      0,    .76600,   1130,   -230,   -120,    110,      0/
   3240,      0,    .80500,   1130,   -130,    120,   -120,      0/
   3240,      0,    .84400,   1130,   -130,    110,    110,      0/
   3240,      0,    .88300,   1330,    120,   -120,    110,      0/
   3240,      0,    .92200,   1330,    110,    110,    110,      0/
   3240,      0,    .96100,   2330,    120,    120,   -120,      0/
   3240,      0,   1.00000,   2330,    120,    110,    110,      0/
   3340,      3,    .07500,    -12,     11,   3331,      0,      0/
   3340,      3,    .15000,    -14,     13,   3331,      0,      0/
   3340,      0,    .25000,   1330,   -230,      0,      0,      0/
   3340,      0,    .31000,   3331,    120,      0,      0,      0/
   3340,      0,    .37000,   1331,   -230,      0,      0,      0/
   3340,      0,    .43000,   1330,   -231,      0,      0,      0/
   3340,      0,    .49000,   2330,   -230,    120,      0,      0/
   3340,      0,    .55000,   1330,   -230,    110,      0,      0/
   3340,      0,    .61000,   1330,   -130,    120,      0,      0/
   3340,      0,    .67500,   3331,    120,    120,   -120,      0/
   3340,      0,    .74000,   3331,    120,    110,    110,      0/
   3340,      0,    .80500,   1330,   -230,    120,   -120,      0/
   3340,      0,    .87000,   1330,   -230,    110,    110,      0/
   3340,      0,    .93500,   2330,   -230,    120,    110,      0/
   3340,      0,   1.00000,   2330,   -130,    120,    120,      0/
   1141,      0,   1.00000,   2140,    120,      0,      0,      0/
   1241,      0,   1.00000,   2140,    110,      0,      0,      0/
   2241,      0,   1.00000,   2140,   -120,      0,      0,      0/
   1341,      0,    .66670,   2340,    120,      0,      0,      0/
   1341,      0,   1.00000,   1340,    110,      0,      0,      0/
   2341,      0,    .66670,   1340,   -120,      0,      0,      0/
   2341,      0,   1.00000,   2340,    110,      0,      0,      0/
   3341,      0,   1.00000,   3340,    110,      0,      0,      0/
   1150,      3,    .06000,     12,    -11,   1140,      0,      0/
   1150,      3,    .12000,     12,    -11,   1141,      0,      0/
   1150,      3,    .18000,     14,    -13,   1140,      0,      0/
   1150,      3,    .24000,     14,    -13,   1141,      0,      0/
   1150,      3,    .25500,     16,    -15,   1140,      0,      0/
   1150,      3,    .27000,     16,    -15,   1141,      0,      0/
   1150,      0,    .28925,   1140,   -120,      0,      0,      0/
   1150,      0,    .30850,   1140,   -121,      0,      0,      0/
   1150,      0,    .32775,   1141,   -120,      0,      0,      0/
   1150,      0,    .34700,   1141,   -121,      0,      0,      0/
   1150,      0,    .35775,   1140,    340,      0,      0,      0/
   1150,      0,    .36850,   1140,    341,      0,      0,      0/
   1150,      0,    .37925,   1141,    340,      0,      0,      0/
   1150,      0,    .39000,   1141,    341,      0,      0,      0/
   1150,      0,    .42050,   1140,   -120,    110,      0,      0/
   1150,      0,    .45100,   1140,   -120,    220,      0,      0/
   1150,      0,    .48150,   1140,   -120,    111,      0,      0/
   1150,      0,    .51200,   1140,   -120,    221,      0,      0/
   1150,      0,    .54250,   1140,   -121,    110,      0,      0/
   1150,      0,    .57300,   1140,   -121,    220,      0,      0/
   1150,      0,    .60350,   1140,   -121,    111,      0,      0/
   1150,      0,    .63400,   1140,   -121,    221,      0,      0/
   1150,      0,    .66450,   1141,   -120,    110,      0,      0/
   1150,      0,    .69500,   1141,   -120,    220,      0,      0/
   1150,      0,    .72550,   1141,   -120,    111,      0,      0/
   1150,      0,    .75600,   1141,   -120,    221,      0,      0/
   1150,      0,    .78650,   1141,   -121,    110,      0,      0/
   1150,      0,    .81700,   1141,   -121,    220,      0,      0/
   1150,      0,    .84750,   1141,   -121,    111,      0,      0/
   1150,      0,    .87800,   1141,   -121,    221,      0,      0/
   1150,      0,    .89325,   1140,   -130,    230,      0,      0/
   1150,      0,    .90850,   1140,   -130,    231,      0,      0/
   1150,      0,    .92375,   1140,   -131,    230,      0,      0/
   1150,      0,    .93900,   1140,   -131,    231,      0,      0/
   1150,      0,    .95425,   1141,   -130,    230,      0,      0/
   1150,      0,    .96950,   1141,   -130,    231,      0,      0/
   1150,      0,    .98475,   1141,   -131,    230,      0,      0/
   1150,      0,   1.00000,   1141,   -131,    231,      0,      0/
   1250,      3,    .06000,     12,    -11,   1240,      0,      0/
   1250,      3,    .12000,     12,    -11,   1241,      0,      0/
   1250,      3,    .18000,     14,    -13,   1240,      0,      0/
   1250,      3,    .24000,     14,    -13,   1241,      0,      0/
   1250,      3,    .25500,     16,    -15,   1240,      0,      0/
   1250,      3,    .27000,     16,    -15,   1241,      0,      0/
   1250,      0,    .28925,   1240,   -120,      0,      0,      0/
   1250,      0,    .30850,   1240,   -121,      0,      0,      0/
   1250,      0,    .32775,   1241,   -120,      0,      0,      0/
   1250,      0,    .34700,   1241,   -121,      0,      0,      0/
   1250,      0,    .35775,   1240,    340,      0,      0,      0/
   1250,      0,    .36850,   1240,    341,      0,      0,      0/
   1250,      0,    .37925,   1241,    340,      0,      0,      0/
   1250,      0,    .39000,   1241,    341,      0,      0,      0/
   1250,      0,    .42050,   1240,   -120,    110,      0,      0/
   1250,      0,    .45100,   1240,   -120,    220,      0,      0/
   1250,      0,    .48150,   1240,   -120,    111,      0,      0/
   1250,      0,    .51200,   1240,   -120,    221,      0,      0/
   1250,      0,    .54250,   1240,   -121,    110,      0,      0/
   1250,      0,    .57300,   1240,   -121,    220,      0,      0/
   1250,      0,    .60350,   1240,   -121,    111,      0,      0/
   1250,      0,    .63400,   1240,   -121,    221,      0,      0/
   1250,      0,    .66450,   1241,   -120,    110,      0,      0/
   1250,      0,    .69500,   1241,   -120,    220,      0,      0/
   1250,      0,    .72550,   1241,   -120,    111,      0,      0/
   1250,      0,    .75600,   1241,   -120,    221,      0,      0/
   1250,      0,    .78650,   1241,   -121,    110,      0,      0/
   1250,      0,    .81700,   1241,   -121,    220,      0,      0/
   1250,      0,    .84750,   1241,   -121,    111,      0,      0/
   1250,      0,    .87800,   1241,   -121,    221,      0,      0/
   1250,      0,    .89325,   1240,   -130,    230,      0,      0/
   1250,      0,    .90850,   1240,   -130,    231,      0,      0/
   1250,      0,    .92375,   1240,   -131,    230,      0,      0/
   1250,      0,    .93900,   1240,   -131,    231,      0,      0/
   1250,      0,    .95425,   1241,   -130,    230,      0,      0/
   1250,      0,    .96950,   1241,   -130,    231,      0,      0/
   1250,      0,    .98475,   1241,   -131,    230,      0,      0/
   1250,      0,   1.00000,   1241,   -131,    231,      0,      0/
   1350,      3,    .06000,     12,    -11,   1340,      0,      0/
   1350,      3,    .12000,     12,    -11,   1341,      0,      0/
   1350,      3,    .18000,     14,    -13,   1340,      0,      0/
   1350,      3,    .24000,     14,    -13,   1341,      0,      0/
   1350,      3,    .25500,     16,    -15,   1340,      0,      0/
   1350,      3,    .27000,     16,    -15,   1341,      0,      0/
   1350,      0,    .28925,   1340,   -120,      0,      0,      0/
   1350,      0,    .30850,   1340,   -121,      0,      0,      0/
   1350,      0,    .32775,   1341,   -120,      0,      0,      0/
   1350,      0,    .34700,   1341,   -121,      0,      0,      0/
   1350,      0,    .35775,   1340,    340,      0,      0,      0/
   1350,      0,    .36850,   1340,    341,      0,      0,      0/
   1350,      0,    .37925,   1341,    340,      0,      0,      0/
   1350,      0,    .39000,   1341,    341,      0,      0,      0/
   1350,      0,    .42050,   1340,   -120,    110,      0,      0/
   1350,      0,    .45100,   1340,   -120,    220,      0,      0/
   1350,      0,    .48150,   1340,   -120,    111,      0,      0/
   1350,      0,    .51200,   1340,   -120,    221,      0,      0/
   1350,      0,    .54250,   1340,   -121,    110,      0,      0/
   1350,      0,    .57300,   1340,   -121,    220,      0,      0/
   1350,      0,    .60350,   1340,   -121,    111,      0,      0/
   1350,      0,    .63400,   1340,   -121,    221,      0,      0/
   1350,      0,    .66450,   1341,   -120,    110,      0,      0/
   1350,      0,    .69500,   1341,   -120,    220,      0,      0/
   1350,      0,    .72550,   1341,   -120,    111,      0,      0/
   1350,      0,    .75600,   1341,   -120,    221,      0,      0/
   1350,      0,    .78650,   1341,   -121,    110,      0,      0/
   1350,      0,    .81700,   1341,   -121,    220,      0,      0/
   1350,      0,    .84750,   1341,   -121,    111,      0,      0/
   1350,      0,    .87800,   1341,   -121,    221,      0,      0/
   1350,      0,    .89325,   1340,   -130,    230,      0,      0/
   1350,      0,    .90850,   1340,   -130,    231,      0,      0/
   1350,      0,    .92375,   1340,   -131,    230,      0,      0/
   1350,      0,    .93900,   1340,   -131,    231,      0,      0/
   1350,      0,    .95425,   1341,   -130,    230,      0,      0/
   1350,      0,    .96950,   1341,   -130,    231,      0,      0/
   1350,      0,    .98475,   1341,   -131,    230,      0,      0/
   1350,      0,   1.00000,   1341,   -131,    231,      0,      0/
   2150,      3,    .06000,     12,    -11,   2140,      0,      0/
   2150,      3,    .12000,     12,    -11,   1241,      0,      0/
   2150,      3,    .18000,     14,    -13,   2140,      0,      0/
   2150,      3,    .24000,     14,    -13,   1241,      0,      0/
   2150,      3,    .25500,     16,    -15,   2140,      0,      0/
   2150,      3,    .27000,     16,    -15,   1241,      0,      0/
   2150,      0,    .28925,   2140,   -120,      0,      0,      0/
   2150,      0,    .30850,   2140,   -121,      0,      0,      0/
   2150,      0,    .32775,   1241,   -120,      0,      0,      0/
   2150,      0,    .34700,   1241,   -121,      0,      0,      0/
   2150,      0,    .35775,   2140,    340,      0,      0,      0/
   2150,      0,    .36850,   2140,    341,      0,      0,      0/
   2150,      0,    .37925,   1241,    340,      0,      0,      0/
   2150,      0,    .39000,   1241,    341,      0,      0,      0/
   2150,      0,    .42050,   2140,   -120,    110,      0,      0/
   2150,      0,    .45100,   2140,   -120,    220,      0,      0/
   2150,      0,    .48150,   2140,   -120,    111,      0,      0/
   2150,      0,    .51200,   2140,   -120,    221,      0,      0/
   2150,      0,    .54250,   2140,   -121,    110,      0,      0/
   2150,      0,    .57300,   2140,   -121,    220,      0,      0/
   2150,      0,    .60350,   2140,   -121,    111,      0,      0/
   2150,      0,    .63400,   2140,   -121,    221,      0,      0/
   2150,      0,    .66450,   1241,   -120,    110,      0,      0/
   2150,      0,    .69500,   1241,   -120,    220,      0,      0/
   2150,      0,    .72550,   1241,   -120,    111,      0,      0/
   2150,      0,    .75600,   1241,   -120,    221,      0,      0/
   2150,      0,    .78650,   1241,   -121,    110,      0,      0/
   2150,      0,    .81700,   1241,   -121,    220,      0,      0/
   2150,      0,    .84750,   1241,   -121,    111,      0,      0/
   2150,      0,    .87800,   1241,   -121,    221,      0,      0/
   2150,      0,    .89325,   2140,   -130,    230,      0,      0/
   2150,      0,    .90850,   2140,   -130,    231,      0,      0/
   2150,      0,    .92375,   2140,   -131,    230,      0,      0/
   2150,      0,    .93900,   2140,   -131,    231,      0,      0/
   2150,      0,    .95425,   1241,   -130,    230,      0,      0/
   2150,      0,    .96950,   1241,   -130,    231,      0,      0/
   2150,      0,    .98475,   1241,   -131,    230,      0,      0/
   2150,      0,   1.00000,   1241,   -131,    231,      0,      0/
   2250,      3,    .06000,     12,    -11,   2240,      0,      0/
   2250,      3,    .12000,     12,    -11,   2241,      0,      0/
   2250,      3,    .18000,     14,    -13,   2240,      0,      0/
   2250,      3,    .24000,     14,    -13,   2241,      0,      0/
   2250,      3,    .25500,     16,    -15,   2240,      0,      0/
   2250,      3,    .27000,     16,    -15,   2241,      0,      0/
   2250,      0,    .28925,   2240,   -120,      0,      0,      0/
   2250,      0,    .30850,   2240,   -121,      0,      0,      0/
   2250,      0,    .32775,   2241,   -120,      0,      0,      0/
   2250,      0,    .34700,   2241,   -121,      0,      0,      0/
   2250,      0,    .35775,   2240,    340,      0,      0,      0/
   2250,      0,    .36850,   2240,    341,      0,      0,      0/
   2250,      0,    .37925,   2241,    340,      0,      0,      0/
   2250,      0,    .39000,   2241,    341,      0,      0,      0/
   2250,      0,    .42050,   2240,   -120,    110,      0,      0/
   2250,      0,    .45100,   2240,   -120,    220,      0,      0/
   2250,      0,    .48150,   2240,   -120,    111,      0,      0/
   2250,      0,    .51200,   2240,   -120,    221,      0,      0/
   2250,      0,    .54250,   2240,   -121,    110,      0,      0/
   2250,      0,    .57300,   2240,   -121,    220,      0,      0/
   2250,      0,    .60350,   2240,   -121,    111,      0,      0/
   2250,      0,    .63400,   2240,   -121,    221,      0,      0/
   2250,      0,    .66450,   2241,   -120,    110,      0,      0/
   2250,      0,    .69500,   2241,   -120,    220,      0,      0/
   2250,      0,    .72550,   2241,   -120,    111,      0,      0/
   2250,      0,    .75600,   2241,   -120,    221,      0,      0/
   2250,      0,    .78650,   2241,   -121,    110,      0,      0/
   2250,      0,    .81700,   2241,   -121,    220,      0,      0/
   2250,      0,    .84750,   2241,   -121,    111,      0,      0/
   2250,      0,    .87800,   2241,   -121,    221,      0,      0/
   2250,      0,    .89325,   2240,   -130,    230,      0,      0/
   2250,      0,    .90850,   2240,   -130,    231,      0,      0/
   2250,      0,    .92375,   2240,   -131,    230,      0,      0/
   2250,      0,    .93900,   2240,   -131,    231,      0,      0/
   2250,      0,    .95425,   2241,   -130,    230,      0,      0/
   2250,      0,    .96950,   2241,   -130,    231,      0,      0/
   2250,      0,    .98475,   2241,   -131,    230,      0,      0/
   2250,      0,   1.00000,   2241,   -131,    231,      0,      0/
   2350,      3,    .06000,     12,    -11,   2340,      0,      0/
   2350,      3,    .12000,     12,    -11,   2341,      0,      0/
   2350,      3,    .18000,     14,    -13,   2340,      0,      0/
   2350,      3,    .24000,     14,    -13,   2341,      0,      0/
   2350,      3,    .25500,     16,    -15,   2340,      0,      0/
   2350,      3,    .27000,     16,    -15,   2341,      0,      0/
   2350,      0,    .28925,   2340,   -120,      0,      0,      0/
   2350,      0,    .30850,   2340,   -121,      0,      0,      0/
   2350,      0,    .32775,   2341,   -120,      0,      0,      0/
   2350,      0,    .34700,   2341,   -121,      0,      0,      0/
   2350,      0,    .35775,   2340,    340,      0,      0,      0/
   2350,      0,    .36850,   2340,    341,      0,      0,      0/
   2350,      0,    .37925,   2341,    340,      0,      0,      0/
   2350,      0,    .39000,   2341,    341,      0,      0,      0/
   2350,      0,    .42050,   2340,   -120,    110,      0,      0/
   2350,      0,    .45100,   2340,   -120,    220,      0,      0/
   2350,      0,    .48150,   2340,   -120,    111,      0,      0/
   2350,      0,    .51200,   2340,   -120,    221,      0,      0/
   2350,      0,    .54250,   2340,   -121,    110,      0,      0/
   2350,      0,    .57300,   2340,   -121,    220,      0,      0/
   2350,      0,    .60350,   2340,   -121,    111,      0,      0/
   2350,      0,    .63400,   2340,   -121,    221,      0,      0/
   2350,      0,    .66450,   2341,   -120,    110,      0,      0/
   2350,      0,    .69500,   2341,   -120,    220,      0,      0/
   2350,      0,    .72550,   2341,   -120,    111,      0,      0/
   2350,      0,    .75600,   2341,   -120,    221,      0,      0/
   2350,      0,    .78650,   2341,   -121,    110,      0,      0/
   2350,      0,    .81700,   2341,   -121,    220,      0,      0/
   2350,      0,    .84750,   2341,   -121,    111,      0,      0/
   2350,      0,    .87800,   2341,   -121,    221,      0,      0/
   2350,      0,    .89325,   2340,   -130,    230,      0,      0/
   2350,      0,    .90850,   2340,   -130,    231,      0,      0/
   2350,      0,    .92375,   2340,   -131,    230,      0,      0/
   2350,      0,    .93900,   2340,   -131,    231,      0,      0/
   2350,      0,    .95425,   2341,   -130,    230,      0,      0/
   2350,      0,    .96950,   2341,   -130,    231,      0,      0/
   2350,      0,    .98475,   2341,   -131,    230,      0,      0/
   2350,      0,   1.00000,   2341,   -131,    231,      0,      0/
   3150,      3,    .06000,     12,    -11,   3140,      0,      0/
   3150,      3,    .12000,     12,    -11,   1341,      0,      0/
   3150,      3,    .18000,     14,    -13,   3140,      0,      0/
   3150,      3,    .24000,     14,    -13,   1341,      0,      0/
   3150,      3,    .25500,     16,    -15,   3140,      0,      0/
   3150,      3,    .27000,     16,    -15,   1341,      0,      0/
   3150,      0,    .28925,   3140,   -120,      0,      0,      0/
   3150,      0,    .30850,   3140,   -121,      0,      0,      0/
   3150,      0,    .32775,   1341,   -120,      0,      0,      0/
   3150,      0,    .34700,   1341,   -121,      0,      0,      0/
   3150,      0,    .35775,   3140,    340,      0,      0,      0/
   3150,      0,    .36850,   3140,    341,      0,      0,      0/
   3150,      0,    .37925,   1341,    340,      0,      0,      0/
   3150,      0,    .39000,   1341,    341,      0,      0,      0/
   3150,      0,    .42050,   3140,   -120,    110,      0,      0/
   3150,      0,    .45100,   3140,   -120,    220,      0,      0/
   3150,      0,    .48150,   3140,   -120,    111,      0,      0/
   3150,      0,    .51200,   3140,   -120,    221,      0,      0/
   3150,      0,    .54250,   3140,   -121,    110,      0,      0/
   3150,      0,    .57300,   3140,   -121,    220,      0,      0/
   3150,      0,    .60350,   3140,   -121,    111,      0,      0/
   3150,      0,    .63400,   3140,   -121,    221,      0,      0/
   3150,      0,    .66450,   1341,   -120,    110,      0,      0/
   3150,      0,    .69500,   1341,   -120,    220,      0,      0/
   3150,      0,    .72550,   1341,   -120,    111,      0,      0/
   3150,      0,    .75600,   1341,   -120,    221,      0,      0/
   3150,      0,    .78650,   1341,   -121,    110,      0,      0/
   3150,      0,    .81700,   1341,   -121,    220,      0,      0/
   3150,      0,    .84750,   1341,   -121,    111,      0,      0/
   3150,      0,    .87800,   1341,   -121,    221,      0,      0/
   3150,      0,    .89325,   3140,   -130,    230,      0,      0/
   3150,      0,    .90850,   3140,   -130,    231,      0,      0/
   3150,      0,    .92375,   3140,   -131,    230,      0,      0/
   3150,      0,    .93900,   3140,   -131,    231,      0,      0/
   3150,      0,    .95425,   1341,   -130,    230,      0,      0/
   3150,      0,    .96950,   1341,   -130,    231,      0,      0/
   3150,      0,    .98475,   1341,   -131,    230,      0,      0/
   3150,      0,   1.00000,   1341,   -131,    231,      0,      0/
   3250,      0,    .06000,     12,    -11,   3240,      0,      0/
   3250,      0,    .12000,     12,    -11,   2341,      0,      0/
   3250,      0,    .18000,     14,    -13,   3240,      0,      0/
   3250,      0,    .24000,     14,    -13,   2341,      0,      0/
   3250,      0,    .25500,     16,    -15,   3240,      0,      0/
   3250,      0,    .27000,     16,    -15,   2341,      0,      0/
   3250,      0,    .28925,   3240,   -120,      0,      0,      0/
   3250,      0,    .30850,   3240,   -121,      0,      0,      0/
   3250,      0,    .32775,   2341,   -120,      0,      0,      0/
   3250,      0,    .34700,   2341,   -121,      0,      0,      0/
   3250,      0,    .35775,   3240,    340,      0,      0,      0/
   3250,      0,    .36850,   3240,    341,      0,      0,      0/
   3250,      0,    .37925,   2341,    340,      0,      0,      0/
   3250,      0,    .39000,   2341,    341,      0,      0,      0/
   3250,      0,    .42050,   3240,   -120,    110,      0,      0/
   3250,      0,    .45100,   3240,   -120,    220,      0,      0/
   3250,      0,    .48150,   3240,   -120,    111,      0,      0/
   3250,      0,    .51200,   3240,   -120,    221,      0,      0/
   3250,      0,    .54250,   3240,   -121,    110,      0,      0/
   3250,      0,    .57300,   3240,   -121,    220,      0,      0/
   3250,      0,    .60350,   3240,   -121,    111,      0,      0/
   3250,      0,    .63400,   3240,   -121,    221,      0,      0/
   3250,      0,    .66450,   2341,   -120,    110,      0,      0/
   3250,      0,    .69500,   2341,   -120,    220,      0,      0/
   3250,      0,    .72550,   2341,   -120,    111,      0,      0/
   3250,      0,    .75600,   2341,   -120,    221,      0,      0/
   3250,      0,    .78650,   2341,   -121,    110,      0,      0/
   3250,      0,    .81700,   2341,   -121,    220,      0,      0/
   3250,      0,    .84750,   2341,   -121,    111,      0,      0/
   3250,      0,    .87800,   2341,   -121,    221,      0,      0/
   3250,      0,    .89325,   3240,   -130,    230,      0,      0/
   3250,      0,    .90850,   3240,   -130,    231,      0,      0/
   3250,      0,    .92375,   3240,   -131,    230,      0,      0/
   3250,      0,    .93900,   3240,   -131,    231,      0,      0/
   3250,      0,    .95425,   2341,   -130,    230,      0,      0/
   3250,      0,    .96950,   2341,   -130,    231,      0,      0/
   3250,      0,    .98475,   2341,   -131,    230,      0,      0/
   3250,      0,   1.00000,   2341,   -131,    231,      0,      0/
   3350,      3,    .06000,     12,    -11,   3340,      0,      0/
   3350,      3,    .12000,     12,    -11,   3341,      0,      0/
   3350,      3,    .18000,     14,    -13,   3340,      0,      0/
   3350,      3,    .24000,     14,    -13,   3341,      0,      0/
   3350,      3,    .25500,     16,    -15,   3340,      0,      0/
   3350,      3,    .27000,     16,    -15,   3341,      0,      0/
   3350,      0,    .28925,   3340,   -120,      0,      0,      0/
   3350,      0,    .30850,   3340,   -121,      0,      0,      0/
   3350,      0,    .32775,   3341,   -120,      0,      0,      0/
   3350,      0,    .34700,   3341,   -121,      0,      0,      0/
   3350,      0,    .35775,   3340,    340,      0,      0,      0/
   3350,      0,    .36850,   3340,    341,      0,      0,      0/
   3350,      0,    .37925,   3341,    340,      0,      0,      0/
   3350,      0,    .39000,   3341,    341,      0,      0,      0/
   3350,      0,    .42050,   3340,   -120,    110,      0,      0/
   3350,      0,    .45100,   3340,   -120,    220,      0,      0/
   3350,      0,    .48150,   3340,   -120,    111,      0,      0/
   3350,      0,    .51200,   3340,   -120,    221,      0,      0/
   3350,      0,    .54250,   3340,   -121,    110,      0,      0/
   3350,      0,    .57300,   3340,   -121,    220,      0,      0/
   3350,      0,    .60350,   3340,   -121,    111,      0,      0/
   3350,      0,    .63400,   3340,   -121,    221,      0,      0/
   3350,      0,    .66450,   3341,   -120,    110,      0,      0/
   3350,      0,    .69500,   3341,   -120,    220,      0,      0/
   3350,      0,    .72550,   3341,   -120,    111,      0,      0/
   3350,      0,    .75600,   3341,   -120,    221,      0,      0/
   3350,      0,    .78650,   3341,   -121,    110,      0,      0/
   3350,      0,    .81700,   3341,   -121,    220,      0,      0/
   3350,      0,    .84750,   3341,   -121,    111,      0,      0/
   3350,      0,    .87800,   3341,   -121,    221,      0,      0/
   3350,      0,    .89325,   3340,   -130,    230,      0,      0/
   3350,      0,    .90850,   3340,   -130,    231,      0,      0/
   3350,      0,    .92375,   3340,   -131,    230,      0,      0/
   3350,      0,    .93900,   3340,   -131,    231,      0,      0/
   3350,      0,    .95425,   3341,   -130,    230,      0,      0/
   3350,      0,    .96950,   3341,   -130,    231,      0,      0/
   3350,      0,    .98475,   3341,   -131,    230,      0,      0/
   3350,      0,   1.00000,   3341,   -131,    231,      0,      0/
   1151,      0,   1.00000,   1150,     10,      0,      0,      0/
   1251,      0,   1.00000,   1250,     10,      0,      0,      0/
   2251,      0,   1.00000,   2250,     10,      0,      0,      0/
   1351,      0,   1.00000,   1350,     10,      0,      0,      0/
   2351,      0,   1.00000,   2350,     10,      0,      0,      0/
   3351,      0,   1.00000,   3350,     10,      0,      0,      0/
      6,      4,    .33330,      1,     -2,      5,      0,      0/
      6,      4,    .66660,      4,     -3,      5,      0,      0/
      6,      4,    .77770,     11,    -12,      5,      0,      0/
      6,      4,    .88880,     13,    -14,      5,      0,      0/
      6,      4,   1.00000,     15,    -16,      5,      0,      0/
     80,      0,    .33330,      1,     -2,      0,      0,      0/
     80,      0,    .66660,      4,     -3,      0,      0,      0/
     80,      0,    .77770,     11,    -12,      0,      0,      0/
     80,      0,    .88880,     13,    -14,      0,      0,      0/
     80,      0,   1.00000,     15,    -16,      0,      0,      0/
     90,      0,    .11922,      1,     -1,      0,      0,      0/
     90,      0,    .27297,      2,     -2,      0,      0,      0/
     90,      0,    .42672,      3,     -3,      0,      0,      0/
     90,      0,    .54595,      4,     -4,      0,      0,      0/
     90,      0,    .69969,      5,     -5,      0,      0,      0/
     90,      0,    .76637,     11,    -11,      0,      0,      0/
     90,      0,    .79979,     12,    -12,      0,      0,      0/
     90,      0,    .86647,     13,    -13,      0,      0,      0/
     90,      0,    .89989,     14,    -14,      0,      0,      0/
     90,      0,    .96657,     15,    -15,      0,      0,      0/
     90,      0,   1.00000,     16,    -16,      0,      0,      0/
      0/
+EOD
+DECK,NOTES
////
+EOD
+PATCH,ISAUTIL
+EOD
+DECK,MAKEVAX
$ SAVE_VER = F$VERIFY()
$ SET NOVERIFY
$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$! ISAMAKE.COM:
$! @ISAMAKE                  compile ISAJET from ISAJET.CAR under VMS
$! @ISAMAKE CLEAN            delete all unneeded files
$! @ISAMAKE SUPERCLEAN       delete all created files
$! Patchy and the symbol YPATCHY must be defined.
$! You must be in a directory containing ISAJET.CAR and 20K free blocks.
$! For VMS 6.x, FFLAGS must be set to
$! FFLAGS :== "/SEPARATE_COMPILATION"
$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$ FFLAGS :== "/SEPARATE_COMPILATION"
$ LFLAGS :== ""
$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$ SAY :== WRITE SYS$OUTPUT
$ IF P1 .EQS. "CLEAN" THEN GOTO CLEAN
$ IF P1 .EQS. "SUPERCLEAN" THEN GOTO SUPERCLEAN
$!
$ SAY ""
$ SAY "Making ISAJET.TEX LaTeX instruction file ..."
$ YPATCHY
ISAJET.CAR ISAJET.DOC TTY MAKE_DOC .GO
+USE,*ISATEXT,VAX
+EXE
+PAM,T=CARDS
+QUIT
$!
$ SAY ""
$ SAY "Making ISAJET.FOR ..."
$ YPATCHY
ISAJET.CAR ISAJET TTY MAKE_FOR .GO
+USE,*ISAJET,VAX
+USE,*ISAPLT
+USE,NOCERN
+EXE
+PAM,T=CARDS
+QUIT
$!
$ SAY ""
$ SAY "Making ISADECAY.DAT decay table ..."
$ YPATCHY
ISAJET.CAR ISADECAY.DAT TTY MAKE_DAT .GO
+USE,*ISADECAY
+EXE
+PAM,T=CARDS
+QUIT
$!
$ SAY ""
$ SAY "Creating main program ..."
$ CREATE ISARUN.FOR
      PROGRAM ISARUN
C          MAIN PROGRAM FOR ISAJET
      OPEN(UNIT=1,STATUS='OLD',FORM='FORMATTED',READONLY)
      OPEN(UNIT=2,STATUS='NEW',FORM='UNFORMATTED')
      OPEN(UNIT=3,STATUS='OLD',FORM='FORMATTED')
      OPEN(UNIT=4,STATUS='NEW',FORM='FORMATTED')
      CALL ISAJET(-1,2,3,4)
      STOP
      END
$ FORTRAN'FFLAGS' []ISARUN.FOR
$!
$ SAY ""
$ SAY "Compiling ISAJET and making library..."
$ FORTRAN'FFLAGS' []ISAJET.FOR
$ LIBRARY/CREATE []ISAJET []ISAJET.OBJ
$ SAY ""
$ SAY "Linking ISAJET..."
$ LINK'LFLAGS'/EXE=[]ISAJET []ISARUN,[]ISAJET/LIBRARY/INCLUDE=ALDATA
$!
$ SAY ""
$ SAY "Making ISASUSY.EXE ..."
$ YPATCHY
ISAJET.CAR SSRUN.FOR TTY MAKE_SUSY .GO
+USE,*ISASUSY,VAX
+USE,NOCERN
+USE,ISASSRUN
+EXE,ISASSRUN
+PAM,T=CARDS
+QUIT
$ FORTRAN'FFLAGS' []SSRUN.FOR
$ LINK'LFLAGS'/EXE=[]ISASUSY []SSRUN,[]ISAJET/LIBRARY/INCLUDE=ALDATA
$!
$ SAY ""
$ SAY "Making ISASUGRA.EXE ..."
$ YPATCHY
ISAJET.CAR SUGRUN.FOR TTY MAKE_SUGRA .GO
+USE,*ISASUGRA,VAX
+USE,NOCERN
+USE,ISASSRUN
+EXE,ISASSRUN
+PAM,T=CARDS
+QUIT
$ FORTRAN'FFLAGS' []SUGRUN.FOR
$ LINK'LFLAGS'/EXE=[]ISASUGRA []SUGRUN,[]ISAJET/LIBRARY/INCLUDE=ALDATA
$!
$ SAY ""
$ SAY "See ISAJET.TEX for instructions on using ISAJET."
$ SAY "Run LaTeX 2.09/2e three times to resolve forward references."
$ GOTO DONE
$!
$ CLEAN:
$ DELETE []ISAJET.FOR;*
$ DELETE []ISAJET.OBJ;*
$ DELETE []MAKE_*.LIS;*
$ DELETE []ISARUN.*;*
$ DELETE []SSRUN.*;*
$ DELETE []SUGRUN.*;*
$ GOTO DONE
$!
$ SUPERCLEAN:
$ DELETE []ISADECAY.DAT;*
$ DELETE []ISAJET.EXE;*
$ DELETE []ISAJET.DOC;*
$ DELETE []ISAJET.OLB;*
$ DELETE []ISASUSY.EXE;*
$ DELETE []ISASUGRA.EXE;*
$ GOTO CLEAN
$!
$ DONE:
$ IF SAVE_VER THEN SET VERIFY
$ EXIT     
+EOD
+DECK,RUNVMS
$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$! COM file to generate ISAJET events. Usage:
$!      @ISAJET <jobname>
$! where 
$!      <jobname>.PAR = ISAJET parameter file
$!      <jobname>.DAT = ISAJET data file
$!      <jobname>.LIS = ISAJET listing file
$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$ ASSIGN USER01:[PAIGE.ISAJET] ISA:
$!
$ ASSIGN ISA:ISADECAY.DAT FOR001
$ ASSIGN 'P1'.DAT         FOR002
$ ASSIGN 'P1'.PAR         FOR003
$ ASSIGN 'P1'.LIS         FOR004
$! 
$ RUN ISA:ISAJET
+EOD
+DECK,RUNIBM
/********************************************************************/
/* ISAJET EXEC  --  F.E. Paige, S.D. Protopopescu                   */
/* Purpose: Generate ISAJET events.                                 */
/* Usage:   ISAJET <jname>                                          */
/*                 <jname> INPUT  = ISAJET input file               */
/*                 <jname> DATA   = ISAJET data file (created)      */
/*                 <jname> OUTPUT = ISAJET listing file (created)   */
/*                                                                  */
/*      ISAJET MODULE and ISADECAY DATA are assumed to exist on     */
/* minidisk PAIGE 192.                                              */
/********************************************************************/

ARG JNAME .                                         /* Get job name */

IF JNAME = '' | jname = '?' THEN DO
   SAY 'EXEC to generate ISAJET events. Usage:'
   SAY '     ISAJET <jname>'
   SAY 'where'
   SAY '     <jname> INPUT  = ISAJET input file'
   SAY '     <jname> DATA   = ISAJET data file'
   SAY '     <jname> OUTPUT = ISAJET listing file'
   SAY 'See ISAJET MEMO for detailed instructions on ISAJET.'
   EXIT 100
   END

'SMODE' JNAME 'INPUT'                        /* Look for input file */
IF RC /= 0 THEN DO
   SAY JNAME 'INPUT * not found'
   SAY 'Job terminated'
   EXIT 101
   END

PULL FMINPUT .                                     /* Get file mode */
SAY 'ISAJET input file is' JNAME 'INPUT' FMINPUT

/* Abort job if JNAME DATA or JNAME OUTPUT exists.                  */
ADDRESS COMMAND 'STATE' JNAME 'DATA A'
IF RC = 0 THEN DO
   SAY JNAME 'DATA A found'
   SAY 'Job terminated'
   EXIT 102
   END
ADDRESS COMMAND 'STATE' JNAME 'OUTPUT A'
IF RC = 0 THEN DO
   SAY JNAME 'OUTPUT A found'
   SAY 'Job terminated'
   EXIT 102
   END

ADDRESS COMMAND 'STATE PAIGE DISK191 *'  /* Look for Paige 191 disk */
IF RC /= 0 THEN DO
   'GIME PAIGE 191'
   END
ADDRESS COMMAND 'STATE PAIGE DISK192 *'  /* Look for Paige 192 disk */
IF RC /= 0 THEN DO
   'GIME PAIGE 192'
   END
'SMODE PAIGE DISK192'                   /* Get fm for PAIGE DISK192 */
PULL FEP192 .                                         /* and pull it */

/* Define Fortran files as CMS files                                */
'FILEDEF 1 DISK ISADECAY DATA' FEP192                /* Decay table */
'FILEDEF 2 DISK' JNAME 'DATA A'                       /* Event data */
'FILEDEF 3 DISK' JNAME 'INPUT' FMINPUT                  /* Commands */
'FILEDEF 4 DISK' JNAME 'OUTPUT A (RECFM FBA LRECL 133'    /* Output */

/* Load and go                                                      */
SAY 'Beginning ISAJET execution ...'
'LOADMOD ISAJET MODULE' FEP192
'START ISARUN'
RCGEN = RC                                      /* Save return code */
IF RCGEN /= 0 THEN DO                          /* and exit on error */
   SAY 'Error during ISAJET execution'
   EXIT RCGEN
   END

/* Successful generation                                            */
LNAME=JNAME
DO WHILE LENGTH(LNAME) < 8;
   LNAME = ' ' || LNAME
   END
SAY ' '
SAY '+-----------------------------------------------+'
SAY '| ISAJET events generated on' LNAME  'DATA   A4 |'
SAY '| ISAJET listing produced on' LNAME  'OUTPUT A1 |'
SAY '+-----------------------------------------------+'
SAY ' '
EXIT
+EOD
+DECK,MAKEUNIX
########################################################################
#       Makefile for ISAJET on a generic Unix system.
#
#       Makes ISAJET library, executables, and auxiliary files from 
# isajet.car in the working directory.
#
#       Usage: Edit the Installation Parameters section. Uncomment the
# appropriate definition of NL for your version of make and comment out
# .IGNORE if possible. Set MAKETMP, CERN, [CERNBIN], [CERNLIB], PDFLIB,
# RANLUX, MACHINE, F77, FFLAGS, LINK, LFLAGS, RANLIB, MAKEFILE, YPATCHY,
# and YCRADLE correctly for your system. Then type 
#       make [>& make.log &]            # make everything
#       -or-
#       make isazeb [>& make.log &]     # Zebra version
#       make clean                      # clean up directory
#       make superclean                 # delete all created files
# It should not be necessary to change anything else. Use s5make
# rather than make on DEC Ultrix.
#
#       The following files should be produced and should remain after
# the make clean step:
#       isajet.tex   documentation
#       libisajet.a  library 
#       aldata.o     block data 
#       isadecay.dat decay table
#       isajet.x     executable to generate events
#       isasusy.x    executable to calculate SUSY decays (MSSM input)
#       isasugra.x   executable to calculate SUSY decays (SUGRA input)
#
# Thanks to Arthur Kreymer (FNAL) for suggesting many improvements to
# the original version.
#
#       ISATOOLS is a package of programs interfaced to ISASUGRA to 
# calculate SUSY contributions to various quantities:
#       DAMU: Anomalous muon magnetic moment
#       ISABSG: Branching ratio for b -> s gamma
#       ISARES: Cross sections for direct dark matter detection
#       ISARED: Cold dark matter relic density.
#       ISABMM: Branching ratios for B_s -> mu mu and B_d -> tau tua
# Set the parameters ISATOOLS and LIBTOOLS. First type
#       make isatools
# This will take some time -- there are 1.4M lines of code. Then proceed 
# as above to make the rest of Isajet.
#
#       22 Nov 1996: nypatchy does not seem to work with the cradle
# piped to standard input. Use a temporary file YCRADLE instead.
#
#       16 Nov 1999: Multiline echo fails on RedHat Linux 6.1. Use 
# multiple single-line echos instead -- this is not pretty but works
# everywhere. Hence NL is no longer needed.
#
#       6 April 2005: Added Isatools.
#
########################################################################

#       Do not change this -- you will break everything.
SHELL = /bin/csh

########## Installation parameters #####################################

#       Some versions of make (e.g. Linux) treat inconsequential warnings
# as errors and stop. Ignore all errors; comment out if possible:
.IGNORE:

#       Name for temporary subdirectory. This will be deleted and 
# recreated:
MAKETMP = ./MakeTmpDir

#       Link with CERN libraries. This is recommended for HP, IBMRT, or 
# LINUX to get date and time information but is not required:
CERN = NOCERN
#CERN = CERN

#       Directories for Cernlib, terminated with a /. These must be set
# if you select CERN or PDFLIB:
CERNDIR = /cern/pro/
CERNBIN = $(CERNDIR)bin/
CERNLIB = $(CERNDIR)lib/

#       PDFLIB support. PDFLIB (part of the CERN library) contains many
# partion distributions but produces a larger executable image:
PDFLIB =
#PDFLIB = PDFLIB

#       RANLUX support. RANLUX provides better random numbers than the
# standard RANF, and each seed gives an independent sequence. It is
# more difficult to restart and slightly slower.
RANLUX = RANLUX
#RANLUX = NORANLUX

#       Computer type. Most only differ in minor ways, e.g., the system
# clock interface. Uncomment the right one:
# ANSI          ANSI Fortran
# DECS          DECStation with Ultrix
# HPUX          HP/700 with HPUX
# IBMRT         IBM RS/6000 with AIX
# LINUX         PC with LINUX and f2c/gcc or g77 or Absoft f77
# OSF           Digital OSF on Alpha processor
# SGI           Silicon Graphics with IRIX
# SUN           Sparc or PC with Solaris
#MACHINE = ANSI
#MACHINE = DECS
#MACHINE = HPUX
#MACHINE = IBMRT
MACHINE = LINUX
#MACHINE = OSF
#MACHINE = SGI
#MACHINE = SUN

#       Fortran 77 compiler.
#F77 = f77
#       For HPUX; note that f77 on HPUX is brain dead. fort77 is also an
# alternate f2c/gcc interface on Linux:
#F77 = fort77
#       GNU Fortran compiler
#F77 = g77
F77 = /usr/bin/g77

#       Fortran compile flags: Want -c, highest safe optimization, all
# variables static, and postpended underscore for Cernlib compatibility.
# Uncomment the right one or make your own:
#       DECS
#FFLAGS = -c -O -static -w
#       HPUX, -O is broken
#FFLAGS = -c -O2 -K +ppu -w
#       IBMRT
#FFLAGS = -c -O -qextname -w
#       LINUX with f2c/gcc or g77. The -fno-silent displays progress...
FFLAGS = -c -O -fno-automatic -fno-silent
#       LINUX  with Absoft Fortran
#FFLAGS = -c -O -w -f -s
#       OSF
#FFLAGS= -c -O -w
#       SGI
#FFLAGS = -c -O -static -w
#       SUN - the second option traps floating errors
#FFLAGS = -c -O -w
#FFLAGS = -c -O -w -fnonstd -ftrap=common

#       Use fsplit or CERN's fcasplit to split the whole Fortran source into
# individual subroutines:
#FSPLIT = $(CERNBIN)fcasplit
#FSPLIT = fsplit
FSPLIT = /users/usr0/paige/Linux/bin/fcasplit

#       Link command for Fortran, c.f. $(F77):
#LINK = f77
#LINK = fort77
#LINK = g77
LINK = /usr/bin/g77

#       Extra libraries (e.g. Cernlib) and flags for link. If you want 
# PDFLIB support, you must also define $(PDFLIB) above. The Zebra
# version requires libpacklib.a.
LFLAGS =
#LFLAGS = -L$(CERNLIB) -lmathlib -lkernlib
#LFLAGS = -L$(CERNLIB) -lpdflib804 -lmathlib -lkernlib
#LFLAGS = -L$(CERNLIB) -lpdflib -lpacklib -lmathlib -lkernlib

#       Ranlib command if required (it is for Sun 4.x and Linux):
RANLIB = ranlib
#RANLIB = $(ECHO)

#       Name for this Makefile:
MAKEFILE = Makefile

#       Patchy commands. YPATCHY can be either ypatchy or nypatchy,
# perhaps with a full path. A temporary cradle file YCRADLE is required;
# it is deleted and recreated:
#YPATCHY = $(CERNBIN)ypatchy
#YPATCHY = $(CERNBIN)nypatchy
YCRADLE = ./tmpcradle.cra
YPATCHY = /users/usr0/paige/Linux/bin/nypatchy

#       Echo command. /bin/echo works on most (all?) systems; plain echo
# fails on AIX 4.1:
ECHO = /bin/echo

#       Remove command:
RM = /bin/rm

#       Parameter to use Isatools

ISATOOLS = ISATOOLS
#ISATOOLS =

LIBTOOLS = -lisared
#LIBTOOLS =

########## End of installation parameters ##############################

all:    isajet.tex isadecay.dat libisajet.a aldata.o isajet.x \
        isasusy.x isasugra.x

isazeb: isajet.tex isadecay.dat libisazeb.a aldata.o isazeb.x

########## Extract files ###############################################

isajet.f:       isajet.car $(MAKEFILE)                                ;\
  $(RM) isajet.f                                                      ;\
  $(RM) isajet.lis                                                    ;\
  $(ECHO) "+USE,*ISAJET,$(PDFLIB),$(MACHINE)"            > $(YCRADLE) ;\
  $(ECHO) "+USE,$(CERN),$(RANLUX),$(ISATOOLS)"          >> $(YCRADLE) ;\
  $(ECHO) "+EXE."                                       >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT"                                       >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car isajet.f $(YCRADLE) isajet.lis .GO'          ;\
  $(RM) $(YCRADLE)

isazeb.f:       isajet.car $(MAKEFILE)                                ;\
  $(RM) isazeb.f                                                      ;\
  $(RM) isazeb.lis                                                    ;\
  $(ECHO) "+USE,*ISAZEB,*ISZRUN,$(PDFLIB),$(MACHINE)"    > $(YCRADLE) ;\
  $(ECHO) "+USE,P=ISARUN,D=ISARUN,T=INHIBIT"            >> $(YCRADLE) ;\
  $(ECHO) "+USE,P=ISZRUN,D=ISZRUN,T=INHIBIT"            >> $(YCRADLE) ;\
  $(ECHO) "+EXE."                                       >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT."                                      >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car isazeb.f $(YCRADLE) isazeb.lis .GO'          ;\
  $(RM) $(YCRADLE)

aldata.f:       isajet.car $(MAKEFILE)                                ;\
  $(RM) aldata.f                                                      ;\
  $(RM) aldata.lis                                                    ;\
  $(ECHO) "+USE,*ISAJET,$(MACHINE)"                      > $(YCRADLE) ;\
  $(ECHO) "+USE,$(CERN)"                                >> $(YCRADLE) ;\
  $(ECHO) "+USE,$(RANLUX)"                              >> $(YCRADLE) ;\
  $(ECHO) "+EXE,ISADATA"                                >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT."                                      >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car aldata.f $(YCRADLE) aldata.lis .GO'          ;\
  $(RM) $(YCRADLE)

isajet.tex:     isajet.car $(MAKEFILE)                                ;\
  $(RM) isajet.tex                                                    ;\
  $(RM) isatex.lis                                                    ;\
  $(ECHO) "+USE,*ISATEXT,$(MACHINE)"                     > $(YCRADLE) ;\
  $(ECHO) "+USE,$(CERN)"                                >> $(YCRADLE) ;\
  $(ECHO) "+USE,$(RANLUX)"                              >> $(YCRADLE) ;\
  $(ECHO) "+EXE"                                        >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT"                                       >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car isajet.tex $(YCRADLE) isatex.lis .GO'        ;\
  $(RM) $(YCRADLE)

isadecay.dat:   isajet.car $(MAKEFILE)                                ;\
  $(RM) isadecay.dat                                                  ;\
  $(RM) isadecay.lis                                                  ;\
  $(ECHO) "+USE,*ISADECAY"                               > $(YCRADLE) ;\
  $(ECHO) "+EXE"                                        >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT"                                       >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car isadecay.dat $(YCRADLE) isadecay.lis .GO'    ;\
  $(RM) $(YCRADLE) 

ssrun.f:  isajet.car $(MAKEFILE)                                      ;\
  $(RM) ssrun.f                                                       ;\
  $(RM) ssrun.lis                                                     ;\
  $(ECHO) "+USE,*ISASUSY,$(MACHINE)"                     > $(YCRADLE) ;\
  $(ECHO) "+EXE,ISASSRUN"                               >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT"                                       >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car ssrun.f $(YCRADLE) ssrun.lis .GO'            ;\
  $(RM) $(YCRADLE)

sugrun.f:       isajet.car $(MAKEFILE)                                ;\
  $(RM) sugrun.f                                                      ;\
  $(RM) sugrun.lis                                                    ;\
  $(ECHO) "+USE,*ISASUGRA,$(MACHINE),$(ISATOOLS)"        > $(YCRADLE) ;\
  $(ECHO) "+EXE,ISASSRUN"                               >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT"                                       >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car sugrun.f $(YCRADLE) sugrun.lis .GO'          ;\
  $(RM) $(YCRADLE)

isarun.f:       isajet.car $(MAKEFILE)                                ;\
$(RM) isarun.f                                                        ;\
$(RM) isarun.lis                                                      ;\
  $(ECHO) "+USE,*ISAZEB,*ISZRUN,$(PDFLIB),$(MACHINE)"    > $(YCRADLE) ;\
  $(ECHO) "+EXE,P=ISARUN,D=ISARUN"                      >> $(YCRADLE) ;\
  $(ECHO) "+PAM,T=C."                                   >> $(YCRADLE) ;\
  $(ECHO) "+QUIT"                                       >> $(YCRADLE) ;\
  $(YPATCHY) 'isajet.car isarun.f $(YCRADLE) isarun.lis .GO'          ;\
  $(RM) $(YCRADLE)

runjet.f:       $(MAKEFILE)                                           ;\
  $(RM) runjet.f                                                      ;\
  $(ECHO) "      PROGRAM RUNJET"                            >runjet.f ;\
  $(ECHO) "      CHARACTER*60 FN"                          >>runjet.f ;\
  $(ECHO) "      READ 1000, FN"                            >>runjet.f ;\
  $(ECHO) "1000  FORMAT(A)"                                >>runjet.f ;\
  $(ECHO) "      PRINT 1020, FN"                           >>runjet.f ;\
  $(ECHO) "1020  FORMAT(1X,'Data file      = ',A)"         >>runjet.f ;\
  $(ECHO) "      OPEN(2,FILE=FN,STATUS='NEW',FORM='UNFORMATTED')" >>runjet.f ;\
  $(ECHO) "      READ 1000, FN"                            >>runjet.f ;\
  $(ECHO) "      PRINT 1030, FN"                           >>runjet.f ;\
  $(ECHO) "1030  FORMAT(1X,'Parameter file = ',A)"         >>runjet.f ;\
  $(ECHO) "      OPEN(3,FILE=FN,STATUS='OLD',FORM='FORMATTED')" >>runjet.f ;\
  $(ECHO) "      READ 1000, FN"                            >>runjet.f ;\
  $(ECHO) "      PRINT 1040, FN"                           >>runjet.f ;\
  $(ECHO) "1040  FORMAT(1X,'Listing file   = ',A)"         >>runjet.f ;\
  $(ECHO) "      OPEN(4,FILE=FN,STATUS='NEW',FORM='FORMATTED')" >>runjet.f ;\
  $(ECHO) "      READ 1000, FN"                            >>runjet.f ;\
  $(ECHO) "      OPEN(1,FILE=FN,STATUS='OLD',FORM='FORMATTED')" >>runjet.f ;\
  $(ECHO) "      CALL ISAJET(-1,2,3,4)"                    >>runjet.f ;\
  $(ECHO) "      STOP"                                     >>runjet.f ;\
  $(ECHO) "      END"                                      >>runjet.f

########## Compile #####################################################

# Note HP compiler cannot compile arbitrarily many files!
libisajet.a:    isajet.f                                              ;\
  $(RM) -r $(MAKETMP)                                                 ;\
  mkdir  $(MAKETMP)                                                   ;\
  cd     $(MAKETMP)                                                   ;\
  $(FSPLIT) ../isajet.f                                               ;\
  $(F77) $(FFLAGS) [a-i,A-I]*.f                                       ;\
  $(F77) $(FFLAGS) [j-r,J-R]*.f                                       ;\
  $(F77) $(FFLAGS) [s,S]*.f                                           ;\
  $(F77) $(FFLAGS) [t-z,T-Z]*.f                                       ;\
  ar r libisajet.a *.o                                                ;\
  $(RANLIB) libisajet.a                                               ;\
  mv libisajet.a ..                                                   ;\
  cd ..

aldata.o:       aldata.f                                              ;\
  $(F77) $(FFLAGS) aldata.f

runjet.o:       runjet.f                                              ;\
  $(F77) $(FFLAGS) runjet.f

isajet.x:       runjet.o aldata.o libisajet.a                         ;\
  $(LINK) -o isajet.x runjet.o aldata.o -L. -lisajet $(LFLAGS)

isasusy.x:      ssrun.f aldata.o libisajet.a                          ;\
  $(F77) $(FFLAGS) ssrun.f ;\
  $(LINK) -o isasusy.x ssrun.o aldata.o -L. -lisajet $(LFLAGS)

isasugra.x:     sugrun.f aldata.o libisajet.a                         ;\
  $(F77) $(FFLAGS) sugrun.f ;\
  $(LINK) -o isasugra.x sugrun.o aldata.o -L. -lisajet $(LIBTOOLS) $(LFLAGS)

libisazeb.a:    isazeb.f                                              ;\
  $(RM) -r $(MAKETMP)                                                 ;\
  mkdir  $(MAKETMP)                                                   ;\
  cd     $(MAKETMP)                                                   ;\
  $(FSPLIT) ../isazeb.f                                               ;\
  $(F77) $(FFLAGS) [a-i,A-I]*.f                                       ;\
  $(F77) $(FFLAGS) [j-r,J-R]*.f                                       ;\
  $(F77) $(FFLAGS) [s,S]*.f                                           ;\
  $(F77) $(FFLAGS) [t-z,T-Z]*.f                                       ;\
  ar r libisazeb.a *.o                                                ;\
  $(RANLIB) libisazeb.a                                               ;\
  mv libisazeb.a ..                                                   ;\
  cd ..

isarun.o:       isarun.f                                              ;\
  $(F77) $(FFLAGS) isarun.f

isazeb.x:       isarun.o aldata.o libisazeb.a                         ;\
  $(LINK) -o isazeb.x isarun.o aldata.o -L. -lisazeb $(LFLAGS)

########## Install/clean ###############################################

clean: ;\
  set nonomatch                                                       ;\
  if (-f aldata.o) mv aldata.o aldata.obj                             ;\
  $(RM) *.f *.o                                                       ;\
  $(RM) *.lis                                                         ;\
  if(-f $(YCRADLE)) $(RM) $(YCRADLE)                                  ;\
  if (-f aldata.obj) mv aldata.obj aldata.o                           ;\
  $(RM) -r $(MAKETMP)

superclean:                                                           ;\
  set nonomatch                                                       ;\
  $(RM) *.f *.o                                                       ;\
  $(RM) *.lis                                                         ;\
  $(RM) $(YCRADLE)                                                    ;\
  $(RM) *.obj                                                         ;\
  $(RM) -r $(MAKETMP)                                                 ;\
  $(RM) isajet.f libisajet.a isajet.x aldata.f \
        isadecay.dat isajet.tex isasusy.x isasugra.x \
        isazeb.x libisazeb.a isarun.o isarun.f


########################################################################
# Isatools: Tools interfaced to Isajet to calculate Delta(a_mu),
# BF(b->s gamma), sigma(Cdm), and Omega h^2 for CDM.
# Requires isared.tar, tar file of CDM code.
########################################################################

isatools:       libisared.a

MAKETOOLS = ./MakeRedDir

libisared.a:  isajet.car isared.tar $(MAKEFILE)                       ;\
  set nonomatch                                                       ;\
  $(RM) -r $(MAKETOOLS)                                               ;\
  mkdir $(MAKETOOLS)                                                  ;\
  cd $(MAKETOOLS)                                                     ;\
  tar xvf ../isared.tar                                               ;\
  $(F77) $(FFLAGS) *.f                                                ;\
  ar r libisared.a *.o                                                ;\
  $(RANLIB) libisared.a                                               ;\
  mv libisared.a ..                                                   ;\
  cd ..

cleantools:                                                           ;\
  set nonomatch                                                       ;\
  $(RM) -r $(MAKETOOLS)
+EOD
+DECK,RUNUNIX
#!/bin/csh
########################################################################
#       C-shell script to run ISAJET on any Unix system, generating a
# standard output file. Usage:
#     isajet name
#     name.par = parameters (input)
#     name.dat = data (output)
#     name.lis = listing (output)
# name.par must exist in the current directory; name.dat and name.lis
# must not exist.
#
#     The shell variable $isa must be properly set below.
########################################################################

#       Files. $isa must be set to the directory containing the ISAJET
# executable made by Makefile and the decay table. Note that PATCHY
# requires lower case names!

set cmd=$0
set isa=~paige/isajet
set tmpdat=/tmp/decay.$$

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

#       Check arguments, etc.
if ($#argv != 1) then
        set rc=-1
        goto badinput
endif

if (! -f $argv[1].par) then
        set rc=-1
        goto badinput
endif

if (-f $argv[1].dat) then
        set rc=-2
        goto badinput
endif

if (-f $argv[1].lis) then
        set rc=-2
        goto badinput
endif

#       Get temporary copy of decay table - no "readonly".
cp $isa/isadecay.dat $tmpdat

#       Run ISAJET:
$isa/isajet.x <<e-o-f
$argv[1].dat
$argv[1].par
$argv[1].lis
$tmpdat
e-o-f

set rc=$status
rm $tmpdat
exit($rc)

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

#       Error exit:
badinput:
echo "Usage: isajet name"
echo "name.par = input parameter file."
echo "name.dat = output data file."
echo "name.lis = output listing file."
exit($rc)
+EOD
